diff --git a/.gitlab/ci/jobs/packaging/opam_package.yml b/.gitlab/ci/jobs/packaging/opam_package.yml index f870e8f6d7a83500cc9b12db4e8e5be1c5cdab5a..7f4d5a1b17d2406b53872d9830653053cb176b61 100644 --- a/.gitlab/ci/jobs/packaging/opam_package.yml +++ b/.gitlab/ci/jobs/packaging/opam_package.yml @@ -429,13 +429,6 @@ opam:octez-accuser-Proxford: variables: package: octez-accuser-Proxford -opam:octez-accuser-PtNairob: - extends: - - .opam_template - - .rules_template__trigger_exec_opam_batch_1 - variables: - package: octez-accuser-PtNairob - # Ignoring unreleased package octez-accuser-alpha. opam:octez-alcotezt: @@ -452,13 +445,6 @@ opam:octez-baker-Proxford: variables: package: octez-baker-Proxford -opam:octez-baker-PtNairob: - extends: - - .opam_template - - .rules_template__trigger_exec_opam_batch_1 - variables: - package: octez-baker-PtNairob - # Ignoring unreleased package octez-baker-alpha. opam:octez-client: @@ -595,21 +581,21 @@ opam:octez-protocol-002-PsYLVpVv-libs: opam:octez-protocol-003-PsddFKi3-libs: extends: - .opam_template - - .rules_template__trigger_all_opam_batch_3 + - .rules_template__trigger_all_opam_batch_2 variables: package: octez-protocol-003-PsddFKi3-libs opam:octez-protocol-004-Pt24m4xi-libs: extends: - .opam_template - - .rules_template__trigger_all_opam_batch_3 + - .rules_template__trigger_all_opam_batch_2 variables: package: octez-protocol-004-Pt24m4xi-libs opam:octez-protocol-005-PsBabyM1-libs: extends: - .opam_template - - .rules_template__trigger_all_opam_batch_3 + - .rules_template__trigger_all_opam_batch_2 variables: package: octez-protocol-005-PsBabyM1-libs @@ -732,7 +718,7 @@ opam:octez-proxy-server: opam:octez-rpc-process: extends: - .opam_template - - .rules_template__trigger_all_opam_batch_4 + - .rules_template__trigger_all_opam_batch_3 variables: package: octez-rpc-process @@ -766,17 +752,10 @@ opam:octez-smart-rollup-node-Proxford: variables: package: octez-smart-rollup-node-Proxford -opam:octez-smart-rollup-node-PtNairob: - extends: - - .opam_template - - .rules_template__trigger_all_opam_batch_2 - variables: - package: octez-smart-rollup-node-PtNairob - opam:octez-smart-rollup-node-alpha: extends: - .opam_template - - .rules_template__trigger_all_opam_batch_2 + - .rules_template__trigger_all_opam_batch_1 variables: package: octez-smart-rollup-node-alpha @@ -797,7 +776,7 @@ opam:octez-smart-rollup-wasm-debugger: opam:octez-smart-rollup-wasm-debugger-lib: extends: - .opam_template - - .rules_template__trigger_all_opam_batch_2 + - .rules_template__trigger_all_opam_batch_1 variables: package: octez-smart-rollup-wasm-debugger-lib @@ -826,12 +805,10 @@ opam:octez-version: opam:tezos-benchmark: extends: - .opam_template - - .rules_template__trigger_all_opam_batch_7 + - .rules_template__trigger_all_opam_batch_6 variables: package: tezos-benchmark -# Ignoring unreleased package tezos-benchmark-017-PtNairob. - # Ignoring unreleased package tezos-benchmark-018-Proxford. # Ignoring unreleased package tezos-benchmark-alpha. @@ -840,14 +817,10 @@ opam:tezos-benchmark: # Ignoring unreleased package tezos-benchmark-tests. -# Ignoring unreleased package tezos-benchmark-type-inference-017-PtNairob. - # Ignoring unreleased package tezos-benchmark-type-inference-018-Proxford. # Ignoring unreleased package tezos-benchmark-type-inference-alpha. -# Ignoring unreleased package tezos-benchmarks-proto-017-PtNairob. - # Ignoring unreleased package tezos-benchmarks-proto-018-Proxford. # Ignoring unreleased package tezos-benchmarks-proto-alpha. @@ -855,14 +828,14 @@ opam:tezos-benchmark: opam:tezos-client-demo-counter: extends: - .opam_template - - .rules_template__trigger_all_opam_batch_4 + - .rules_template__trigger_all_opam_batch_3 variables: package: tezos-client-demo-counter opam:tezos-client-genesis: extends: - .opam_template - - .rules_template__trigger_all_opam_batch_4 + - .rules_template__trigger_all_opam_batch_3 variables: package: tezos-client-genesis @@ -901,7 +874,7 @@ opam:tezos-dal-node-lib: opam:tezos-dal-node-services: extends: - .opam_template - - .rules_template__trigger_all_opam_batch_7 + - .rules_template__trigger_all_opam_batch_6 variables: package: tezos-dal-node-services @@ -953,21 +926,21 @@ opam:tezos-protocol-003-PsddFKi3: opam:tezos-protocol-004-Pt24m4xi: extends: - .opam_template - - .rules_template__trigger_all_opam_batch_5 + - .rules_template__trigger_all_opam_batch_4 variables: package: tezos-protocol-004-Pt24m4xi opam:tezos-protocol-005-PsBABY5H: extends: - .opam_template - - .rules_template__trigger_all_opam_batch_5 + - .rules_template__trigger_all_opam_batch_4 variables: package: tezos-protocol-005-PsBABY5H opam:tezos-protocol-005-PsBabyM1: extends: - .opam_template - - .rules_template__trigger_all_opam_batch_5 + - .rules_template__trigger_all_opam_batch_4 variables: package: tezos-protocol-005-PsBabyM1 @@ -1044,26 +1017,24 @@ opam:tezos-protocol-014-PtKathma: opam:tezos-protocol-015-PtLimaPt: extends: - .opam_template - - .rules_template__trigger_all_opam_batch_6 + - .rules_template__trigger_all_opam_batch_5 variables: package: tezos-protocol-015-PtLimaPt opam:tezos-protocol-016-PtMumbai: extends: - .opam_template - - .rules_template__trigger_all_opam_batch_6 + - .rules_template__trigger_all_opam_batch_5 variables: package: tezos-protocol-016-PtMumbai opam:tezos-protocol-017-PtNairob: extends: - .opam_template - - .rules_template__trigger_all_opam_batch_6 + - .rules_template__trigger_all_opam_batch_5 variables: package: tezos-protocol-017-PtNairob -# Ignoring unreleased package tezos-protocol-017-PtNairob-tests. - opam:tezos-protocol-018-Proxford: extends: - .opam_template @@ -1106,7 +1077,7 @@ opam:tezos-protocol-genesis: opam:tezos-proxy-server-config: extends: - .opam_template - - .rules_template__trigger_all_opam_batch_7 + - .rules_template__trigger_all_opam_batch_6 variables: package: tezos-proxy-server-config diff --git a/CHANGES.rst b/CHANGES.rst index d02d0cd3b312fbee5932f5258b6d80f9f3e38d07..4306e135c0ca70de8967ef551618ec942bdc0e08 100644 --- a/CHANGES.rst +++ b/CHANGES.rst @@ -25,6 +25,8 @@ be documented here either. General ------- +- Removed binaries for Nairobi (MR :gl:`!12043`) + Node ---- diff --git a/devtools/get_contracts/dune b/devtools/get_contracts/dune index 889fcbdd171e991b0c6c25099c20904433214f6c..0e5e3cbef949b7dc2bf763aeeaaa4e926e32fe45 100644 --- a/devtools/get_contracts/dune +++ b/devtools/get_contracts/dune @@ -7,8 +7,6 @@ octez-libs.micheline octez-libs.base octez-shell-libs.store - tezos-protocol-017-PtNairob.protocol - octez-protocol-017-PtNairob-libs.client tezos-protocol-018-Proxford.protocol octez-protocol-018-Proxford-libs.client tezos-protocol-alpha.protocol diff --git a/devtools/get_contracts/get_contracts_017_PtNairob.ml b/devtools/get_contracts/get_contracts_017_PtNairob.ml deleted file mode 100644 index 0a2072526eb3b49193988037c5efd468c65cb221..0000000000000000000000000000000000000000 --- a/devtools/get_contracts/get_contracts_017_PtNairob.ml +++ /dev/null @@ -1,310 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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 Tezos_protocol_017_PtNairob -open Tezos_client_017_PtNairob -open Protocol - -module Proto = struct - let hash = hash - - let wrap_tzresult = Environment.wrap_tzresult - - module Context = struct - type t = Raw_context.t - - let prepare ~level ~predecessor_timestamp ~timestamp ctxt = - let open Lwt_result_syntax in - let+ ctxt = - Lwt.map wrap_tzresult - @@ Raw_context.prepare ~level ~predecessor_timestamp ~timestamp ctxt - in - Raw_context.set_gas_limit - ctxt - (Gas_limit_repr.fp_of_milligas_int (max_int - 1)) - end - - type context = Context.t - - module Contract = struct - type repr = Contract_repr.t - - let pp = Contract_repr.pp - - let is_implicit = function - | Contract_repr.Implicit _ -> true - | Contract_repr.Originated _ -> false - - let get_code ctxt contract = - Lwt.map wrap_tzresult @@ Storage.Contract.Code.get ctxt contract - - let get_storage ctxt contract = - Lwt.map wrap_tzresult @@ Storage.Contract.Storage.get ctxt contract - - let fold ctxt ~init ~f = - Storage.Contract.fold ctxt ~order:`Undefined ~init ~f - end - - module Script = struct - include Alpha_context.Script - module Hash = Script_expr_hash - - let print_expr = Michelson_v1_printer.print_expr - - let decode_and_costs lazy_expr = - let open Result_syntax in - let decode_cost = Script_repr.stable_force_decode_cost lazy_expr in - let+ expr = wrap_tzresult @@ Script_repr.force_decode lazy_expr in - let encode_cost = - let decoded_lazy_expr = Script_repr.lazy_expr expr in - Script_repr.force_bytes_cost decoded_lazy_expr - in - (expr, (decode_cost :> int), (encode_cost :> int)) - end - - module Translator = struct - type toplevel = Script_ir_translator.toplevel - - type ('a, 'b) ty = ('a, 'b) Script_typed_ir.ty - - type ex_ty = Ex_ty : ('a, 'b) ty -> ex_ty - - type ex_code = Script_ir_translator.ex_code - - let expected_code_size Script_ir_translator.(Ex_code (Code {code_size; _})) - = - (code_size :> int) - - let actual_code_size Script_ir_translator.(Ex_code (Code {code; _})) = - 8 * Obj.(reachable_words @@ repr code) - - let parse_ty (raw_ctxt : Raw_context.t) ~allow_lazy_storage ~allow_operation - ~allow_contract ~allow_ticket script = - let open Result_syntax in - let ctxt : Alpha_context.context = Obj.magic raw_ctxt in - let+ Script_typed_ir.Ex_ty ty, updated_ctxt = - wrap_tzresult - @@ Script_ir_translator.parse_ty - ctxt - ~legacy:true - ~allow_lazy_storage - ~allow_operation - ~allow_contract - ~allow_ticket - script - in - let consumed = - (Alpha_context.Gas.consumed ~since:ctxt ~until:updated_ctxt :> int) - in - assert (consumed > 0) ; - (Ex_ty ty, consumed) - - let parse_data (raw_ctxt : Raw_context.t) ~allow_forged ty expr = - let open Lwt_result_syntax in - let ctxt : Alpha_context.context = Obj.magic raw_ctxt in - let+ data, updated_ctxt = - Lwt.map wrap_tzresult - @@ Script_ir_translator.parse_data - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) - ctxt - ~allow_forged - ty - expr - in - let consumed = - (Alpha_context.Gas.consumed ~since:ctxt ~until:updated_ctxt :> int) - in - assert (consumed > 0) ; - (data, consumed) - - let unparse_data_cost (raw_ctxt : Raw_context.t) ty data = - let open Lwt_result_syntax in - let ctxt : Alpha_context.context = Obj.magic raw_ctxt in - let+ _expr, updated_ctxt = - Lwt.map wrap_tzresult - @@ Script_ir_translator.unparse_data - ctxt - Script_ir_unparser.Optimized - ty - data - in - let consumed = - (Alpha_context.Gas.consumed ~since:ctxt ~until:updated_ctxt :> int) - in - assert (consumed > 0) ; - consumed - - let unparse_ty (raw_ctxt : Raw_context.t) (Ex_ty ty) = - let open Result_syntax in - let ctxt : Alpha_context.context = Obj.magic raw_ctxt in - let+ expr, _ = - wrap_tzresult @@ Script_ir_unparser.unparse_ty ~loc:0 ctxt ty - in - expr - - let parse_toplevel (raw_ctxt : Raw_context.t) expr = - let open Lwt_result_syntax in - let ctxt : Alpha_context.context = Obj.magic raw_ctxt in - let+ toplevel, updated_ctxt = - Lwt.map wrap_tzresult - @@ Script_ir_translator.parse_toplevel ctxt ~legacy:true expr - in - let consumed = - (Alpha_context.Gas.consumed ~since:ctxt ~until:updated_ctxt :> int) - in - assert (consumed > 0) ; - (toplevel, consumed) - - let parse_code (raw_ctxt : Raw_context.t) code = - let open Lwt_result_syntax in - let ctxt : Alpha_context.context = Obj.magic raw_ctxt in - let+ parsed_code, _ = - Lwt.map wrap_tzresult - @@ Script_ir_translator.parse_code - ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) - ~code - in - parsed_code - end - - module Storage = struct - type big_map_id = Storage.Big_map.id - - let id_to_z = Lazy_storage_kind.Big_map.Id.unparse_to_z - - let list_values ?offset ?length (ctxt, id) = - let open Lwt_result_syntax in - let* ctxt, key_values = - Lwt.map wrap_tzresult - @@ Storage.Big_map.Contents.list_key_values ?offset ?length (ctxt, id) - in - let values = List.map snd key_values in - return (ctxt, values) - - let get ctxt id = - Lwt.map wrap_tzresult @@ Storage.Big_map.Value_type.get ctxt id - - let fold ctxt ~init ~f = - Storage.Big_map.fold ctxt ~order:`Undefined ~init ~f - end - - module Lambda = struct - type ex_lambda = - | Ex_lambda : - (('a, 'b) Script_typed_ir.lambda, _) Script_typed_ir.ty - * ('a, 'b) Script_typed_ir.lambda - -> ex_lambda - - type ex_ty_lambdas = - | Ex_ty_lambdas : - ('a, _) Script_typed_ir.ty * ('a -> ex_lambda list) list - -> ex_ty_lambdas - - let lam_node node = - match node with - | Ex_lambda (_, Lam (_, node)) | Ex_lambda (_, LamRec (_, node)) -> node - - let rec find_lambda_tys : - type a c. (a, c) Script_typed_ir.ty -> (a -> ex_lambda list) list = - fun ty -> - let open Script_typed_ir in - match ty with - | Unit_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t | Mutez_t - | Key_hash_t | Key_t | Timestamp_t | Address_t | Bool_t | Set_t _ - | Big_map_t _ | Contract_t _ | Operation_t | Sapling_transaction_t _ - | Sapling_transaction_deprecated_t _ | Sapling_state_t _ | Never_t - | Bls12_381_g1_t | Bls12_381_g2_t | Bls12_381_fr_t | Ticket_t _ - | Chain_id_t | Chest_key_t | Chest_t | Tx_rollup_l2_address_t -> - [] - | Pair_t (t1, t2, _, _) -> - let g1 = List.map (fun g (v, _) -> g v) @@ find_lambda_tys t1 in - let g2 = List.map (fun g (_, v) -> g v) @@ find_lambda_tys t2 in - g1 @ g2 - | Or_t (t1, t2, _, _) -> - let g1 = - List.map (fun g -> function L v -> g v | R _ -> []) - @@ find_lambda_tys t1 - in - let g2 = - List.map (fun g -> function L _ -> [] | R v -> g v) - @@ find_lambda_tys t2 - in - g1 @ g2 - | Lambda_t _ -> [(fun g -> [Ex_lambda (ty, g)])] - | Option_t (t, _, _) -> - List.map (fun g -> function None -> [] | Some v -> g v) - @@ find_lambda_tys t - | List_t (t, _) -> - List.map (fun g l -> - List.flatten @@ List.map g @@ Script_list.to_list l) - @@ find_lambda_tys t - | Map_t (_, tv, _) -> find_lambda_tys_map tv - - and find_lambda_tys_map : - type tk tv c. - (tv, c) Script_typed_ir.ty -> - ((tk, tv) Script_typed_ir.map -> ex_lambda list) list = - fun tv -> - let open Script_typed_ir in - List.map (fun g (Map_tag (module Box) : (tk, tv) map) -> - Box.OPS.fold (fun _k v acc -> g v @ acc) Box.boxed []) - @@ find_lambda_tys tv - - let collect_lambda_tys (Translator.Ex_ty ty) = - match find_lambda_tys ty with - | [] -> None - | lams -> Some (Ex_ty_lambdas (ty, lams)) - - let fold_ex_ty_lambdas (type a) ~(ctxt : Context.t) ~(expr : Script.node) - ~(f : a -> Script.node -> ex_lambda list -> a) ~(acc : a) - (Ex_ty_lambdas (ty, getters)) = - let open Lwt_syntax in - let+ parse_result = - Translator.parse_data ctxt ~allow_forged:true ty expr - in - match parse_result with - | Error _ -> acc - | Ok (data, _cost) -> ( - match Script_ir_unparser.unparse_ty ~loc:0 (Obj.magic ctxt) ty with - | Error _ -> assert false - | Ok (ty_expr, _) -> - List.fold_left (fun acc g -> f acc ty_expr @@ g data) acc getters) - end - - let is_unpack = function - | Michelson_v1_primitives.I_UNPACK -> true - | _ -> false - - let code_storage_type ({storage_type; _} : Translator.toplevel) = storage_type - - module Global_constants = struct - let expand ctxt (expr : Script.expr) = - let open Lwt_syntax in - let+ res = Global_constants_storage.expand ctxt expr in - match res with Error _ -> (ctxt, expr) | Ok x -> x - end -end - -let () = Known_protocols.register (module Proto) diff --git a/devtools/testnet_experiment_tools/dune b/devtools/testnet_experiment_tools/dune index 83569cbdf7960adb7036e378f413c2dd179fa6a3..4817fd47383f6732ec6dbea655003f7531e18d78 100644 --- a/devtools/testnet_experiment_tools/dune +++ b/devtools/testnet_experiment_tools/dune @@ -35,10 +35,6 @@ octez-shell-libs.store octez-shell-libs.store.shared octez-libs.tezos-context - octez-protocol-017-PtNairob-libs.baking - octez-protocol-017-PtNairob-libs.client - octez-protocol-017-PtNairob-libs.client.commands - tezos-protocol-017-PtNairob.protocol octez-protocol-018-Proxford-libs.baking octez-protocol-018-Proxford-libs.client octez-protocol-018-Proxford-libs.client.commands @@ -58,7 +54,7 @@ -open Tezos_store -open Tezos_store_shared -open Tezos_context) - (modules sigs tool_017_PtNairob tool_018_Proxford tool_alpha)) + (modules sigs tool_018_Proxford tool_alpha)) (executable (name simulation_scenario) diff --git a/devtools/testnet_experiment_tools/tool_017_PtNairob.ml b/devtools/testnet_experiment_tools/tool_017_PtNairob.ml deleted file mode 100644 index 794b0a50f716915d6a488d0fffed4357cdbf004e..0000000000000000000000000000000000000000 --- a/devtools/testnet_experiment_tools/tool_017_PtNairob.ml +++ /dev/null @@ -1,992 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* *) -(* 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 Lwt_result_syntax -open Tezos_shell_services -open Tezos_client_017_PtNairob -open Tezos_baking_017_PtNairob -open Tezos_protocol_017_PtNairob -open Protocol -open Alpha_context - -(** Sync node *) - -class wrap_silent_memory_client (t : Client_context.full) : - Protocol_client_context.full = - object - inherit Protocol_client_context.wrap_full t - - method! message : type a. (a, unit) Client_context.lwt_format -> a = - fun x -> Format.kasprintf (fun _msg -> Lwt.return_unit) x - - method! last_modification_time _ = return_some 0. - - (* We rely on the client's cache mechanism to store in memory the - extracted delegate keys. *) - method! load _ ~default _ = return default - - method! write _ _ _ = return_unit - - method! with_lock f = f () - end - -module Sorted_baker_map = Map.Make (struct - type t = Signature.Public_key_hash.t * Tez.t - - let compare (h, x) (h', x') = - (* Descending order *) - let v = Tez.compare x' x in - if v <> 0 then v else Signature.Public_key_hash.compare h h' -end) - -module Consensus_key_set = Set.Make (struct - type t = Signature.Public_key.t * Signature.Public_key_hash.t - - let compare = compare -end) - -type ctxt_kind = - | Wrapped of Protocol_client_context.full - | Generic of Client_context.full - -let load_client_context (cctxt : ctxt_kind) = - let cctxt = - match cctxt with - | Wrapped x -> x - | Generic cctxt -> new Protocol_client_context.wrap_full cctxt - in - let open Lwt_result_syntax in - let open Protocol_client_context in - let* (cycles_raw : Tezos_shell_services.Block_services.Proof.raw_context) = - Alpha_block_services.Context.read cctxt ["cycle"] - in - let cycles = - match cycles_raw with - | Dir m -> String.Map.bindings m |> List.map fst - | _ -> assert false - in - let* all_delegates_and_ck = - let process_delegate_sampler_state acc = function - | Tezos_shell_services.Block_services.Proof.Key sampler_state -> - let sampler_state = - Data_encoding.Binary.of_bytes_exn - (Sampler.encoding Raw_context.consensus_pk_encoding) - sampler_state - in - let support : Raw_context.consensus_pk Environment.FallbackArray.t = - (* Bypass sampler state's inner structure abstraction *) - Obj.(field (repr sampler_state) 1 |> obj) - in - Environment.FallbackArray.fold - (fun acc {Raw_context.consensus_pk; consensus_pkh; delegate} -> - if Signature.Public_key_hash.(consensus_pkh = delegate) then - Signature.Public_key_hash.Map.update - delegate - (function - | None -> Some Consensus_key_set.empty | Some x -> Some x) - acc - else - Signature.Public_key_hash.Map.update - delegate - (function - | None -> - Some - (Consensus_key_set.singleton - (consensus_pk, consensus_pkh)) - | Some s -> - Some - (Consensus_key_set.add - (consensus_pk, consensus_pkh) - s)) - acc) - support - acc - | _ -> assert false - in - List.fold_left_es - (fun acc cycle -> - let* raw_delegate_sampler_state = - Alpha_block_services.Context.read - cctxt - ["cycle"; cycle; "delegate_sampler_state"] - in - return (process_delegate_sampler_state acc raw_delegate_sampler_state)) - Signature.Public_key_hash.Map.empty - cycles - in - let* sorted_bakers = - Signature.Public_key_hash.Map.fold_es - (fun h s acc -> - let* frozen_deposits = - Alpha_services.Delegate.frozen_deposits cctxt (`Main, `Head 0) h - in - Sorted_baker_map.add (h, frozen_deposits) s acc |> return) - all_delegates_and_ck - Sorted_baker_map.empty - in - let mk_unencrypted f x = - Uri.of_string (Format.sprintf "unencrypted:%s" (f x)) - in - let random_sk = - let b = Bytes.create 32 in - fun (pk : Signature.public_key) : Signature.secret_key -> - let open Signature in - let algo : algo = - match pk with - | Ed25519 _ -> Ed25519 - | Secp256k1 _ -> Secp256k1 - | P256 _ -> P256 - | _ -> assert false - in - let i = Random.bits () |> Int32.of_int in - Bytes.set_int32_be b 0 i ; - let _, _, sk = V_latest.generate_key ~algo ~seed:b () in - sk - in - let* delegates_l = - List.mapi_es - (fun i ((pkh, _), cks) -> - let alias = Format.sprintf "baker_%d" i in - let make ?pk alias pkh = - let* pk_opt = - match pk with - | None -> - Alpha_services.Contract.manager_key cctxt (`Main, `Head 0) pkh - | Some pk -> return_some pk - in - let pk = WithExceptions.Option.get ~loc:__LOC__ pk_opt in - let pk_uri = - WithExceptions.Result.get_ok ~loc:__LOC__ - @@ Client_keys.make_pk_uri - (mk_unencrypted Signature.Public_key.to_b58check pk) - in - let sk_uri = - WithExceptions.Result.get_ok ~loc:__LOC__ - @@ Client_keys.make_sk_uri - (mk_unencrypted - Signature.Secret_key.to_b58check - (random_sk pk)) - in - return (alias, pkh, pk, pk_uri, sk_uri) - in - let* baker = make alias pkh in - let* cks = - List.mapi_es - (fun i (ck_pk, ck_pkh) -> - make ~pk:ck_pk (Printf.sprintf "%s_ck_%d" alias i) ck_pkh) - (Consensus_key_set.elements cks) - in - return (baker :: cks)) - (Sorted_baker_map.bindings sorted_bakers) - in - let delegates = List.flatten delegates_l in - let* () = Client_keys.register_keys cctxt delegates in - return_unit - -let get_delegates (cctxt : Protocol_client_context.full) = - let proj_delegate (alias, public_key_hash, public_key, secret_key_uri) = - { - Baking_state.alias = Some alias; - public_key_hash; - public_key; - secret_key_uri; - } - in - let* keys = Client_keys.get_keys cctxt in - let delegates = List.map proj_delegate keys in - - let* () = - Tezos_signer_backends.Encrypted.decrypt_list - cctxt - (List.filter_map - (function - | {Baking_state.alias = Some alias; _} -> Some alias | _ -> None) - delegates) - in - let delegates_no_duplicates = List.sort_uniq compare delegates in - let*! () = - if List.compare_lengths delegates delegates_no_duplicates <> 0 then - cctxt#warning - "Warning: the list of public key hash aliases contains duplicate \ - hashes, which are ignored" - else Lwt.return_unit - in - return delegates_no_duplicates - -let get_current_proposal cctxt ?cache () = - let* block_stream, block_stream_stopper = - Node_rpc.monitor_heads cctxt ?cache ~chain:cctxt#chain () - in - let*! stream_head = Lwt_stream.get block_stream in - match stream_head with - | Some current_head -> - return (block_stream, current_head, block_stream_stopper) - | None -> failwith "head stream unexpectedly ended" - -let create_state cctxt ?synchronize ?monitor_node_mempool ~config - ~current_proposal delegates = - let open Lwt_result_syntax in - let chain = cctxt#chain in - let monitor_node_operations = monitor_node_mempool in - let*! operation_worker = - Operation_worker.create ?monitor_node_operations cctxt - in - Baking_scheduling.create_initial_state - cctxt - ?synchronize - ~chain - config - operation_worker - ~current_proposal - delegates - -let compute_current_round_duration round_durations - ~(predecessor : Baking_state.block_info) round = - let open Result_syntax in - let* start = - Round.timestamp_of_round - round_durations - ~predecessor_timestamp:predecessor.shell.timestamp - ~predecessor_round:predecessor.round - ~round - in - let start = Timestamp.to_seconds start in - let* _end = - Round.timestamp_of_round - round_durations - ~predecessor_timestamp:predecessor.shell.timestamp - ~predecessor_round:predecessor.round - ~round:(Round.succ round) - in - let _end = Timestamp.to_seconds _end in - Ok (Ptime.Span.of_int_s Int64.(sub _end start |> to_int)) - -let one_minute = Ptime.Span.of_int_s 60 - -let wait_next_block block_stream current_proposal = - let open Baking_state in - let open Lwt_syntax in - Lwt.catch - (fun () -> - Lwt_unix.with_timeout 10. @@ fun () -> - let* () = - Lwt_stream.junk_while_s - (fun proposal -> - Lwt.return - (Compare.Int32.( - current_proposal.block.shell.level = proposal.block.shell.level) - && Round.(current_proposal.block.round = proposal.block.round))) - block_stream - in - let* new_block_opt = Lwt_stream.get block_stream in - WithExceptions.Option.get ~loc:__LOC__ new_block_opt |> Lwt.return) - (function - | Lwt_unix.Timeout -> - Format.printf - "Failed to receive expected block, continuing anyway...@." ; - Lwt.return current_proposal - | exn -> Lwt.fail exn) - -let check_round_duration cctxt ?round_duration_target () = - let open Lwt_result_syntax in - let* param = Alpha_services.Constants.parametric cctxt (`Main, `Head 0) in - match round_duration_target with - | None -> - let*? r = - Period.mult 4l param.minimal_block_delay |> Environment.wrap_tzresult - in - let r = Period.to_seconds r |> Int64.to_int |> Ptime.Span.of_int_s in - Format.printf "Default round duration target set to %a@." Ptime.Span.pp r ; - return r - | Some target -> - let minimal_proto_period = - Period.add param.delay_increment_per_round param.minimal_block_delay - |> WithExceptions.Result.get_ok ~loc:__LOC__ - in - let minimal_round_target = - max 5L (Period.to_seconds minimal_proto_period) |> Int64.to_int - in - if target < minimal_round_target then - failwith - "Invalid round duration target, the minimal accepted round duration \ - target for this chain is %a" - Ptime.Span.pp - (Ptime.Span.of_int_s minimal_round_target) - else return (Ptime.Span.of_int_s target) - -let sync_node (cctxt : Client_context.full) ?round_duration_target () = - let open Lwt_result_syntax in - let*! () = Tezos_base_unix.Internal_event_unix.close () in - let cctxt = new wrap_silent_memory_client cctxt in - let* round_duration_target = - check_round_duration cctxt ?round_duration_target () - in - Format.printf "Loading faked delegate keys@." ; - let* () = load_client_context (Wrapped cctxt) in - let* delegates = get_delegates cctxt in - let* block_stream, current_proposal, stopper = - get_current_proposal cctxt () - in - let* is_pred_metadata_present = - let*! r = - Protocol_client_context.Alpha_block_services.metadata - cctxt - ~block:(`Hash (current_proposal.predecessor.hash, 0)) - () - in - match r with Ok _protocols -> return_true | Error _err -> return_false - in - let* current_proposal = - if not is_pred_metadata_present then ( - Format.printf - "Predecessor's metadata are not present: baking a dummy block@." ; - let* () = - Baking_lib.bake cctxt ~minimal_timestamp:true ~force:true delegates - in - (* Waiting next block... *) - let*! new_proposal = Lwt_stream.get block_stream in - return (WithExceptions.Option.get ~loc:__LOC__ new_proposal)) - else return current_proposal - in - let config = Baking_configuration.make ~force:true () in - let rec loop current_proposal = - let* state = create_state cctxt ~config ~current_proposal delegates in - let*? current_round_duration = - Environment.wrap_tzresult - @@ compute_current_round_duration - state.global_state.round_durations - ~predecessor:state.level_state.latest_proposal.predecessor - state.round_state.current_round - in - Format.printf - "Current head level: %ld, current head round: %a@." - state.level_state.latest_proposal.block.shell.level - Round.pp - state.level_state.latest_proposal.block.round ; - Format.printf - "Current round %a. Duration: %a@." - Round.pp - state.round_state.current_round - Ptime.Span.pp - current_round_duration ; - if Ptime.Span.(compare current_round_duration round_duration_target) > 0 - then ( - Format.printf - "Current round duration is higher than %a, retrying...@." - Ptime.Span.pp - round_duration_target ; - let pred_round = - Result.value - ~default:Round.zero - (Round.pred state.round_state.current_round) - in - Format.printf "Proposing at previous round: %a@." Round.pp pred_round ; - let* () = - Baking_lib.repropose cctxt delegates ~force:true ~force_round:pred_round - in - let*! new_block = wait_next_block block_stream current_proposal in - Format.printf "Baking at next level with minimal round@." ; - let* () = - Baking_lib.bake cctxt delegates ~force:true ~minimal_timestamp:true - in - let*! new_block = wait_next_block block_stream new_block in - loop new_block) - else ( - Format.printf - "Current round duration is %a which is less than %a. Bakers may now be \ - started@." - Ptime.Span.pp - current_round_duration - Ptime.Span.pp - round_duration_target ; - return_unit) - in - let* () = loop current_proposal in - stopper () ; - let*! () = - Tezos_base_unix.Internal_event_unix.( - init ~config:(make_with_defaults ()) ()) - in - return_unit - -(** Manager injector *) - -module ManagerMap = Signature.Public_key_hash.Map -module ManagerSet = Signature.Public_key_hash.Set - -type injected_operation = { - original_hash : Operation_hash.t; - modified_hash : Operation_hash.t; -} - -type t = { - last_injected_op_per_manager : injected_operation ManagerMap.t; - operation_queues : (Operation_hash.t * packed_operation) Queue.t ManagerMap.t; -} - -let pp_state fmt {last_injected_op_per_manager; operation_queues} = - Format.fprintf - fmt - "%d injected operations pending, %d manager queues left" - (ManagerMap.cardinal last_injected_op_per_manager) - (ManagerMap.cardinal operation_queues) - -let pp_initial_state fmt {operation_queues; _} = - Format.( - fprintf - fmt - "@[%d manager queues:@ %a@]@." - (ManagerMap.cardinal operation_queues) - (pp_print_list ~pp_sep:pp_print_cut (fun fmt (manager, queue) -> - Format.fprintf - fmt - "%a: %d" - Signature.Public_key_hash.pp - manager - (Queue.length queue))) - (ManagerMap.bindings operation_queues)) - -let init ~operations_file_path = - Format.printf "Parsing operations file@." ; - let op_encoding = Protocol.Alpha_context.Operation.encoding in - let buffer = Bytes.create (10 * 1024 * 1024) (* 10mb *) in - let*! ic = Lwt_io.open_file ~mode:Input operations_file_path in - let rec loop acc = - let*! op_len = - Lwt.catch - (fun () -> - let*! op_len = Lwt_io.BE.read_int32 ic in - let*! () = - Lwt_io.read_into_exactly ic buffer 0 (Int32.to_int op_len) - in - Lwt.return_ok (`Op_len op_len)) - (function - | End_of_file -> Lwt.return_ok `EOF - | exn -> failwith "%s" (Printexc.to_string exn)) - in - match op_len with - | Error x -> Lwt.return_error x - | Ok `EOF -> return (List.rev acc) - | Ok (`Op_len op_len) -> - let op = - Data_encoding.Binary.of_bytes_exn - op_encoding - (Bytes.sub buffer 0 (Int32.to_int op_len)) - in - loop (op :: acc) - in - let total = ref 0 in - let* all_ops = loop [] in - let*! () = Lwt_io.close ic in - Format.printf "Loading operations file@." ; - let rec loop - (acc : (Operation_hash.t * packed_operation) Queue.t ManagerMap.t) : - packed_operation list -> - (Operation_hash.t * packed_operation) Queue.t ManagerMap.t = function - | [] -> acc - | ({ - protocol_data = - Operation_data {contents = Single (Manager_operation {source; _}); _}; - _; - } as op) - :: r - | ({ - protocol_data = - Operation_data - {contents = Cons (Manager_operation {source; _}, _); _}; - _; - } as op) - :: r -> - incr total ; - let oph = Operation.hash_packed op in - let acc = - ManagerMap.update - source - (function - | None -> - let q = Queue.create () in - Queue.add (oph, op) q ; - Some q - | Some q -> - Queue.add (oph, op) q ; - Some q) - acc - in - loop acc r - | _non_manager_op :: r -> loop acc r - in - let operation_queues = loop ManagerMap.empty all_ops in - Format.printf "%d manager operations loaded@." !total ; - return - { - last_injected_op_per_manager = Signature.Public_key_hash.Map.empty; - operation_queues; - } - -let choose_new_operations state prohibited_managers n = - (* Prioritize large operations queues *) - let sorted_queues = - ManagerMap.bindings state.operation_queues - |> List.sort (fun (_, q) (_, q') -> - Int.compare (Queue.length q') (Queue.length q)) - in - let ops = ref [] in - let cpt = ref 0 in - let updated_operation_queues = ref state.operation_queues in - let selected_ops = - let exception End in - try - List.iter - (fun (manager, op_q) -> - if !cpt = n then raise End ; - if not (ManagerSet.mem manager prohibited_managers) then - match Queue.take_opt op_q with - | Some op -> - incr cpt ; - ops := (manager, op) :: !ops - | None -> - updated_operation_queues := - ManagerMap.remove manager !updated_operation_queues) - sorted_queues ; - !ops - with End -> !ops - in - let state = {state with operation_queues = !updated_operation_queues} in - (selected_ops, state) - -let choose_and_inject_operations cctxt state prohibited_managers n = - let* finalized_head = Shell_services.Blocks.hash cctxt ~block:(`Head 2) () in - let cpt = ref 0 in - let errors = ref 0 in - let updated_state = ref state in - let exception End in - let* nb_injected, nb_erroneous, new_state = - Lwt.catch - (fun () -> - let* () = - ManagerMap.iter_es - (fun manager op_q -> - let* () = if !cpt = n then raise End else return_unit in - if ManagerSet.mem manager prohibited_managers then return_unit - else - match Queue.take_opt op_q with - | None -> - updated_state := - { - !updated_state with - operation_queues = - ManagerMap.remove - manager - !updated_state.operation_queues; - } ; - return_unit - | Some (original_hash, op) -> ( - let modified_op = - {op with shell = {branch = finalized_head}} - in - let modified_hash = Operation.hash_packed modified_op in - let op = {modified_hash; original_hash} in - let*! injection_result = - Shell_services.Injection.operation - cctxt - (Data_encoding.Binary.to_bytes_exn - Operation.encoding - modified_op) - in - match injection_result with - | Ok _h -> - incr cpt ; - updated_state := - { - !updated_state with - last_injected_op_per_manager = - ManagerMap.add - manager - op - !updated_state.last_injected_op_per_manager; - } ; - return_unit - | Error _err -> - incr errors ; - updated_state := - { - !updated_state with - operation_queues = - ManagerMap.remove - manager - !updated_state.operation_queues; - } ; - return_unit)) - state.operation_queues - in - return (!cpt, !errors, !updated_state)) - (function - | End -> return (!cpt, !errors, !updated_state) | exn -> Lwt.fail exn) - in - Format.printf - "%d new manager operations injected, %d erroneous operation manager queues \ - discarded@." - nb_injected - nb_erroneous ; - return new_state - -let start_injector cctxt ~op_per_mempool ~min_manager_queues - ~operations_file_path = - let* state = init ~operations_file_path in - Format.printf "Starting injector@." ; - let* head_stream, _stopper = Monitor_services.heads cctxt `Main in - let block_stream = - Lwt_stream.map_s - (fun (bh, header) -> - let*! opl = - Protocol_client_context.Alpha_block_services.Operations - .operations_in_pass - cctxt - ~metadata:`Always - ~block:(`Hash (bh, 0)) - Operation_repr.manager_pass - in - let opl = WithExceptions.Result.get_ok ~loc:__LOC__ opl in - Lwt.return (header, opl)) - head_stream - in - let*! current_head_opt = Lwt_stream.get block_stream in - let ((header, _mopl) as _current_head) = - WithExceptions.Option.get ~loc:__LOC__ current_head_opt - in - let current_level = header.shell.level in - let rec loop state current_level = - let*! r = Lwt_stream.get block_stream in - match r with - | None -> failwith "Head stream ended: lost connection with node?" - | Some (header, _opll) - when Compare.Int32.(header.shell.level <= current_level) -> - (* reorg *) - Format.printf "New head with non-increasing level: ignoring@." ; - loop state current_level - | Some (_header, mopl) as _new_head -> - Format.printf - "New increasing head received with %d included operations@." - (List.length mopl) ; - let* mempool = - Protocol_client_context.Alpha_block_services.Mempool - .pending_operations - cctxt - ~validated:true - ~refused:false - ~outdated:false - ~branch_refused:false - ~branch_delayed:false - ~validation_passes:[Operation_repr.manager_pass] - () - in - let live_operations = - Operation_hash.Set.( - union - (of_list - (List.map - fst - (Operation_hash.Map.bindings mempool.unprocessed))) - (of_list (List.map fst mempool.validated))) - in - Format.printf - "%d manager operations still live in the mempool@." - (Operation_hash.Set.cardinal live_operations) ; - let new_last_injected, prohibited_managers = - let last_injected_op_per_manager = - state.last_injected_op_per_manager - in - ManagerMap.fold - (fun manager {modified_hash; _} (new_last_injected, acc) -> - if Operation_hash.Set.mem modified_hash live_operations then - (new_last_injected, ManagerSet.add manager acc) - else (ManagerMap.remove manager new_last_injected, acc)) - last_injected_op_per_manager - (last_injected_op_per_manager, ManagerSet.empty) - in - let state = - {state with last_injected_op_per_manager = new_last_injected} - in - let nb_missing_operations = - op_per_mempool - - ManagerMap.cardinal state.last_injected_op_per_manager - in - Format.printf - "Injecting %d new manager operations...@." - nb_missing_operations ; - let* state = - choose_and_inject_operations - cctxt - state - prohibited_managers - nb_missing_operations - in - let remaining_manager_queues = - ManagerMap.cardinal state.operation_queues - in - Format.printf "Current state: %a@." pp_state state ; - (* Stop when there the number of manager operation queues left is lower - than `min_manager_queues`. *) - if remaining_manager_queues < min_manager_queues then ( - Format.printf - "Not enough manager operation queues left to continue the \ - experiment (%d left, %d required). Terminating.@. " - remaining_manager_queues - min_manager_queues ; - return_unit) - else loop state header.shell.level - in - loop state current_level - -(* Block time "hot-patch" *) - -type cycle_era = { - first_level : Raw_level_repr.t; - first_cycle : Cycle_repr.t; - blocks_per_cycle : int32; - blocks_per_commitment : int32; -} - -(* Copy-paste of the protocol abstracted cycle_eras type and - encoding *) - -type cycle_eras = cycle_era list - -let cycle_eras_encoding = - let open Result_syntax in - let create_cycle_eras cycle_eras = - match cycle_eras with - | [] -> assert false - | newest_era :: older_eras -> - let rec aux {first_level; first_cycle; _} older_eras = - match older_eras with - | ({ - first_level = first_level_of_previous_era; - first_cycle = first_cycle_of_previous_era; - _; - } as previous_era) - :: even_older_eras -> - if - Raw_level_repr.(first_level > first_level_of_previous_era) - && Cycle_repr.(first_cycle > first_cycle_of_previous_era) - then aux previous_era even_older_eras - else assert false - | [] -> return_unit - in - let* () = aux newest_era older_eras in - return cycle_eras - in - let cycle_era_encoding = - let open Data_encoding in - conv - (fun {first_level; first_cycle; blocks_per_cycle; blocks_per_commitment} -> - (first_level, first_cycle, blocks_per_cycle, blocks_per_commitment)) - (fun (first_level, first_cycle, blocks_per_cycle, blocks_per_commitment) -> - {first_level; first_cycle; blocks_per_cycle; blocks_per_commitment}) - (obj4 - (req - "first_level" - ~description:"The first level of a new cycle era." - Raw_level_repr.encoding) - (req - "first_cycle" - ~description:"The first cycle of a new cycle era." - Cycle_repr.encoding) - (req - "blocks_per_cycle" - ~description: - "The value of the blocks_per_cycle constant used during the \ - cycle era starting with first_level." - int32) - (req - "blocks_per_commitment" - ~description: - "The value of the blocks_per_commitment constant used during the \ - cycle era starting with first_level." - int32)) - in - Data_encoding.conv_with_guard - (fun eras -> eras) - (fun eras -> - match create_cycle_eras eras with - | Ok eras -> Ok eras - | Error _ -> Error "Invalid cycle eras") - (Data_encoding.list cycle_era_encoding) - -let patch_block_time ctxt ~head_level ~block_time_target = - let pf = Format.printf in - let open Environment in - let patch_flag_key = ["patch_flag"] in - let* () = - let*! opt = Context.find ctxt patch_flag_key in - match opt with - | Some _ -> - failwith - "The context was already patched with a custom block time. The patch \ - must be applied on a fresh context." - | None -> return_unit - in - let constants_key = ["v1"; "constants"] in - let* (constants : Constants_parametric_repr.t) = - let*! opt = Context.find ctxt constants_key in - match opt with - | None -> failwith "Internal error: cannot read constants in context." - | Some bytes -> ( - match - Data_encoding.Binary.of_bytes_opt - Constants_parametric_repr.encoding - bytes - with - | None -> failwith "Internal error: cannot parse constants in context." - | Some constants -> return constants) - in - let current_block_time = - Int64.to_int @@ Period_repr.to_seconds constants.minimal_block_delay - in - let speedup_ratio = float current_block_time /. float block_time_target in - let blocks_per_cycle = - float (Int32.to_int constants.blocks_per_cycle) *. speedup_ratio - |> int_of_float |> Int32.of_int - in - let hard_gas_limit_per_block = - let patched_block_gas_limit = - let b_gas_lim_f = - Gas_limit_repr.Arith.integral_to_z constants.hard_gas_limit_per_block - |> Z.to_int |> float - in - b_gas_lim_f /. speedup_ratio - |> int_of_float |> Gas_limit_repr.Arith.integral_of_int_exn - in - Gas_limit_repr.Arith.max - constants.hard_gas_limit_per_operation - patched_block_gas_limit - in - let proof_of_work_threshold = - Int64.shift_right - constants.proof_of_work_threshold - (max 0 (log speedup_ratio /. log 2. |> int_of_float)) - in - let max_operations_time_to_live = - float constants.max_operations_time_to_live *. speedup_ratio |> int_of_float - in - let minimal_block_delay = - Period_repr.of_seconds_exn (Int64.of_int block_time_target) - in - let delay_increment_per_round = - Period_repr.of_seconds_exn (Int64.of_int (max 1 (block_time_target / 2))) - in - let blocks_per_commitment = constants.blocks_per_commitment in - pf "Block time speed up ratio: %.2f%%@." (speedup_ratio *. 100.) ; - pf - "Minimal block delay: %a -> %a@." - Period_repr.pp - constants.minimal_block_delay - Period_repr.pp - minimal_block_delay ; - pf - "Delay increment per round: %a -> %a@." - Period_repr.pp - constants.delay_increment_per_round - Period_repr.pp - delay_increment_per_round ; - pf "Block per cycle: %ld -> %ld@." constants.blocks_per_cycle blocks_per_cycle ; - pf - "Hard gas limit per block: %a -> %a (minimum = hard gas limit per op. = \ - %a)@." - Gas_limit_repr.Arith.pp - constants.hard_gas_limit_per_block - Gas_limit_repr.Arith.pp - hard_gas_limit_per_block - Gas_limit_repr.Arith.pp - constants.hard_gas_limit_per_operation ; - pf - "Proof of work difficulty: %.1f -> %.1f@." - (log (float (Int64.to_int constants.proof_of_work_threshold))) - (log (float (Int64.to_int proof_of_work_threshold))) ; - pf - "Max operations time to live: %d -> %d@." - constants.max_operations_time_to_live - max_operations_time_to_live ; - let patched_constants = - { - constants with - Constants_parametric_repr.minimal_block_delay; - delay_increment_per_round; - blocks_per_cycle; - hard_gas_limit_per_block; - proof_of_work_threshold; - max_operations_time_to_live; - } - |> Data_encoding.Binary.to_bytes_exn Constants_parametric_repr.encoding - in - let cycle_eras_key = ["v1"; "cycle_eras"] in - let* patched_cycle_eras = - let*! opt = Context.find ctxt cycle_eras_key in - match opt with - | None -> failwith "Internal error: cannot read cycle eras in context." - | Some bytes -> ( - match Data_encoding.Binary.of_bytes_opt cycle_eras_encoding bytes with - | Some (latest_era :: _rest as l) -> - let head_level = Raw_level_repr.of_int32_exn head_level in - let cycle = - let level_position_in_era = - Raw_level_repr.diff head_level latest_era.first_level - in - let cycles_since_era_start = - Int32.div level_position_in_era latest_era.blocks_per_cycle - in - Cycle_repr.add - latest_era.first_cycle - (Int32.to_int cycles_since_era_start) - in - let cycle_eras = - { - first_level = head_level; - first_cycle = cycle; - blocks_per_cycle; - blocks_per_commitment; - } - :: l - in - return - (Data_encoding.Binary.to_bytes_exn cycle_eras_encoding cycle_eras) - | _ -> failwith "Internal error: cannot parse cycle eras in context.") - in - let*! ctxt = Context.add ctxt constants_key patched_constants in - let*! ctxt = Context.add ctxt cycle_eras_key patched_cycle_eras in - let*! ctxt = Context.add ctxt patch_flag_key Bytes.empty in - return ctxt - -module Tool : Sigs.PROTO_TOOL = struct - let extract_client_context cctxt = load_client_context (Generic cctxt) - - let sync_node = sync_node - - let start_injector = start_injector - - let patch_block_time = patch_block_time -end - -let () = Sigs.register Protocol.hash (module Tool) diff --git a/devtools/yes_wallet/dune b/devtools/yes_wallet/dune index 07b83017e78f80819a489505ae984f73b9ed4a1b..580df9272a29058c00601a17a6b31115a24c1556 100644 --- a/devtools/yes_wallet/dune +++ b/devtools/yes_wallet/dune @@ -12,7 +12,6 @@ octez-shell-libs.store octez-shell-libs.shell-context octez-libs.tezos-context - tezos-protocol-017-PtNairob.protocol tezos-protocol-018-Proxford.protocol tezos-protocol-alpha.protocol) (library_flags (:standard -linkall)) diff --git a/devtools/yes_wallet/get_delegates_017_PtNairob.ml b/devtools/yes_wallet/get_delegates_017_PtNairob.ml deleted file mode 100644 index dbbbcb79ea4fe731797f5e9eac7359956b3a81cb..0000000000000000000000000000000000000000 --- a/devtools/yes_wallet/get_delegates_017_PtNairob.ml +++ /dev/null @@ -1,120 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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 Get_delegates = struct - open Tezos_protocol_017_PtNairob - open Protocol - - type context = Alpha_context.t - - type contract = Alpha_context.Contract.t - - let hash = hash - - module Tez = struct - include Alpha_context.Tez - - let ( +? ) a b = Environment.wrap_tzresult (a +? b) - end - - module Signature = struct - include Tezos_crypto.Signature.V1 - module To_latest = Tezos_crypto.Signature.Of_V1 - end - - module Contract = struct - open Alpha_context.Contract - - let fold context ~init ~f = - let open Lwt_syntax in - let* l = list context in - Lwt_list.fold_left_s f init l - - let balance ctxt t = get_balance ctxt t |> Lwt.map Environment.wrap_tzresult - - let frozen_bonds ctxt t = - get_frozen_bonds ctxt t |> Lwt.map Environment.wrap_tzresult - - let get_staked_balance _ctxt _t = Lwt_result_syntax.return None - - let get_unstaked_frozen_balance _ctxt _t = Lwt_result_syntax.return None - - let get_unstaked_finalizable_balance _ctxt _t = - Lwt_result_syntax.return None - - let get_full_balance _ctxt _t = Lwt_result_syntax.return Tez.zero - - let contract_address contract = Alpha_context.Contract.to_b58check contract - - let total_supply _ctxt = Lwt_result_syntax.return Tez.zero - end - - module Commitment = struct - include Alpha_context.Commitment - - type t = Blinded_public_key_hash.t - - (* Use Obj.magic to access commitments from raw context without modifying Protocol 017 *) - let fold ctxt ~order ~init ~f = - let context : Tezos_protocol_017_PtNairob.Protocol.Raw_context.t = - Obj.magic ctxt - in - Tezos_protocol_017_PtNairob.Protocol.Storage.Commitments.fold - context - ~order - ~init - ~f:(fun c t acc -> f c (Tez_repr.to_mutez t) acc) - end - - module Delegate = struct - open Alpha_context.Delegate - - let fold ctxt ~order ~init ~f = fold ctxt ~order ~init ~f - - let pubkey ctxt pkh = - Alpha_context.Contract.get_manager_key ctxt pkh - |> Lwt.map Environment.wrap_tzresult - - let staking_balance ctxt pkh = - staking_balance ctxt pkh |> Lwt.map Environment.wrap_tzresult - - let current_frozen_deposits _ctxt _pkh = Lwt_result_syntax.return Tez.zero - - let unstaked_frozen_deposits _ctxt _pkh = Lwt_result_syntax.return Tez.zero - - let deactivated ctxt pkh = - deactivated ctxt pkh |> Lwt.map Environment.wrap_tzresult - end - - let prepare_context ctxt ~level ~predecessor_timestamp ~timestamp = - let open Lwt_result_syntax in - let+ ctxt, _, _ = - Alpha_context.prepare ctxt ~level ~predecessor_timestamp ~timestamp - |> Lwt.map Environment.wrap_tzresult - in - ctxt -end - -let () = Known_protocols.register (module Get_delegates) diff --git a/docs/doc_gen/dune b/docs/doc_gen/dune index df502c1a1618836619e605db9f052ec12449a6b8..3b229dcc5f5ce3ab52ed7b76dbc4ffaed22389d8 100644 --- a/docs/doc_gen/dune +++ b/docs/doc_gen/dune @@ -15,7 +15,6 @@ data-encoding re tezos-protocol-genesis.embedded-protocol - tezos-protocol-017-PtNairob.embedded-protocol tezos-protocol-018-Proxford.embedded-protocol tezos-protocol-alpha.embedded-protocol) (link_flags diff --git a/dune-project b/dune-project index ae616e826eae303ffc4c9782e73f7b66c01e77f1..9d879c6f78c873ca0d309d1a3365655a7d5dea66 100644 --- a/dune-project +++ b/dune-project @@ -9,11 +9,9 @@ (package (name kaitai)) (package (name kaitai-of-data-encoding)) (package (name octez-accuser-Proxford)) -(package (name octez-accuser-PtNairob)) (package (name octez-accuser-alpha)) (package (name octez-alcotezt)) (package (name octez-baker-Proxford)) -(package (name octez-baker-PtNairob)) (package (name octez-baker-alpha)) (package (name octez-client)) (package (name octez-codec)) @@ -65,7 +63,6 @@ (package (name octez-signer)) (package (name octez-smart-rollup-node)) (package (name octez-smart-rollup-node-Proxford)(allow_empty)) -(package (name octez-smart-rollup-node-PtNairob)(allow_empty)) (package (name octez-smart-rollup-node-alpha)(allow_empty)) (package (name octez-smart-rollup-node-lib)) (package (name octez-smart-rollup-wasm-debugger)) @@ -77,15 +74,12 @@ (package (name octez-version)) (package (name octogram)) (package (name tezos-benchmark)) -(package (name tezos-benchmark-017-PtNairob)) (package (name tezos-benchmark-018-Proxford)) (package (name tezos-benchmark-alpha)) (package (name tezos-benchmark-examples)) (package (name tezos-benchmark-tests)(allow_empty)) -(package (name tezos-benchmark-type-inference-017-PtNairob)) (package (name tezos-benchmark-type-inference-018-Proxford)) (package (name tezos-benchmark-type-inference-alpha)) -(package (name tezos-benchmarks-proto-017-PtNairob)) (package (name tezos-benchmarks-proto-018-Proxford)) (package (name tezos-benchmarks-proto-alpha)) (package (name tezos-client-demo-counter)) @@ -123,7 +117,6 @@ (package (name tezos-protocol-015-PtLimaPt)) (package (name tezos-protocol-016-PtMumbai)) (package (name tezos-protocol-017-PtNairob)) -(package (name tezos-protocol-017-PtNairob-tests)(allow_empty)) (package (name tezos-protocol-018-Proxford)) (package (name tezos-protocol-018-Proxford-tests)(allow_empty)) (package (name tezos-protocol-alpha)) diff --git a/manifest/main.ml b/manifest/main.ml index 59c876508ad9c19f0cfb63c8da691558a8fcbb45..657e53edfe226af97b1cde72e4a85d47f802ea71 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -7042,7 +7042,7 @@ let hash = Protocol.hash let _016_PtMumbai = frozen (Name.v "PtMumbai" 016) - let _017_PtNairob = active (Name.v "PtNairob" 017) + let _017_PtNairob = frozen (Name.v "PtNairob" 017) let _018_Proxford = active (Name.v "Proxford" 018) diff --git a/opam/octez-accuser-PtNairob.opam b/opam/octez-accuser-PtNairob.opam deleted file mode 100644 index b7402ba9a3229d0513e0a6871f09ed28a47c42f0..0000000000000000000000000000000000000000 --- a/opam/octez-accuser-PtNairob.opam +++ /dev/null @@ -1,23 +0,0 @@ -# This file was automatically generated, do not edit. -# Edit file manifest/main.ml instead. -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: [ - "dune" { >= "3.11.1" } - "ocaml" { >= "4.14" } - "octez-libs" - "tezos-protocol-017-PtNairob" - "octez-protocol-017-PtNairob-libs" - "octez-shell-libs" -] -build: [ - ["rm" "-r" "vendors" "contrib"] - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -synopsis: "Tezos/Protocol: accuser binary" diff --git a/opam/octez-baker-PtNairob.opam b/opam/octez-baker-PtNairob.opam deleted file mode 100644 index e791681b598f5f724d372f48fe01c6ff84a964d9..0000000000000000000000000000000000000000 --- a/opam/octez-baker-PtNairob.opam +++ /dev/null @@ -1,23 +0,0 @@ -# This file was automatically generated, do not edit. -# Edit file manifest/main.ml instead. -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: [ - "dune" { >= "3.11.1" } - "ocaml" { >= "4.14" } - "octez-libs" - "tezos-protocol-017-PtNairob" - "octez-protocol-017-PtNairob-libs" - "octez-shell-libs" -] -build: [ - ["rm" "-r" "vendors" "contrib"] - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -synopsis: "Tezos/Protocol: baker binary" diff --git a/opam/octez-client.opam b/opam/octez-client.opam index c4803d03b7fc91eef8ec1688693f68482f2347ed..901e6bd85c1fa9645fbd38d1b2485bb0f834c592 100644 --- a/opam/octez-client.opam +++ b/opam/octez-client.opam @@ -13,7 +13,6 @@ depends: [ "octez-libs" "octez-shell-libs" "uri" { >= "3.1.0" } - "octez-protocol-017-PtNairob-libs" "octez-protocol-018-Proxford-libs" ] depopts: [ @@ -36,6 +35,7 @@ depopts: [ "octez-protocol-014-PtKathma-libs" "octez-protocol-015-PtLimaPt-libs" "octez-protocol-016-PtMumbai-libs" + "octez-protocol-017-PtNairob-libs" "octez-protocol-alpha-libs" ] build: [ diff --git a/opam/octez-dac-client.opam b/opam/octez-dac-client.opam index 71f36c6723cde8e21768a1ee9e633145cec86114..b1192ab510b735570639b70a121863a0a4047726 100644 --- a/opam/octez-dac-client.opam +++ b/opam/octez-dac-client.opam @@ -14,7 +14,6 @@ depends: [ "octez-shell-libs" "tezos-dac-lib" "tezos-dac-client-lib" - "octez-protocol-017-PtNairob-libs" "octez-protocol-018-Proxford-libs" ] depopts: [ diff --git a/opam/octez-dac-node.opam b/opam/octez-dac-node.opam index 50b301d3ad24b2537f6240fad9adf173216619ab..4f894c67fdaddee819ea52ca21fa2b7c4326fede 100644 --- a/opam/octez-dac-node.opam +++ b/opam/octez-dac-node.opam @@ -16,7 +16,6 @@ depends: [ "tezos-dac-node-lib" "octez-l2-libs" "octez-internal-libs" - "octez-protocol-017-PtNairob-libs" "octez-protocol-018-Proxford-libs" ] depopts: [ diff --git a/opam/octez-dal-node.opam b/opam/octez-dal-node.opam index e9e5e7b1fbd86cf739de6c7d8a88e8b7915860ce..bbe049d4298b1ff598fd93581269a7a84edd33e2 100644 --- a/opam/octez-dal-node.opam +++ b/opam/octez-dal-node.opam @@ -19,7 +19,6 @@ depends: [ "octez-internal-libs" "prometheus-app" { >= "1.2" } "prometheus" { >= "1.2" } - "octez-protocol-017-PtNairob-libs" "octez-protocol-018-Proxford-libs" ] depopts: [ diff --git a/opam/octez-node.opam b/opam/octez-node.opam index 6b315f714e9b14d2c53be69167d92c0e6fbfa100..9114e5640b4d4a20a3bd6ee60d1d6702123ae528 100644 --- a/opam/octez-node.opam +++ b/opam/octez-node.opam @@ -22,8 +22,6 @@ depends: [ "lwt-exit" "uri" { >= "3.1.0" } "tezos-protocol-000-Ps9mPmXa" - "tezos-protocol-017-PtNairob" - "octez-protocol-017-PtNairob-libs" "tezos-protocol-018-Proxford" "octez-protocol-018-Proxford-libs" ] @@ -59,6 +57,8 @@ depopts: [ "octez-protocol-015-PtLimaPt-libs" "tezos-protocol-016-PtMumbai" "octez-protocol-016-PtMumbai-libs" + "tezos-protocol-017-PtNairob" + "octez-protocol-017-PtNairob-libs" "tezos-protocol-alpha" "octez-protocol-alpha-libs" ] diff --git a/opam/octez-protocol-017-PtNairob-libs.opam b/opam/octez-protocol-017-PtNairob-libs.opam index 44088be2f8a2116eb7e47d94d5742c268f89453d..7dd8b2d21b0a203e45c2b5776e10a34a8732d3da 100644 --- a/opam/octez-protocol-017-PtNairob-libs.opam +++ b/opam/octez-protocol-017-PtNairob-libs.opam @@ -15,22 +15,9 @@ depends: [ "tezos-protocol-017-PtNairob" "octez-shell-libs" "uri" { >= "3.1.0" } - "qcheck-alcotest" { >= "0.20" } "octez-proto-libs" - "octez-version" - "tezos-dal-node-services" - "lwt-canceler" { >= "0.3" & < "0.4" } - "lwt-exit" - "data-encoding" { >= "0.7.1" & < "1.0.0" } - "tezt" { >= "4.0.0" & < "5.0.0" } - "octez-protocol-compiler" - "tezos-dal-node-lib" - "tezos-dac-lib" - "tezos-dac-client-lib" "octez-injector" "octez-l2-libs" - "octez-alcotezt" {with-test} - "tezos-dac-node-lib" {with-test} ] build: [ ["rm" "-r" "vendors" "contrib"] diff --git a/opam/octez-smart-rollup-node-PtNairob.opam b/opam/octez-smart-rollup-node-PtNairob.opam deleted file mode 100644 index 767890dfaf4bcf025f71ed70d060fdfb320ad85d..0000000000000000000000000000000000000000 --- a/opam/octez-smart-rollup-node-PtNairob.opam +++ /dev/null @@ -1,38 +0,0 @@ -# This file was automatically generated, do not edit. -# Edit file manifest/main.ml instead. -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: [ - "dune" { >= "3.11.1" } - "ocaml" { >= "4.14" } - "octez-libs" - "octez-shell-libs" - "octez-protocol-017-PtNairob-libs" - "tezos-protocol-017-PtNairob" - "tezos-dal-node-services" - "tezos-dal-node-lib" - "tezos-dac-lib" - "octez-l2-libs" - "octez-crawler" - "data-encoding" { >= "0.7.1" & < "1.0.0" } - "octez-internal-libs" - "aches" { >= "1.0.0" } - "aches-lwt" { >= "1.0.0" } - "octez-injector" - "octez-smart-rollup-node-lib" - "octez-version" -] -conflicts: [ - "checkseum" { = "0.5.0" } -] -build: [ - ["rm" "-r" "vendors" "contrib"] - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -synopsis: "Protocol specific (for 017-PtNairob) library for smart rollup node" diff --git a/opam/octez-smart-rollup-node.opam b/opam/octez-smart-rollup-node.opam index 7be1d4cc0ee4e153c67e9a4e6d1a1e935c64ccaa..b1878a685002651834026f8dd5d9fd5dcb271cbf 100644 --- a/opam/octez-smart-rollup-node.opam +++ b/opam/octez-smart-rollup-node.opam @@ -14,7 +14,6 @@ depends: [ "octez-shell-libs" "octez-l2-libs" "octez-smart-rollup-node-lib" - "octez-smart-rollup-node-PtNairob" "octez-smart-rollup-node-Proxford" ] depopts: [ diff --git a/opam/tezos-benchmark-017-PtNairob.opam b/opam/tezos-benchmark-017-PtNairob.opam deleted file mode 100644 index 19430157107d0dcf4bd0ffa9b90cfe9be1afb19b..0000000000000000000000000000000000000000 --- a/opam/tezos-benchmark-017-PtNairob.opam +++ /dev/null @@ -1,27 +0,0 @@ -# This file was automatically generated, do not edit. -# Edit file manifest/main.ml instead. -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: [ - "dune" { >= "3.11.1" } - "ocaml" { >= "4.14" } - "octez-libs" - "tezos-micheline-rewriting" - "tezos-benchmark" - "tezos-benchmark-type-inference-017-PtNairob" - "tezos-protocol-017-PtNairob" - "hashcons" - "octez-protocol-017-PtNairob-libs" - "prbnmcn-stats" { = "0.0.6" } -] -build: [ - ["rm" "-r" "vendors" "contrib"] - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -synopsis: "Tezos/Protocol: library for writing benchmarks (protocol-specific part)" diff --git a/opam/tezos-benchmark-type-inference-017-PtNairob.opam b/opam/tezos-benchmark-type-inference-017-PtNairob.opam deleted file mode 100644 index 03040f582947f2cd910bcde673665cc18abf9dc6..0000000000000000000000000000000000000000 --- a/opam/tezos-benchmark-type-inference-017-PtNairob.opam +++ /dev/null @@ -1,24 +0,0 @@ -# This file was automatically generated, do not edit. -# Edit file manifest/main.ml instead. -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: [ - "dune" { >= "3.11.1" } - "ocaml" { >= "4.14" } - "octez-libs" - "tezos-micheline-rewriting" - "tezos-protocol-017-PtNairob" - "hashcons" - "octez-protocol-017-PtNairob-libs" {with-test} -] -build: [ - ["rm" "-r" "vendors" "contrib"] - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -synopsis: "Tezos: type inference for partial Michelson expressions" diff --git a/opam/tezos-benchmarks-proto-017-PtNairob.opam b/opam/tezos-benchmarks-proto-017-PtNairob.opam deleted file mode 100644 index 4aa4b77d61e1865ad3e1cbc9b39e09db1d6fe4f8..0000000000000000000000000000000000000000 --- a/opam/tezos-benchmarks-proto-017-PtNairob.opam +++ /dev/null @@ -1,27 +0,0 @@ -# This file was automatically generated, do not edit. -# Edit file manifest/main.ml instead. -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: [ - "dune" { >= "3.11.1" } - "ocaml" { >= "4.14" } - "octez-libs" - "tezos-protocol-017-PtNairob" - "tezos-benchmark" - "tezos-benchmark-017-PtNairob" - "tezos-benchmark-type-inference-017-PtNairob" - "octez-shell-libs" - "octez-protocol-017-PtNairob-libs" - "octez-proto-libs" -] -build: [ - ["rm" "-r" "vendors" "contrib"] - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -synopsis: "Tezos/Protocol: protocol benchmarks" diff --git a/opam/tezos-protocol-017-PtNairob-tests.opam b/opam/tezos-protocol-017-PtNairob-tests.opam deleted file mode 100644 index d88e5d929fec8da780c8c67cc9134cf83240965c..0000000000000000000000000000000000000000 --- a/opam/tezos-protocol-017-PtNairob-tests.opam +++ /dev/null @@ -1,32 +0,0 @@ -# This file was automatically generated, do not edit. -# Edit file manifest/main.ml instead. -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: [ - "dune" { >= "3.11.1" } - "ocaml" { >= "4.14" } - "tezt" { with-test & >= "4.0.0" & < "5.0.0" } - "octez-libs" {with-test} - "octez-alcotezt" {with-test} - "octez-protocol-017-PtNairob-libs" {with-test} - "tezos-protocol-017-PtNairob" {with-test} - "tezos-benchmark" {with-test} - "tezos-benchmark-017-PtNairob" {with-test} - "tezos-benchmark-type-inference-017-PtNairob" {with-test} - "qcheck-alcotest" { with-test & >= "0.20" } - "tezt-tezos" {with-test} - "octez-shell-libs" {with-test} - "octez-proto-libs" {with-test} - "octez-l2-libs" {with-test} -] -build: [ - ["rm" "-r" "vendors" "contrib"] - ["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/opam/tezos-sc-rollup-node-test.opam b/opam/tezos-sc-rollup-node-test.opam index 079ca53c76f00658d568f97eee98bb6fe2682779..d9a692712fee9e4fb11312ba63b98e633707f990 100644 --- a/opam/tezos-sc-rollup-node-test.opam +++ b/opam/tezos-sc-rollup-node-test.opam @@ -12,13 +12,10 @@ depends: [ "ocaml" { >= "4.14" } "tezt" { with-test & >= "4.0.0" & < "5.0.0" } "octez-libs" {with-test} - "tezos-protocol-017-PtNairob" {with-test} - "octez-protocol-017-PtNairob-libs" {with-test} - "octez-smart-rollup-node-PtNairob" {with-test} - "octez-alcotezt" {with-test} "tezos-protocol-018-Proxford" {with-test} "octez-protocol-018-Proxford-libs" {with-test} "octez-smart-rollup-node-Proxford" {with-test} + "octez-alcotezt" {with-test} "tezos-protocol-alpha" {with-test} "octez-protocol-alpha-libs" {with-test} "octez-smart-rollup-node-alpha" {with-test} diff --git a/opam/tezos-smart-rollup-node-lib-test.opam b/opam/tezos-smart-rollup-node-lib-test.opam index 83bda66b8075595fdf5a616c0356f5bb6f65ad18..fc77110ce6c02b7f08f65b631f9cd9a00323a6d9 100644 --- a/opam/tezos-smart-rollup-node-lib-test.opam +++ b/opam/tezos-smart-rollup-node-lib-test.opam @@ -19,7 +19,6 @@ depends: [ "logs" {with-test} "octez-alcotezt" {with-test} "octez-shell-libs" {with-test} - "octez-smart-rollup-node-PtNairob" {with-test} "octez-smart-rollup-node-Proxford" {with-test} ] depopts: [ diff --git a/script-inputs/active_protocol_versions b/script-inputs/active_protocol_versions index c1c04e8513da44b45d5e7b75e01d7a980429a983..65608b5202f9d595367e4d477c2d0acf3b8d3cb1 100644 --- a/script-inputs/active_protocol_versions +++ b/script-inputs/active_protocol_versions @@ -1,3 +1,2 @@ -017-PtNairob 018-Proxford alpha diff --git a/script-inputs/active_protocol_versions_without_number b/script-inputs/active_protocol_versions_without_number index 87e28beac15f97693f36555e41811bd770f1022a..79a02e742b12661baddd7668e07996fb52acb22d 100644 --- a/script-inputs/active_protocol_versions_without_number +++ b/script-inputs/active_protocol_versions_without_number @@ -1,3 +1,2 @@ -PtNairob Proxford alpha diff --git a/script-inputs/released-executables b/script-inputs/released-executables index ec30c7e602f19661e33f7b79913b62ac92d567ec..4d71cd89c7dc9328064102ff63e3fe4b1984dcef 100644 --- a/script-inputs/released-executables +++ b/script-inputs/released-executables @@ -10,5 +10,3 @@ octez-admin-client octez-node octez-accuser-Proxford octez-baker-Proxford -octez-accuser-PtNairob -octez-baker-PtNairob diff --git a/src/bin_client/dune b/src/bin_client/dune index 08f4ec5b3dfb90f4bceb38821bb7d1dea1f887c5..62f2100f26ed03d7c97a2d5cc00be46bec141f97 100644 --- a/src/bin_client/dune +++ b/src/bin_client/dune @@ -107,9 +107,12 @@ (select void_for_linking-octez-protocol-016-PtMumbai-libs-plugin from (octez-protocol-016-PtMumbai-libs.plugin -> void_for_linking-octez-protocol-016-PtMumbai-libs-plugin.empty) (-> void_for_linking-octez-protocol-016-PtMumbai-libs-plugin.empty)) - octez-protocol-017-PtNairob-libs.client.commands-registration - octez-protocol-017-PtNairob-libs.baking-commands.registration - octez-protocol-017-PtNairob-libs.plugin + (select void_for_linking-octez-protocol-017-PtNairob-libs-client-commands-registration from + (octez-protocol-017-PtNairob-libs.client.commands-registration -> void_for_linking-octez-protocol-017-PtNairob-libs-client-commands-registration.empty) + (-> void_for_linking-octez-protocol-017-PtNairob-libs-client-commands-registration.empty)) + (select void_for_linking-octez-protocol-017-PtNairob-libs-plugin from + (octez-protocol-017-PtNairob-libs.plugin -> void_for_linking-octez-protocol-017-PtNairob-libs-plugin.empty) + (-> void_for_linking-octez-protocol-017-PtNairob-libs-plugin.empty)) octez-protocol-018-Proxford-libs.client.commands-registration octez-protocol-018-Proxford-libs.baking-commands.registration octez-protocol-018-Proxford-libs.plugin @@ -170,6 +173,8 @@ (write-file void_for_linking-octez-protocol-015-PtLimaPt-libs-plugin.empty "") (write-file void_for_linking-octez-protocol-016-PtMumbai-libs-client-commands-registration.empty "") (write-file void_for_linking-octez-protocol-016-PtMumbai-libs-plugin.empty "") + (write-file void_for_linking-octez-protocol-017-PtNairob-libs-client-commands-registration.empty "") + (write-file void_for_linking-octez-protocol-017-PtNairob-libs-plugin.empty "") (write-file void_for_linking-octez-protocol-alpha-libs-client-commands-registration.empty "") (write-file void_for_linking-octez-protocol-alpha-libs-baking-commands-registration.empty "") (write-file void_for_linking-octez-protocol-alpha-libs-plugin.empty "")))) diff --git a/src/bin_dac_client/dune b/src/bin_dac_client/dune index 028f2a2d354a77590d4c0eb6ee40c4cc8cf38477..496d6292ebd15c371bbfa18f0f808e5605d93e1e 100644 --- a/src/bin_dac_client/dune +++ b/src/bin_dac_client/dune @@ -17,7 +17,6 @@ octez-libs.stdlib tezos-dac-lib tezos-dac-client-lib - octez-protocol-017-PtNairob-libs.dac octez-protocol-018-Proxford-libs.dac (select void_for_linking-octez-protocol-alpha-libs-dac from (octez-protocol-alpha-libs.dac -> void_for_linking-octez-protocol-alpha-libs-dac.empty) diff --git a/src/bin_dac_node/dune b/src/bin_dac_node/dune index 2c15e3d7f17f28e79faefdf15ae0c7c0dd0ae370..798fefae1b5958d974c3278deee929acd0d5603d 100644 --- a/src/bin_dac_node/dune +++ b/src/bin_dac_node/dune @@ -25,7 +25,6 @@ octez-internal-libs.irmin_pack octez-internal-libs.irmin_pack.unix octez-internal-libs.irmin - octez-protocol-017-PtNairob-libs.dac octez-protocol-018-Proxford-libs.dac (select void_for_linking-octez-protocol-alpha-libs-dac from (octez-protocol-alpha-libs.dac -> void_for_linking-octez-protocol-alpha-libs-dac.empty) diff --git a/src/bin_dal_node/dune b/src/bin_dal_node/dune index 1407cda6d1833558c1176fe16fb0ab4351c65129..bf0ea5c49aa68cf6ab16bc1670f87e3598a4af48 100644 --- a/src/bin_dal_node/dune +++ b/src/bin_dal_node/dune @@ -38,7 +38,6 @@ octez-internal-libs.irmin prometheus-app prometheus - octez-protocol-017-PtNairob-libs.dal octez-protocol-018-Proxford-libs.dal (select void_for_linking-octez-protocol-alpha-libs-dal from (octez-protocol-alpha-libs.dal -> void_for_linking-octez-protocol-alpha-libs-dal.empty) diff --git a/src/bin_node/dune b/src/bin_node/dune index ad1b852dce858afa228333c9c3ac68e504c8d3eb..2210337774cdd594124a284c0898b82aa7de75b5 100644 --- a/src/bin_node/dune +++ b/src/bin_node/dune @@ -129,8 +129,12 @@ (select void_for_linking-octez-protocol-016-PtMumbai-libs-plugin-registerer from (octez-protocol-016-PtMumbai-libs.plugin-registerer -> void_for_linking-octez-protocol-016-PtMumbai-libs-plugin-registerer.empty) (-> void_for_linking-octez-protocol-016-PtMumbai-libs-plugin-registerer.empty)) - tezos-protocol-017-PtNairob.embedded-protocol - octez-protocol-017-PtNairob-libs.plugin-registerer + (select void_for_linking-tezos-protocol-017-PtNairob-embedded-protocol from + (tezos-protocol-017-PtNairob.embedded-protocol -> void_for_linking-tezos-protocol-017-PtNairob-embedded-protocol.empty) + (-> void_for_linking-tezos-protocol-017-PtNairob-embedded-protocol.empty)) + (select void_for_linking-octez-protocol-017-PtNairob-libs-plugin-registerer from + (octez-protocol-017-PtNairob-libs.plugin-registerer -> void_for_linking-octez-protocol-017-PtNairob-libs-plugin-registerer.empty) + (-> void_for_linking-octez-protocol-017-PtNairob-libs-plugin-registerer.empty)) tezos-protocol-018-Proxford.embedded-protocol octez-protocol-018-Proxford-libs.plugin-registerer (select void_for_linking-tezos-protocol-alpha-embedded-protocol from @@ -200,6 +204,8 @@ (write-file void_for_linking-octez-protocol-015-PtLimaPt-libs-plugin-registerer.empty "") (write-file void_for_linking-tezos-protocol-016-PtMumbai-embedded-protocol.empty "") (write-file void_for_linking-octez-protocol-016-PtMumbai-libs-plugin-registerer.empty "") + (write-file void_for_linking-tezos-protocol-017-PtNairob-embedded-protocol.empty "") + (write-file void_for_linking-octez-protocol-017-PtNairob-libs-plugin-registerer.empty "") (write-file void_for_linking-tezos-protocol-alpha-embedded-protocol.empty "") (write-file void_for_linking-octez-protocol-alpha-libs-plugin-registerer.empty "")))) diff --git a/src/bin_smart_rollup_node/dune b/src/bin_smart_rollup_node/dune index 78a4c8ca9f5e2aca832d97d29433345c8eb33a4d..9c9ddaa797a4e6233f1c491e5475350810020cf1 100644 --- a/src/bin_smart_rollup_node/dune +++ b/src/bin_smart_rollup_node/dune @@ -15,7 +15,6 @@ octez-shell-libs.client-commands octez-l2-libs.smart-rollup octez-smart-rollup-node-lib - octez_smart_rollup_node_PtNairob octez_smart_rollup_node_Proxford (select void_for_linking-octez_smart_rollup_node_alpha from (octez_smart_rollup_node_alpha -> void_for_linking-octez_smart_rollup_node_alpha.empty) diff --git a/src/lib_smart_rollup_node/test/helpers/dune b/src/lib_smart_rollup_node/test/helpers/dune index 2ea722492b5b3b4ab6790a2f0f72d68aed99d2d6..5fcb0e0de6e1ab440fff163c2578ec2e0c0719bd 100644 --- a/src/lib_smart_rollup_node/test/helpers/dune +++ b/src/lib_smart_rollup_node/test/helpers/dune @@ -16,7 +16,6 @@ octez-l2-libs.smart-rollup octez-smart-rollup-node-lib octez-l2-libs.layer2_store - octez_smart_rollup_node_PtNairob octez_smart_rollup_node_Proxford (select void_for_linking-octez_smart_rollup_node_alpha from (octez_smart_rollup_node_alpha -> void_for_linking-octez_smart_rollup_node_alpha.empty) diff --git a/src/proto_017_PtNairob/bin_accuser/dune b/src/proto_017_PtNairob/bin_accuser/dune deleted file mode 100644 index fa09ae7e415b7569db20aaec08f0572ee9064147..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/bin_accuser/dune +++ /dev/null @@ -1,31 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(executable - (name main_accuser_017_PtNairob) - (public_name octez-accuser-PtNairob) - (package octez-accuser-PtNairob) - (instrumentation (backend bisect_ppx)) - (libraries - octez-libs.base - octez-libs.clic - tezos-protocol-017-PtNairob.protocol - octez-protocol-017-PtNairob-libs.client - octez-shell-libs.client-commands - octez-protocol-017-PtNairob-libs.baking-commands - octez-libs.stdlib-unix - octez-shell-libs.client-base-unix) - (link_flags - (:standard) - (:include %{workspace_root}/static-link-flags.sexp) - (:include %{workspace_root}/macos-link-flags.sexp)) - (flags - (:standard) - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_protocol_017_PtNairob - -open Tezos_client_017_PtNairob - -open Tezos_client_commands - -open Tezos_baking_017_PtNairob_commands - -open Tezos_stdlib_unix - -open Tezos_client_base_unix)) diff --git a/src/proto_017_PtNairob/bin_accuser/main_accuser_017_PtNairob.ml b/src/proto_017_PtNairob/bin_accuser/main_accuser_017_PtNairob.ml deleted file mode 100644 index ebbd70c5ebed3685e1b3cbdc6dea55b573523e53..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/bin_accuser/main_accuser_017_PtNairob.ml +++ /dev/null @@ -1,38 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2019 Nomadic Labs, *) -(* *) -(* 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 () = - Client_commands.register Protocol.hash @@ fun _network -> - List.map (Tezos_clic.map_command (new Protocol_client_context.wrap_full)) - @@ Baking_commands.accuser_commands () - -let select_commands _ _ = - return - (List.map - (Tezos_clic.map_command (new Protocol_client_context.wrap_full)) - (Baking_commands.accuser_commands ())) - -let () = Client_main_run.run (module Daemon_config) ~select_commands diff --git a/src/proto_017_PtNairob/bin_baker/dune b/src/proto_017_PtNairob/bin_baker/dune deleted file mode 100644 index 0c3eaff571510229b1fe4340bf9f8d6f8d78165a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/bin_baker/dune +++ /dev/null @@ -1,31 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(executable - (name main_baker_017_PtNairob) - (public_name octez-baker-PtNairob) - (package octez-baker-PtNairob) - (instrumentation (backend bisect_ppx)) - (libraries - octez-libs.base - octez-libs.clic - tezos-protocol-017-PtNairob.protocol - octez-protocol-017-PtNairob-libs.client - octez-shell-libs.client-commands - octez-protocol-017-PtNairob-libs.baking-commands - octez-libs.stdlib-unix - octez-shell-libs.client-base-unix) - (link_flags - (:standard) - (:include %{workspace_root}/static-link-flags.sexp) - (:include %{workspace_root}/macos-link-flags.sexp)) - (flags - (:standard) - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_protocol_017_PtNairob - -open Tezos_client_017_PtNairob - -open Tezos_client_commands - -open Tezos_baking_017_PtNairob_commands - -open Tezos_stdlib_unix - -open Tezos_client_base_unix)) diff --git a/src/proto_017_PtNairob/bin_baker/main_baker_017_PtNairob.ml b/src/proto_017_PtNairob/bin_baker/main_baker_017_PtNairob.ml deleted file mode 100644 index bd7485151dc4f001b92c607a2e196c54e88f251b..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/bin_baker/main_baker_017_PtNairob.ml +++ /dev/null @@ -1,53 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2019 Nomadic Labs, *) -(* *) -(* 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 () = - Client_commands.register Protocol.hash @@ fun _network -> - List.map (Tezos_clic.map_command (new Protocol_client_context.wrap_full)) - @@ Baking_commands.baker_commands () - -let select_commands _ _ = - return - (List.map - (Tezos_clic.map_command (new Protocol_client_context.wrap_full)) - (Baking_commands.baker_commands ())) - -(* This call is not strictly necessary as the parameters are initialized - lazily the first time a Sapling operation (validation or forging) is - done. This is what the client does. - For a long running binary however it is important to make sure that the - parameters files are there at the start and avoid failing much later while - validating an operation. Plus paying this cost upfront means that the first - validation will not be more expensive. *) -let () = Tezos_sapling.Core.Validator.init_params () - -module Config = struct - include Daemon_config - - let default_daily_logs_path = Some ("octez-baker-" ^ Protocol.name) -end - -let () = Client_main_run.run (module Config) ~select_commands diff --git a/src/proto_017_PtNairob/lib_benchmark/README.md b/src/proto_017_PtNairob/lib_benchmark/README.md deleted file mode 100644 index 8adba76cbf901753ff9f76082b04be90aee0ff90..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/README.md +++ /dev/null @@ -1,42 +0,0 @@ -# `Tezos_benchmark_alpha` - -This library is dedicated to sampling Michelson values and in particular -Michelson programs. - -## Architecture - -This library provides a sampling-based interface for well-typed -Michelson generation. Internally, this library is built on a sampler for an -intermediate language called Mikhailsky post-composed with a function to -map Mikhailsky terms to Michelson ones. - -### Layer 1: Mikhailsky - Mikhailsky corresponds to "Michelson with typed holes". Mikhailsky terms - are encoded inside Micheline. The library `lib_benchmark_type_inference` - provides the language definition as well as a type inference engine. - -### Layer 2: Sampling Mikhailsky terms - We sample Mikhailsky terms using a Markov chain where transitions correspond - to local rewriting rules. The state space of the Markov chain is defined - in `State_space` module. The rewriting infrastructure is provided in the - `Kernel` module by instantiating `lib_micheline_rewriting`. - Rewrites are checked to preserved well-typedness in the Mikhailsky sense - using the type inference engine provided with Mikhailsky. The `Rules` - module defines all rewriting rules, for both Mikhailsky _programs_ - (submodule `Rules.Instruction`) and _data_ - (submodule `Rules.Data_rewrite_leaves`). The function `Rules.rewriting` - performs the enumeration of possible rewritings. - - The Markov chain is biased to sample terms of a specified - size using the Metropolis-Hasting functors provided by `StaTz`. - The instantiation of this Markov chain is defined in the `Sampler` - module. - -### Layer 3: - Once we can sample Mikhaislky terms of a specified size, we need - to convert them to Michelson ones. This is performed in two steps. - - In the first step, we use the `Autocomplete` module to fill holes - in Mikhailsky terms (resp. data) with well-typed code (resp. data). - This is a relatively ad-hoc process. - - The last step is to convert Mikhaislky to Michelson using the - `Michelson` module. diff --git a/src/proto_017_PtNairob/lib_benchmark/autocomp.ml b/src/proto_017_PtNairob/lib_benchmark/autocomp.ml deleted file mode 100644 index 0b3f0d8b62debbb1bc48a95a505df191e45ccaf4..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/autocomp.ml +++ /dev/null @@ -1,380 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Autocompletion functions (removing holes from Mikhailsky terms). *) - -open Sampling_helpers - -(* ------------------------------------------------------------------------- *) -(* Helpers *) - -let rec stack_length (stack : Type.Stack.t) acc = - match stack.node with - | Empty_t -> acc - | Stack_var_t _ -> acc + 1 - | Item_t (_, tl) -> stack_length tl (acc + 1) - -(* We need to sort and remove duplicate elements - of sets and maps to make them Michelson-compatible. *) -let sort_set_elements elements = - List.sort_uniq - (Structural_compare.compare - ~prim_compare:Mikhailsky.Mikhailsky_signature.compare) - elements - -let sort_map_elements elements = - let open Micheline in - List.sort_uniq - (fun node1 node2 -> - match (node1, node2) with - | ( Prim (_, Mikhailsky_prim.D_Elt, [k1; _v1], _), - Prim (_, Mikhailsky_prim.D_Elt, [k2; _v2], _) ) -> - Structural_compare.compare - ~prim_compare:Mikhailsky.Mikhailsky_signature.compare - k1 - k2 - | _ -> Stdlib.failwith "Autocomp.sort_map_elements: invalid Michelson map") - elements - -(* ------------------------------------------------------------------------- *) -(* Error handling *) - -type error_case = - | Cannot_complete_data of Mikhailsky.node * Kernel.Path.t - | Cannot_complete_code of Mikhailsky.node * Kernel.Path.t - -exception Autocompletion_error of error_case - -let cannot_complete_data node path = - raise (Autocompletion_error (Cannot_complete_data (node, path))) - -let cannot_complete_code node path = - raise (Autocompletion_error (Cannot_complete_code (node, path))) - -(* ------------------------------------------------------------------------- *) -(* Code & data autocompletion *) - -(* By default, comparable values are unit. *) -let default_comparable_type = Type.unit - -let generate_comparable _sp = Mikhailsky.Data.unit - -(* Instantiates variables in a base type, remaining variables - are mapped to some consistent choice of ground type - (this is made complicated by comparability constraints) *) -let rec instantiate_and_set ty = - let open Inference.M in - Inference.instantiate_base ty >>= fun ty -> replace_vars ty - -and replace_vars (ty : Type.Base.t) = - let open Inference.M in - let node = ty.node in - match node with - | Type.Base.Unit_t | Type.Base.Int_t | Type.Base.Nat_t | Type.Base.Bool_t - | Type.Base.String_t | Type.Base.Bytes_t | Type.Base.Key_hash_t - | Type.Base.Timestamp_t | Type.Base.Mutez_t | Type.Base.Key_t -> - return ty - | Type.Base.Var_t v -> ( - get_repr_exn v >>= fun repr -> - match repr with - | Inference.Stack_type _ -> assert false - | Inference.Base_type {comparable = _; repr = Some _} -> assert false - | Inference.Base_type {comparable; repr = None} -> ( - match comparable with - | Inference.Comparable -> return default_comparable_type - | Inference.Unconstrained | Inference.Not_comparable -> - return Type.unit)) - | Type.Base.Option_t ty -> - replace_vars ty >>= fun ty -> return (Type.option ty) - | Type.Base.Pair_t (lt, rt) -> - replace_vars lt >>= fun lt -> - replace_vars rt >>= fun rt -> return (Type.pair lt rt) - | Type.Base.Or_t (lt, rt) -> - replace_vars lt >>= fun lt -> - replace_vars rt >>= fun rt -> return (Type.or_ lt rt) - | Type.Base.List_t ty -> replace_vars ty >>= fun ty -> return (Type.list ty) - | Type.Base.Set_t ty -> replace_vars ty >>= fun ty -> return (Type.set ty) - | Type.Base.Map_t (k, v) -> - replace_vars k >>= fun k -> - replace_vars v >>= fun v -> return (Type.map k v) - | Type.Base.Lambda_t (dom, range) -> - replace_vars dom >>= fun dom -> - replace_vars range >>= fun range -> return (Type.lambda dom range) - -let rec instantiate_and_set_stack (stack_ty : Type.Stack.t) = - let open Inference.M in - let node = stack_ty.node in - match node with - | Type.Stack.Empty_t -> return Type.empty - | Type.Stack.Stack_var_t _ -> return Type.empty - | Type.Stack.Item_t (hd, tl) -> - instantiate_and_set hd >>= fun hd -> - instantiate_and_set_stack tl >>= fun tl -> return (Type.item hd tl) - -(* In the following we perform computations in the composite monad - (sampler o Inference.M.t), it is convenient to define the bind and return - explicitly. *) -module SM = struct - type 'a t = 'a Inference.M.t sampler - - let ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t = - fun m f rng_state s -> - let x, s = m rng_state s in - f x rng_state s - [@@inline] - - let sample : 'a sampler -> 'a Inference.M.t sampler = - fun x rng_state st -> (x rng_state, st) - [@@inline] - - let deterministic : 'a Inference.M.t -> 'a t = fun x _rng_state -> x - - let return x _ s = (x, s) [@@inline] -end - -module Make - (Michelson_base : Michelson_samplers_base.S) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) = -struct - (* Generates minimally sized random data of specified type. - Used in autocompletion. *) - (* /!\ Always call [instantiate_and_set] on the type argument of - [generate_data]. /!\ *) - let rec generate_data : Type.Base.t -> Mikhailsky.node SM.t = - fun ty -> - let open SM in - let open Type.Base in - let desc = ty.node in - match desc with - | Var_t _v -> assert false - | Unit_t -> return Mikhailsky.Data.unit - | Int_t -> - sample @@ Michelson_base.int >>= fun i -> - let i = Protocol.Script_int.to_zint i in - return (Mikhailsky.Data.big_integer i) - | Nat_t -> - sample @@ Michelson_base.nat >>= fun n -> - let n = Protocol.Script_int.to_zint n in - return (Mikhailsky.Data.big_natural n) - | Bool_t -> - sample Base_samplers.uniform_bool >>= fun b -> - if b then return Mikhailsky.Data.true_ - else return Mikhailsky.Data.false_ - | String_t -> - sample Michelson_base.string >>= fun str -> - let str = Protocol.Script_string.to_string str in - return (Mikhailsky.Data.string str) - | Bytes_t -> - sample Michelson_base.bytes >>= fun bytes -> - return (Mikhailsky.Data.bytes bytes) - | Key_hash_t -> - sample Crypto_samplers.pkh >>= fun pkh -> - return (Mikhailsky.Data.key_hash pkh) - | Timestamp_t -> - sample Michelson_base.timestamp >>= fun tstamp -> - return (Mikhailsky.Data.timestamp tstamp) - | Mutez_t -> - sample Michelson_base.tez >>= fun tz -> - return (Mikhailsky.Data.mutez tz) - | Key_t -> - sample Crypto_samplers.pk >>= fun pk -> return (Mikhailsky.Data.key pk) - | Option_t ty -> - sample Base_samplers.uniform_bool >>= fun b -> - if b then return Mikhailsky.Data.none - else generate_data ty >>= fun res -> return (Mikhailsky.Data.some res) - | Pair_t (lty, rty) -> - generate_data lty >>= fun lv -> - generate_data rty >>= fun rv -> return (Mikhailsky.Data.pair lv rv) - | Or_t (lty, rty) -> - sample Base_samplers.uniform_bool >>= fun b -> - if b then generate_data lty >>= fun v -> return (Mikhailsky.Data.left v) - else generate_data rty >>= fun v -> return (Mikhailsky.Data.right v) - | List_t _ty -> return (Mikhailsky.Data.list []) - | Set_t _ty -> return (Mikhailsky.Data.set []) - | Map_t (_kty, _vty) -> return (Mikhailsky.Data.map []) - | Lambda_t (dom, range) -> - invent_term Type.(item dom empty) Type.(item range empty) - >>= fun code -> return (Mikhailsky.Data.lambda code) - - and invent_term (bef : Type.Stack.t) (aft : Type.Stack.t) : - Mikhailsky.node list SM.t = - let open SM in - install_dummy_stack aft [] >>= fun code -> - let terms = drop_stack bef code in - return terms - - and drop_stack (stack : Type.Stack.t) code = - Mikhailsky.Instructions.dropn (stack_length stack 0) :: code - - and install_dummy_stack (stack : Type.Stack.t) (acc : Mikhailsky.node list) = - let open SM in - match stack.node with - | Empty_t -> return acc - | Stack_var_t _ -> - let acc = Mikhailsky.(Instructions.push unit_ty Data.unit) :: acc in - return acc - | Item_t (hd, tl) -> - deterministic @@ instantiate_and_set hd >>= fun hd -> - (match hd.node with - | Lambda_t (dom, range) -> - invent_term Type.(item dom empty) Type.(item range empty) - >>= fun code -> - let instr = Mikhailsky.(prim I_LAMBDA [seq code] []) in - return instr - | _ -> - generate_data hd >>= fun term -> - let ty = Mikhailsky.unparse_ty_exn hd in - return (Mikhailsky.Instructions.push ty term)) - >>= fun instr -> install_dummy_stack tl (instr :: acc) - - (* Autocomplete Mikhailsky data. - When encountering a hole, we lookup its type and instantiate - some random data of the specified type. *) - let rec complete_data : - Mikhailsky.node -> Kernel.Path.t -> Mikhailsky.node SM.t = - let open SM in - fun node path -> - match node with - | Micheline.Int (_, _) | Micheline.String (_, _) | Micheline.Bytes (_, _) - -> - return node - | Micheline.Prim (_, D_Hole, _, _) -> ( - deterministic @@ Inference.M.get_data_annot path >>= fun ty_opt -> - match ty_opt with - | None -> cannot_complete_data node path - | Some ty -> - deterministic @@ instantiate_and_set ty >>= fun ty -> - generate_data ty) - | Micheline.Prim (_, A_Set, [Micheline.Seq (_, elements)], _) -> - complete_data_list (Kernel.Path.at_index 0 path) 0 elements [] - >>= fun elements -> - let elements = sort_set_elements elements in - return (Mikhailsky.Data.set elements) - | Micheline.Prim (_, A_Map, [Micheline.Seq (_, elements)], _) -> - complete_data_list (Kernel.Path.at_index 0 path) 0 elements [] - >>= fun elements -> - let elements = sort_map_elements elements in - return (Mikhailsky.Data.map elements) - | Micheline.Prim (_, prim, subterms, _) -> - complete_data_list path 0 subterms [] >>= fun subterms -> - return (Mikhailsky.prim prim subterms []) - | Micheline.Seq (_, subterms) -> - complete_data_list path 0 subterms [] >>= fun subterms -> - return (Mikhailsky.seq subterms) - - and complete_data_list path i subterms acc = - let open SM in - match subterms with - | [] -> return (List.rev acc) - | subterm :: tl -> - let path' = Kernel.Path.at_index i path in - complete_data subterm path' >>= fun term -> - complete_data_list path (i + 1) tl (term :: acc) - - let complete_data typing node rng_state = - let root_type_opt, _ = Inference.M.get_data_annot Kernel.Path.root typing in - match root_type_opt with - | None -> Stdlib.failwith "Autocomp.complete_data: cannot get type of expr" - | Some ty -> - let _, typing = Inference.instantiate_base ty typing in - let result, _ = - try complete_data node Kernel.Path.root rng_state typing - with Autocompletion_error (Cannot_complete_data (subterm, path)) -> - Format.eprintf "Cannot complete data@." ; - Format.eprintf "at path %s@." (Kernel.Path.to_string path) ; - Format.eprintf "%a@." Mikhailsky.pp subterm ; - Stdlib.failwith "in autocomp.ml: unrecoverable failure" - in - let typ, _typing = - try Inference.infer_data_with_state result - with Inference.Ill_typed_script error -> - Format.eprintf "%a@." Inference.pp_inference_error error ; - Format.eprintf "%a@." Mikhailsky.pp result ; - assert false - in - (result, typ) - - (* Autocomplete Mikhailsky code. *) - - let rec complete_code : - Mikhailsky.node -> Kernel.Path.t -> Mikhailsky.node SM.t = - let open SM in - fun node path -> - match node with - | Micheline.Int (_, _) | Micheline.String (_, _) | Micheline.Bytes (_, _) - -> - return node - | Micheline.Prim (_, I_Hole, _, _) -> ( - deterministic @@ Inference.M.get_instr_annot path >>= function - | None -> cannot_complete_code node path - | Some {bef; aft} -> - deterministic @@ Inference.instantiate bef >>= fun bef -> - deterministic @@ Inference.instantiate aft >>= fun aft -> - invent_term bef aft >>= fun code -> return (Mikhailsky.seq code)) - | Micheline.Prim (_, prim, subterms, _) -> - complete_code_list path 0 subterms [] >>= fun subterms -> - return (Mikhailsky.prim prim subterms []) - | Micheline.Seq (_, subterms) -> - complete_code_list path 0 subterms [] >>= fun subterms -> - return (Mikhailsky.seq subterms) - - and complete_code_list path i subterms acc = - let open SM in - match subterms with - | [] -> return (List.rev acc) - | subterm :: tl -> - let path' = Kernel.Path.at_index i path in - complete_code subterm path' >>= fun term -> - complete_code_list path (i + 1) tl (term :: acc) - - let complete_code typing node rng_state = - let root_type_opt, _ = - Inference.M.get_instr_annot Kernel.Path.root typing - in - match root_type_opt with - | None -> Stdlib.failwith "Autocomp.complete_code: cannot get type of expr" - | Some {bef; aft} -> - let _, typing = Inference.instantiate bef typing in - let _, typing = Inference.instantiate aft typing in - let result, _ = - try complete_code node Kernel.Path.root rng_state typing with - | Autocompletion_error (Cannot_complete_code (subterm, path)) -> - Format.eprintf "Cannot complete code@." ; - Format.eprintf "at path %s@." (Kernel.Path.to_string path) ; - Format.eprintf "%a@." Mikhailsky.pp subterm ; - Stdlib.failwith "in autocomp.ml: unrecoverable failure" - | _ -> assert false - in - let (bef, aft), typing = - try Inference.infer_with_state result - with Inference.Ill_typed_script error -> - Format.eprintf "%a@." Inference.pp_inference_error error ; - Format.eprintf "%a@." Mikhailsky.pp result ; - assert false - in - let bef, typing = instantiate_and_set_stack bef typing in - let aft, typing = instantiate_and_set_stack aft typing in - (result, (bef, aft), typing) -end diff --git a/src/proto_017_PtNairob/lib_benchmark/dune b/src/proto_017_PtNairob/lib_benchmark/dune deleted file mode 100644 index 30ab99198aaafc4611da661b5ed3c447aa4e0b19..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/dune +++ /dev/null @@ -1,34 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name tezos_benchmark_017_PtNairob) - (public_name tezos-benchmark-017-PtNairob) - (libraries - octez-libs.stdlib - octez-libs.base - octez-libs.error-monad - octez-libs.micheline - tezos-micheline-rewriting - tezos-benchmark - tezos-benchmark-type-inference-017-PtNairob - tezos-protocol-017-PtNairob.protocol - octez-libs.crypto - tezos-protocol-017-PtNairob.parameters - hashcons - octez-protocol-017-PtNairob-libs.test-helpers - prbnmcn-stats) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezos_stdlib - -open Tezos_base - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_error_monad - -open Tezos_micheline - -open Tezos_micheline_rewriting - -open Tezos_benchmark - -open Tezos_benchmark_type_inference_017_PtNairob - -open Tezos_protocol_017_PtNairob - -open Tezos_017_PtNairob_test_helpers) - (private_modules kernel rules state_space)) diff --git a/src/proto_017_PtNairob/lib_benchmark/execution_context.ml b/src/proto_017_PtNairob/lib_benchmark/execution_context.ml deleted file mode 100644 index a7212fc9ee040ac08b24b19e12797e17dc801a6c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/execution_context.ml +++ /dev/null @@ -1,95 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 - -type context = Alpha_context.context * Script_interpreter.step_constants - -let initial_balance = 4_000_000_000_000L - -let context_init_memory ~rng_state = - Context.init_n - ~rng_state - ~bootstrap_balances: - [ - initial_balance; - initial_balance; - initial_balance; - initial_balance; - initial_balance; - ] - 5 - () - >>=? fun (block, accounts) -> - match accounts with - | [bs1; bs2; bs3; bs4; bs5] -> - return (`Mem_block (block, (bs1, bs2, bs3, bs4, bs5))) - | _ -> assert false - -let context_init ~rng_state = context_init_memory ~rng_state - -let make ~rng_state = - context_init_memory ~rng_state >>=? fun context -> - let amount = Alpha_context.Tez.one in - let chain_id = Tezos_crypto.Hashed.Chain_id.zero in - let now = Script_timestamp.of_zint Z.zero in - let level = Script_int.zero_n in - let open Script_interpreter in - (match context with - | `Mem_block (block, (bs1, _, _, _, _)) -> - let source = Alpha_context.Destination.Contract bs1 in - let payer = Contract_helpers.default_payer in - let self = Contract_helpers.default_self in - let step_constants = - { - source; - payer; - self; - amount; - balance = Alpha_context.Tez.of_mutez_exn initial_balance; - chain_id; - now; - level; - } - in - return (block, step_constants)) - >>=? fun (block, step_constants) -> - Context.get_constants (B block) >>=? fun csts -> - let minimal_block_delay = - Protocol.Alpha_context.Period.to_seconds csts.parametric.minimal_block_delay - in - Incremental.begin_construction - ~timestamp: - (Time.Protocol.add block.header.shell.timestamp minimal_block_delay) - block - >>=? fun vs -> - let ctxt = Incremental.alpha_ctxt vs in - let ctxt = - (* Required for eg Create_contract *) - Protocol.Alpha_context.Origination_nonce.init - ctxt - Tezos_crypto.Hashed.Operation_hash.zero - in - return (ctxt, step_constants) diff --git a/src/proto_017_PtNairob/lib_benchmark/kernel.ml b/src/proto_017_PtNairob/lib_benchmark/kernel.ml deleted file mode 100644 index 0932302aa20b62c763e382067cf97ad4e09a9639..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/kernel.ml +++ /dev/null @@ -1,39 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(* ------------------------------------------------------------------------- *) -(* Instantiate rewriting subsystem *) - -module Lang = - Micheline_with_hash_consing.Make - (Mikhailsky.Mikhailsky_signature) - (struct - let initial_size = None - end) - -module Path = Mikhailsky.Path -module Patt = Pattern.Make (Mikhailsky.Mikhailsky_signature) (Lang) (Path) -module Rewriter = - Rewrite.Make (Mikhailsky.Mikhailsky_signature) (Lang) (Path) (Patt) diff --git a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/dune b/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/dune deleted file mode 100644 index c5e98d57dc8d03a960ae6987b851302faaaaba13..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/dune +++ /dev/null @@ -1,23 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name tezos_benchmark_type_inference_017_PtNairob) - (public_name tezos-benchmark-type-inference-017-PtNairob) - (instrumentation (backend bisect_ppx)) - (libraries - octez-libs.stdlib - octez-libs.error-monad - octez-libs.crypto - octez-libs.micheline - tezos-micheline-rewriting - tezos-protocol-017-PtNairob.protocol - hashcons) - (flags - (:standard) - -open Tezos_stdlib - -open Tezos_error_monad - -open Tezos_crypto - -open Tezos_micheline - -open Tezos_micheline_rewriting - -open Tezos_protocol_017_PtNairob)) diff --git a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/inference.ml b/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/inference.ml deleted file mode 100644 index d8c47801dca357ac1905cd72a3dd51d9c2cd7ad1..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/inference.ml +++ /dev/null @@ -1,1150 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 -module UF = Uf.UF - -(* The domain of comparability: - * - * Comparable Not_comparable - * ^ ^ - * \ / - * \ / - * Unconstrained - * - * The higher we go, the more information we have. - * This domain admits all glbs but not all lubs. - *) - -type comparability = Comparable | Not_comparable | Unconstrained - -let pp_comparability fmtr (cmp : comparability) = - match cmp with - | Comparable -> Format.fprintf fmtr "Comparable" - | Not_comparable -> Format.fprintf fmtr "Not_comparable" - | Unconstrained -> Format.fprintf fmtr "Unconstrained" - -let sup_comparability (c1 : comparability) (c2 : comparability) = - match (c1, c2) with - | Unconstrained, c | c, Unconstrained -> Some c - | Comparable, Comparable -> Some Comparable - | Not_comparable, Not_comparable -> Some Not_comparable - | Comparable, Not_comparable | Not_comparable, Comparable -> None - -type michelson_type = - | Base_type of {repr : Type.Base.t option; comparable : comparability} - | Stack_type of Type.Stack.t option - -type transformer = {bef : Type.Stack.t; aft : Type.Stack.t} - -let michelson_type_to_string (x : michelson_type) = - match x with - | Base_type {repr = None; comparable} -> - Format.asprintf "?::[%a]" pp_comparability comparable - | Base_type {repr = Some ty; comparable} -> - Format.asprintf "%a::[%a]" Type.Base.pp ty pp_comparability comparable - | Stack_type None -> "" - | Stack_type (Some sty) -> Format.asprintf "%a" Type.Stack.pp sty - -(* ------------------------------------------------------------------------- *) -(* Typechecking errors *) - -type inference_error = - (* | Expected_data_with_ground_type of Mikhailsky.Path.t * Mikhailsky.node *) - | Unhandled_micheline of Mikhailsky.Path.t * Mikhailsky.node - | Expected_micheline_prim - | Unsatisfiable_comparability_constraint of comparability_error_witness - | Base_types_incompatible of Type.Base.t * Type.Base.t - | Stack_types_incompatible of Type.Stack.t * Type.Stack.t - | Badly_typed_arithmetic of Mikhailsky_prim.prim * Type.Base.t * Type.Base.t - | Ill_formed_arithmetic of Mikhailsky.Path.t * Mikhailsky.node - | Cyclic_stack_type - | Cyclic_base_type - | Invalid_ast of string option * Mikhailsky.Path.t * Mikhailsky.node - -and comparability_error_witness = - | Comparability_error_types of michelson_type * michelson_type - | Comparability_error_tags of Type.Base.t * comparability * comparability - -let pp_inference_error fmtr (err : inference_error) = - match err with - (* | Expected_data_with_ground_type (path, node) -> - * let path = Mikhailsky.Path.to_string path in - * let node = Mikhailsky.to_string node in - * Format.fprintf fmtr "Expected data with ground type: %s at path %s" node path *) - | Unhandled_micheline (path, node) -> - let path = Mikhailsky.Path.to_string path in - let node = Mikhailsky.to_string node in - Format.fprintf fmtr "Unhandled micheline: %s at path %s" node path - | Expected_micheline_prim -> - Format.fprintf fmtr "%s" "Expected_micheline_prim" - | Unsatisfiable_comparability_constraint - (Comparability_error_types (ty1, ty2)) -> - let ty1 = michelson_type_to_string ty1 in - let ty2 = michelson_type_to_string ty2 in - Format.fprintf - fmtr - "Unsatisfiable comparability constraint: %s # %s" - ty1 - ty2 - | Unsatisfiable_comparability_constraint - (Comparability_error_tags (ty, cmp1, cmp2)) -> - Format.fprintf - fmtr - "Unsatisfiable comparability constraint: %a :: %a # %a" - Type.Base.pp - ty - pp_comparability - cmp1 - pp_comparability - cmp2 - | Base_types_incompatible (ty1, ty2) -> - Format.fprintf - fmtr - "Base types incompatible: %a %a" - Type.Base.pp - ty1 - Type.Base.pp - ty2 - | Stack_types_incompatible (sty1, sty2) -> - Format.fprintf - fmtr - "Stack types incompatible: %a %a" - Type.Stack.pp - sty1 - Type.Stack.pp - sty2 - | Badly_typed_arithmetic (prim, ty1, ty2) -> - Format.fprintf - fmtr - "Badly typed arithmetic: %a(%a, %a)" - Mikhailsky_prim.pp - prim - Type.Base.pp - ty1 - Type.Base.pp - ty2 - | Ill_formed_arithmetic (path, node) -> - let path = Mikhailsky.Path.to_string path in - let node = Mikhailsky.to_string node in - Format.fprintf fmtr "Ill formed arithmetic: %s at path %s" node path - | Cyclic_stack_type -> Format.fprintf fmtr "Cyclic stack type" - | Cyclic_base_type -> Format.fprintf fmtr "Cyclic base type" - | Invalid_ast (msg_opt, path, node) -> ( - let path = Mikhailsky.Path.to_string path in - let node = Mikhailsky.to_string node in - match msg_opt with - | None -> Format.fprintf fmtr "Invalid ast: %s at path %s" node path - | Some msg -> - Format.fprintf fmtr "Invalid ast: %s at path %s (%s)" node path msg) - -exception Ill_typed_script of inference_error - -let unsatisfiable_comparability ty cmp1 cmp2 = - raise - (Ill_typed_script - (Unsatisfiable_comparability_constraint - (Comparability_error_tags (ty, cmp1, cmp2)))) - -let invalid_ast ?msg path node = - raise (Ill_typed_script (Invalid_ast (msg, path, node))) - -let () = - Printexc.register_printer (fun exn -> - match exn with - | Ill_typed_script error -> - Some (Format.asprintf "%a" pp_inference_error error) - | _ -> None) - -(* ------------------------------------------------------------------------- *) - -module Repr_store = - Stores.Map - (Int_map) - (struct - type key = int - - type value = michelson_type - - let key_to_string = string_of_int - - let value_to_string = michelson_type_to_string - end) - -module Repr_sm = Monads.Make_state_monad (Repr_store) -module Path_map = Map.Make (Mikhailsky.Path) - -module Annot_instr_store = - Stores.Map - (Path_map) - (struct - type key = Mikhailsky.Path.t - - type value = transformer - - let key_to_string = Mikhailsky.Path.to_string - - let value_to_string {bef; aft} = - Format.asprintf "%a => %a" Type.Stack.pp bef Type.Stack.pp aft - end) - -module Annot_instr_sm = Monads.Make_state_monad (Annot_instr_store) - -module Annot_data_store = - Stores.Map - (Path_map) - (struct - type key = Mikhailsky.Path.t - - type value = Type.Base.t - - let key_to_string = Mikhailsky.Path.to_string - - let value_to_string ty = Format.asprintf "%a" Type.Base.pp ty - end) - -module Annot_data_sm = Monads.Make_state_monad (Annot_data_store) - -type state = { - uf : UF.M.state; - repr : Repr_sm.state; - annot_instr : Annot_instr_sm.state; - annot_data : Annot_data_sm.state; -} - -module M = struct - type 'a t = state -> 'a * state - - let empty : unit -> state = - fun () -> - { - uf = UF.M.empty (); - repr = Repr_sm.empty (); - annot_instr = Annot_instr_sm.empty (); - annot_data = Annot_data_sm.empty (); - } - - let ( >>= ) m f s = - let x, s = m s in - f x s - [@@inline] - - let return x s = (x, s) - - (* let run m = fst (m (empty ())) *) - - let uf_lift : 'a UF.M.t -> 'a t = - fun computation state -> - let res, uf = computation state.uf in - (res, {state with uf}) - [@@inline] - - let repr_lift : 'a Repr_sm.t -> 'a t = - fun computation state -> - let res, repr = computation state.repr in - (res, {state with repr}) - [@@inline] - - let annot_instr_lift : 'a Annot_instr_sm.t -> 'a t = - fun computation state -> - let res, annot_instr = computation state.annot_instr in - (res, {state with annot_instr}) - [@@inline] - - let annot_data_lift : 'a Annot_data_sm.t -> 'a t = - fun computation state -> - let res, annot_data = computation state.annot_data in - (res, {state with annot_data}) - [@@inline] - - let set_repr k v = repr_lift (Repr_sm.set k v) [@@inline] - - let get_repr_exn k = - repr_lift (Repr_sm.get k) >>= function - | None -> Stdlib.failwith "get_repr_exn" - | Some res -> return res - [@@inline] - - let set_instr_annot k v = annot_instr_lift (Annot_instr_sm.set k v) [@@inline] - - let get_instr_annot k = annot_instr_lift (Annot_instr_sm.get k) [@@inline] - - let set_data_annot k v = annot_data_lift (Annot_data_sm.set k v) [@@inline] - - let get_data_annot k = annot_data_lift (Annot_data_sm.get k) [@@inline] - - let get_state state = (state, state) -end - -module S = Set.Make (Int) - -let rec instantiate (encountered : S.t) (stack_ty : Type.Stack.t) : - Type.Stack.t M.t = - let open Type.Stack in - let open M in - if S.mem stack_ty.tag encountered then - raise (Ill_typed_script Cyclic_stack_type) - else - let encountered = S.add stack_ty.tag encountered in - match stack_ty.node with - | Empty_t -> return stack_ty - | Stack_var_t x -> ( - uf_lift (UF.find x) >>= fun root -> - get_repr_exn root >>= function - | Stack_type None -> return (Type.stack_var root) - | Stack_type (Some ty) -> instantiate encountered ty - | _ -> assert false) - | Item_t (head, tail) -> - instantiate_base S.empty head >>= fun head -> - instantiate encountered tail >>= fun tail -> - return (Type.item head tail) - -and instantiate_base (encountered : S.t) (ty : Type.Base.t) : Type.Base.t M.t = - let open Type.Base in - let open M in - if S.mem ty.tag encountered then raise (Ill_typed_script Cyclic_base_type) - else - let encountered = S.add ty.tag encountered in - match ty.node with - | Unit_t | Int_t | Nat_t | Bool_t | String_t | Bytes_t | Key_hash_t | Key_t - | Timestamp_t | Mutez_t -> - return ty - | Option_t ty -> - instantiate_base encountered ty >>= fun ty -> return (Type.option ty) - | List_t ty -> - instantiate_base encountered ty >>= fun ty -> return (Type.list ty) - | Set_t ty -> - instantiate_base encountered ty >>= fun ty -> return (Type.set ty) - | Map_t (kty, vty) -> - instantiate_base encountered kty >>= fun kty -> - instantiate_base encountered vty >>= fun vty -> - return (Type.map kty vty) - | Pair_t (lty, rty) -> - instantiate_base encountered lty >>= fun lty -> - instantiate_base encountered rty >>= fun rty -> - return (Type.pair lty rty) - | Or_t (lty, rty) -> - instantiate_base encountered lty >>= fun lty -> - instantiate_base encountered rty >>= fun rty -> - return (Type.or_ lty rty) - | Lambda_t (dom, range) -> - instantiate_base encountered dom >>= fun dom -> - instantiate_base encountered range >>= fun range -> - return (Type.lambda dom range) - | Var_t x -> ( - uf_lift (UF.find x) >>= fun root -> - get_repr_exn root >>= function - | Base_type {repr = None; _} -> return (Type.var root) - | Base_type {repr = Some ty; _} -> instantiate_base encountered ty - | _ -> assert false) - -let instantiate_base base_ty = instantiate_base S.empty base_ty - -let instantiate stack_ty = instantiate S.empty stack_ty - -let rec unify (x : Type.Stack.t) (y : Type.Stack.t) : unit M.t = - let open Type.Stack in - let open M in - let unify_single_stack v x = - (match Type.Stack.vars x with - | None -> return () - | Some v' -> - if v = v' then raise (Ill_typed_script Cyclic_stack_type) else return ()) - >>= fun () -> - M.uf_lift (UF.find v) >>= fun root -> - get_repr_exn root >>= fun repr -> - merge_reprs (Stack_type (Some x)) repr >>= fun repr -> set_repr root repr - in - if x.tag = y.tag then return () - else - match (x.node, y.node) with - | Empty_t, Empty_t -> return () - | Stack_var_t x, Stack_var_t y -> - M.uf_lift (UF.find x) >>= fun root_x -> - M.uf_lift (UF.find y) >>= fun root_y -> - get_repr_exn root_x >>= fun repr_x -> - get_repr_exn root_y >>= fun repr_y -> - M.uf_lift (UF.union x y) >>= fun root -> - merge_reprs repr_x repr_y >>= fun repr -> set_repr root repr - | Stack_var_t v, _ -> unify_single_stack v y - | _, Stack_var_t v -> unify_single_stack v x - | Item_t (ty1, tail1), Item_t (ty2, tail2) -> - unify_base ty1 ty2 >>= fun () -> - unify tail1 tail2 >>= fun () -> return () - | _ -> raise (Ill_typed_script (Stack_types_incompatible (x, y))) - -and unify_base (x : Type.Base.t) (y : Type.Base.t) : unit M.t = - let open Type.Base in - let open M in - let unify_single_var v x = - (if List.mem v (Type.Base.vars x) then - raise (Ill_typed_script Cyclic_base_type) - else return ()) - >>= fun () -> - M.uf_lift (UF.find v) >>= fun root -> - get_repr_exn root >>= fun repr -> - get_comparability x >>= fun comparable -> - merge_reprs (Base_type {repr = Some x; comparable}) repr >>= fun repr -> - set_repr root repr - in - if x.tag = y.tag then return () - else - match (x.node, y.node) with - | Unit_t, Unit_t - | Int_t, Int_t - | Nat_t, Nat_t - | Bool_t, Bool_t - | String_t, String_t - | Bytes_t, Bytes_t - | Key_hash_t, Key_hash_t - | Timestamp_t, Timestamp_t - | Mutez_t, Mutez_t - | Key_t, Key_t -> - return () - | Option_t x, Option_t y -> unify_base x y - | List_t x, List_t y -> unify_base x y - | Set_t x, Set_t y -> unify_base x y - | Map_t (kx, vx), Map_t (ky, vy) -> - unify_base kx ky >>= fun () -> unify_base vx vy - | Pair_t (x, x'), Pair_t (y, y') -> - unify_base x y >>= fun () -> unify_base x' y' - | Or_t (x, x'), Or_t (y, y') -> - unify_base x y >>= fun () -> unify_base x' y' - | Lambda_t (x, x'), Lambda_t (y, y') -> - unify_base x y >>= fun () -> unify_base x' y' - | Var_t x, Var_t y -> - M.uf_lift (UF.find x) >>= fun root_x -> - M.uf_lift (UF.find y) >>= fun root_y -> - get_repr_exn root_x >>= fun repr_x -> - get_repr_exn root_y >>= fun repr_y -> - M.uf_lift (UF.union x y) >>= fun root -> - merge_reprs repr_x repr_y >>= fun repr -> set_repr root repr - | Var_t v, _ -> unify_single_var v y - | _, Var_t v -> unify_single_var v x - | _ -> - instantiate_base x >>= fun x -> - instantiate_base y >>= fun y -> - raise (Ill_typed_script (Base_types_incompatible (x, y))) - -and merge_reprs (repr1 : michelson_type) (repr2 : michelson_type) : - michelson_type M.t = - let open M in - match (repr1, repr2) with - | (Stack_type None as repr), Stack_type None - | (Stack_type (Some _) as repr), Stack_type None - | Stack_type None, (Stack_type (Some _) as repr) -> - return repr - | (Stack_type (Some sty1) as repr), Stack_type (Some sty2) -> - unify sty1 sty2 >>= fun () -> return repr - | ( Base_type {repr = opt1; comparable = cmp1}, - Base_type {repr = opt2; comparable = cmp2} ) -> ( - let comparable_opt = sup_comparability cmp1 cmp2 in - match comparable_opt with - | None -> - raise - (Ill_typed_script - (Unsatisfiable_comparability_constraint - (Comparability_error_types (repr1, repr2)))) - | Some comparable -> ( - match (opt1, opt2) with - | None, None -> return (Base_type {repr = None; comparable}) - | (Some ty as repr), None -> - assert_comparability comparable ty >>= fun () -> - return (Base_type {repr; comparable}) - | None, (Some ty as repr) -> - assert_comparability comparable ty >>= fun () -> - return (Base_type {repr; comparable}) - | Some ty1, Some ty2 -> - unify_base ty1 ty2 >>= fun () -> - assert_comparability comparable ty1 >>= fun () -> - assert_comparability comparable ty2 >>= fun () -> - return (Base_type {repr = opt1; comparable}))) - | _ -> assert false - -and assert_comparability comparable ty = - assert_comparability_aux comparable ty [] - -and assert_comparability_aux lower_bound (ty : Type.Base.t) - (encountered : int list) : unit M.t = - let open M in - if List.mem ty.tag encountered then raise (Ill_typed_script Cyclic_base_type) - else - let encountered = ty.tag :: encountered in - match ty.node with - | Var_t v -> ( - uf_lift (UF.find v) >>= fun root -> - get_repr_exn root >>= fun repr -> - match repr with - | Base_type {repr = None; comparable} -> ( - match sup_comparability comparable lower_bound with - | None -> unsatisfiable_comparability ty comparable lower_bound - | Some comparable -> - set_repr root (Base_type {repr = None; comparable})) - | Base_type {repr = Some ty; comparable} -> ( - match sup_comparability comparable lower_bound with - | None -> unsatisfiable_comparability ty comparable lower_bound - | Some comparable -> - assert_comparability_aux lower_bound ty encountered - >>= fun () -> - set_repr root (Base_type {repr = Some ty; comparable})) - | Stack_type _ -> assert false) - | List_t _ | Set_t _ | Map_t _ | Lambda_t _ | Key_t -> ( - match lower_bound with - | Unconstrained | Not_comparable -> return () - | Comparable -> unsatisfiable_comparability ty Unconstrained lower_bound - ) - | Unit_t | Int_t | Nat_t | Bool_t | String_t | Bytes_t | Key_hash_t - | Timestamp_t | Mutez_t -> - (* if not (le_comparability lower_bound Comparable) then - * unsatisfiable_comparability ty Comparable lower_bound - * else *) - return () - | Option_t ty -> ( - match lower_bound with - | Comparable -> assert_comparability_aux Comparable ty encountered - | Not_comparable | Unconstrained -> return ()) - | Pair_t (l, r) -> ( - match lower_bound with - | Comparable -> - assert_comparability_aux Comparable l encountered >>= fun () -> - assert_comparability_aux Comparable r encountered - | Unconstrained | Not_comparable -> return ()) - | Or_t (l, r) -> ( - match lower_bound with - | Comparable -> - assert_comparability_aux Comparable l encountered >>= fun () -> - assert_comparability_aux Comparable r encountered - | Unconstrained | Not_comparable -> return ()) - -and get_comparability (ty : Type.Base.t) : comparability M.t = - let open M in - match ty.node with - | Var_t v -> ( - get_repr_exn v >>= fun repr -> - match repr with - | Stack_type _ -> assert false - | Base_type {comparable; _} -> return comparable) - | Unit_t | Int_t | Nat_t | Bool_t | String_t | Bytes_t | Key_hash_t - | Timestamp_t | Mutez_t -> - return Comparable - | List_t _ | Set_t _ | Map_t _ | Lambda_t _ | Key_t -> return Not_comparable - | Option_t ty -> get_comparability ty - | Or_t (lt, rt) | Pair_t (lt, rt) -> ( - get_comparability lt >>= fun lc -> - get_comparability rt >>= fun rc -> - match (lc, rc) with - | Comparable, Comparable -> return Comparable - | _ -> return Unconstrained) - -let fresh = - let x = ref ~-1 in - fun () -> - incr x ; - !x - -let exists_stack : unit -> Type.Stack.t M.t = - let open M in - fun () -> - let fresh = fresh () in - uf_lift (UF.add fresh) >>= fun () -> - set_repr fresh (Stack_type None) >>= fun () -> return (Type.stack_var fresh) - -let exists : unit -> Type.Base.t M.t = - let open M in - fun () -> - let fresh = fresh () in - uf_lift (UF.add fresh) >>= fun () -> - set_repr fresh (Base_type {repr = None; comparable = Unconstrained}) - >>= fun () -> return (Type.var fresh) - -let exists_cmp : unit -> Type.Base.t M.t = - let open M in - fun () -> - let fresh = fresh () in - uf_lift (UF.add fresh) >>= fun () -> - set_repr fresh (Base_type {repr = None; comparable = Comparable}) - >>= fun () -> return (Type.var fresh) - -(* Adapted from [script_ir_translator] *) -let parse_uint30 n : int = - let max_uint30 = 0x3fffffff in - match n with - | Micheline.Int (_, n') - when Compare.Z.(Z.zero <= n') && Compare.Z.(n' <= Z.of_int max_uint30) -> - Z.to_int n' - | _ -> assert false - -(* encodes the per-instruction relationship between input and output types - of binary arithmetic operations. *) -let arith_type (instr : Mikhailsky_prim.prim) (ty1 : Type.Base.t) - (ty2 : Type.Base.t) : Type.Base.t option = - match (instr, ty1.node, ty2.node) with - | (I_ADD | I_MUL), Int_t, Int_t - | (I_ADD | I_MUL), Int_t, Nat_t - | (I_ADD | I_MUL), Nat_t, Int_t -> - Some Type.int - | (I_ADD | I_MUL), Nat_t, Nat_t -> Some Type.nat - | I_SUB, Int_t, Int_t - | I_SUB, Int_t, Nat_t - | I_SUB, Nat_t, Int_t - | I_SUB, Nat_t, Nat_t - | I_SUB, Timestamp_t, Timestamp_t -> - Some Type.int - | I_EDIV, Int_t, Int_t - | I_EDIV, Int_t, Nat_t - | I_EDIV, Nat_t, Int_t - | I_EDIV, Nat_t, Nat_t -> - Some Type.(option (pair nat nat)) - (* Timestamp *) - | I_ADD, Timestamp_t, Int_t - | I_ADD, Int_t, Timestamp_t - | I_SUB, Timestamp_t, Int_t -> - Some Type.timestamp - (* Mutez *) - | I_ADD, Mutez_t, Mutez_t - | I_SUB, Mutez_t, Mutez_t - | I_MUL, Mutez_t, Nat_t - | I_MUL, Nat_t, Mutez_t -> - Some Type.mutez - | I_EDIV, Mutez_t, Nat_t -> Some Type.(option (pair mutez mutez)) - | I_EDIV, Mutez_t, Mutez_t -> Some Type.(option (pair nat mutez)) - | _ -> None - -let rec generate_constraints (path : Mikhailsky.Path.t) (node : Mikhailsky.node) - (bef : Type.Stack.t) (aft : Type.Stack.t) : unit M.t = - let open M in - set_instr_annot path {bef; aft} >>= fun () -> - match node with - | Int (_, _) -> - assert false (* Ints should always be guarded by annotations *) - | String (_, _) | Bytes (_, _) -> - raise (Ill_typed_script Expected_micheline_prim) - (* Hole *) - | Prim (_, I_Hole, [], _) -> return () - (* Stack ops - simple cases *) - | Prim (_loc, I_DROP, [], _annot) -> - exists () >>= fun top -> unify bef (Type.item top aft) - | Prim (_loc, I_DROP, [n], _annot) -> - let n = parse_uint30 n in - generate_constraints_dropn n bef aft - | Prim (_loc, I_DUP, [], _annot) -> - exists () >>= fun top -> - exists_stack () >>= fun rest -> - unify bef Type.(item top rest) >>= fun () -> - unify aft Type.(item top (item top rest)) - | Prim (_loc, I_SWAP, [], _annot) -> - exists () >>= fun a -> - exists () >>= fun b -> - exists_stack () >>= fun rest -> - unify bef Type.(item a (item b rest)) >>= fun () -> - unify aft Type.(item b (item a rest)) - | Prim (_loc, I_PUSH, [t; d], _annot) -> - let ty = - Mikhailsky.parse_ty - ~allow_big_map:false - ~allow_operation:false - ~allow_contract:false - t - in - generate_constraints_data (Mikhailsky.Path.at_index 1 path) d ty - >>= fun () -> - (* assert_data_has_ground_type (Mikhailsky.Path.at_index 1 path) d ty >>= fun () -> *) - unify aft Type.(item ty bef) - | Prim (_loc, I_UNIT, [], _annot) -> unify aft Type.(item unit bef) - | Prim (_loc, I_DIP, [code], _annot) -> - exists () >>= fun top -> - exists_stack () >>= fun bef_rest -> - exists_stack () >>= fun aft_rest -> - unify bef Type.(item top bef_rest) >>= fun () -> - unify aft Type.(item top aft_rest) >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 0 path) - code - bef_rest - aft_rest - (* TODO: DIGn, etc *) - (* Option-related instructions *) - | Prim (_, I_SOME, [], _) -> - exists () >>= fun top -> - exists_stack () >>= fun rest -> - unify bef Type.(item top rest) >>= fun () -> - unify aft Type.(item (option top) rest) - | Prim (_, I_NONE, [t], _) -> - let ty = - Mikhailsky.parse_ty - ~allow_big_map:true - ~allow_operation:true - ~allow_contract:true - t - in - unify aft Type.(item (option ty) bef) - | Prim (_, I_IF_NONE, [bt; bf], _) -> - exists () >>= fun a -> - exists_stack () >>= fun rest -> - unify bef Type.(item (option a) rest) >>= fun () -> - generate_constraints (Mikhailsky.Path.at_index 0 path) bt rest aft - >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 1 path) - bf - Type.(item a rest) - aft - (* bool-based control flow *) - | Prim (_, I_IF, [bt; bf], _) -> - exists_stack () >>= fun rest -> - unify bef Type.(item bool rest) >>= fun () -> - generate_constraints (Mikhailsky.Path.at_index 0 path) bt rest aft - >>= fun () -> - generate_constraints (Mikhailsky.Path.at_index 1 path) bf rest aft - | Prim (_, I_LOOP, [body], _) -> - unify bef Type.(item bool aft) >>= fun () -> - generate_constraints (Mikhailsky.Path.at_index 0 path) body aft bef - (* Boolean binops *) - | Prim (_, I_AND, [], _) | Prim (_, I_OR, [], _) | Prim (_, I_XOR, [], _) -> - exists_stack () >>= fun rest -> - unify bef Type.(item bool (item bool rest)) >>= fun () -> - unify aft Type.(item bool rest) - (* Arithmetic *) - | Prim (_, ((I_ADD | I_SUB | I_MUL | I_EDIV) as instr), [ty1; ty2], _) -> ( - let ty1 = - Mikhailsky.parse_ty - ~allow_big_map:false - ~allow_operation:false - ~allow_contract:false - ty1 - in - let ty2 = - Mikhailsky.parse_ty - ~allow_big_map:false - ~allow_operation:false - ~allow_contract:false - ty2 - in - match arith_type instr ty1 ty2 with - | None -> - raise (Ill_typed_script (Badly_typed_arithmetic (instr, ty1, ty2))) - | Some ret -> - exists_stack () >>= fun rest -> - unify bef Type.(item ty1 (item ty2 rest)) >>= fun () -> - unify aft Type.(item ret rest)) - | Prim (_, (I_ADD | I_SUB | I_MUL | I_EDIV), _, _) -> - raise (Ill_typed_script (Ill_formed_arithmetic (path, node))) - | Prim (_, I_COMPARE, [], _) -> - exists_cmp () >>= fun a -> - exists_stack () >>= fun rest -> - unify bef Type.(item a (item a rest)) >>= fun () -> - unify aft Type.(item int rest) - | Prim (_, I_ABS, [], _) -> - exists_stack () >>= fun rest -> - unify bef Type.(item int rest) >>= fun () -> - unify aft Type.(item nat rest) - | Prim (_, I_GT, [], _) -> - exists_stack () >>= fun rest -> - unify bef Type.(item int rest) >>= fun () -> - unify aft Type.(item bool rest) - (* Strings/bytes *) - | Prim (_, I_CONCAT, [], _) -> - exists_stack () >>= fun rest -> - unify bef Type.(item string (item string rest)) >>= fun () -> - unify aft Type.(item string rest) - | Prim (_, I_SIZE_STRING, [], _) -> - exists_stack () >>= fun rest -> - unify bef Type.(item string rest) >>= fun () -> - unify aft Type.(item nat rest) - | Prim (_, I_SIZE_BYTES, [], _) -> - exists_stack () >>= fun rest -> - unify bef Type.(item bytes rest) >>= fun () -> - unify aft Type.(item nat rest) - (* Crypto *) - | Prim (_, I_SHA256, [], _) - | Prim (_, I_SHA512, [], _) - | Prim (_, I_BLAKE2B, [], _) -> - exists_stack () >>= fun rest -> - unify bef Type.(item bytes rest) >>= fun () -> - unify aft Type.(item bytes rest) - | Prim (_, I_HASH_KEY, [], _) -> - exists_stack () >>= fun rest -> - unify bef Type.(item key rest) >>= fun () -> - unify aft Type.(item key_hash rest) - (* sets *) - | Prim (_, I_EMPTY_SET, [], _) -> - exists_cmp () >>= fun cmpty -> unify aft Type.(item (set cmpty) bef) - | Prim (_, I_UPDATE_SET, [], _) -> - exists_cmp () >>= fun cty -> - exists_stack () >>= fun rest -> - unify bef Type.(item cty (item bool (item (set cty) rest))) >>= fun () -> - unify aft Type.(item (set cty) rest) - | Prim (_, I_SIZE_SET, [], _) -> - exists_cmp () >>= fun cmpty -> - exists_stack () >>= fun rest -> - unify bef Type.(item (set cmpty) rest) >>= fun () -> - unify aft Type.(item nat rest) - | Prim (_, I_ITER_SET, [code], _) -> - exists_cmp () >>= fun cmpty -> - unify bef Type.(item (set cmpty) aft) >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 0 path) - code - Type.(item cmpty aft) - aft - | Prim (_, I_MEM_SET, [], _) -> - exists_cmp () >>= fun cmpty -> - exists_stack () >>= fun rest -> - unify bef Type.(item cmpty (item (set cmpty) rest)) >>= fun () -> - unify aft Type.(item bool rest) - (* maps *) - | Prim (_, I_EMPTY_MAP, [], _) -> - exists_cmp () >>= fun kty -> - exists () >>= fun vty -> unify aft Type.(item (map kty vty) bef) - | Prim (_, I_UPDATE_MAP, [], _) -> - exists_cmp () >>= fun kty -> - exists () >>= fun vty -> - exists_stack () >>= fun rest -> - unify bef Type.(item kty (item (option vty) (item (map kty vty) rest))) - >>= fun () -> unify aft Type.(item (map kty vty) rest) - | Prim (_, I_SIZE_MAP, [], _) -> - exists_cmp () >>= fun kty -> - exists () >>= fun vty -> - exists_stack () >>= fun rest -> - unify bef Type.(item (map kty vty) rest) >>= fun () -> - unify aft Type.(item nat rest) - | Prim (_, I_ITER_MAP, [code], _) -> - exists_cmp () >>= fun kty -> - exists () >>= fun vty -> - unify bef Type.(item (map kty vty) aft) >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 0 path) - code - Type.(item (pair kty vty) aft) - aft - | Prim (_, I_MAP_MAP, [code], _) -> - exists_cmp () >>= fun kty -> - exists () >>= fun vty1 -> - exists () >>= fun vty2 -> - exists_stack () >>= fun rest -> - unify bef Type.(item (map kty vty1) rest) >>= fun () -> - unify aft Type.(item (map kty vty2) rest) >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 0 path) - code - Type.(item (pair kty vty1) rest) - Type.(item vty2 rest) - | Prim (_, I_MEM_MAP, [], _) -> - exists_cmp () >>= fun kty -> - exists () >>= fun vty -> - exists_stack () >>= fun rest -> - unify bef Type.(item kty (item (map kty vty) rest)) >>= fun () -> - unify aft Type.(item bool rest) - | Prim (_, I_GET_MAP, [], _) -> - exists_cmp () >>= fun kty -> - exists () >>= fun vty -> - exists_stack () >>= fun rest -> - unify bef Type.(item kty (item (map kty vty) rest)) >>= fun () -> - unify aft Type.(item (option vty) rest) - (* Pairs *) - | Prim (_, I_PAIR, [], _) -> - exists () >>= fun a -> - exists () >>= fun b -> - exists_stack () >>= fun rest -> - unify bef Type.(item a (item b rest)) >>= fun () -> - unify aft Type.(item (pair a b) rest) - | Prim (_, I_CAR, [], _) -> - exists () >>= fun a -> - exists () >>= fun b -> - exists_stack () >>= fun rest -> - unify bef Type.(item (pair a b) rest) >>= fun () -> - unify aft Type.(item a rest) - | Prim (_, I_CDR, [], _) -> - exists () >>= fun a -> - exists () >>= fun b -> - exists_stack () >>= fun rest -> - unify bef Type.(item (pair a b) rest) >>= fun () -> - unify aft Type.(item b rest) - (* Ors *) - | Prim (_, I_LEFT, [], _) -> - exists () >>= fun lt -> - exists () >>= fun rt -> - exists_stack () >>= fun rest -> - unify bef (Type.item lt rest) >>= fun () -> - unify aft Type.(item (or_ lt rt) rest) >>= fun res -> return res - | Prim (_, I_RIGHT, [], _) -> - exists () >>= fun lt -> - exists () >>= fun rt -> - exists_stack () >>= fun rest -> - unify bef Type.(item rt rest) >>= fun () -> - unify aft Type.(item (or_ lt rt) rest) - | Prim (_, (I_LEFT | I_RIGHT), _ :: _, _) -> - invalid_ast ~msg:__LOC__ path node - | Prim (_, I_LOOP_LEFT, [body], _) -> - exists () >>= fun l -> - exists () >>= fun r -> - exists_stack () >>= fun rest -> - unify bef Type.(item (or_ l r) rest) >>= fun () -> - unify aft Type.(item r rest) >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 0 path) - body - Type.(item l rest) - bef - | Prim (_, I_IF_LEFT, [bt; bf], _) -> - exists () >>= fun a -> - exists () >>= fun b -> - exists_stack () >>= fun rest -> - unify bef Type.(item (or_ a b) rest) >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 0 path) - bt - (Type.item a rest) - aft - >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 1 path) - bf - (Type.item b rest) - aft - (* lambdas *) - | Prim (_, I_LAMBDA, [code], _) -> - exists () >>= fun dom -> - exists () >>= fun range -> - unify aft Type.(item (lambda dom range) bef) >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 0 path) - code - Type.(item dom empty) - Type.(item range empty) - | Prim (_, I_LAMBDA, _, _) -> invalid_ast ~msg:__LOC__ path node - | Prim (_, I_APPLY, [], _) -> - exists () >>= fun a -> - exists () >>= fun b -> - exists () >>= fun ret -> - exists_stack () >>= fun rest -> - unify bef Type.(item a (item (lambda (pair a b) ret) rest)) >>= fun () -> - unify aft Type.(item (lambda b ret) rest) - | Prim (_, I_EXEC, [], _) -> - exists () >>= fun a -> - exists () >>= fun ret -> - exists_stack () >>= fun rest -> - unify bef Type.(item a (item (lambda a ret) rest)) >>= fun () -> - unify aft Type.(item ret rest) - (* lists *) - | Prim (_, I_NIL, [], _) -> - exists () >>= fun a -> unify aft Type.(item (list a) bef) - | Prim (_, I_CONS, [], _) -> - exists () >>= fun a -> - exists_stack () >>= fun rest -> - unify bef Type.(item a (item (list a) rest)) >>= fun () -> - unify aft Type.(item (list a) rest) - | Prim (_, I_SIZE_LIST, [], _) -> - exists () >>= fun ty -> - exists_stack () >>= fun rest -> - unify bef Type.(item (list ty) rest) >>= fun () -> - unify aft Type.(item nat rest) - | Prim (_, I_ITER_LIST, [code], _) -> - exists () >>= fun ty -> - unify bef Type.(item (list ty) aft) >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 0 path) - code - Type.(item ty aft) - aft - | Prim (_, I_MAP_LIST, [code], _) -> - exists () >>= fun ty1 -> - exists () >>= fun ty2 -> - exists_stack () >>= fun rest -> - unify bef Type.(item (list ty1) rest) >>= fun () -> - unify aft Type.(item (list ty2) rest) >>= fun () -> - generate_constraints - (Mikhailsky.Path.at_index 0 path) - code - Type.(item ty1 rest) - Type.(item ty2 rest) - (* pack/unpack*) - | Prim (_, I_PACK, [], _) -> - exists () >>= fun ty -> - exists_stack () >>= fun rest -> - unify bef Type.(item ty rest) >>= fun () -> - unify aft Type.(item bytes rest) - | Prim (_, I_UNPACK, [], _) -> - exists () >>= fun ty -> - exists_stack () >>= fun rest -> - unify bef Type.(item bytes rest) >>= fun () -> - unify aft Type.(item (option ty) rest) - (* Others *) - | Seq (_, []) -> unify bef aft - | Seq (_, [single]) -> - generate_constraints (Mikhailsky.Path.at_index 0 path) single bef aft - | Seq (_, instrs) -> generate_constraints_seq path 0 instrs bef aft - | _ -> raise (Ill_typed_script (Unhandled_micheline (path, node))) - -and generate_constraints_seq path index instrs bef aft = - let open M in - match instrs with - | [] -> assert false - | [single] -> - generate_constraints (Mikhailsky.Path.at_index index path) single bef aft - | hd :: tl -> - exists_stack () >>= fun stack_ty -> - generate_constraints (Mikhailsky.Path.at_index index path) hd bef stack_ty - >>= fun () -> generate_constraints_seq path (index + 1) tl stack_ty aft - -and generate_constraints_data (path : Mikhailsky.Path.t) - (node : Mikhailsky.node) (ty : Type.Base.t) : unit M.t = - let open M in - set_data_annot path ty >>= fun () -> - match node with - | Prim (_, D_Hole, [], _) -> return () - | Prim (_, D_Unit, [], _) -> unify_base ty Type.unit - | Prim (_, D_True, [], _) | Prim (_, D_False, [], _) -> - unify_base ty Type.bool - | String _ -> unify_base ty Type.string - | Bytes _ -> unify_base ty Type.bytes - | Prim (_, D_Pair, [vl; vr], _) -> - exists () >>= fun lty -> - exists () >>= fun rty -> - generate_constraints_data (Mikhailsky.Path.at_index 0 path) vl lty - >>= fun () -> - generate_constraints_data (Mikhailsky.Path.at_index 1 path) vr rty - >>= fun () -> unify_base ty (Type.pair lty rty) - | Prim (_, D_Left, [term], _) -> - exists () >>= fun lty -> - exists () >>= fun rty -> - generate_constraints_data (Mikhailsky.Path.at_index 0 path) term lty - >>= fun () -> unify_base ty (Type.or_ lty rty) - | Prim (_, D_Right, [term], _) -> - exists () >>= fun lty -> - exists () >>= fun rty -> - generate_constraints_data (Mikhailsky.Path.at_index 0 path) term rty - >>= fun () -> unify_base ty (Type.or_ lty rty) - | Prim (_, D_None, [], _) -> - exists () >>= fun elt_ty -> unify_base ty (Type.option elt_ty) - | Prim (_, D_Some, [v], _) -> - exists () >>= fun elt_ty -> - generate_constraints_data (Mikhailsky.Path.at_index 0 path) v elt_ty - >>= fun () -> unify_base ty (Type.option elt_ty) - | Prim (_, A_Int, [Int (_, _)], _) -> unify_base ty Type.int - | Prim (_, A_Nat, [Int (_, _)], _) -> unify_base ty Type.nat - | Prim (_, A_Timestamp, [Int (_, _)], _) -> unify_base ty Type.timestamp - | Prim (_, A_Mutez, [Int (_, _)], _) -> unify_base ty Type.mutez - | Prim (_, A_Key_hash, [Bytes (_, _)], _) -> unify_base ty Type.key_hash - | Prim (_, A_Key, [Bytes (_, _)], _) -> unify_base ty Type.key - | Prim (_, A_List, [Seq (_, subterms)], _) -> - exists () >>= fun elt_ty -> - unify_base ty Type.(list elt_ty) >>= fun () -> - (* path' accounts for the fact that the Seq is hidden under an annot. *) - let path' = Mikhailsky.Path.at_index 0 path in - generate_constraints_data_list path' 0 subterms elt_ty - | Prim (_, A_Set, [Seq (_, subterms)], _) -> - exists_cmp () >>= fun elt_ty -> - unify_base ty Type.(set elt_ty) >>= fun () -> - (* path' accounts for the fact that the Seq is hidden under an annot. *) - let path' = Mikhailsky.Path.at_index 0 path in - generate_constraints_data_set path' 0 subterms elt_ty - | Prim (_, A_Map, [Seq (_, subterms)], _) -> - exists_cmp () >>= fun k_ty -> - exists () >>= fun v_ty -> - unify_base ty Type.(map k_ty v_ty) >>= fun () -> - (* path' accounts for the fact that the Seq is hidden under an annot. *) - let path' = Mikhailsky.Path.at_index 0 path in - generate_constraints_data_map path' 0 subterms k_ty v_ty - | Prim (_, A_Lambda, [(Seq (_, _) as node)], _) -> - exists () >>= fun dom -> - exists () >>= fun range -> - unify_base ty Type.(lambda dom range) >>= fun () -> - let path' = Mikhailsky.Path.at_index 0 path in - let bef = Type.(item dom empty) in - let aft = Type.(item range empty) in - generate_constraints path' node bef aft - | Prim (_, (A_Int | A_Nat | A_List), _, _) -> - invalid_ast ~msg:__LOC__ path node - | Int _ - (* Ints should always be guarded by annotations *) - | Seq (_, _) - (* Lists, sets, maps, lambdas, should always be guarded by annotations *) - | _ -> - invalid_ast ~msg:__LOC__ path node - -(* raise (Ill_typed_script (Invalid_ast (path, node))) *) -and generate_constraints_data_list path index data ty = - let open M in - match data with - | [] -> return () - | hd :: tl -> - let hd_path = Mikhailsky.Path.at_index index path in - generate_constraints_data hd_path hd ty >>= fun () -> - generate_constraints_data_list path (index + 1) tl ty - -and generate_constraints_data_set path index data ty = - let open M in - match data with - | [] -> return () - | hd :: tl -> - let hd_path = Mikhailsky.Path.at_index index path in - generate_constraints_data hd_path hd ty >>= fun () -> - generate_constraints_data_list path (index + 1) tl ty - -and generate_constraints_data_map path index data k_ty v_ty = - let open M in - match data with - | [] -> return () - | elt :: tl -> ( - let elt_path = Mikhailsky.Path.at_index index path in - match elt with - | Prim (_, D_Elt, [k; v], _) -> - let k_path = Mikhailsky.Path.at_index 0 elt_path in - generate_constraints_data k_path k k_ty >>= fun () -> - let v_path = Mikhailsky.Path.at_index 1 elt_path in - generate_constraints_data v_path v v_ty >>= fun () -> - generate_constraints_data_map path (index + 1) tl k_ty v_ty - | _ -> invalid_ast ~msg:__LOC__ elt_path elt) - -and generate_constraints_dropn n bef aft = - let open M in - if n = 0 then unify bef aft - else - exists () >>= fun top -> - generate_constraints_dropn (n - 1) bef (Type.item top aft) - -let infer_with_state (node : Mikhailsky.node) : - (Type.Stack.t * Type.Stack.t) * state = - let open M in - ( exists_stack () >>= fun bef -> - exists_stack () >>= fun aft -> - generate_constraints Mikhailsky.Path.root node bef aft >>= fun () -> - instantiate bef >>= fun bef -> - instantiate aft >>= fun aft -> return (bef, aft) ) - (M.empty ()) - -let infer (node : Mikhailsky.node) : Type.Stack.t * Type.Stack.t = - fst (infer_with_state node) - -let infer_data_with_state (node : Mikhailsky.node) : Type.Base.t * state = - let open M in - ( exists () >>= fun ty -> - generate_constraints_data Mikhailsky.Path.root node ty >>= fun () -> - instantiate_base ty >>= fun ty -> return ty ) - (M.empty ()) - -let infer_data (node : Mikhailsky.node) : Type.Base.t = - fst (infer_data_with_state node) diff --git a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/inference.mli b/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/inference.mli deleted file mode 100644 index e44d83fab0695fa48ed3832c8998aad3b9272880..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/inference.mli +++ /dev/null @@ -1,145 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Errors and their pretty-printing function *) -type inference_error - -exception Ill_typed_script of inference_error - -val pp_inference_error : Format.formatter -> inference_error -> unit - -(** Comparability tag. *) -type comparability = Comparable | Not_comparable | Unconstrained - -(** Michelson types. *) -type michelson_type = - | Base_type of {repr : Type.Base.t option; comparable : comparability} - | Stack_type of Type.Stack.t option - -type transformer = {bef : Type.Stack.t; aft : Type.Stack.t} - -(** State of the type inference module *) - -(** Store implementation for type representatives *) -module Repr_store : Stores.S with type key = int and type value = michelson_type - -(** State monad built on [Repr_store] *) -module Repr_sm : - Monads.State_sig - with type state = Repr_store.state - and type key = int - and type value = michelson_type - -(** Store implementation for instruction type representatives *) -module Annot_instr_store : - Stores.S with type key = Mikhailsky.Path.t and type value = transformer - -(** State monad handling annotations on instructions *) -module Annot_instr_sm : - Monads.State_sig - with type state = Annot_instr_store.state - and type value = transformer - and type key = Mikhailsky.Path.t - -(** Store implementation for data type representatives *) -module Annot_data_store : - Stores.S with type key = Mikhailsky.Path.t and type value = Type.Base.t - -(** State monad handling annotations on data *) -module Annot_data_sm : - Monads.State_sig - with type state = Annot_data_store.state - and type value = Type.Base.t - and type key = Mikhailsky.Path.t - -(** State of the inference module *) -type state = { - uf : Uf.UF.M.state; - repr : Repr_sm.state; - annot_instr : Annot_instr_sm.state; - annot_data : Annot_data_sm.state; -} - -(** State monad of the inference module. *) -module M : sig - type 'a t = state -> 'a * state - - val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t - - val empty : unit -> state - - val return : 'a -> 'a t - - val set_repr : int -> michelson_type -> unit t - - val get_repr_exn : int -> michelson_type t - - val get_instr_annot : Annot_data_sm.key -> transformer option t - - val get_data_annot : Annot_data_sm.key -> Type.Base.t option t - - val uf_lift : 'a Uf.UF.M.t -> 'a t - - val repr_lift : 'a Repr_sm.t -> 'a t - - val annot_instr_lift : 'a Annot_instr_sm.t -> 'a t - - val annot_data_lift : 'a Annot_data_sm.t -> 'a t - - val get_state : state t -end - -(** Unifies two stack types. *) -val unify : Type.Stack.t -> Type.Stack.t -> unit M.t - -(** Unifies two base types. *) -val unify_base : Type.Base.t -> Type.Base.t -> unit M.t - -(** Instantiate type variables with the associated terms in a base type. *) -val instantiate_base : Type.Base.t -> Type.Base.t M.t - -(** Instantiate type variables with the associated terms in a stack type. *) -val instantiate : Type.Stack.t -> Type.Stack.t M.t - -(** Get comparability flag for a base type. *) -val get_comparability : Type.Base.t -> comparability M.t - -(** Performs inference on the given Mikhailsky term and returns - its type (as a pair of [before] and [after] stack) as well as the - inference engine state. *) -val infer_with_state : Mikhailsky.node -> (Type.Stack.t * Type.Stack.t) * state - -(** Performs inference on the given Mikhailsky term and throws - the inference engine state away. *) -val infer : Mikhailsky.node -> Type.Stack.t * Type.Stack.t - -(** Performs inference on a piece of Mikhailsky [data] and - returns the inference engine state along the inferred type. *) -val infer_data_with_state : Mikhailsky.node -> Type.Base.t * state - -(** Performs inference on a piece of Mikhailsky [data] and - returns the inferred type, throwing the inference engine - state away. *) -val infer_data : Mikhailsky.node -> Type.Base.t diff --git a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/int_map.ml b/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/int_map.ml deleted file mode 100644 index e9b05fe91caae667479cf7aeee9f14e6dbdbd737..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/int_map.ml +++ /dev/null @@ -1,26 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 Map.Make (Compare.Int) diff --git a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/mikhailsky.ml b/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/mikhailsky.ml deleted file mode 100644 index 83b38c9cedd6525766f2e14dc9aa682d4c540e9c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/mikhailsky.ml +++ /dev/null @@ -1,422 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 - -exception Term_contains_holes - -module Mikhailsky_signature : - Algebraic_signature.S with type t = Mikhailsky_prim.prim = struct - type t = Mikhailsky_prim.prim - - let compare (x : t) (y : t) = Stdlib.compare x y - - let hash (x : t) = Hashtbl.hash x - - let pp = Mikhailsky_prim.pp -end - -include - Micheline_with_hash_consing.Make - (Mikhailsky_signature) - (struct - let initial_size = None - end) - -module Path = Path.With_hash_consing (struct - let initial_size = None -end) - -(* Prints a Mikhailsky term. *) -let pp fmt node = - let canonical = Micheline.strip_locations node in - let printable = - Micheline_printer.printable Mikhailsky_prim.string_of_prim canonical - in - Micheline_printer.print_expr fmt printable - -let to_string node = - pp Format.str_formatter node ; - Format.flush_str_formatter () - -(* Adapted from Script_ir_translator.parse_ty *) -let rec parse_ty : - allow_big_map:bool -> - allow_operation:bool -> - allow_contract:bool -> - node -> - Type.Base.t = - fun ~allow_big_map ~allow_operation ~allow_contract node -> - match node with - | Prim (_loc, T_unit, [], _annot) -> Type.unit - | Prim (_loc, T_int, [], _annot) -> Type.int - | Prim (_loc, T_nat, [], _annot) -> Type.nat - | Prim (_loc, T_string, [], _annot) -> Type.string - | Prim (_loc, T_bytes, [], _annot) -> Type.bytes - | Prim (_loc, T_bool, [], _annot) -> Type.bool - | Prim (_loc, T_key_hash, [], _annot) -> Type.key_hash - | Prim (_loc, T_timestamp, [], _annot) -> Type.timestamp - | Prim (_loc, T_mutez, [], _annot) -> Type.mutez - | Prim (_loc, T_option, [ut], _annot) -> - let ty = parse_ty ~allow_big_map ~allow_operation ~allow_contract ut in - Type.option ty - | Prim (_loc, T_pair, [utl; utr], _annot) -> - let lty = parse_ty ~allow_big_map ~allow_operation ~allow_contract utl in - let rty = parse_ty ~allow_big_map ~allow_operation ~allow_contract utr in - Type.pair lty rty - | Prim (_loc, T_or, [utl; utr], _annot) -> - let lty = parse_ty ~allow_big_map ~allow_operation ~allow_contract utl in - let rty = parse_ty ~allow_big_map ~allow_operation ~allow_contract utr in - Type.or_ lty rty - | Prim (_loc, T_set, [ut], _annot) -> - let ut = parse_ty ~allow_big_map ~allow_operation ~allow_contract ut in - Type.set ut - | Prim (_loc, T_map, [uta; utb], _annot) -> - let uta = parse_ty ~allow_big_map ~allow_operation ~allow_contract uta in - let utb = parse_ty ~allow_big_map ~allow_operation ~allow_contract utb in - Type.map uta utb - | Prim (_loc, T_lambda, [dom; range], _annot) -> - let dom = parse_ty ~allow_big_map ~allow_operation ~allow_contract dom in - let range = - parse_ty ~allow_big_map ~allow_operation ~allow_contract range - in - Type.lambda dom range - | Prim (_loc, T_list, [elt], _annot) -> - let elt = parse_ty ~allow_big_map ~allow_operation ~allow_contract elt in - Type.list elt - | _ -> - let s = to_string node in - Stdlib.failwith ("Mikhailsky.parse_ty: could not parse " ^ s) - -exception Term_has_variables - -exception Ill_formed_mikhailsky - -let rec map_var f (x : Type.Base.t) = - match x.node with - | Unit_t -> prim T_unit [] [] - | Var_t v -> f v - | Int_t -> prim T_int [] [] - | Nat_t -> prim T_nat [] [] - | Bool_t -> prim T_bool [] [] - | String_t -> prim T_string [] [] - | Bytes_t -> prim T_bytes [] [] - | Key_hash_t -> prim T_key_hash [] [] - | Timestamp_t -> prim T_timestamp [] [] - | Mutez_t -> prim T_mutez [] [] - | Key_t -> prim T_key [] [] - | Option_t ty -> - let mty = map_var f ty in - prim T_option [mty] [] - | Pair_t (lty, rty) -> - let lty = map_var f lty in - let rty = map_var f rty in - prim T_pair [lty; rty] [] - | Or_t (lty, rty) -> - let lty = map_var f lty in - let rty = map_var f rty in - prim T_or [lty; rty] [] - | List_t ty -> - let mty = map_var f ty in - prim T_list [mty] [] - | Set_t ty -> - let mty = map_var f ty in - prim T_set [mty] [] - | Map_t (kty, vty) -> - let mkty = map_var f kty in - let mvty = map_var f vty in - prim T_map [mkty; mvty] [] - | Lambda_t (dom, range) -> - let dom = map_var f dom in - let range = map_var f range in - prim T_lambda [dom; range] [] - -let unparse_ty_exn (x : Type.Base.t) = - map_var (fun _ -> raise Term_has_variables) x - -let unparse_ty (x : Type.Base.t) = - try Some (unparse_ty_exn x) with Term_has_variables -> None - -(* Exports a Mikhailsky term to Michelson. Fails if term contains holes. - Erases annotations, introduces types where missing. *) -let rec to_michelson (n : node) = - match n with - | Micheline.Int (_, i) -> Micheline.Int (0, i) - | Micheline.Prim (_, head, [term], _) - when Mikhailsky_prim.kind head = Annot_kind && head <> A_Lambda -> - to_michelson term - | Micheline.Prim (_, I_Hole, _, _) -> raise Term_contains_holes - | Micheline.Prim (_, D_Hole, _, _) -> raise Term_contains_holes - | Micheline.Prim (_, head, subterms, annots) -> - let head = Mikhailsky_prim.to_michelson head in - Micheline.Prim (0, head, List.map to_michelson subterms, annots) - | Micheline.String (_, s) -> Micheline.String (0, s) - | Micheline.Bytes (_, b) -> Micheline.Bytes (0, b) - | Micheline.Seq (_, subterms) -> - Micheline.Seq (0, List.map to_michelson subterms) - -let to_michelson (n : node) : Script_repr.expr = - Micheline.strip_locations (to_michelson n) - -let rec size : node -> int = - fun node -> - match node with - | Micheline.Int (_, _) -> 1 - | Micheline.String (_, _) -> 1 - | Micheline.Bytes (_, _) -> 1 - | Micheline.Prim (_, _, subterms, _) -> - List.fold_left (fun acc n -> acc + size n) 1 subterms - | Micheline.Seq (_, subterms) -> - List.fold_left (fun acc n -> acc + size n) 1 subterms - -let instr_hole = prim I_Hole [] [] - -let data_hole = prim D_Hole [] [] - -(* types *) -let unit_ty = prim T_unit [] [] - -let bool_ty = prim T_bool [] [] - -let int_ty = prim T_int [] [] - -let nat_ty = prim T_nat [] [] - -let string_ty = prim T_string [] [] - -let bytes_ty = prim T_bytes [] [] - -let key_hash_ty = prim T_key_hash [] [] - -let option_ty x = prim T_option [x] [] - -let list_ty x = prim T_list [x] [] - -(* Unique identifier provided by hash-consing Micheline terms. *) -let tag node = - let l = label node in - l.tag - -(* hash of term *) -let hash node = - let l = label node in - l.hash - -module Instructions = struct - (* arithmetic *) - - let add ty1 ty2 = prim I_ADD [ty1; ty2] [] - - let sub ty1 ty2 = prim I_SUB [ty1; ty2] [] - - let mul ty1 ty2 = prim I_MUL [ty1; ty2] [] - - let ediv ty1 ty2 = prim I_EDIV [ty1; ty2] [] - - let abs = prim I_ABS [] [] - - let gt = prim I_GT [] [] - - (* stack ops *) - let push ty v = prim I_PUSH [ty; v] [] - - let dip code = prim I_DIP [seq [code]] [] - - let dup = prim I_DUP [] [] - - let drop = prim I_DROP [] [] - - let dropn n = prim I_DROP [int (Z.of_int n)] [] - - let swap = prim I_SWAP [] [] - - (* crypto *) - let blake2b = prim I_BLAKE2B [] [] - - let sha256 = prim I_SHA256 [] [] - - let sha512 = prim I_SHA512 [] [] - - let hash_key = prim I_HASH_KEY [] [] - - (* control *) - let if_ bt bf = prim I_IF [seq [bt]; seq [bf]] [] - - let if_left bt bf = prim I_IF_LEFT [seq [bt]; seq [bf]] [] - - let if_none bt bf = prim I_IF_NONE [seq [bt]; seq [bf]] [] - - let loop b = prim I_LOOP [seq [b]] [] - - let loop_left b = prim I_LOOP_LEFT [seq [b]] [] - - (* pairs *) - let car = prim I_CAR [] [] - - let cdr = prim I_CDR [] [] - - let pair = prim I_PAIR [] [] - - (* ors *) - - let left = prim I_LEFT [] [] - - let right = prim I_RIGHT [] [] - - (* boolean *) - let and_ = prim I_AND [] [] - - (* compare *) - let compare = prim I_COMPARE [] [] - - (* map/set *) - let empty_set = prim I_EMPTY_SET [] [] - - let update_set = prim I_UPDATE_SET [] [] - - let size_set = prim I_SIZE_SET [] [] - - let iter_set code = prim I_ITER_SET [seq code] [] - - let mem_set = prim I_MEM_SET [] [] - - let empty_map = prim I_EMPTY_MAP [] [] - - let update_map = prim I_UPDATE_MAP [] [] - - let size_map = prim I_SIZE_MAP [] [] - - let iter_map code = prim I_ITER_MAP [seq code] [] - - let map_map code = prim I_MAP_MAP [seq code] [] - - let get_map = prim I_GET_MAP [] [] - - let mem_map = prim I_MEM_MAP [] [] - - (* lists*) - let nil = prim I_NIL [] [] - - let cons = prim I_CONS [] [] - - let size_list = prim I_SIZE_LIST [] [] - - let iter_list code = prim I_ITER_LIST [seq code] [] - - let map_list code = prim I_MAP_LIST [seq code] [] - - (* strings *) - let concat = prim I_CONCAT [] [] - - let size_string = prim I_SIZE_STRING [] [] - - let size_bytes = prim I_SIZE_BYTES [] [] - - (* Lambdas *) - let lambda code = prim I_LAMBDA [seq code] [] - - let exec = prim I_EXEC [] [] - - let apply = prim I_APPLY [] [] - - (* pack/unpack *) - let pack = prim I_PACK [] [] - - let unpack = prim I_UNPACK [] [] - - (* hole *) - let hole = instr_hole -end - -(* value constructors *) -module Data = struct - let unit = prim D_Unit [] [] - - let false_ = prim D_False [] [] - - let true_ = prim D_True [] [] - - let none = prim D_None [] [] - - let some x = prim D_Some [x] [] - - let pair x y = prim D_Pair [x; y] [] - - let left x = prim D_Left [x] [] - - let right x = prim D_Right [x] [] - - let list elts = prim A_List [seq elts] [] - - let set elts = prim A_Set [seq elts] [] - - let map_elt k v = prim D_Elt [k; v] [] - - let map elts = prim A_Map [seq elts] [] - - let timestamp ts = - let z = Protocol.Script_timestamp.to_zint ts in - prim A_Timestamp [int z] [] - - let mutez (tz : Protocol.Alpha_context.Tez.tez) = - let i = Protocol.Alpha_context.Tez.to_mutez tz in - prim A_Mutez [int (Z.of_int64 i)] [] - - let key_hash kh = - let b = - Data_encoding.Binary.to_bytes_exn - Environment.Signature.Public_key_hash.encoding - kh - in - prim A_Key_hash [bytes b] [] - - let key k = - let b = - Data_encoding.Binary.to_bytes_exn - Environment.Signature.Public_key.encoding - k - in - prim A_Key [bytes b] [] - - let integer (i : int) = prim A_Int [int (Z.of_int i)] [] - - let natural (i : int) = - assert (i >= 0) ; - prim A_Nat [int (Z.of_int i)] [] - - let big_integer (i : Z.t) = prim A_Int [int i] [] - - let big_natural (i : Z.t) = - assert (Z.geq i Z.zero) ; - prim A_Nat [int i] [] - - let string = string - - let bytes = bytes - - let lambda code = prim A_Lambda [seq code] [] - - let hole = data_hole -end diff --git a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/mikhailsky.mli b/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/mikhailsky.mli deleted file mode 100644 index 724bfa299074d04eb4a0743caa9210735a7c550f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/mikhailsky.mli +++ /dev/null @@ -1,331 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 - -(** Mikhailsky: Michelson in Micheline form, with typed holes and annotations. - Mikhailsky terms are hash-consed. *) - -(** - Michelson code is a hard to type-check and generate incrementally due to - the presence of ambiguous constructs, such as literals - like [{ 1 ; 2 ; 3 }]. Is it a list of ints? of nats? of tez? Or a set? - - Thus, we will work with Mikhailsky, a better behaved version of Michelson - allowing local reconstruction of types. - - Differences wrt Michelson: - - 1. non string/byte literals are explicitly annotated with their head type constructor. - Here is an int i: Prim (_, D_int, [Int i], _) - Here is an nat n: Prim (_, D_nat, [Int i], _) - Here is an list of something: Prim (_, D_list, michelson_list, _) - Here is a set: Prim (_, D_set, michelson_set, _) - Here is a map: Prim (_, D_map, michelson_map, _) - etc. - Projecting back from this language to Michelson is trivial. - - 2. Instructions `LEFT/RIGHT` do not need to carry the type of the other - component of the disjunction. These has to be filled in back when - generating Michelson from Mikhailsky. - - 4. The same holds for the input/output type of a lambda as specified in the - `LAMBDA` instruction. - - 3. Some instructions are annotated with the type on which they operate. - Eg if Prim (_, I_ADD, [], []) is the (ad-hoc polymorphic) addition in Michelson, - we will have the following variants in Mikhailsky: - - Prim (_, I_ADD, [ Prim (_, T_mutez, [], []), - Prim (_, T_mutez, [], []) ], []) for mutez addition - - Prim (_, I_ADD, [ Prim (_, T_int, [], []), - Prim (_, T_nat, [], []) ], []) for int+nat addition - etc. -*) - -(** The signature of Mikhailsky terms. *) -module Mikhailsky_signature : - Algebraic_signature.S with type t = Mikhailsky_prim.prim - -(** Elements of type [Path.t] allow to index subterms of Mikhailsky terms. *) -module Path : Path.S - -(** The following types correspond to those provided when instantiating the - functor [Micheline_with_hash_consing.Make] on [Mikhailsky_signature]. *) -type label = Micheline_with_hash_consing.hcons_info - -type head = Mikhailsky_signature.t - -type node = (label, head) Micheline.node - -exception Term_contains_holes - -exception Ill_formed_mikhailsky - -(** [parse_ty] returns a type from a Mikhailsky term. *) -val parse_ty : - allow_big_map:bool -> - allow_operation:bool -> - allow_contract:bool -> - node -> - Type.Base.t - -(** [map_var f x] maps the function f on all variables contained - in the type [x]. *) -val map_var : (int -> node) -> Type.Base.t -> node - -(** [unparse_ty] returns a Mikhailsky term representing a type. *) -val unparse_ty_exn : Type.Base.t -> node - -val unparse_ty : Type.Base.t -> node option - -(** Extracts a Michelson term from a Mikhailsky one. Raises - [Term_contains_holes] if it cannot be done. *) -val to_michelson : node -> Script_repr.expr - -(** Pretty printer. *) -val pp : Format.formatter -> node -> unit - -val to_string : node -> string - -(** Returns the number of nodes of a Mikhailsky term. *) -val size : node -> int - -(** Micheline generic constructors *) -val prim : Mikhailsky_prim.prim -> node list -> string list -> node - -val seq : node list -> node - -val string : string -> node - -val bytes : Bytes.t -> node - -(** Mikhailsky smart constructors*) - -(** Holes *) -val instr_hole : node - -val data_hole : node - -(** Types *) -val unit_ty : node - -val int_ty : node - -val nat_ty : node - -val bool_ty : node - -val string_ty : node - -val bytes_ty : node - -val key_hash_ty : node - -val option_ty : node -> node - -val list_ty : node -> node - -(** Project unique tag out of Mikhailsky node *) -val tag : node -> int - -(** Project hash out of Mikhailsky node *) -val hash : node -> int - -(** Instructions *) -module Instructions : sig - (** Arithmetic. Binary operations take the input types as extra arguments. *) - val add : node -> node -> node - - val sub : node -> node -> node - - val mul : node -> node -> node - - val ediv : node -> node -> node - - val abs : node - - val gt : node - - (** Stack *) - val push : node -> node -> node - - val dip : node -> node - - val dup : node - - val drop : node - - val dropn : int -> node - - val swap : node - - (** Crypto *) - val blake2b : node - - val sha256 : node - - val sha512 : node - - val hash_key : node - - (** Control *) - val if_ : node -> node -> node - - val if_left : node -> node -> node - - val if_none : node -> node -> node - - val loop : node -> node - - val loop_left : node -> node - - (** Pairs *) - val car : node - - val cdr : node - - val pair : node - - (** Unions *) - val left : node - - val right : node - - (** Booleans *) - val and_ : node - - (** Compare *) - val compare : node - - (** Set/Map *) - val empty_set : node - - val update_set : node - - val size_set : node - - val iter_set : node list -> node - - val mem_set : node - - val empty_map : node - - val update_map : node - - val size_map : node - - val iter_map : node list -> node - - val map_map : node list -> node - - val get_map : node - - val mem_map : node - - (** Lists *) - val nil : node - - val cons : node - - val size_list : node - - val iter_list : node list -> node - - val map_list : node list -> node - - (** Strings/bytes *) - val concat : node - - val size_string : node - - val size_bytes : node - - (** Lambdas *) - val lambda : node list -> node - - val exec : node - - val apply : node - - (** pack/unpack *) - - val pack : node - - val unpack : node - - (** Hole *) - val hole : node -end - -(** data *) -module Data : sig - val unit : node - - val false_ : node - - val true_ : node - - val none : node - - val some : node -> node - - val pair : node -> node -> node - - val left : node -> node - - val right : node -> node - - val list : node list -> node - - val set : node list -> node - - val map_elt : node -> node -> node - - val map : node list -> node - - val timestamp : Script_timestamp.t -> node - - val mutez : Alpha_context.Tez.t -> node - - val key_hash : Environment.Signature.Public_key_hash.t -> node - - val key : Environment.Signature.Public_key.t -> node - - val integer : int -> node - - val natural : int -> node - - val big_integer : Z.t -> node - - val big_natural : Z.t -> node - - val string : string -> node - - val bytes : Bytes.t -> node - - val lambda : node list -> node - - val hole : node -end diff --git a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/mikhailsky_prim.ml b/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/mikhailsky_prim.ml deleted file mode 100644 index 362ec1eb45f2b3b4972ee9425454a1305ac92338..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/mikhailsky_prim.ml +++ /dev/null @@ -1,572 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 - -(** Mikhailsky primitives correspond to Michelson primitives plus special - "holes" for instructions and data. *) - -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_CHAIN_ID - | 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_BIG_MAP - | I_EMPTY_MAP - | I_EMPTY_SET - | I_EQ - | I_EXEC - | I_APPLY - | I_FAILWITH - | I_GE - | I_GET_MAP - | I_GET_AND_UPDATE_MAP - | 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_MAP - | I_MAP_LIST - | I_MEM_SET - | I_MEM_MAP - | I_MUL - | I_NEG - | I_NEQ - | I_NIL - | I_NONE - | I_NOT - | I_NOW - | I_OR - | I_PAIR - | I_UNPAIR - | I_PUSH - | I_RIGHT - | I_SIZE_SET - | I_SIZE_MAP - | I_SIZE_LIST - | I_SIZE_STRING - | I_SIZE_BYTES - | 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_SET - | I_UPDATE_MAP - | I_XOR - | I_ITER_MAP - | I_ITER_LIST - | I_ITER_SET - | I_LOOP_LEFT - | I_ADDRESS - | I_CONTRACT - | I_ISNAT - | I_CAST - | I_RENAME - | I_DIG - | I_DUG - | I_LEVEL - | I_SELF_ADDRESS - | I_NEVER - | I_SAPLING_EMPTY_STATE - | I_SAPLING_VERIFY_UPDATE - | I_VOTING_POWER - | I_TOTAL_VOTING_POWER - | I_KECCAK - | I_SHA3 - | I_PAIRING_CHECK - | I_TICKET - | I_READ_TICKET - | I_SPLIT_TICKET - | I_JOIN_TICKETS - | 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 - | T_chain_id - | T_never - | T_sapling_state - | T_sapling_transaction_deprecated - | T_bls12_381_g1 - | T_bls12_381_g2 - | T_bls12_381_fr - | T_ticket - (* Holes in programs and data. *) - | I_Hole - | D_Hole - (* Annotations. *) - | A_Int - | A_Nat - | A_Timestamp - | A_Mutez - | A_Key_hash - | A_Key - | A_List - | A_Set - | A_Map - | A_Lambda - -let relation = - [ - (K_parameter, Michelson_v1_primitives.K_parameter); - (K_storage, Michelson_v1_primitives.K_storage); - (K_code, Michelson_v1_primitives.K_code); - (D_False, Michelson_v1_primitives.D_False); - (D_Elt, Michelson_v1_primitives.D_Elt); - (D_Left, Michelson_v1_primitives.D_Left); - (D_None, Michelson_v1_primitives.D_None); - (D_Pair, Michelson_v1_primitives.D_Pair); - (D_Right, Michelson_v1_primitives.D_Right); - (D_Some, Michelson_v1_primitives.D_Some); - (D_True, Michelson_v1_primitives.D_True); - (D_Unit, Michelson_v1_primitives.D_Unit); - (I_PACK, Michelson_v1_primitives.I_PACK); - (I_UNPACK, Michelson_v1_primitives.I_UNPACK); - (I_BLAKE2B, Michelson_v1_primitives.I_BLAKE2B); - (I_SHA256, Michelson_v1_primitives.I_SHA256); - (I_SHA512, Michelson_v1_primitives.I_SHA512); - (I_ABS, Michelson_v1_primitives.I_ABS); - (I_ADD, Michelson_v1_primitives.I_ADD); - (I_AMOUNT, Michelson_v1_primitives.I_AMOUNT); - (I_AND, Michelson_v1_primitives.I_AND); - (I_BALANCE, Michelson_v1_primitives.I_BALANCE); - (I_CAR, Michelson_v1_primitives.I_CAR); - (I_CDR, Michelson_v1_primitives.I_CDR); - (I_CHAIN_ID, Michelson_v1_primitives.I_CHAIN_ID); - (I_CHECK_SIGNATURE, Michelson_v1_primitives.I_CHECK_SIGNATURE); - (I_COMPARE, Michelson_v1_primitives.I_COMPARE); - (I_CONCAT, Michelson_v1_primitives.I_CONCAT); - (I_CONS, Michelson_v1_primitives.I_CONS); - (I_CREATE_ACCOUNT, Michelson_v1_primitives.I_CREATE_ACCOUNT); - (I_CREATE_CONTRACT, Michelson_v1_primitives.I_CREATE_CONTRACT); - (I_IMPLICIT_ACCOUNT, Michelson_v1_primitives.I_IMPLICIT_ACCOUNT); - (I_DIP, Michelson_v1_primitives.I_DIP); - (I_DROP, Michelson_v1_primitives.I_DROP); - (I_DUP, Michelson_v1_primitives.I_DUP); - (I_EDIV, Michelson_v1_primitives.I_EDIV); - (I_EMPTY_BIG_MAP, Michelson_v1_primitives.I_EMPTY_BIG_MAP); - (I_EMPTY_MAP, Michelson_v1_primitives.I_EMPTY_MAP); - (I_EMPTY_SET, Michelson_v1_primitives.I_EMPTY_SET); - (I_EQ, Michelson_v1_primitives.I_EQ); - (I_EXEC, Michelson_v1_primitives.I_EXEC); - (I_APPLY, Michelson_v1_primitives.I_APPLY); - (I_FAILWITH, Michelson_v1_primitives.I_FAILWITH); - (I_GE, Michelson_v1_primitives.I_GE); - (I_GET_MAP, Michelson_v1_primitives.I_GET); - (I_GET_AND_UPDATE_MAP, Michelson_v1_primitives.I_GET_AND_UPDATE); - (I_GT, Michelson_v1_primitives.I_GT); - (I_HASH_KEY, Michelson_v1_primitives.I_HASH_KEY); - (I_IF, Michelson_v1_primitives.I_IF); - (I_IF_CONS, Michelson_v1_primitives.I_IF_CONS); - (I_IF_LEFT, Michelson_v1_primitives.I_IF_LEFT); - (I_IF_NONE, Michelson_v1_primitives.I_IF_NONE); - (I_INT, Michelson_v1_primitives.I_INT); - (I_LAMBDA, Michelson_v1_primitives.I_LAMBDA); - (I_LE, Michelson_v1_primitives.I_LE); - (I_LEFT, Michelson_v1_primitives.I_LEFT); - (I_LEVEL, Michelson_v1_primitives.I_LEVEL); - (I_LOOP, Michelson_v1_primitives.I_LOOP); - (I_LSL, Michelson_v1_primitives.I_LSL); - (I_LSR, Michelson_v1_primitives.I_LSR); - (I_LT, Michelson_v1_primitives.I_LT); - (I_MAP_MAP, Michelson_v1_primitives.I_MAP); - (I_MAP_LIST, Michelson_v1_primitives.I_MAP); - (I_MEM_SET, Michelson_v1_primitives.I_MEM); - (I_MEM_MAP, Michelson_v1_primitives.I_MEM); - (I_MUL, Michelson_v1_primitives.I_MUL); - (I_NEG, Michelson_v1_primitives.I_NEG); - (I_NEQ, Michelson_v1_primitives.I_NEQ); - (I_NIL, Michelson_v1_primitives.I_NIL); - (I_NONE, Michelson_v1_primitives.I_NONE); - (I_NOT, Michelson_v1_primitives.I_NOT); - (I_NOW, Michelson_v1_primitives.I_NOW); - (I_OR, Michelson_v1_primitives.I_OR); - (I_PAIR, Michelson_v1_primitives.I_PAIR); - (I_UNPAIR, Michelson_v1_primitives.I_UNPAIR); - (I_PUSH, Michelson_v1_primitives.I_PUSH); - (I_RIGHT, Michelson_v1_primitives.I_RIGHT); - (I_SIZE_SET, Michelson_v1_primitives.I_SIZE); - (I_SIZE_MAP, Michelson_v1_primitives.I_SIZE); - (I_SIZE_LIST, Michelson_v1_primitives.I_SIZE); - (I_SIZE_STRING, Michelson_v1_primitives.I_SIZE); - (I_SIZE_BYTES, Michelson_v1_primitives.I_SIZE); - (I_SOME, Michelson_v1_primitives.I_SOME); - (I_SOURCE, Michelson_v1_primitives.I_SOURCE); - (I_SENDER, Michelson_v1_primitives.I_SENDER); - (I_SELF, Michelson_v1_primitives.I_SELF); - (I_SELF_ADDRESS, Michelson_v1_primitives.I_SELF_ADDRESS); - (I_SLICE, Michelson_v1_primitives.I_SLICE); - (I_STEPS_TO_QUOTA, Michelson_v1_primitives.I_STEPS_TO_QUOTA); - (I_SUB, Michelson_v1_primitives.I_SUB); - (I_SWAP, Michelson_v1_primitives.I_SWAP); - (I_TRANSFER_TOKENS, Michelson_v1_primitives.I_TRANSFER_TOKENS); - (I_SET_DELEGATE, Michelson_v1_primitives.I_SET_DELEGATE); - (I_UNIT, Michelson_v1_primitives.I_UNIT); - (I_UPDATE_SET, Michelson_v1_primitives.I_UPDATE); - (I_UPDATE_MAP, Michelson_v1_primitives.I_UPDATE); - (I_XOR, Michelson_v1_primitives.I_XOR); - (I_ITER_MAP, Michelson_v1_primitives.I_ITER); - (I_ITER_LIST, Michelson_v1_primitives.I_ITER); - (I_ITER_SET, Michelson_v1_primitives.I_ITER); - (I_LOOP_LEFT, Michelson_v1_primitives.I_LOOP_LEFT); - (I_ADDRESS, Michelson_v1_primitives.I_ADDRESS); - (I_CONTRACT, Michelson_v1_primitives.I_CONTRACT); - (I_ISNAT, Michelson_v1_primitives.I_ISNAT); - (I_CAST, Michelson_v1_primitives.I_CAST); - (I_RENAME, Michelson_v1_primitives.I_RENAME); - (I_SAPLING_EMPTY_STATE, Michelson_v1_primitives.I_SAPLING_EMPTY_STATE); - (I_SAPLING_VERIFY_UPDATE, Michelson_v1_primitives.I_SAPLING_VERIFY_UPDATE); - (I_DIG, Michelson_v1_primitives.I_DIG); - (I_DUG, Michelson_v1_primitives.I_DUG); - (I_NEVER, Michelson_v1_primitives.I_NEVER); - (I_VOTING_POWER, Michelson_v1_primitives.I_VOTING_POWER); - (I_TOTAL_VOTING_POWER, Michelson_v1_primitives.I_TOTAL_VOTING_POWER); - (I_KECCAK, Michelson_v1_primitives.I_KECCAK); - (I_SHA3, Michelson_v1_primitives.I_SHA3); - (I_PAIRING_CHECK, Michelson_v1_primitives.I_PAIRING_CHECK); - (I_TICKET, Michelson_v1_primitives.I_TICKET); - (I_READ_TICKET, Michelson_v1_primitives.I_READ_TICKET); - (I_SPLIT_TICKET, Michelson_v1_primitives.I_SPLIT_TICKET); - (I_JOIN_TICKETS, Michelson_v1_primitives.I_JOIN_TICKETS); - (T_bool, Michelson_v1_primitives.T_bool); - (T_contract, Michelson_v1_primitives.T_contract); - (T_int, Michelson_v1_primitives.T_int); - (T_key, Michelson_v1_primitives.T_key); - (T_key_hash, Michelson_v1_primitives.T_key_hash); - (T_lambda, Michelson_v1_primitives.T_lambda); - (T_list, Michelson_v1_primitives.T_list); - (T_map, Michelson_v1_primitives.T_map); - (T_big_map, Michelson_v1_primitives.T_big_map); - (T_nat, Michelson_v1_primitives.T_nat); - (T_option, Michelson_v1_primitives.T_option); - (T_or, Michelson_v1_primitives.T_or); - (T_pair, Michelson_v1_primitives.T_pair); - (T_set, Michelson_v1_primitives.T_set); - (T_signature, Michelson_v1_primitives.T_signature); - (T_string, Michelson_v1_primitives.T_string); - (T_bytes, Michelson_v1_primitives.T_bytes); - (T_mutez, Michelson_v1_primitives.T_mutez); - (T_timestamp, Michelson_v1_primitives.T_timestamp); - (T_unit, Michelson_v1_primitives.T_unit); - (T_operation, Michelson_v1_primitives.T_operation); - (T_address, Michelson_v1_primitives.T_address); - ( T_sapling_transaction_deprecated, - Michelson_v1_primitives.T_sapling_transaction_deprecated ); - (T_sapling_state, Michelson_v1_primitives.T_sapling_state); - (T_chain_id, Michelson_v1_primitives.T_chain_id); - (T_never, Michelson_v1_primitives.T_never); - (T_bls12_381_g1, Michelson_v1_primitives.T_bls12_381_g1); - (T_bls12_381_g2, Michelson_v1_primitives.T_bls12_381_g2); - (T_bls12_381_fr, Michelson_v1_primitives.T_bls12_381_fr); - (T_ticket, Michelson_v1_primitives.T_ticket); - ] - -let relation_table = - let table = Hashtbl.create 269 in - List.iter - (fun (mikhailsky, michelson) -> Hashtbl.add table mikhailsky michelson) - relation ; - table - -exception Primitive_cannot_be_cast_back_to_Michelson of prim - -let to_michelson prim = - match Hashtbl.find relation_table prim with - | exception Not_found -> - raise (Primitive_cannot_be_cast_back_to_Michelson prim) - | res -> res - -let string_of_prim prim = - match prim with - | K_parameter -> "K_parameter" - | K_storage -> "K_storage" - | K_code -> "K_code" - | D_False -> "D_False" - | D_Elt -> "D_Elt" - | D_Left -> "D_Left" - | D_None -> "D_None" - | D_Pair -> "D_Pair" - | D_Right -> "D_Right" - | D_Some -> "D_Some" - | D_True -> "D_True" - | D_Unit -> "D_Unit" - | I_PACK -> "I_PACK" - | I_UNPACK -> "I_UNPACK" - | I_BLAKE2B -> "I_BLAKE2B" - | I_SHA256 -> "I_SHA256" - | I_SHA512 -> "I_SHA512" - | I_ABS -> "I_ABS" - | I_ADD -> "I_ADD" - | I_AMOUNT -> "I_AMOUNT" - | I_AND -> "I_AND" - | I_BALANCE -> "I_BALANCE" - | I_CAR -> "I_CAR" - | I_CDR -> "I_CDR" - | I_CHAIN_ID -> "I_CHAIN_ID" - | I_CHECK_SIGNATURE -> "I_CHECK_SIGNATURE" - | I_COMPARE -> "I_COMPARE" - | I_CONCAT -> "I_CONCAT" - | I_CONS -> "I_CONS" - | I_CREATE_ACCOUNT -> "I_CREATE_ACCOUNT" - | I_CREATE_CONTRACT -> "I_CREATE_CONTRACT" - | I_IMPLICIT_ACCOUNT -> "I_IMPLICIT_ACCOUNT" - | I_DIP -> "I_DIP" - | I_DROP -> "I_DROP" - | I_DUP -> "I_DUP" - | I_EDIV -> "I_EDIV" - | I_EMPTY_BIG_MAP -> "I_EMPTY_BIG_MAP" - | I_EMPTY_MAP -> "I_EMPTY_MAP" - | I_EMPTY_SET -> "I_EMPTY_SET" - | I_EQ -> "I_EQ" - | I_EXEC -> "I_EXEC" - | I_APPLY -> "I_APPLY" - | I_FAILWITH -> "I_FAILWITH" - | I_GE -> "I_GE" - | I_GET_MAP -> "I_GET_MAP" - | I_GET_AND_UPDATE_MAP -> "I_GET_AND_UPDATE_MAP" - | I_GT -> "I_GT" - | I_HASH_KEY -> "I_HASH_KEY" - | I_IF -> "I_IF" - | I_IF_CONS -> "I_IF_CONS" - | I_IF_LEFT -> "I_IF_LEFT" - | I_IF_NONE -> "I_IF_NONE" - | I_INT -> "I_INT" - | I_LAMBDA -> "I_LAMBDA" - | I_LE -> "I_LE" - | I_LEFT -> "I_LEFT" - | I_LOOP -> "I_LOOP" - | I_LSL -> "I_LSL" - | I_LSR -> "I_LSR" - | I_LT -> "I_LT" - | I_MAP_MAP -> "I_MAP_MAP" - | I_MAP_LIST -> "I_MAP_LIST" - | I_MEM_SET -> "I_MEM_SET" - | I_MEM_MAP -> "I_MEM_MAP" - | I_MUL -> "I_MUL" - | I_NEG -> "I_NEG" - | I_NEQ -> "I_NEQ" - | I_NIL -> "I_NIL" - | I_NONE -> "I_NONE" - | I_NOT -> "I_NOT" - | I_NOW -> "I_NOW" - | I_OR -> "I_OR" - | I_PAIR -> "I_PAIR" - | I_UNPAIR -> "I_UNPAIR" - | I_PUSH -> "I_PUSH" - | I_RIGHT -> "I_RIGHT" - | I_SIZE_SET -> "I_SIZE_SET" - | I_SIZE_MAP -> "I_SIZE_MAP" - | I_SIZE_LIST -> "I_SIZE_LIST" - | I_SIZE_STRING -> "I_SIZE_STRING" - | I_SIZE_BYTES -> "I_SIZE_BYTES" - | I_SOME -> "I_SOME" - | I_SOURCE -> "I_SOURCE" - | I_SENDER -> "I_SENDER" - | I_SELF -> "I_SELF" - | I_SLICE -> "I_SLICE" - | I_STEPS_TO_QUOTA -> "I_STEPS_TO_QUOTA" - | I_SUB -> "I_SUB" - | I_SWAP -> "I_SWAP" - | I_TRANSFER_TOKENS -> "I_TRANSFER_TOKENS" - | I_SET_DELEGATE -> "I_SET_DELEGATE" - | I_UNIT -> "I_UNIT" - | I_UPDATE_SET -> "I_UPDATE_SET" - | I_UPDATE_MAP -> "I_UPDATE_MAP" - | I_XOR -> "I_XOR" - | I_ITER_MAP -> "I_ITER_MAP" - | I_ITER_LIST -> "I_ITER_LIST" - | I_ITER_SET -> "I_ITER_SET" - | I_LOOP_LEFT -> "I_LOOP_LEFT" - | I_ADDRESS -> "I_ADDRESS" - | I_CONTRACT -> "I_CONTRACT" - | I_ISNAT -> "I_ISNAT" - | I_CAST -> "I_CAST" - | I_RENAME -> "I_RENAME" - | I_DIG -> "I_DIG" - | I_DUG -> "I_DUG" - | I_LEVEL -> "I_LEVEL" - | I_SELF_ADDRESS -> "I_SELF_ADDRESS" - | I_NEVER -> "I_NEVER" - | I_SAPLING_EMPTY_STATE -> "I_SAPLING_EMPTY_STATE" - | I_SAPLING_VERIFY_UPDATE -> "I_SAPLING_VERIFY_UPDATE" - | I_VOTING_POWER -> "I_VOTING_POWER" - | I_TOTAL_VOTING_POWER -> "I_TOTAL_VOTING_POWER" - | I_KECCAK -> "I_KECCAK" - | I_SHA3 -> "I_SHA3" - | I_PAIRING_CHECK -> "I_PAIRING_CHECK" - | I_TICKET -> "I_TICKET" - | I_READ_TICKET -> "I_READ_TICKET" - | I_SPLIT_TICKET -> "I_SPLIT_TICKET" - | I_JOIN_TICKETS -> "I_JOIN_TICKETS" - | T_bool -> "T_bool" - | T_contract -> "T_contract" - | T_int -> "T_int" - | T_key -> "T_key" - | T_key_hash -> "T_key_hash" - | T_lambda -> "T_lambda" - | T_list -> "T_list" - | T_map -> "T_map" - | T_big_map -> "T_big_map" - | T_nat -> "T_nat" - | T_option -> "T_option" - | T_or -> "T_or" - | T_pair -> "T_pair" - | T_set -> "T_set" - | T_signature -> "T_signature" - | T_string -> "T_string" - | T_bytes -> "T_bytes" - | T_mutez -> "T_mutez" - | T_timestamp -> "T_timestamp" - | T_unit -> "T_unit" - | T_operation -> "T_operation" - | T_address -> "T_address" - | T_chain_id -> "T_chain_id" - | T_never -> "T_never" - | T_sapling_state -> "T_sapling_state" - | T_sapling_transaction_deprecated -> "T_sapling_transaction_deprecated" - | T_bls12_381_g1 -> "T_bls12_381_g1" - | T_bls12_381_g2 -> "T_bls12_381_g2" - | T_bls12_381_fr -> "T_bls12_381_fr" - | T_ticket -> "T_ticket" - | I_Hole -> "I_Hole" - | D_Hole -> "D_Hole" - | A_Int -> "A_Int" - | A_Nat -> "A_Nat" - | A_Timestamp -> "A_Timestamp" - | A_Mutez -> "A_Mutez" - | A_Key_hash -> "A_Key_hash" - | A_Key -> "A_Key" - | A_List -> "A_List" - | A_Set -> "A_Set" - | A_Map -> "A_Map" - | A_Lambda -> "A_Lambda" - -let pp fmtr prim = Format.fprintf fmtr "%s" (string_of_prim prim) - -type kind = Data_kind | Instr_kind | Type_kind | Keyword_kind | Annot_kind - -let kind (x : prim) = - match x with - | K_parameter | K_storage | K_code -> Keyword_kind - | D_Hole | D_False | D_Elt | D_Left | D_None | D_Pair | D_Right | D_Some - | D_True | D_Unit -> - Data_kind - | 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_CHAIN_ID - | 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_BIG_MAP | I_EMPTY_MAP | I_EMPTY_SET | I_EQ | I_EXEC | I_APPLY - | I_FAILWITH | I_GE | I_GET_MAP | I_GET_AND_UPDATE_MAP | 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_MAP | I_MAP_LIST | I_MEM_SET - | I_MEM_MAP | I_MUL | I_NEG | I_NEQ | I_NIL | I_NONE | I_NOT | I_NOW | I_OR - | I_PAIR | I_UNPAIR | I_PUSH | I_RIGHT | I_SIZE_SET | I_SIZE_MAP | I_SIZE_LIST - | I_SIZE_STRING | I_SIZE_BYTES | 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_SET | I_UPDATE_MAP | I_XOR | I_ITER_MAP - | I_ITER_LIST | I_ITER_SET | I_LOOP_LEFT | I_ADDRESS | I_CONTRACT | I_ISNAT - | I_CAST | I_RENAME | I_DIG | I_DUG | I_LEVEL | I_SELF_ADDRESS | I_NEVER - | I_SAPLING_EMPTY_STATE | I_SAPLING_VERIFY_UPDATE | I_VOTING_POWER - | I_TOTAL_VOTING_POWER | I_KECCAK | I_SHA3 | I_PAIRING_CHECK | I_TICKET - | I_READ_TICKET | I_SPLIT_TICKET | I_JOIN_TICKETS | I_Hole -> - Instr_kind - | 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 | T_chain_id | T_never | T_sapling_state - | T_sapling_transaction_deprecated | T_bls12_381_g1 | T_bls12_381_g2 - | T_bls12_381_fr | T_ticket -> - Type_kind - (* Holes in programs and data. *) - (* Annotations. *) - | A_Int | A_Nat | A_Timestamp | A_Mutez | A_Key_hash | A_Key | A_List | A_Set - | A_Map | A_Lambda -> - Annot_kind diff --git a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/monads.ml b/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/monads.ml deleted file mode 100644 index 47273406af50d8114e4e2464c2ac484b187f6f02..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/monads.ml +++ /dev/null @@ -1,83 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(* Widely used module types. *) - -module type S = sig - type 'a t - - val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t - - val return : 'a -> 'a t - - val run : 'a t -> 'a -end - -(* Signature of a state monad. *) -module type State_sig = sig - type state - - type key - - type value - - include S with type 'a t = state -> 'a * state - - val empty : unit -> state - - val set : key -> value -> unit t - - val get : key -> value option t - - val iter_list : ('a -> unit t) -> 'a list -> unit t -end - -module Make_state_monad (X : Stores.S) : - State_sig - with type state = X.state - and type key = X.key - and type value = X.value - and type 'a t = X.state -> 'a * X.state = struct - include X - - type 'a t = state -> 'a * state - - let ( >>= ) m f s = - let x, s = m s in - f x s - - let return x s = (x, s) - - let run m = fst (m (empty ())) - - let set k v s = ((), set k v s) - - let get k s = (get k s, s) - - let rec iter_list (f : 'a -> unit t) (l : 'a list) = - match l with - | [] -> return () - | elt :: tl -> f elt >>= fun () -> iter_list f tl -end diff --git a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/stores.ml b/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/stores.ml deleted file mode 100644 index dff87824d1b4e657629dd1a4f26071f1a6834094..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/stores.ml +++ /dev/null @@ -1,85 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(* Various implementations of Monads.Store_sig *) - -(* Signature of a persistent store. *) -module type S = sig - type state - - type key - - type value - - val empty : unit -> state - - val set : key -> value -> state -> state - - val get : key -> state -> value option - - val map : (value -> value) -> state -> state - - val to_string : state -> string -end - -module type Map_store_param_sig = sig - type key - - type value - - val key_to_string : key -> string - - val value_to_string : value -> string -end - -(* An implemention of [S] using maps. *) -module Map (M : Map.S) (V : Map_store_param_sig with type key = M.key) : - S with type state = V.value M.t and type key = M.key and type value = V.value = -struct - type state = V.value M.t - - type key = M.key - - type value = V.value - - let empty () = M.empty - - let set = M.add - - let get = M.find_opt - - let map = M.map - - let to_string s = - M.fold - (fun key node acc -> - Printf.sprintf - "%s\n%s |-> %s" - acc - (V.key_to_string key) - (V.value_to_string node)) - s - "" -end diff --git a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/test/dune b/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/test/dune deleted file mode 100644 index 4962b1c6fb1e497ccd278624c2bf10953c8c809e..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/test/dune +++ /dev/null @@ -1,29 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(executables - (names test_uf test_inference) - (libraries - octez-libs.micheline - tezos-micheline-rewriting - tezos-benchmark-type-inference-017-PtNairob - tezos-protocol-017-PtNairob.protocol - octez-libs.error-monad - octez-protocol-017-PtNairob-libs.client) - (link_flags - (:standard) - (:include %{workspace_root}/macos-link-flags.sexp)) - (flags - (:standard) - -open Tezos_micheline - -open Tezos_benchmark_type_inference_017_PtNairob)) - -(rule - (alias runtest) - (package tezos-benchmark-type-inference-017-PtNairob) - (action (run %{dep:./test_uf.exe}))) - -(rule - (alias runtest) - (package tezos-benchmark-type-inference-017-PtNairob) - (action (run %{dep:./test_inference.exe}))) diff --git a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml b/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml deleted file mode 100644 index 4b702dd05667a8ab593401e650ca5f4a203d962d..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/test/test_inference.ml +++ /dev/null @@ -1,615 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 Tezos_rewriting *) -open Mikhailsky - -let unopt x = match x with Some x -> x | None -> assert false - -let time f = - let now = Unix.gettimeofday () in - let res = f () in - let later = Unix.gettimeofday () in - (later -. now, res) - -let add_ii = Instructions.(add Mikhailsky.int_ty Mikhailsky.int_ty) - -let add_in = Instructions.(add Mikhailsky.int_ty Mikhailsky.nat_ty) - -let mul_ii = Instructions.(mul Mikhailsky.int_ty Mikhailsky.int_ty) - -let push_int = Instructions.push int_ty (Data.big_integer (Z.of_int 100)) - -let push_nat = Instructions.push nat_ty (Data.big_natural (Z.of_int 100)) - -module Test1 = struct - open Data - open Instructions - - let program = seq [add_ii; push bool_ty false_; dip instr_hole; dip swap] - - let timing, (bef, aft) = time @@ fun () -> Inference.infer program - - let _ = - Format.printf "Testing type inference\n" ; - Format.printf "EXPECTING SUCCESS\n" ; - Format.printf "Program\n" ; - Format.printf "%a\n" Mikhailsky.pp program ; - Format.printf "In %f seconds:\n" timing ; - Format.printf "bef: %a@." Type.Stack.pp bef ; - Format.printf "aft: %a@." Type.Stack.pp aft ; - print_newline () -end - -module Test2 = struct - open Instructions - - let program = seq [loop swap; and_] - - let () = - Format.printf "Testing type inference\n" ; - Format.printf "EXPECTING FAILURE\n" ; - Format.printf "Program: %a\n" Mikhailsky.pp program ; - let exception Test_failed in - try - ignore - ( time @@ fun () -> - ignore @@ Inference.infer program ; - raise Test_failed ) - with - | Inference.Ill_typed_script error -> - Format.printf "Error:\n" ; - Format.printf "%a\n" Inference.pp_inference_error error - | Test_failed -> Format.printf "No type error: Test failed!" - - let _ = print_newline () -end - -module Test3 = struct - open Instructions - - let program = - seq - [ - dip (seq [swap; dup]); - swap; - dip cdr; - loop (seq [dip instr_hole; cdr; loop instr_hole]); - car; - car; - push int_ty (Data.integer 10); - compare; - ] - - let _ = - Format.printf "Testing rewriting and type inference\n" ; - Format.printf "Source program: %a\n" Mikhailsky.pp program - - open Tezos_micheline_rewriting - - module Lang = - Micheline_with_hash_consing.Make - (Mikhailsky.Mikhailsky_signature) - (struct - let initial_size = None - end) - - module Path = Mikhailsky.Path - module Patt = Pattern.Make (Mikhailsky.Mikhailsky_signature) (Lang) (Path) - module Rewriter = - Rewrite.Make (Mikhailsky.Mikhailsky_signature) (Lang) (Path) (Patt) - - let timing, ((bef, aft), state) = - try time @@ fun () -> Inference.infer_with_state program - with Inference.Ill_typed_script error -> - let s = Mikhailsky.to_string program in - Format.printf - "Ill-typed script:%a\n%s\n" - Inference.pp_inference_error - error - s ; - Format.printf "Test failed\n" ; - exit 1 - - let () = - Format.printf "In %f seconds:\n" timing ; - Format.printf "bef: %a@." Type.Stack.pp bef ; - Format.printf "aft: %a@." Type.Stack.pp aft - - let () = - try - ignore - ((let open Inference in - let open M in - M.uf_lift Uf.UF.show >>= fun uf_state -> - Inference.M.repr_lift (fun s -> (Inference.Repr_store.to_string s, s)) - >>= fun repr_state -> - Printf.printf "uf_state:\n%s\n" uf_state ; - Printf.printf "repr_state:\n%s\n" repr_state ; - let path = - Path.(at_index 2 (at_index 0 (at_index 0 (at_index 3 root)))) - in - let subterm = Rewriter.get_subterm ~term:program ~path in - Format.printf - "subterm at path %s:\n%a\n" - (Path.to_string path) - Mikhailsky.pp - subterm ; - Inference.M.annot_instr_lift (Inference.Annot_instr_sm.get path) - >>= fun typ -> - (match typ with - | None -> assert false - | Some {bef; aft} -> - Inference.instantiate bef >>= fun bef -> - Inference.instantiate aft >>= fun aft -> - Format.printf "Type of subterm:\n" ; - Format.printf "bef: %a@." Type.Stack.pp bef ; - Format.printf "aft: %a@." Type.Stack.pp aft ; - return ()) - >>= fun () -> return ()) - state) - with Inference.Ill_typed_script error -> - let s = Mikhailsky.to_string program in - Format.printf - "Ill-typed script:\n%a\n%s\n" - Inference.pp_inference_error - error - s - - let _ = print_newline () -end - -module Test4 = struct - open Instructions - - let program = - seq - [ - empty_set; - push Type.(unopt (unparse_ty bool)) Data.true_; - push - Type.(unopt (unparse_ty (pair int int))) - Data.(pair (integer 0) (integer 0)); - update_set; - ] - - let timing, (bef, aft) = time @@ fun () -> Inference.infer program - - let _ = - Format.printf "Testing type inference\n" ; - Format.printf "EXPECTING SUCCESS\n" ; - Format.printf "Program\n" ; - Format.printf "%a\n" Mikhailsky.pp program ; - Format.printf "In %f seconds:\n" timing ; - Format.printf "bef: %a@." Type.Stack.pp bef ; - Format.printf "aft: %a@." Type.Stack.pp aft ; - print_newline () -end - -module Test5 = struct - open Instructions - - let unopt x = match x with Some x -> x | None -> assert false - - let program = - seq - [ - empty_map; - push Type.(unopt (unparse_ty (option (set int)))) Data.none; - push - Type.(unopt (unparse_ty (pair int int))) - Data.(pair (integer 0) (integer 0)); - update_map; - ] - - let timing, (bef, aft) = time @@ fun () -> Inference.infer program - - let _ = - Format.printf "Testing type inference\n" ; - Format.printf "EXPECTING SUCCESS\n" ; - Format.printf "Program\n" ; - Format.printf "%a\n" Mikhailsky.pp program ; - Format.printf "In %f seconds:\n" timing ; - Format.printf "bef: %a@." Type.Stack.pp bef ; - Format.printf "aft: %a@." Type.Stack.pp aft ; - print_newline () - - let program = - seq - [ - push - Type.(unopt (unparse_ty (map (pair int int) (set int)))) - Data.( - map - [ - map_elt - (pair (integer 0) (integer 1)) - (set [integer 42; integer 44]); - map_elt - (pair (integer 1) (integer 2)) - (set [integer 42; integer 48]); - ]); - ] - - let timing, (bef, aft) = time @@ fun () -> Inference.infer program - - let _ = - Format.printf "Testing type inference\n" ; - Format.printf "EXPECTING SUCCESS\n" ; - Format.printf "Program\n" ; - Format.printf "%a\n" Mikhailsky.pp program ; - Format.printf "In %f seconds:\n" timing ; - Format.printf "bef: %a@." Type.Stack.pp bef ; - Format.printf "aft: %a@." Type.Stack.pp aft ; - print_newline () -end - -module Test6 = struct - open Instructions - - (* We remove a chunk from a well-typed program to make it ill-typed, and - expect the type inference to fail *) - let program = - seq - [ - push int_ty (Data.integer 0); - push int_ty (Data.integer 100); - swap; - drop; - drop; - drop; - push unit_ty Data.unit; - push bool_ty Data.false_; - push unit_ty Data.unit; - push int_ty (Data.integer 4073851221413541140); - push string_ty (string "n"); - push string_ty (string "k"); - push int_ty (Data.integer 1391989767887046289); - (* push int_ty (integer 100); - * abs; - * drop; *) - dip (prim I_CONCAT [] []); - compare; - ] - - let () = - Format.printf "Testing type inference\n" ; - Format.printf "EXPECTING FAILURE\n" ; - Format.printf "Program: %a\n" Mikhailsky.pp program ; - let exception Test_failed in - try - ignore (Inference.infer program) ; - raise Test_failed - with - | Inference.Ill_typed_script error -> - Format.printf "Got error, as expected:\n" ; - Format.printf "%a@." Inference.pp_inference_error error - | Test_failed -> - Format.printf "No type error: Test failed!" ; - exit 1 -end - -module Test7 = struct - open Instructions - - let program = - seq - [ - push int_ty (Data.integer 42); - left; - push string_ty (Data.string "forty-two"); - right; - pair; - left; - ] - - let timing, (bef, aft) = time @@ fun () -> Inference.infer program - - let _ = - Format.printf "Testing type inference\n" ; - Format.printf "EXPECTING SUCCESS\n" ; - Format.printf "Program\n" ; - Format.printf "%a\n" Mikhailsky.pp program ; - Format.printf "In %f seconds:\n" timing ; - Format.printf "bef: %a@." Type.Stack.pp bef ; - Format.printf "aft: %a@." Type.Stack.pp aft ; - print_newline () -end - -module Test8 = struct - open Instructions - - let program = - seq - [ - hole; - add_ii; - push int_ty (Data.big_integer (Z.of_int 100)); - abs; - right; - dup; - push int_ty (Data.big_integer (Z.of_int 100)); - dip (loop_left hole); - push_int; - hole; - mul_ii; - hole; - loop_left left; - sha512; - push_int; - dup; - add_ii; - right; - swap; - hole; - drop; - compare; - mul_ii; - push_int; - ] - - let timing, (bef, aft) = time @@ fun () -> Inference.infer program - - let _ = - Format.printf "Testing type inference\n" ; - Format.printf "EXPECTING SUCCESS\n" ; - Format.printf "Program\n" ; - Format.printf "%a\n" Mikhailsky.pp program ; - Format.printf "In %f seconds:\n" timing ; - Format.printf "bef: %a@." Type.Stack.pp bef ; - Format.printf "aft: %a@." Type.Stack.pp aft ; - print_newline () -end - -module Test9 = struct - open Instructions - - let program = seq [car; if_none hole hole] - - let timing, (bef, aft) = time @@ fun () -> Inference.infer program - - let _ = - Format.printf "Testing type inference\n" ; - Format.printf "EXPECTING SUCCESS\n" ; - Format.printf "Program\n" ; - Format.printf "%a\n" Mikhailsky.pp program ; - Format.printf "In %f seconds:\n" timing ; - Format.printf "bef: %a@." Type.Stack.pp bef ; - Format.printf "aft: %a@." Type.Stack.pp aft ; - print_newline () -end - -module Test10 = struct - open Instructions - - let program = seq [hash_key] - - let timing, (bef, aft) = time @@ fun () -> Inference.infer program - - let _ = - Format.printf "Testing type inference\n" ; - Format.printf "EXPECTING SUCCESS\n" ; - Format.printf "Program\n" ; - Format.printf "%a\n" Mikhailsky.pp program ; - Format.printf "In %f seconds:\n" timing ; - Format.printf "bef: %a@." Type.Stack.pp bef ; - Format.printf "aft: %a@." Type.Stack.pp aft ; - print_newline () -end - -module Test11 = struct - open Instructions - - let program = - seq [lambda [dup; car; dip cdr; add_in]; push_int; apply; push_nat; exec] - - let timing, (bef, aft) = time @@ fun () -> Inference.infer program - - let _ = - Format.printf "Testing type inference\n" ; - Format.printf "EXPECTING SUCCESS\n" ; - Format.printf "Program\n" ; - Format.printf "%a\n" Mikhailsky.pp program ; - Format.printf "In %f seconds:\n" timing ; - Format.printf "bef: %a@." Type.Stack.pp bef ; - Format.printf "aft: %a@." Type.Stack.pp aft ; - print_newline () -end - -module Test12 = struct - open Instructions - - let program = seq [dup; dup; if_none hole (seq [drop]); dup; compare] - - let timing, (bef, aft) = time @@ fun () -> Inference.infer program - - let _ = - Format.printf "Testing type inference\n" ; - Format.printf "EXPECTING SUCCESS\n" ; - Format.printf "Program\n" ; - Format.printf "%a\n" Mikhailsky.pp program ; - Format.printf "In %f seconds:\n" timing ; - Format.printf "bef: %a@." Type.Stack.pp bef ; - Format.printf "aft: %a@." Type.Stack.pp aft ; - print_newline () -end - -module Test13 = struct - open Instructions - - let program = - seq [push Type.(unparse_ty_exn (lambda int int)) (Data.lambda [])] - - let timing, (bef, aft) = time @@ fun () -> Inference.infer program - - let _ = - Format.printf "Testing type inference\n" ; - Format.printf "EXPECTING SUCCESS\n" ; - Format.printf "Program\n" ; - Format.printf "%a\n" Mikhailsky.pp program ; - Format.printf "In %f seconds:\n" timing ; - Format.printf "bef: %a@." Type.Stack.pp bef ; - Format.printf "aft: %a@." Type.Stack.pp aft ; - print_newline () -end - -module Test14 = struct - open Instructions - - let program = seq [nil; push_int; cons] - - let timing, (bef, aft) = time @@ fun () -> Inference.infer program - - let _ = - Format.printf "Testing type inference\n" ; - Format.printf "EXPECTING SUCCESS\n" ; - Format.printf "Program\n" ; - Format.printf "%a\n" Mikhailsky.pp program ; - Format.printf "In %f seconds:\n" timing ; - Format.printf "bef: %a@." Type.Stack.pp bef ; - Format.printf "aft: %a@." Type.Stack.pp aft ; - print_newline () -end - -module Test15 = struct - open Instructions - - let program = seq [empty_set; size_set; empty_map; size_map; nil; size_list] - - let timing, (bef, aft) = time @@ fun () -> Inference.infer program - - let _ = - Format.printf "Testing type inference\n" ; - Format.printf "EXPECTING SUCCESS\n" ; - Format.printf "Program\n" ; - Format.printf "%a\n" Mikhailsky.pp program ; - Format.printf "In %f seconds:\n" timing ; - Format.printf "bef: %a@." Type.Stack.pp bef ; - Format.printf "aft: %a@." Type.Stack.pp aft ; - print_newline () -end - -module Test16 = struct - open Instructions - - let program = - seq - [ - empty_set; - push bool_ty Data.true_; - push_int; - update_set; - iter_set [dup; add_ii; add_ii]; - ] - - let timing, (bef, aft) = time @@ fun () -> Inference.infer program - - let _ = - Format.printf "Testing type inference\n" ; - Format.printf "EXPECTING SUCCESS\n" ; - Format.printf "Program\n" ; - Format.printf "%a\n" Mikhailsky.pp program ; - Format.printf "In %f seconds:\n" timing ; - Format.printf "bef: %a@." Type.Stack.pp bef ; - Format.printf "aft: %a@." Type.Stack.pp aft ; - print_newline () -end - -module Test17 = struct - open Instructions - - let program = - seq - [ - empty_map; - push (option_ty (list_ty bool_ty)) Data.(some (list [false_; true_])); - push_int; - update_map; - map_map - [ - cdr; - map_list - [ - if_ - (seq [push bool_ty Data.false_]) - (seq [push bool_ty Data.true_]); - ]; - ]; - ] - - let timing, (bef, aft) = time @@ fun () -> Inference.infer program - - let _ = - Format.printf "Testing type inference\n" ; - Format.printf "EXPECTING SUCCESS\n" ; - Format.printf "Program\n" ; - Format.printf "%a\n" Mikhailsky.pp program ; - Format.printf "In %f seconds:\n" timing ; - Format.printf "bef: %a@." Type.Stack.pp bef ; - Format.printf "aft: %a@." Type.Stack.pp aft ; - print_newline () -end - -module Test18 = struct - open Instructions - - let program = - seq - [ - empty_map; - push (option_ty (list_ty bool_ty)) Data.(some (list [false_; true_])); - push_int; - update_map; - map_map - [ - cdr; - map_list - [ - if_ - (seq [push bool_ty Data.false_]) - (seq [push bool_ty Data.true_]); - ]; - ]; - dup; - dip push_int; - push_int; - mem_map; - if_ - (seq [get_map]) - (seq [drop; drop; push (option_ty (list_ty bool_ty)) Data.none]); - ] - - let timing, (bef, aft) = time @@ fun () -> Inference.infer program - - let _ = - Format.printf "Testing type inference\n" ; - Format.printf "EXPECTING SUCCESS\n" ; - Format.printf "Program\n" ; - Format.printf "%a\n" Mikhailsky.pp program ; - Format.printf "In %f seconds:\n" timing ; - Format.printf "bef: %a@." Type.Stack.pp bef ; - Format.printf "aft: %a@." Type.Stack.pp aft ; - print_newline () -end diff --git a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/test/test_uf.ml b/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/test/test_uf.ml deleted file mode 100644 index 84fdd856e9ba514520c07c82667f22fd39f34fc5..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/test/test_uf.ml +++ /dev/null @@ -1,63 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 _ = - print_newline () ; - Printf.printf "Testing union-find algorithm\n" - -module UF = Uf.UF - -let test = - let open UF.M in - UF.add 0 >>= fun () -> - UF.add 1 >>= fun () -> - UF.add 2 >>= fun () -> - UF.add 3 >>= fun () -> - UF.add 4 >>= fun () -> - UF.find 0 >>= fun v0_repr -> - UF.find 1 >>= fun v1_repr -> - assert (v0_repr <> v1_repr) ; - UF.union 0 1 >>= fun _ -> - UF.find 0 >>= fun v0_repr -> - UF.find 1 >>= fun v1_repr -> - UF.find 2 >>= fun v2_repr -> - assert (v0_repr = v1_repr) ; - assert (v0_repr <> v2_repr) ; - UF.union 2 3 >>= fun _ -> - UF.union 0 3 >>= fun _ -> - UF.find 1 >>= fun v1_repr -> - UF.find 2 >>= fun v2_repr -> - UF.find 3 >>= fun v3_repr -> - UF.find 4 >>= fun v4_repr -> - assert (v1_repr = v2_repr) ; - UF.union 4 4 >>= fun _ -> - assert (v3_repr <> v4_repr) ; - UF.show >>= fun s -> - Printf.printf "UF state:%s\n" s ; - return () - -let () = UF.M.run test - -let _ = Printf.printf "Success.\n" diff --git a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/type.ml b/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/type.ml deleted file mode 100644 index bc8d164c6c5cbaa382e8730a088abec0278a3539..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/type.ml +++ /dev/null @@ -1,200 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(* Michelson types. *) - -module Base = struct - type comparable_tag = Comparable | Maybe_not_comparable - - type t = t_node Hashcons.hash_consed - - and t_node = - | Unit_t - | Var_t of int - | Int_t - | Nat_t - | Bool_t - | String_t - | Bytes_t - | Key_hash_t - | Timestamp_t - | Mutez_t - | Key_t - | Option_t of t - | Pair_t of t * t - | Or_t of t * t - | List_t of t - | Set_t of t - | Map_t of t * t - | Lambda_t of t * t - - module Hashed = struct - type t = t_node - - let equal (t1 : t) (t2 : t) = - match (t1, t2) with - | Var_t v1, Var_t v2 -> v1 = v2 - | Unit_t, Unit_t - | Int_t, Int_t - | Nat_t, Nat_t - | Bool_t, Bool_t - | String_t, String_t - | Bytes_t, Bytes_t - | Key_hash_t, Key_hash_t - | Timestamp_t, Timestamp_t - | Mutez_t, Mutez_t - | Key_t, Key_t -> - true - | Option_t ty1, Option_t ty2 -> ty1.tag = ty2.tag - | Pair_t (l1, r1), Pair_t (l2, r2) -> l1.tag = l2.tag && r1.tag = r2.tag - | Or_t (l1, r1), Or_t (l2, r2) -> l1.tag = l2.tag && r1.tag = r2.tag - | List_t ty1, List_t ty2 -> ty1.tag = ty2.tag - | Set_t ty1, Set_t ty2 -> ty1.tag = ty2.tag - | Map_t (kty1, vty1), Map_t (kty2, vty2) -> - kty1.tag = kty2.tag && vty1.tag = vty2.tag - | Lambda_t (dom1, range1), Lambda_t (dom2, range2) -> - dom1.tag = dom2.tag && range1.tag = range2.tag - | _ -> false - - let hash (t : t) = Hashtbl.hash t - end - - module Table = Hashcons.Make (Hashed) - - let table = Table.create 101 - - let rec pp fmtr x = - match x.Hashcons.node with - | Unit_t -> Format.pp_print_string fmtr "unit" - | Var_t v -> Format.fprintf fmtr "%d" v - | Int_t -> Format.pp_print_string fmtr "int" - | Nat_t -> Format.pp_print_string fmtr "nat" - | Bool_t -> Format.pp_print_string fmtr "bool" - | String_t -> Format.pp_print_string fmtr "string" - | Bytes_t -> Format.pp_print_string fmtr "bytes" - | Key_hash_t -> Format.pp_print_string fmtr "key_hash" - | Timestamp_t -> Format.pp_print_string fmtr "timestamp" - | Mutez_t -> Format.pp_print_string fmtr "mutez" - | Key_t -> Format.pp_print_string fmtr "key" - | Option_t ty -> Format.fprintf fmtr "(option %a)" pp ty - | List_t ty -> Format.fprintf fmtr "(list %a)" pp ty - | Pair_t (lty, rty) -> Format.fprintf fmtr "(pair %a %a)" pp lty pp rty - | Or_t (lty, rty) -> Format.fprintf fmtr "(or %a %a)" pp lty pp rty - | Set_t ty -> Format.fprintf fmtr "(set %a)" pp ty - | Map_t (kty, vty) -> Format.fprintf fmtr "(map %a %a)" pp kty pp vty - | Lambda_t (dom, range) -> - Format.fprintf fmtr "(lambda %a %a)" pp dom pp range - - let rec vars x acc = - match x.Hashcons.node with - | Unit_t | Int_t | Nat_t | Bool_t | String_t | Bytes_t | Key_hash_t - | Timestamp_t | Mutez_t | Key_t -> - acc - | Var_t v -> v :: acc - | Option_t ty | List_t ty | Set_t ty -> vars ty acc - | Pair_t (lty, rty) | Or_t (lty, rty) -> vars lty (vars rty acc) - | Map_t (kty, vty) -> vars kty (vars vty acc) - | Lambda_t (dom, range) -> vars dom (vars range acc) - - let vars x = vars x [] -end - -module Stack = struct - type t = t_node Hashcons.hash_consed - - and t_node = Empty_t | Stack_var_t of int | Item_t of Base.t * t - - module Hashed = struct - type t = t_node - - let equal (t1 : t) (t2 : t) = - match (t1, t2) with - | Empty_t, Empty_t -> true - | Stack_var_t v1, Stack_var_t v2 -> v1 = v2 - | Item_t (h1, tl1), Item_t (h2, tl2) -> h1 == h2 && tl1 == tl2 - | _ -> false - - let hash (t : t) = Hashtbl.hash t - end - - module Table = Hashcons.Make (Hashed) - - let table = Table.create 101 - - let rec pp fmtr x = - match x.Hashcons.node with - | Empty_t -> Format.pp_print_string fmtr "[]" - | Stack_var_t v -> Format.fprintf fmtr "<%d>" v - | Item_t (head, tail) -> Format.fprintf fmtr "%a :: %a" Base.pp head pp tail - - let rec vars x = - match x.Hashcons.node with - | Empty_t -> None - | Stack_var_t v -> Some v - | Item_t (_head, tail) -> vars tail -end - -let unit = Base.Table.hashcons Base.table Unit_t - -let var x = Base.Table.hashcons Base.table (Var_t x) - -let int = Base.Table.hashcons Base.table Int_t - -let nat = Base.Table.hashcons Base.table Nat_t - -let bool = Base.Table.hashcons Base.table Bool_t - -let string = Base.Table.hashcons Base.table String_t - -let bytes = Base.Table.hashcons Base.table Bytes_t - -let key_hash = Base.Table.hashcons Base.table Key_hash_t - -let timestamp = Base.Table.hashcons Base.table Timestamp_t - -let mutez = Base.Table.hashcons Base.table Mutez_t - -let key = Base.Table.hashcons Base.table Key_t - -let option ty = Base.Table.hashcons Base.table (Option_t ty) - -let pair lty rty = Base.Table.hashcons Base.table (Pair_t (lty, rty)) - -let or_ lty rty = Base.Table.hashcons Base.table (Or_t (lty, rty)) - -let list ty = Base.Table.hashcons Base.table (List_t ty) - -let set ty = Base.Table.hashcons Base.table (Set_t ty) - -let map kty vty = Base.Table.hashcons Base.table (Map_t (kty, vty)) - -let lambda dom range = Base.Table.hashcons Base.table (Lambda_t (dom, range)) - -(* Stack smart constructors *) -let empty = Stack.Table.hashcons Stack.table Empty_t - -let stack_var x = Stack.Table.hashcons Stack.table (Stack_var_t x) - -let item head tail = Stack.Table.hashcons Stack.table (Item_t (head, tail)) diff --git a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/type.mli b/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/type.mli deleted file mode 100644 index bdc806590b25098ef70df154b0e97df27af79375..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/type.mli +++ /dev/null @@ -1,111 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Michelson types, hash-consed. *) - -(** Base types *) -module Base : sig - type comparable_tag = Comparable | Maybe_not_comparable - - type t = t_node Hashcons.hash_consed - - and t_node = private - | Unit_t - | Var_t of int - | Int_t - | Nat_t - | Bool_t - | String_t - | Bytes_t - | Key_hash_t - | Timestamp_t - | Mutez_t - | Key_t - | Option_t of t - | Pair_t of t * t - | Or_t of t * t - | List_t of t - | Set_t of t - | Map_t of t * t - | Lambda_t of t * t - - val pp : Format.formatter -> t -> unit - - val vars : t -> int list -end - -(** Stack types *) -module Stack : sig - type t = t_node Hashcons.hash_consed - - and t_node = private Empty_t | Stack_var_t of int | Item_t of Base.t * t - - val pp : Format.formatter -> t -> unit - - val vars : t -> int option -end - -(** Smart constructors *) -val unit : Base.t - -val var : int -> Base.t - -val int : Base.t - -val nat : Base.t - -val bool : Base.t - -val string : Base.t - -val bytes : Base.t - -val key_hash : Base.t - -val timestamp : Base.t - -val mutez : Base.t - -val key : Base.t - -val option : Base.t -> Base.t - -val pair : Base.t -> Base.t -> Base.t - -val or_ : Base.t -> Base.t -> Base.t - -val list : Base.t -> Base.t - -val set : Base.t -> Base.t - -val map : Base.t -> Base.t -> Base.t - -val lambda : Base.t -> Base.t -> Base.t - -val empty : Stack.t - -val stack_var : int -> Stack.t - -val item : Base.t -> Stack.t -> Stack.t diff --git a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/uf.ml b/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/uf.ml deleted file mode 100644 index f14a166939a772fbb3dd1baa95ccfb3ae9e61cd8..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/lib_benchmark_type_inference/uf.ml +++ /dev/null @@ -1,99 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(* ------------------------------------------------------------------------- *) -(* Union find parameterized over a persistent store. *) - -module type S = sig - module M : Monads.State_sig - - type key = int - - val add : key -> unit M.t - - val find : key -> key M.t - - val union : key -> key -> key M.t - - val show : string M.t -end - -module UF : S = struct - type node = T of {rank : int} | Ptr of key - - and key = int - - module S = - Stores.Map - (Int_map) - (struct - type key = int - - type value = node - - let key_to_string = string_of_int - - let value_to_string (x : value) = - match x with - | T {rank} -> Printf.sprintf "[%d]" rank - | Ptr k -> Printf.sprintf "ptr(%d)" k - end) - - module M = Monads.Make_state_monad (S) - - let add (k : key) = - let open M in - set k (T {rank = 1}) - - let rec get_root (k : key) (acc : key list) = - let open M in - get k >>= function - | None -> - let msg = Printf.sprintf "UF.get_root: invalid key %d" k in - Stdlib.failwith msg - | Some (T {rank}) -> - let ptr_to_root = Ptr k in - iter_list (fun key -> set key ptr_to_root) acc >>= fun () -> - return (k, rank) - | Some (Ptr k') -> get_root k' (k :: acc) - - let find (k : key) = - let open M in - get_root k [] >>= fun (res, _) -> return res - - let union k1 k2 = - let open M in - get_root k1 [] >>= fun (k1, rank1) -> - get_root k2 [] >>= fun (k2, rank2) -> - if k1 = k2 then return k1 - else if rank1 < rank2 then set k1 (Ptr k2) >>= fun () -> return k2 - else if rank1 > rank2 then set k2 (Ptr k1) >>= fun () -> return k1 - else - let new_root = T {rank = rank1 + 1} in - set k2 (Ptr k1) >>= fun () -> - set k1 new_root >>= fun () -> return k1 - - let show s = (S.to_string s, s) -end diff --git a/src/proto_017_PtNairob/lib_benchmark/micheline_sampler.ml b/src/proto_017_PtNairob/lib_benchmark/micheline_sampler.ml deleted file mode 100644 index 1e4778f856f0fafb2f37645cbec83c549304f183..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/micheline_sampler.ml +++ /dev/null @@ -1,110 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Marigold *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Micheline sampling. *) - -type width_function = depth:int -> int Base_samplers.sampler - -(** [Base_samplers] specifies samplers for leaves, primitives and annotations. *) -module type Base_samplers = sig - (** The type of primitives. *) - type prim - - val sample_prim : prim Base_samplers.sampler - - val sample_annots : string list Base_samplers.sampler - - val sample_string : string Base_samplers.sampler - - val sample_bytes : Bytes.t Base_samplers.sampler - - val sample_z : Z.t Base_samplers.sampler - - val width_function : width_function -end - -module type S = sig - type prim - - val sample : (int, prim) Micheline.node Base_samplers.sampler -end - -type node_kind = Int_node | String_node | Bytes_node | Seq_node | Prim_node - -(* The distribution can be skewed towards non-leaf nodes by repeating their - relevant kind in the array below. *) -let all_kinds = [|Int_node; String_node; Bytes_node; Seq_node; Prim_node|] - -let sample_kind : node_kind Base_samplers.sampler = - fun rng_state -> - let i = Random.State.int rng_state (Array.length all_kinds) in - all_kinds.(i) - -let reasonable_width_function ~depth rng_state = - (* Entirely ad-hoc *) - Base_samplers.( - sample_in_interval - ~range:{min = 0; max = 20 / (Bits.numbits depth + 1)} - rng_state) - -module Make (P : Base_samplers) : S with type prim = P.prim = struct - type prim = P.prim - - let sample (w : width_function) rng_state = - let rec sample depth rng_state k = - match sample_kind rng_state with - | Int_node -> k (Micheline.Int (0, P.sample_z rng_state)) - | String_node -> k (Micheline.String (0, P.sample_string rng_state)) - | Bytes_node -> k (Micheline.Bytes (0, P.sample_bytes rng_state)) - | Seq_node -> - let width = w ~depth rng_state in - sample_list - depth - width - [] - (fun terms -> k (Micheline.Seq (0, terms))) - rng_state - | Prim_node -> - let prim = P.sample_prim rng_state in - let annots = P.sample_annots rng_state in - let width = w ~depth rng_state in - sample_list - depth - width - [] - (fun terms -> k (Micheline.Prim (0, prim, terms, annots))) - rng_state - and sample_list depth width acc k rng_state = - if width < 0 then invalid_arg "sample_list: negative width" - else if width = 0 then k (List.rev acc) - else - sample (depth + 1) rng_state (fun x -> - sample_list depth (width - 1) (x :: acc) k rng_state) - in - sample 0 rng_state (fun x -> x) - - let sample rng_state = sample P.width_function rng_state -end diff --git a/src/proto_017_PtNairob/lib_benchmark/micheline_sampler.mli b/src/proto_017_PtNairob/lib_benchmark/micheline_sampler.mli deleted file mode 100644 index 97e3d4ec1e1273c5f3690d93d6318b6d19341119..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/micheline_sampler.mli +++ /dev/null @@ -1,70 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Marigold *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Micheline sampling. *) - -(** A [width_function] specifies the distribution of node degree as a function - of [depth]. A [width_function] {e must} be supported by the nonnegative - integers. - - Note that picking a [width_function] which doesn't converge fast enough to - the singular distribution on 0 could yield very large terms. *) -type width_function = depth:int -> int Base_samplers.sampler - -(** [reasonable_width_function] is a width function which works well - empirically. *) -val reasonable_width_function : width_function - -(** [Base_samplers] specifies samplers for leaves, primitives and annotations. *) -module type Base_samplers = sig - (** The type of primitives. *) - type prim - - val sample_prim : prim Base_samplers.sampler - - val sample_annots : string list Base_samplers.sampler - - val sample_string : string Base_samplers.sampler - - val sample_bytes : Bytes.t Base_samplers.sampler - - val sample_z : Z.t Base_samplers.sampler - - val width_function : width_function -end - -(** Applying the [Make] functor below yields a module with the following - type. *) -module type S = sig - type prim - - (** [sample w] is a Micheline sampler for the prescribed primitive - type. The sampler uses the provided width function [w]. *) - val sample : (int, prim) Micheline.node Base_samplers.sampler -end - -(** [Make] instantiates a micheline sampler. *) -module Make (P : Base_samplers) : S with type prim = P.prim diff --git a/src/proto_017_PtNairob/lib_benchmark/michelson_mcmc_samplers.ml b/src/proto_017_PtNairob/lib_benchmark/michelson_mcmc_samplers.ml deleted file mode 100644 index a5b66c0f53afcd95e260889a9ef43d0b66504b78..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/michelson_mcmc_samplers.ml +++ /dev/null @@ -1,339 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** MCMC-based Michelson data and code samplers. *) - -open Protocol -open Stats - -type michelson_code = { - term : Script_repr.expr; - bef : Script_repr.expr list; - aft : Script_repr.expr list; -} - -type michelson_data = {term : Script_repr.expr; typ : Script_repr.expr} - -type michelson_sample = Code of michelson_code | Data of michelson_data - -let michelson_sample_list_encoding = - let open Data_encoding in - let e = Script_repr.expr_encoding in - list - @@ union - [ - case - ~title:"Code" - (Tag 0) - (tup3 e (list e) (list e)) - (function - | Code {term; bef; aft} -> Some (term, bef, aft) | _ -> None) - (fun (term, bef, aft) -> Code {term; bef; aft}); - case - ~title:"Data" - (Tag 1) - (tup2 e e) - (function Data {term; typ} -> Some (term, typ) | _ -> None) - (fun (term, typ) -> Data {term; typ}); - ] - -let save ~filename ~terms = - let str = - match - Data_encoding.Binary.to_string michelson_sample_list_encoding terms - with - | Error err -> - Format.eprintf - "Michelson_mcmc_samplers.save: encoding failed (%a); exiting@." - Data_encoding.Binary.pp_write_error - err ; - exit 1 - | Ok res -> res - in - try Lwt_main.run @@ Tezos_stdlib_unix.Lwt_utils_unix.create_file filename str - with exn -> - Format.eprintf - "Michelson_mcmc_samplers.save: create_file %s failed (%s); exiting@." - filename - (Printexc.to_string exn) ; - exit 1 - -let load ~filename = - let open TzPervasives in - let string = - try Lwt_main.run @@ Tezos_stdlib_unix.Lwt_utils_unix.read_file filename - with exn -> - Format.eprintf - "Michelson_mcmc_samplers.load: read_file %s failed (%s); exiting@." - filename - (Printexc.to_string exn) ; - exit 1 - in - let bytes = Bytes.of_string string in - match Data_encoding.Binary.of_bytes michelson_sample_list_encoding bytes with - | Ok result -> result - | Error err -> - Format.eprintf - "Michelson_mcmc_samplers.load: decoding %s failed (%a); exiting@." - filename - Data_encoding.Binary.pp_read_error - err ; - exit 1 - -(* Helpers *) - -let base_type_to_michelson_type (typ : Type.Base.t) = - let typ = Mikhailsky.map_var (fun _ -> Mikhailsky.unit_ty) typ in - Mikhailsky.to_michelson typ - -module type Sampler_parameters_sig = sig - val initial : State_space.t - - val energy : State_space.t -> float - - val rules : Rules.rule_set list - - val infer : Mikhailsky.node -> Inference.state - - val verbosity : [`Silent | `Progress | `Trace] -end - -(* The Markov chain in state [state] *) -type mc_state = { - state : State_space.t; - jump : State_space.t Fin.Float.prb Lazy.t; -} - -module State_hashtbl = Hashtbl.Make (State_space) - -(** Generic MCMC michelson sampler (can be used for code and data) *) -module Make_generic (P : Sampler_parameters_sig) = struct - let uniform (l : State_space.t list) : State_space.t Fin.Float.prb = - match l with - | [] -> - (* This can only happen is the MCMC was driven to a coffin state, - which means that it's not reversible (this is a bug) *) - assert false - | _ -> - let arr = Array.of_list l in - let emp = Emp.of_raw_data arr in - Fin.Float.counts_of_empirical (module State_hashtbl) emp - |> Fin.Float.normalize - - let unrecoverable_failure err current result = - Format.eprintf "Error when typechecking term:@." ; - Format.eprintf "%a@." Inference.pp_inference_error err ; - Format.eprintf "Original state: @[%a@]@." State_space.pp current ; - Format.eprintf "Erroneous term: %a@." Mikhailsky.pp result ; - Stdlib.failwith "in sampler.ml: unrecoverable failure." - - let of_state : State_space.t -> mc_state = - fun state -> - { - state; - jump = - Lazy.from_fun (fun () -> - let current = state in - let rewriting_options = Rules.rewriting current P.rules in - let term = current.term in - let rewritings = - List.fold_left - (fun rewritings (path, replacement) -> - let result = Kernel.Rewriter.subst ~term ~path ~replacement in - let typing = - Lazy.from_fun (fun () -> - try P.infer result - with Inference.Ill_typed_script err -> - unrecoverable_failure err current result) - in - {State_space.typing; term = result} :: rewritings) - [] - rewriting_options - in - uniform rewritings); - } - - module MH_params : Mh.MH_parameters with type t = mc_state = struct - type t = mc_state - - let pp fmtr {state; jump = _} = State_space.pp fmtr state - - let trace state = - match P.verbosity with - | `Silent | `Progress -> () - | `Trace -> - Format.eprintf "@." ; - Format.eprintf "%a" State_space.pp state ; - Format.eprintf "energy:@." ; - Format.eprintf "%f:@." (P.energy state) - - let proposal_log_density s1 s2 = - let jump = Lazy.force s1.jump in - let p = try Fin.Float.eval_prb jump s2.state with Not_found -> 0.0 in - Log_space.of_float p - - let proposal mcmc_state rng_state = - trace mcmc_state.state ; - let dist = Lazy.force mcmc_state.jump in - let next = Fin.Float.sample (Fin.Float.as_measure dist) rng_state in - of_state next - - let log_weight state = Log_space.unsafe_cast (-.P.energy state.state) - end - - module Sampler = Mh.Make (MH_params) - - let generator ~burn_in = - P.(Sampler.mcmc ~verbosity ~initial:(of_state initial) ~burn_in) -end - -module Make_code_sampler - (Michelson_base : Michelson_samplers_base.S) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) (X : sig - val rng_state : Random.State.t - - val target_size : int - - val verbosity : [`Silent | `Progress | `Trace] - end) = -struct - module Autocomp = Autocomp.Make (Michelson_base) (Crypto_samplers) - - module MCMC = Make_generic (struct - let initial = - let term = Mikhailsky.Instructions.hole in - let typing = Lazy.from_val @@ snd (Inference.infer_with_state term) in - {State_space.term; typing} - - let energy state = - let stats = State_space.statistics state in - let size_deficit = - abs_float - (float_of_int X.target_size -. float_of_int stats.State_space.size) - in - let holes_proportion = float stats.holes /. float stats.size in - let holes_deficit = - (* we want at least 1% of holes, above is ok *) - if holes_proportion < 0.01 then - (0.01 -. holes_proportion) *. size_deficit - else 0.0 - in - size_deficit +. holes_deficit - - let rules = Rules.Instruction.rules - - let infer term = snd (Inference.infer_with_state term) - - let verbosity = X.verbosity - end) - - let to_michelson {state = ({typing; term} : State_space.t); jump = _} = - let typing = Lazy.force typing in - let node, (bef, aft), state = - Autocomp.complete_code typing term X.rng_state - in - let node = - Micheline.strip_locations @@ Mikhailsky_to_michelson.convert node state - in - { - term = node; - bef = Type_helpers.stack_type_to_michelson_type_list bef; - aft = Type_helpers.stack_type_to_michelson_type_list aft; - } - - let generator ~burn_in = - Gen.map (MCMC.generator ~burn_in) @@ fun after_burn_in -> - Gen.map after_burn_in to_michelson -end - -module Make_data_sampler - (Michelson_base : Michelson_samplers_base.S) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) (X : sig - val rng_state : Random.State.t - - val target_size : int - - val verbosity : [`Silent | `Progress | `Trace] - end) = -struct - module Autocomp = Autocomp.Make (Michelson_base) (Crypto_samplers) - module Rewrite_rules = - Rules.Data_rewrite_leaves (Michelson_base) (Crypto_samplers) - - module MCMC = Make_generic (struct - let initial = - let term = Mikhailsky.Data.hole in - let typing = - Lazy.from_val @@ snd (Inference.infer_data_with_state term) - in - {State_space.term; typing} - - let energy state = - let stats = State_space.statistics state in - let size_deficit = - abs_float - (float_of_int X.target_size -. float_of_int stats.State_space.size) - in - let holes_proportion = - float_of_int stats.holes /. float_of_int stats.size - in - let holes_deficit = - (* we want at least 10% of holes, above is ok *) - if holes_proportion < 0.5 then (0.5 -. holes_proportion) *. size_deficit - else 0.0 - in - let depth_deficit = - abs_float - ((0.1 *. float_of_int X.target_size) -. float_of_int stats.depth) - in - size_deficit +. holes_deficit +. depth_deficit - - let rules = Rewrite_rules.rules X.rng_state - - let infer term = snd (Inference.infer_data_with_state term) - - let verbosity = X.verbosity - end) - - let to_michelson {state = ({typing; term} : State_space.t); jump = _} = - let typing = Lazy.force typing in - let node, _ = Autocomp.complete_data typing term X.rng_state in - let typ, state = - try Inference.infer_data_with_state node - with _ -> - Format.eprintf "Bug found!@." ; - Format.eprintf "Ill-typed autocompletion. Resulting term:@." ; - Format.eprintf "%a@." Mikhailsky.pp node ; - Stdlib.failwith "in generators.ml: unrecoverable failure" - in - let node = - Micheline.strip_locations @@ Mikhailsky_to_michelson.convert node state - in - {term = node; typ = base_type_to_michelson_type typ} - - let generator ~burn_in = - Gen.map (MCMC.generator ~burn_in) @@ fun after_burn_in -> - Gen.map after_burn_in to_michelson -end diff --git a/src/proto_017_PtNairob/lib_benchmark/michelson_mcmc_samplers.mli b/src/proto_017_PtNairob/lib_benchmark/michelson_mcmc_samplers.mli deleted file mode 100644 index bd67d13e3c165f1a7261a8074c71525c0ca74e24..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/michelson_mcmc_samplers.mli +++ /dev/null @@ -1,115 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** MCMC-based Michelson data and code samplers. *) - -open Protocol - -(** MCMC samplers can either produce data or code. Note that the samplers - natively produce data and code in Micheline (ie untyped) form. *) - -type michelson_code = { - term : Script_repr.expr; - (** [term] is a typeable Michelson program in Micheline form. *) - bef : Script_repr.expr list; - (** [bef] is an input stack type for which [term] is a well-typed script. *) - aft : Script_repr.expr list; - (** [aft] is the stack type corresponding to the execution of [term] - on a stack of type [bef]. *) -} - -type michelson_data = { - term : Script_repr.expr; - (** [term] is a typeable Michelson data in Micheline form. *) - typ : Script_repr.expr; (** [typ] is the type of [term]. *) -} - -(** A [michelson_sample] is either a code sample or a data sample. *) -type michelson_sample = Code of michelson_code | Data of michelson_data - -(** Encoding used for saving or loading data. *) -val michelson_sample_list_encoding : michelson_sample list Data_encoding.t - -(** Saving a list of samples to a file. - Exits with code 1 if an error arises during encoding or file manipulation. *) -val save : filename:string -> terms:michelson_sample list -> unit - -(** Loading a list of samples from a file. - Exits with code 1 if an error arises during decoding or file manipulation. *) -val load : filename:string -> michelson_sample list - -(** [Make_code_sampler] produces a sampler for well-typed Michelson code. - The parameters of the functor are: - - a module [Michelson_base] implementing samplers for basic values - - a module [Crypto_samplers] implementing samplers for pk/pkh/sk triplets - - a module [X] containing some parameters to the Markov chain sampler: - - [rng_state] is the mutable state that will be used during sampling - - [target_size] specifies the size, in terms of Micheline nodes, of the - terms that the sampler should try to produce - - [verbosity] specifies how much information should be written on stdout - during the sampling process. - - The outcome is a [michelson_code] [generator]. The [burn_in] parameter - specifies how much samples should be thrown away before starting to - produce sample (this is used to let the underlying Markov chain reach - its stationary distribution - the value should be commensurate with - the [target_size]. - *) -module Make_code_sampler : functor - (Michelson_base : Michelson_samplers_base.S) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) - (X : sig - val rng_state : Random.State.t - - val target_size : int - - val verbosity : [`Progress | `Silent | `Trace] - end) - -> sig - (** [generator ~burn_in rng_state] performs a burn-in phase consisting of sampling [burn_in] times, - throwing the results away and returns a michelson term sampler. The goal of burn-in is - to drive the underlying Markov chain to its stationary distribution, ie to sample - terms around the specified [X.target_size]. *) - val generator : burn_in:int -> Random.State.t -> michelson_code Stats.Gen.t -end - -(** See documentation for [Make_code_sampler] *) -module Make_data_sampler : functor - (Michelson_base : Michelson_samplers_base.S) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) - (X : sig - val rng_state : Random.State.t - - val target_size : int - - val verbosity : [`Progress | `Silent | `Trace] - end) - -> sig - (** [generator ~burn_in rng_state] performs a burn-in phase consisting of sampling [burn_in] times, - throwing the results away and returns a michelson term sampler. The goal of burn-in is - to drive the underlying Markov chain to its stationary distribution, ie to sample - terms around the specified [X.target_size]. *) - val generator : burn_in:int -> Random.State.t -> michelson_data Stats.Gen.t -end diff --git a/src/proto_017_PtNairob/lib_benchmark/michelson_samplers.ml b/src/proto_017_PtNairob/lib_benchmark/michelson_samplers.ml deleted file mode 100644 index 0bad66b9794432d338d5ab0d7dd7b2a52f2373cd..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/michelson_samplers.ml +++ /dev/null @@ -1,802 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021-2022 Nomadic Labs *) -(* *) -(* 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 -open Script_typed_ir - -type parameters = { - base_parameters : Michelson_samplers_base.parameters; - list_size : Base_samplers.range; - set_size : Base_samplers.range; - map_size : Base_samplers.range; -} - -let parameters_encoding = - let open Data_encoding in - let range_encoding = Base_samplers.range_encoding in - conv - (fun {base_parameters; list_size; set_size; map_size} -> - (base_parameters, (list_size, set_size, map_size))) - (fun (base_parameters, (list_size, set_size, map_size)) -> - {base_parameters; list_size; set_size; map_size}) - (merge_objs - Michelson_samplers_base.parameters_encoding - (obj3 - (req "list_size" range_encoding) - (req "set_size" range_encoding) - (req "map_size" range_encoding))) - -(* ------------------------------------------------------------------------- *) -(* Type names. *) - -(* We only want to generated inhabited types, hence Never is not included. *) - -type type_name = - [ `TUnit - | `TInt - | `TNat - | `TSignature - | `TString - | `TBytes - | `TMutez - | `TKey_hash - | `TKey - | `TTimestamp - | `TAddress - | `TBool - | `TPair - | `TOr - | `TLambda - | `TOption - | `TList - | `TSet - | `TMap - | `TBig_map - | `TContract - | `TSapling_transaction - | `TSapling_transaction_deprecated - | `TSapling_state - | `TOperation - | `TChain_id - | `TBls12_381_g1 - | `TBls12_381_g2 - | `TBls12_381_fr - | `TTicket ] - -type atomic_type_name = - [ `TUnit - | `TInt - | `TNat - | `TSignature - | `TString - | `TBytes - | `TMutez - | `TKey_hash - | `TKey - | `TTimestamp - | `TAddress - | `TBool - | `TSapling_transaction - | `TSapling_transaction_deprecated - | `TSapling_state - | `TChain_id - | `TBls12_381_g1 - | `TBls12_381_g2 - | `TBls12_381_fr ] - -type non_atomic_type_name = - [ `TPair - | `TOr - | `TLambda - | `TOption - | `TList - | `TSet - | `TMap - | `TBig_map - | `TContract - | `TTicket ] - -(* Ensure inclusion of atomic_type_name in type_name *) -let (_ : atomic_type_name -> type_name) = fun x -> (x :> type_name) - -(* Ensure inclusion of non_atomic_type_name in type_name *) -let (_ : non_atomic_type_name -> type_name) = fun x -> (x :> type_name) - -let all_atomic_type_names : atomic_type_name array = - [| - `TUnit; - `TInt; - `TNat; - `TSignature; - `TString; - `TBytes; - `TMutez; - `TKey_hash; - `TKey; - `TTimestamp; - `TAddress; - `TBool; - `TSapling_transaction; - `TSapling_transaction_deprecated; - `TSapling_state; - `TChain_id; - `TBls12_381_g1; - `TBls12_381_g2; - `TBls12_381_fr; - |] - -let all_non_atomic_type_names : non_atomic_type_name array = - [| - `TPair; - `TOr; - `TLambda; - `TOption; - `TList; - `TSet; - `TMap; - `TBig_map; - `TContract; - `TTicket; - |] - -type comparable_type_name = - [ `TUnit - | `TInt - | `TNat - | `TSignature - | `TString - | `TBytes - | `TMutez - | `TBool - | `TKey_hash - | `TKey - | `TTimestamp - | `TChain_id - | `TAddress - | `TPair - | `TOr - | `TOption ] - -(* Ensure inclusion of comparable_type_name in type_name *) -let (_ : comparable_type_name -> type_name) = fun x -> (x :> type_name) - -type 'a comparable_and_atomic = 'a - constraint 'a = [< comparable_type_name] constraint 'a = [< atomic_type_name] - -let all_comparable_atomic_type_names : 'a comparable_and_atomic array = - [| - `TUnit; - `TInt; - `TNat; - `TSignature; - `TString; - `TBytes; - `TMutez; - `TBool; - `TKey_hash; - `TKey; - `TTimestamp; - `TChain_id; - `TAddress; - |] - -type 'a comparable_and_non_atomic = 'a - constraint 'a = [< comparable_type_name] - constraint 'a = [< non_atomic_type_name] - -let all_comparable_non_atomic_type_names : 'a comparable_and_non_atomic array = - [|`TPair; `TOr; `TOption|] - -(* Ensure inclusion of comparable_and_atomic in type_name *) -let (_ : 'a comparable_and_atomic -> type_name) = fun x -> (x :> type_name) - -(* ------------------------------------------------------------------------- *) -(* Uniform type name generators *) - -open Sampling_helpers - -let uniform : 'a array -> 'a sampler = - fun arr rng_state -> - let i = Random.State.int rng_state (Array.length arr) in - arr.(i) - -let uniform_atomic_type_name : atomic_type_name sampler = - uniform all_atomic_type_names - -let uniform_comparable_atomic_type_name : 'a comparable_and_atomic sampler = - uniform all_comparable_atomic_type_names - -let uniform_comparable_non_atomic_type_name : - 'a comparable_and_non_atomic sampler = - uniform all_comparable_non_atomic_type_names - -(* ------------------------------------------------------------------------- *) -(* Random generation functor. *) - -module type S = sig - module Michelson_base : Michelson_samplers_base.S - - module Random_type : sig - val m_type : size:int -> Script_typed_ir.ex_ty sampler - - val m_comparable_type : - size:int -> Script_ir_translator.ex_comparable_ty sampler - end - - module Random_value : sig - val value : ('a, _) Script_typed_ir.ty -> 'a sampler - - val comparable : 'a Script_typed_ir.comparable_ty -> 'a sampler - - val stack : ('a, 'b) Script_typed_ir.stack_ty -> ('a * 'b) sampler - end -end - -exception SamplingError of string - -let fail_sampling error = raise (SamplingError error) - -module Make (P : sig - val parameters : parameters -end) -(Crypto_samplers : Crypto_samplers.Finite_key_pool_S) : S = struct - module Michelson_base = Michelson_samplers_base.Make (struct - let parameters = P.parameters.base_parameters - end) - - let memo_size = - Alpha_context.Sapling.Memo_size.parse_z Z.zero |> Result.get_ok - - (* [pick_split x] randomly splits the integer [x] into two integers [left] - and [right] such that [1 <= left], [1 <= right], and [left + right = x]. - Expects [x >= 2]. *) - let pick_split : int -> (int * int) sampler = - fun x rng_state -> - if x < 2 then invalid_arg "pick_split" - else - (* x >= 2 *) - let left = 1 + Random.State.int rng_state (x - 1) in - let right = x - left in - assert (left + right = x) ; - (left, right) - - (* Random generation of Michelson types. *) - module Random_type = struct - let type_of_atomic_type_name (at_tn : atomic_type_name) : - Script_typed_ir.ex_ty = - match at_tn with - | `TString -> Ex_ty string_t - | `TNat -> Ex_ty nat_t - | `TKey -> Ex_ty key_t - | `TBytes -> Ex_ty bytes_t - | `TBool -> Ex_ty bool_t - | `TAddress -> Ex_ty address_t - | `TTimestamp -> Ex_ty timestamp_t - | `TKey_hash -> Ex_ty key_hash_t - | `TMutez -> Ex_ty mutez_t - | `TSignature -> Ex_ty signature_t - | `TUnit -> Ex_ty unit_t - | `TInt -> Ex_ty int_t - | `TSapling_state -> Ex_ty (sapling_state_t ~memo_size) - | `TSapling_transaction -> Ex_ty (sapling_transaction_t ~memo_size) - | `TSapling_transaction_deprecated -> - Ex_ty (sapling_transaction_deprecated_t ~memo_size) - | `TChain_id -> Ex_ty chain_id_t - | `TBls12_381_g1 -> Ex_ty bls12_381_g1_t - | `TBls12_381_g2 -> Ex_ty bls12_381_g2_t - | `TBls12_381_fr -> Ex_ty bls12_381_fr_t - - let comparable_type_of_comparable_atomic_type_name - (cmp_tn : 'a comparable_and_atomic) : - Script_ir_translator.ex_comparable_ty = - match cmp_tn with - | `TString -> Ex_comparable_ty string_t - | `TNat -> Ex_comparable_ty nat_t - | `TBytes -> Ex_comparable_ty bytes_t - | `TBool -> Ex_comparable_ty bool_t - | `TAddress -> Ex_comparable_ty address_t - | `TTimestamp -> Ex_comparable_ty timestamp_t - | `TKey_hash -> Ex_comparable_ty key_hash_t - | `TMutez -> Ex_comparable_ty mutez_t - | `TInt -> Ex_comparable_ty int_t - | `TUnit -> Ex_comparable_ty unit_t - | `TSignature -> Ex_comparable_ty signature_t - | `TKey -> Ex_comparable_ty key_t - | `TChain_id -> Ex_comparable_ty chain_id_t - - let rec m_type ~size : Script_typed_ir.ex_ty sampler = - let open Script_ir_translator in - let open M in - if size <= 0 then Stdlib.failwith "m_type: size <= 0" - else if size = 1 then - (* only atomic types can have size 1 *) - let* at_tn = uniform_atomic_type_name in - return (type_of_atomic_type_name at_tn) - else if size = 2 then - bind (uniform [|`TOption; `TList; `TSet; `TTicket; `TContract|]) - @@ function - | `TOption -> ( - let* (Ex_ty t) = m_type ~size:1 in - match option_t (-1) t with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TList -> ( - let* (Ex_ty t) = m_type ~size:1 in - match list_t (-1) t with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TSet -> ( - let* (Ex_comparable_ty t) = m_comparable_type ~size:1 in - match set_t (-1) t with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TTicket -> ( - let* (Ex_comparable_ty contents) = m_comparable_type ~size:1 in - match ticket_t (-1) contents with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TContract -> ( - let* (Ex_ty t) = m_type ~size:1 in - match contract_t (-1) t with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - else - bind (uniform all_non_atomic_type_names) @@ function - | `TPair -> ( - let* lsize, rsize = pick_split (size - 1) in - let* (Ex_ty left) = m_type ~size:lsize in - let* (Ex_ty right) = m_type ~size:rsize in - match pair_t (-1) left right with - | Error _ -> assert false - | Ok (Ty_ex_c res_ty) -> return @@ Ex_ty res_ty) - | `TLambda -> ( - let* lsize, rsize = pick_split (size - 1) in - let* (Ex_ty domain) = m_type ~size:lsize in - let* (Ex_ty range) = m_type ~size:rsize in - match lambda_t (-1) domain range with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TOr -> ( - let* lsize, rsize = pick_split (size - 1) in - let* (Ex_ty left) = m_type ~size:lsize in - let* (Ex_ty right) = m_type ~size:rsize in - match or_t (-1) left right with - | Error _ -> assert false - | Ok (Ty_ex_c res_ty) -> return @@ Ex_ty res_ty) - | `TOption -> ( - let* (Ex_ty t) = m_type ~size:(size - 1) in - match option_t (-1) t with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TMap -> ( - let* lsize, rsize = pick_split (size - 1) in - let* (Ex_comparable_ty key) = m_comparable_type ~size:lsize in - let* (Ex_ty elt) = m_type ~size:rsize in - match map_t (-1) key elt with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TSet -> ( - let* (Ex_comparable_ty key_ty) = - m_comparable_type ~size:(size - 1) - in - match set_t (-1) key_ty with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TList -> ( - let* (Ex_ty elt) = m_type ~size:(size - 1) in - match list_t (-1) elt with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TTicket -> ( - let* (Ex_comparable_ty contents) = - m_comparable_type ~size:(size - 1) - in - match ticket_t (-1) contents with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TContract -> ( - let* (Ex_ty t) = m_type ~size:(size - 1) in - match contract_t (-1) t with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_ty res_ty) - | `TBig_map -> - (* Don't know what to do with theses. Redraw. *) - m_type ~size - - and m_comparable_type ~size : Script_ir_translator.ex_comparable_ty sampler - = - let open M in - let open Script_ir_translator in - let atomic_case () = - let* at_tn = uniform_comparable_atomic_type_name in - return (comparable_type_of_comparable_atomic_type_name at_tn) - in - let option_case size = - let size = size - 1 in - let* (Ex_comparable_ty t) = m_comparable_type ~size in - match option_t (-1) t with - | Error _ -> (* what should be done here? *) assert false - | Ok res_ty -> return @@ Ex_comparable_ty res_ty - in - let pair_case size = - let size = size - 1 in - let* size_left = - Base_samplers.sample_in_interval ~range:{min = 1; max = size - 1} - in - let size_right = size - size_left in - let* (Ex_comparable_ty l) = m_comparable_type ~size:size_left in - let* (Ex_comparable_ty r) = m_comparable_type ~size:size_right in - match comparable_pair_t (-1) l r with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_comparable_ty res_ty - in - let or_case size = - let size = size - 1 in - let* size_left = - Base_samplers.sample_in_interval ~range:{min = 1; max = size - 1} - in - let size_right = size - size_left in - let* (Ex_comparable_ty l) = m_comparable_type ~size:size_left in - let* (Ex_comparable_ty r) = m_comparable_type ~size:size_right in - match comparable_or_t (-1) l r with - | Error _ -> assert false - | Ok res_ty -> return @@ Ex_comparable_ty res_ty - in - - if size <= 1 then atomic_case () - else if size = 2 then option_case size - else - let* cmp_tn = uniform_comparable_non_atomic_type_name in - match cmp_tn with - | `TPair -> pair_case size - | `TOr -> or_case size - | `TOption -> option_case size - end - - (* Type-directed generation of random values. *) - module Random_value : sig - val value : ('a, _) Script_typed_ir.ty -> 'a sampler - - val comparable : 'a Script_typed_ir.comparable_ty -> 'a sampler - - val stack : ('a, 'b) Script_typed_ir.stack_ty -> ('a * 'b) sampler - end = struct - let implicit = Crypto_samplers.pkh - - let originated rng_state = - (* For a description of the format, see - tezos-codec describe alpha.contract binary encoding *) - let string = - "\001" ^ Base_samplers.uniform_string ~nbytes:20 rng_state ^ "\000" - in - Data_encoding.Binary.of_string_exn - Alpha_context.Contract.originated_encoding - string - - let sc_rollup rng_state = - let string = Base_samplers.uniform_string ~nbytes:20 rng_state in - Data_encoding.Binary.of_string_exn - Alpha_context.Sc_rollup.Address.encoding - string - - let entrypoint rng_state = - Alpha_context.Entrypoint.of_string_strict_exn - @@ Base_samplers.string ~size:{min = 1; max = 31} rng_state - - let address rng_state = - if Base_samplers.uniform_bool rng_state then - let destination = - Alpha_context.Destination.Contract (Implicit (implicit rng_state)) - in - {destination; entrypoint = Alpha_context.Entrypoint.default} - else - let destination = - Alpha_context.Destination.Contract (Originated (originated rng_state)) - in - let entrypoint = entrypoint rng_state in - {destination; entrypoint} - - let generate_originated_contract : - type arg argc. - (arg, argc) Script_typed_ir.ty -> - arg Script_typed_ir.typed_contract sampler = - fun arg_ty -> - let open M in - let* c = originated in - let* entrypoint in - let destination = Alpha_context.Destination.Contract (Originated c) in - return - (Typed_contract.Internal_for_tests.typed_exn - arg_ty - destination - entrypoint) - - let generate_sc_rollup_contract : - type arg argc. - (arg, argc) Script_typed_ir.ty -> - arg Script_typed_ir.typed_contract sampler = - fun arg_ty -> - let open M in - let* ru = sc_rollup in - let destination = Alpha_context.Destination.Sc_rollup ru in - return - (Typed_contract.Internal_for_tests.typed_exn - arg_ty - destination - Alpha_context.Entrypoint.default) - - let generate_any_type_contract : - type arg argc. - (arg, argc) Script_typed_ir.ty -> - arg Script_typed_ir.typed_contract sampler = - fun arg_ty -> - let open M in - let* b = Base_samplers.uniform_bool in - if b then generate_originated_contract arg_ty - else generate_sc_rollup_contract arg_ty - - let generate_contract : - type arg argc. - (arg, argc) Script_typed_ir.ty -> - arg Script_typed_ir.typed_contract sampler = - fun arg_ty -> - let open M in - match arg_ty with - | Unit_t -> - let* b = Base_samplers.uniform_bool in - if b then - let* pkh = implicit in - let destination = - Alpha_context.Destination.Contract (Implicit pkh) - in - let entrypoint = Alpha_context.Entrypoint.default in - return - (Typed_contract.Internal_for_tests.typed_exn - arg_ty - destination - entrypoint) - else generate_any_type_contract arg_ty - | _ -> generate_any_type_contract arg_ty - - let chain_id rng_state = - let string = Base_samplers.uniform_string ~nbytes:4 rng_state in - Data_encoding.Binary.of_string_exn Script_chain_id.encoding string - - let signature rng_state = - Script_signature.make (Michelson_base.signature rng_state) - - let rec value : type a ac. (a, ac) Script_typed_ir.ty -> a sampler = - let open Script_typed_ir in - fun typ -> - match typ with - | Never_t -> assert false - | Unit_t -> M.return () - | Int_t -> Michelson_base.int - | Nat_t -> Michelson_base.nat - | Signature_t -> signature - | String_t -> Michelson_base.string - | Bytes_t -> Michelson_base.bytes - | Mutez_t -> Michelson_base.tez - | Key_hash_t -> Crypto_samplers.pkh - | Key_t -> Crypto_samplers.pk - | Timestamp_t -> Michelson_base.timestamp - | Bool_t -> Base_samplers.uniform_bool - | Address_t -> address - | Pair_t (left_t, right_t, _, _) -> - M.( - let* left_v = value left_t in - let* right_v = value right_t in - return (left_v, right_v)) - | Or_t (left_t, right_t, _, _) -> - fun rng_state -> - if Base_samplers.uniform_bool rng_state then - L (value left_t rng_state) - else R (value right_t rng_state) - | Lambda_t (arg_ty, ret_ty, _) -> generate_lambda arg_ty ret_ty - | Option_t (ty, _, _) -> - fun rng_state -> - if Base_samplers.uniform_bool rng_state then None - else Some (value ty rng_state) - | List_t (elt_ty, _) -> generate_list elt_ty - | Set_t (elt_ty, _) -> generate_set elt_ty - | Map_t (key_ty, val_ty, _) -> generate_map key_ty val_ty - | Contract_t (arg_ty, _) -> generate_contract arg_ty - | Operation_t -> generate_operation - | Big_map_t (key_ty, val_ty, _) -> generate_big_map key_ty val_ty - | Chain_id_t -> chain_id - | Bls12_381_g1_t -> generate_bls12_381_g1 - | Bls12_381_g2_t -> generate_bls12_381_g2 - | Bls12_381_fr_t -> generate_bls12_381_fr - | Ticket_t (contents_ty, _) -> generate_ticket contents_ty - | Tx_rollup_l2_address_t -> - fail_sampling - "Michelson_samplers: tx_rollup_l2_address is deprecated" - | Sapling_transaction_t _ -> - fail_sampling - "Michelson_samplers: sapling transactions not handled yet" - | Sapling_transaction_deprecated_t _ -> - fail_sampling - "Michelson_samplers: sapling transactions not handled yet" - | Sapling_state_t _ -> - fail_sampling "Michelson_samplers: sapling state not handled yet" - | Chest_key_t -> - fail_sampling "Michelson_samplers: chest key not handled yet" - | Chest_t -> fail_sampling "Michelson_samplers: chest not handled yet" - - and generate_lambda : - type arg argc ret retc. - (arg, argc) Script_typed_ir.ty -> - (ret, retc) Script_typed_ir.ty -> - (arg, ret) Script_typed_ir.lambda sampler = - fun _arg_ty _ret_ty _rng_state -> - fail_sampling "Michelson_samplers: lambda not handled yet" - - and generate_list : - type elt eltc. - (elt, eltc) Script_typed_ir.ty -> elt Script_list.t sampler = - fun elt_type -> - let open M in - let* _, elements = - Structure_samplers.list - ~range:P.parameters.list_size - ~sampler:(value elt_type) - in - return @@ Script_list.of_list elements - - (* Note that we might very well generate sets smaller than the specified range (consider the - case of a set of type [unit]). *) - and generate_set : - type elt. - elt Script_typed_ir.comparable_ty -> elt Script_typed_ir.set sampler = - fun elt_ty -> - let open M in - let* _, elements = - Structure_samplers.list - ~range:P.parameters.set_size - ~sampler:(value elt_ty) - in - return - @@ List.fold_left - (fun set x -> Script_set.update x true set) - (Script_set.empty elt_ty) - elements - - and generate_map : - type key elt eltc. - key Script_typed_ir.comparable_ty -> - (elt, eltc) Script_typed_ir.ty -> - (key, elt) Script_typed_ir.map sampler = - fun key_ty elt_ty rng_state -> - let size = - Base_samplers.sample_in_interval rng_state ~range:P.parameters.map_size - in - let keys = List.init size (fun _ -> value key_ty rng_state) in - let elts = List.init size (fun _ -> value elt_ty rng_state) in - List.fold_left2 - (fun map key elt -> Script_map.update key (Some elt) map) - (Script_map.empty key_ty) - keys - elts - - and generate_big_map : - type key elt eltc. - key Script_typed_ir.comparable_ty -> - (elt, eltc) Script_typed_ir.ty -> - (key, elt) Script_typed_ir.big_map sampler = - let open Script_typed_ir in - fun key_ty elt_ty rng_state -> - let open TzPervasives in - let result = - Lwt_main.run - ( Execution_context.make ~rng_state >>=? fun (ctxt, _) -> - let big_map = Script_big_map.empty key_ty elt_ty in - (* Cannot have big maps under big maps *) - option_t (-1) elt_ty |> Environment.wrap_tzresult - >>?= fun opt_elt_ty -> - let map = generate_map key_ty opt_elt_ty rng_state in - Script_map.fold - (fun k v acc -> - acc >>=? fun (bm, ctxt_acc) -> - Script_big_map.update ctxt_acc k v bm) - map - (return (big_map, ctxt)) - >|= Environment.wrap_tzresult - >>=? fun (big_map, _) -> return big_map ) - in - match result with - | Ok x -> x - | Error e -> - Format.eprintf - "%a@." - (Error_monad.TzTrace.pp_print Error_monad.pp) - e ; - fail_sampling "raise_if_error" - - and generate_operation : Script_typed_ir.operation sampler = - fun rng_state -> - let transfer = generate_transfer_tokens rng_state in - Script_typed_ir.{piop = transfer; lazy_storage_diff = None} - - and generate_transfer_tokens : - Script_typed_ir.packed_internal_operation sampler = - fun _rng_state -> fail_sampling "generate_transfer_tokens: unimplemented" - - and generate_bls12_381_g1 : Script_bls.G1.t sampler = - fun rng_state -> - let b = Bls12_381.G1.(to_bytes (random ~state:rng_state ())) in - match Script_bls.G1.of_bytes_opt b with - | Some x -> x - | None -> assert false - - and generate_bls12_381_g2 : Script_bls.G2.t sampler = - fun rng_state -> - let b = Bls12_381.G2.(to_bytes (random ~state:rng_state ())) in - match Script_bls.G2.of_bytes_opt b with - | Some x -> x - | None -> assert false - - and generate_bls12_381_fr : Script_bls.Fr.t sampler = - fun rng_state -> - let b = Bls12_381.Fr.(to_bytes (random ~state:rng_state ())) in - match Script_bls.Fr.of_bytes_opt b with - | Some x -> x - | None -> assert false - - and generate_ticket : - type a ac. - (a, ac) Script_typed_ir.ty -> a Script_typed_ir.ticket sampler = - fun ty rng_state -> - let contents = value ty rng_state in - let ticketer = - Alpha_context.Contract.Implicit (Crypto_samplers.pkh rng_state) - in - let amount = - let open Ticket_amount in - match of_n (Michelson_base.nat rng_state) with - | Some amount -> add amount one - | None -> one - in - Script_typed_ir.{ticketer; contents; amount} - - let comparable ty = value ty - - (* Random stack generation. *) - let rec stack : type a b. (a, b) Script_typed_ir.stack_ty -> (a * b) sampler - = - let open M in - let open Script_typed_ir in - fun stack_ty -> - match stack_ty with - | Item_t (ty, tl) -> - let* elt = value ty in - let* tl = stack tl in - return ((elt, tl) : a * b) - | Bot_t -> return (EmptyCell, EmptyCell) - end -end - -module Internal_for_tests = struct - type nonrec type_name = type_name -end diff --git a/src/proto_017_PtNairob/lib_benchmark/michelson_samplers.mli b/src/proto_017_PtNairob/lib_benchmark/michelson_samplers.mli deleted file mode 100644 index ea10e0e94dd96751619c1d80018c270788c02bf1..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/michelson_samplers.mli +++ /dev/null @@ -1,132 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021-2022 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Sampling various Michelson values. *) - -open Protocol -open Base_samplers - -(** This module exposes a functor implementing various samplers for Michelson. - These allow to sample: - - types and comparable types (given a target size), - - values and comparable values of a given Michelson type (given some more - parameters fixed at functor instantiation time) - - stacks - - Note that some kind of values might not be supported. At the time of writing, - the value sampler doesn't handle the following types: - - Sapling transaction and states - - Timelock chests and chest keys - - Operations - - Lambdas (ie code) - - For the latter, consider using the samplers in {!Michelson_mcmc_samplers}. -*) - -(** Parameters for the Michelson samplers. *) -type parameters = { - base_parameters : Michelson_samplers_base.parameters; - list_size : Base_samplers.range; - (** The range of the size, measured in number of elements, in which lists must be sampled.*) - set_size : Base_samplers.range; - (** The range of the size, measured in number of elements, in which sets must be sampled.*) - map_size : Base_samplers.range; - (** The range of the size, measured in number of bindings, in which maps must be sampled.*) -} - -(** Encoding for sampler prameters. *) -val parameters_encoding : parameters Data_encoding.t - -(** The module type produced by the [Make] functor. *) -module type S = sig - (** Basic Michelson samplers, re-exported for convenience by the functor. *) - module Michelson_base : Michelson_samplers_base.S - - (** Samplers for random Michelson types. *) - module Random_type : sig - (** [m_type ~size] samples a type containing exactly [size] constructors. *) - val m_type : size:int -> Script_typed_ir.ex_ty sampler - - (** [m_comparable_type ~size] samples a comparable type containing - exactly [size] constructors. *) - val m_comparable_type : - size:int -> Script_ir_translator.ex_comparable_ty sampler - end - - (** Samplers for random Michelson values. Restrictions apply on the - supported types as listed at the beginning of this file. *) - module Random_value : sig - (** Sample a value given its type. *) - val value : ('a, _) Script_typed_ir.ty -> 'a sampler - - (** Sample a comparable value given its type. *) - val comparable : 'a Script_typed_ir.comparable_ty -> 'a sampler - - (** Sample a stack given its type. *) - val stack : ('a, 'b) Script_typed_ir.stack_ty -> ('a * 'b) sampler - end -end - -(** Instantiate a module of type {!S}. *) -module Make : functor - (P : sig - val parameters : parameters - end) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) - -> S - -module Internal_for_tests : sig - type type_name = - [ `TAddress - | `TBig_map - | `TBls12_381_fr - | `TBls12_381_g1 - | `TBls12_381_g2 - | `TBool - | `TBytes - | `TChain_id - | `TContract - | `TInt - | `TKey - | `TKey_hash - | `TLambda - | `TList - | `TMap - | `TMutez - | `TNat - | `TOperation - | `TOption - | `TPair - | `TSapling_state - | `TSapling_transaction - | `TSapling_transaction_deprecated - | `TSet - | `TSignature - | `TString - | `TTicket - | `TTimestamp - | `TOr - | `TUnit ] -end diff --git a/src/proto_017_PtNairob/lib_benchmark/michelson_samplers_base.ml b/src/proto_017_PtNairob/lib_benchmark/michelson_samplers_base.ml deleted file mode 100644 index 837374f56709070badface6ef66338f4d0f77e13..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/michelson_samplers_base.ml +++ /dev/null @@ -1,139 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 -open Sampling_helpers - -(** Parameters for basic samplers *) -type parameters = { - int_size : Base_samplers.range; - string_size : Base_samplers.range; - bytes_size : Base_samplers.range; -} - -(** Encoding for basic samplers parameters *) -let parameters_encoding = - let open Data_encoding in - let range = Base_samplers.range_encoding in - conv - (fun {int_size; string_size; bytes_size} -> - (int_size, string_size, bytes_size)) - (fun (int_size, string_size, bytes_size) -> - {int_size; string_size; bytes_size}) - (obj3 - (req "int_size" range) - (req "string_size" range) - (req "bytes_size" range)) - -(** A module of type [S] packs samplers used to construct basic Michelson values. *) -module type S = sig - val int : Script_int.z Script_int.num sampler - - val nat : Script_int.n Script_int.num sampler - - val signature : Tezos_crypto.Signature.t sampler - - val string : Script_string.t sampler - - val bytes : bytes sampler - - val tez : Alpha_context.Tez.tez sampler - - val timestamp : Script_timestamp.t sampler -end - -(* Samplers for basic Michelson types. *) - -module Make (P : sig - val parameters : parameters -end) : S = struct - let int rng_state = - let i = Base_samplers.int ~size:P.parameters.int_size rng_state in - Script_int.of_zint i - - let nat rng_state = - let i = Base_samplers.nat ~size:P.parameters.int_size rng_state in - Script_int.abs (Script_int.of_zint i) - - let signature rng_state = - let i = Random.State.int rng_state 5 in - match i with - | 0 -> ( - let open Tezos_crypto.Signature.Ed25519 in - let bytes = Base_samplers.uniform_bytes ~nbytes:size rng_state in - match of_bytes_opt bytes with - | None -> assert false - | Some s -> Tezos_crypto.Signature.of_ed25519 s) - | 1 -> ( - let open Tezos_crypto.Signature.Secp256k1 in - let bytes = Base_samplers.uniform_bytes ~nbytes:size rng_state in - match of_bytes_opt bytes with - | None -> assert false - | Some s -> Tezos_crypto.Signature.of_secp256k1 s) - | 2 -> ( - let open Tezos_crypto.Signature.P256 in - let bytes = Base_samplers.uniform_bytes ~nbytes:size rng_state in - match of_bytes_opt bytes with - | None -> assert false - | Some s -> Tezos_crypto.Signature.of_p256 s) - | 3 -> - (* BLS checks that signatures are on the curve so we need to generate real - ones by signing a message. *) - let open Tezos_crypto.Signature.Bls in - let msg = Base_samplers.uniform_bytes ~nbytes:32 rng_state in - let seed = Base_samplers.uniform_bytes ~nbytes:32 rng_state in - let _, _, sk = generate_key ~seed () in - Tezos_crypto.Signature.of_bls (sign sk msg) - | _ -> - let open Tezos_crypto.Signature in - let bytes = - Base_samplers.uniform_bytes - ~nbytes:Tezos_crypto.Signature.Ed25519.size - rng_state - in - Unknown bytes - - let string rng_state = - let s = - Base_samplers.readable_ascii_string - ~size:P.parameters.string_size - rng_state - in - match Protocol.Script_string.of_string s with - | Ok s -> s - | Error _ -> assert false - - let bytes = Base_samplers.bytes ~size:P.parameters.bytes_size - - let tez rng_state = - let i = Random.State.int64 rng_state (Int64.of_int max_int) in - match Protocol.Alpha_context.Tez.of_mutez i with - | Some res -> res - | None -> assert false - - let timestamp rng_state = - let i = Base_samplers.int ~size:P.parameters.int_size rng_state in - Script_timestamp.of_zint i -end diff --git a/src/proto_017_PtNairob/lib_benchmark/michelson_samplers_base.mli b/src/proto_017_PtNairob/lib_benchmark/michelson_samplers_base.mli deleted file mode 100644 index ae7a79c00cad85b93e978a6466bf4bb5db40ea18..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/michelson_samplers_base.mli +++ /dev/null @@ -1,67 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Samplers for basic Michelson values (not including pairs, ors, tickets, big maps, etc) *) - -open Protocol -open Base_samplers - -(** Parameters for basic samplers *) -type parameters = { - int_size : Base_samplers.range; - (** The range of the size, measured in bytes, in which big integers must be sampled.*) - string_size : Base_samplers.range; - (** The range of the size, measured in bytes, in which strings must be sampled.*) - bytes_size : Base_samplers.range; - (** The range of the size, measured in bytes, in which [bytes] must be sampled.*) -} - -(** Encoding for [parameters] *) -val parameters_encoding : parameters Data_encoding.t - -(** A module of type [S] packs samplers used to construct basic Michelson values. *) -module type S = sig - val int : Script_int.z Script_int.num sampler - - val nat : Script_int.n Script_int.num sampler - - val signature : Tezos_crypto.Signature.t sampler - - val string : Script_string.t sampler - - val bytes : bytes sampler - - val tez : Alpha_context.Tez.tez sampler - - val timestamp : Script_timestamp.t sampler -end - -(** The [Make] functor instantiates a module of type [S], where the - samplers satisfy the given parameters. *) -module Make : functor - (P : sig - val parameters : parameters - end) - -> S diff --git a/src/proto_017_PtNairob/lib_benchmark/mikhailsky_to_michelson.ml b/src/proto_017_PtNairob/lib_benchmark/mikhailsky_to_michelson.ml deleted file mode 100644 index 6ee761048306df2a52c5e36148c4f028c10050a3..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/mikhailsky_to_michelson.ml +++ /dev/null @@ -1,229 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -exception Cannot_get_type of Mikhailsky.node * Kernel.Path.t - -exception Unexpected_stack_type of string - -exception Unexpected_base_type - -let unparse_type = Mikhailsky.map_var (fun _ -> Mikhailsky.prim T_unit [] []) - -let project_top (aft : Type.Stack.t) = - match aft.node with - | Type.Stack.Empty_t -> raise (Unexpected_stack_type "empty") - | Type.Stack.Stack_var_t _ -> raise (Unexpected_stack_type "var") - | Type.Stack.Item_t (top, _) -> top - -let project_or (aft : Type.Stack.t) = - let top = project_top aft in - match top.node with - | Type.Base.Or_t (l, r) -> (l, r) - | _ -> raise Unexpected_base_type - -let project_lambda (aft : Type.Stack.t) = - let top = project_top aft in - match top.node with - | Type.Base.Lambda_t (dom, range) -> (dom, range) - | _ -> raise Unexpected_base_type - -let project_list (aft : Type.Stack.t) = - let top = project_top aft in - match top.node with - | Type.Base.List_t t -> t - | _ -> raise Unexpected_base_type - -let project_set (aft : Type.Stack.t) = - let top = project_top aft in - match top.node with Type.Base.Set_t t -> t | _ -> raise Unexpected_base_type - -let project_map (aft : Type.Stack.t) = - let top = project_top aft in - match top.node with - | Type.Base.Map_t (k, v) -> (k, v) - | _ -> raise Unexpected_base_type - -let project_option (aft : Type.Stack.t) = - let top = project_top aft in - match top.node with - | Type.Base.Option_t t -> t - | _ -> raise Unexpected_base_type - -let rec convert_raw : Mikhailsky.node -> (int, 'a) Micheline.node = - fun node -> - match node with - | Micheline.Int (_, i) -> Micheline.Int (0, i) - | Micheline.Prim (_, head, subterms, annots) -> - let head = Mikhailsky_prim.to_michelson head in - Micheline.Prim (0, head, List.map convert_raw subterms, annots) - | Micheline.String (_, s) -> Micheline.String (0, s) - | Micheline.Bytes (_, b) -> Micheline.Bytes (0, b) - | Micheline.Seq (_, subterms) -> - Micheline.Seq (0, List.map convert_raw subterms) - -(* We assume that the term has been completed. *) -let rec convert : - Mikhailsky.node -> Kernel.Path.t -> (int, 'a) Micheline.node Inference.M.t = - fun node path -> - let open Inference.M in - match node with - | Micheline.Int (_, i) -> return (Micheline.Int (0, i)) - | Micheline.String (_, s) -> return (Micheline.String (0, s)) - | Micheline.Bytes (_, b) -> return (Micheline.Bytes (0, b)) - (* Remove annotations *) - | Micheline.Prim (_, prim, [term], _) - when Mikhailsky_prim.kind prim = Annot_kind -> - let path = Kernel.Path.at_index 0 path in - convert term path - (* Fail on holes *) - | Micheline.Prim (_, I_Hole, _, _) | Micheline.Prim (_, D_Hole, _, _) -> - raise Mikhailsky.Term_contains_holes - (* Add type information to or injections *) - | Micheline.Prim (_, I_LEFT, [], annots) -> ( - get_instr_annot path >>= fun ty_opt -> - match ty_opt with - | None -> raise (Cannot_get_type (node, path)) - | Some {aft; _} -> - Inference.instantiate aft >>= fun aft -> - let _, r = project_or aft in - Inference.instantiate_base r >>= fun r -> - Autocomp.replace_vars r >>= fun r -> - let r = unparse_type r in - let head = Mikhailsky_prim.to_michelson I_LEFT in - return (Micheline.Prim (0, head, [convert_raw r], annots))) - | Micheline.Prim (_, I_RIGHT, [], annots) -> ( - get_instr_annot path >>= fun ty_opt -> - match ty_opt with - | None -> raise (Cannot_get_type (node, path)) - | Some {aft; _} -> - Inference.instantiate aft >>= fun aft -> - let l, _ = project_or aft in - Inference.instantiate_base l >>= fun l -> - Autocomp.replace_vars l >>= fun l -> - let l = unparse_type l in - let head = Mikhailsky_prim.to_michelson I_RIGHT in - return (Micheline.Prim (0, head, [convert_raw l], annots))) - | Micheline.Prim (_, (I_LEFT | I_RIGHT), _, _) -> - raise Mikhailsky.Ill_formed_mikhailsky - (* Add type information for lambdas *) - | Micheline.Prim (_, I_LAMBDA, [code], annots) -> ( - convert code (Kernel.Path.at_index 0 path) >>= fun code -> - get_instr_annot path >>= fun ty_opt -> - match ty_opt with - | None -> raise (Cannot_get_type (node, path)) - | Some {aft; _} -> - Inference.instantiate aft >>= fun aft -> - let dom, range = project_lambda aft in - Inference.instantiate_base dom >>= fun dom -> - Autocomp.replace_vars dom >>= fun dom -> - Inference.instantiate_base range >>= fun range -> - Autocomp.replace_vars range >>= fun range -> - let dom = unparse_type dom in - let range = unparse_type range in - let head = Mikhailsky_prim.to_michelson I_LAMBDA in - return - (Micheline.Prim - (0, head, [convert_raw dom; convert_raw range; code], annots))) - (* Add type information for empty_set, empty_map *) - | Micheline.Prim (_, I_EMPTY_SET, [], annots) -> ( - get_instr_annot path >>= fun ty_opt -> - match ty_opt with - | None -> raise (Cannot_get_type (node, path)) - | Some {aft; _} -> - Inference.instantiate aft >>= fun aft -> - let elt = project_set aft in - Inference.instantiate_base elt >>= fun elt -> - Autocomp.replace_vars elt >>= fun elt -> - let elt = unparse_type elt in - let head = Mikhailsky_prim.to_michelson I_EMPTY_SET in - return (Micheline.Prim (0, head, [convert_raw elt], annots))) - | Micheline.Prim (_, I_EMPTY_MAP, [], annots) -> ( - get_instr_annot path >>= fun ty_opt -> - match ty_opt with - | None -> raise (Cannot_get_type (node, path)) - | Some {aft; _} -> - Inference.instantiate aft >>= fun aft -> - let k, v = project_map aft in - Inference.instantiate_base k >>= fun k -> - Autocomp.replace_vars k >>= fun k -> - Inference.instantiate_base v >>= fun v -> - Autocomp.replace_vars v >>= fun v -> - let k = convert_raw (unparse_type k) in - let v = convert_raw (unparse_type v) in - let head = Mikhailsky_prim.to_michelson I_EMPTY_MAP in - return (Micheline.Prim (0, head, [k; v], annots))) - (* Add type information for UNPACK *) - | Micheline.Prim (_, I_UNPACK, [], annots) -> ( - get_instr_annot path >>= fun ty_opt -> - match ty_opt with - | None -> raise (Cannot_get_type (node, path)) - | Some {aft; _} -> - Inference.instantiate aft >>= fun aft -> - let elt = project_option aft in - Inference.instantiate_base elt >>= fun elt -> - Autocomp.replace_vars elt >>= fun elt -> - let elt = unparse_type elt in - let head = Mikhailsky_prim.to_michelson I_UNPACK in - return (Micheline.Prim (0, head, [convert_raw elt], annots))) - (* Add type information for NIL *) - | Micheline.Prim (_, I_NIL, [], annots) -> ( - get_instr_annot path >>= fun ty_opt -> - match ty_opt with - | None -> raise (Cannot_get_type (node, path)) - | Some {aft; _} -> - Inference.instantiate aft >>= fun aft -> - let elt = project_list aft in - Inference.instantiate_base elt >>= fun elt -> - Autocomp.replace_vars elt >>= fun elt -> - let elt = unparse_type elt in - let head = Mikhailsky_prim.to_michelson I_NIL in - return (Micheline.Prim (0, head, [convert_raw elt], annots))) - | Micheline.Prim (_, I_NIL, _, _) -> raise Mikhailsky.Ill_formed_mikhailsky - (* Project out type information from arithmetic ops *) - | Prim (_, ((I_ADD | I_SUB | I_MUL | I_EDIV) as instr), [_ty1; _ty2], annots) - -> - let head = Mikhailsky_prim.to_michelson instr in - return (Micheline.Prim (0, head, [], annots)) - | Prim (_, (I_ADD | I_SUB | I_MUL | I_EDIV), _, _) -> - raise Mikhailsky.Ill_formed_mikhailsky - (* Base case *) - | Micheline.Prim (_, head, subterms, annots) -> - let head = Mikhailsky_prim.to_michelson head in - convert_list path 0 subterms [] >>= fun subterms -> - return (Micheline.Prim (0, head, subterms, annots)) - | Micheline.Seq (_, subterms) -> - convert_list path 0 subterms [] >>= fun subterms -> - return (Micheline.Seq (0, subterms)) - -and convert_list path i subterms acc = - let open Inference.M in - match subterms with - | [] -> return (List.rev acc) - | subterm :: tl -> - let path' = Kernel.Path.at_index i path in - convert subterm path' >>= fun term -> - convert_list path (i + 1) tl (term :: acc) - -let convert node state = fst (convert node Kernel.Path.root state) diff --git a/src/proto_017_PtNairob/lib_benchmark/rules.ml b/src/proto_017_PtNairob/lib_benchmark/rules.ml deleted file mode 100644 index 88a148e0213e85c6d26ef93451d104e965915440..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/rules.ml +++ /dev/null @@ -1,975 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 Kernel - -type rule_set = {rule_patt : pattern; replacements : guarded_replacement list} - -and guarded_replacement = { - type_constraint : type_constraint; - replacement : replacement list; -} - -and type_constraint = - | No_cnstrnt - | Data_cnstrnt of {cnstrnt : Type.Base.t; fresh : int list} - | Instr_cnstrnt of { - cnstrnt : Inference.transformer; - fresh : var list; - fresh_stack : int list; - } - -and replacement = - | Context_aware of (Mikhailsky.node -> Mikhailsky.node) - | Context_blind of (unit -> Mikhailsky.node) - -and pattern = Pattern of Patt.t | Root - -and var = Plain of int | Cmp of int - -let stack_repr = Inference.Stack_type None - -let base_repr = - Inference.Base_type {repr = None; comparable = Inference.Unconstrained} - -let cmp_repr = - Inference.Base_type {repr = None; comparable = Inference.Comparable} - -let rec add_fresh_stack_variables vars = - let open Inference.M in - match vars with - | [] -> return () - | fresh :: tl -> - uf_lift (Uf.UF.add fresh) >>= fun () -> - set_repr fresh stack_repr >>= fun () -> add_fresh_stack_variables tl - -let rec add_fresh_data_variables vars = - let open Inference.M in - match vars with - | [] -> return () - | fresh :: tl -> - uf_lift (Uf.UF.add fresh) >>= fun () -> - set_repr fresh base_repr >>= fun () -> add_fresh_data_variables tl - -let rec add_fresh_variables vars plain_repr cmp_repr = - let open Inference.M in - match vars with - | [] -> return () - | Plain fresh :: tl -> - uf_lift (Uf.UF.add fresh) >>= fun () -> - set_repr fresh plain_repr >>= fun () -> - add_fresh_variables tl plain_repr cmp_repr - | Cmp fresh :: tl -> - uf_lift (Uf.UF.add fresh) >>= fun () -> - set_repr fresh cmp_repr >>= fun () -> - add_fresh_variables tl plain_repr cmp_repr - -let evaluate_guard_monadic guard path = - let open Inference.M in - match guard with - | No_cnstrnt -> return () - | Data_cnstrnt {cnstrnt = base_type_constraint; fresh} -> ( - add_fresh_data_variables fresh >>= fun () -> - get_data_annot path >>= fun res_opt -> - match res_opt with - | None -> assert false - | Some type_of_expr -> - Inference.unify_base type_of_expr base_type_constraint >>= fun () -> - Inference.instantiate_base type_of_expr >>= fun _ -> return ()) - | Instr_cnstrnt {cnstrnt = {bef = pre; aft = post}; fresh; fresh_stack} -> ( - (* Add base fresh type variables *) - add_fresh_variables fresh base_repr cmp_repr - >>= fun () -> - add_fresh_stack_variables fresh_stack >>= fun () -> - get_instr_annot path >>= fun res_opt -> - match res_opt with - | None -> assert false - | Some {bef; aft} -> - Inference.unify pre bef >>= fun () -> - Inference.unify post aft >>= fun () -> - Inference.instantiate bef >>= fun _bef -> - Inference.instantiate aft >>= fun _aft -> return ()) - -let evaluate_guard typing guard path = - try - let _ = evaluate_guard_monadic guard path typing in - true - with Inference.Ill_typed_script _ -> false - -let filter_matches typing guard matches = - List.filter (evaluate_guard typing guard) matches - -(* Provides a speedup but should better be done in the - rewriting module (so that not only top matches are hash-consed). *) -let matches_with_hash_consing = - let match_table : (int * int, Kernel.Path.t list) Hashtbl.t = - Hashtbl.create 97 - in - fun pattern term -> - match pattern with - | Root -> [Path.root] - | Pattern patt -> ( - let key = (Kernel.Patt.uid patt, Mikhailsky.tag term) in - match Hashtbl.find_opt match_table key with - | None -> - let res = Rewriter.all_matches patt term in - Hashtbl.add match_table key res ; - res - | Some res -> res) - -let matches_without_consing pattern term = - match pattern with - | Root -> [Path.root] - | Pattern patt -> Rewriter.all_matches patt term - -let rewriting (state : State_space.t) (rules : rule_set list) = - List.fold_left - (fun acc rule -> - let matches = matches_without_consing rule.rule_patt state.term in - List.fold_left - (fun acc guarded_replacement -> - let matches = - filter_matches - (Lazy.force state.typing) - guarded_replacement.type_constraint - matches - in - List.fold_left - (fun acc replacement -> - match replacement with - | Context_blind term -> - List.fold_left - (fun acc path -> (path, term ()) :: acc) - acc - matches - | Context_aware f -> - List.fold_left - (fun acc path -> - let term = Rewriter.get_subterm ~term:state.term ~path in - (path, f term) :: acc) - acc - matches) - acc - guarded_replacement.replacement) - acc - rule.replacements) - [] - rules - -module Instruction = struct - (* ----------------------------------------------------------------------- *) - (* Rule: replace instruction by hole. *) - - (* Matches instructions *) - let match_any_instr = - let open Patt in - Pattern - (focus - (prim_pred - (fun prim -> Mikhailsky_prim.kind prim = Mikhailsky_prim.Instr_kind) - list_any)) - - let replace_any_instr_by_hole = - let replace_by_hole = - { - type_constraint = No_cnstrnt; - replacement = [Context_blind (fun () -> Mikhailsky.instr_hole)]; - } - in - {rule_patt = match_any_instr; replacements = [replace_by_hole]} - - (* ----------------------------------------------------------------------- *) - (* Rule: replace instruction hole by instruction satisfying typing - constraints. *) - - (* Matches instruction holes *) - let match_instr_hole = - let open Patt in - Pattern (focus (prim I_Hole list_any)) - - let replacement ?(fresh = []) ?(fresh_stack = []) ~bef ~aft ~replacement () : - guarded_replacement = - { - type_constraint = Instr_cnstrnt {cnstrnt = {bef; aft}; fresh; fresh_stack}; - replacement; - } - - let instructions = - let open Type in - let module M = Mikhailsky in - let module I = Inference in - let alpha = ~-1 in - let beta = ~-2 in - let gamma = ~-3 in - let delta = ~-4 in - [ - replacement - ~fresh_stack:[alpha] - ~bef:(item bytes (stack_var alpha)) - ~aft:(item bytes (stack_var alpha)) - ~replacement: - [ - Context_blind (fun () -> M.Instructions.blake2b); - Context_blind (fun () -> M.Instructions.sha256); - Context_blind (fun () -> M.Instructions.sha512); - ] - (); - replacement - ~fresh_stack:[alpha] - ~bef:(item int (stack_var alpha)) - ~aft:(item bool (stack_var alpha)) - ~replacement:[Context_blind (fun () -> M.Instructions.gt)] - (); - replacement - ~fresh_stack:[alpha] - ~bef:(item int (stack_var alpha)) - ~aft:(item nat (stack_var alpha)) - ~replacement:[Context_blind (fun () -> M.Instructions.abs)] - (); - replacement - ~fresh_stack:[alpha] - ~bef:(item int (item int (stack_var alpha))) - ~aft:(item int (stack_var alpha)) - ~replacement: - [ - Context_blind (fun () -> M.Instructions.add M.int_ty M.int_ty); - Context_blind (fun () -> M.Instructions.mul M.int_ty M.int_ty); - ] - (); - replacement - ~fresh:[Plain alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(item (pair (var alpha) (var beta)) (stack_var gamma)) - ~aft:(item (var alpha) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.car)] - (); - replacement - ~fresh:[Plain alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(item (pair (var alpha) (var beta)) (stack_var gamma)) - ~aft:(item (var beta) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.cdr)] - (); - replacement - ~fresh:[Cmp alpha] - ~fresh_stack:[gamma] - ~bef:(item (var alpha) (item (var alpha) (stack_var gamma))) - ~aft:(item int (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.compare)] - (); - replacement - ~fresh_stack:[gamma] - ~bef:(item string (item string (stack_var gamma))) - ~aft:(item string (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.concat)] - (); - replacement - ~fresh:[Plain alpha] - ~fresh_stack:[beta; gamma] - ~bef:(item (var alpha) (stack_var beta)) - ~aft:(item (var alpha) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.(dip hole))] - (); - replacement - ~fresh:[Plain alpha] - ~fresh_stack:[beta] - ~bef:(item (var alpha) (stack_var beta)) - ~aft:(stack_var beta) - ~replacement:[Context_blind (fun () -> M.Instructions.drop)] - (); - replacement - ~fresh:[Plain alpha] - ~fresh_stack:[beta] - ~bef:(item (var alpha) (stack_var beta)) - ~aft:(item (var alpha) (item (var alpha) (stack_var beta))) - ~replacement:[Context_blind (fun () -> M.Instructions.dup)] - (); - replacement - ~fresh:[] - ~fresh_stack:[alpha] - ~bef:(stack_var alpha) - ~aft:(item int (stack_var alpha)) - ~replacement: - [ - (* TODO : push random integer? *) - Context_blind - (fun () -> M.Instructions.push M.int_ty (M.Data.integer 100)); - ] - (); - replacement - ~fresh:[Plain alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(item (var alpha) (item (var beta) (stack_var gamma))) - ~aft:(item (var beta) (item (var alpha) (stack_var gamma))) - ~replacement:[Context_blind (fun () -> M.Instructions.swap)] - (); - (* control *) - replacement - ~fresh_stack:[alpha] - ~bef:(item bool (stack_var alpha)) - ~aft:(stack_var alpha) - ~replacement:[Context_blind (fun () -> M.Instructions.(loop hole))] - (); - replacement - ~fresh:[Plain alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(item (or_ (var alpha) (var beta)) (stack_var gamma)) - ~aft:(item (var beta) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.(loop_left hole))] - (); - replacement - ~fresh:[Plain alpha] - ~fresh_stack:[beta; gamma] - ~bef:(item (option (var alpha)) (stack_var beta)) - ~aft:(stack_var gamma) - ~replacement: - [Context_blind (fun () -> M.Instructions.(if_none hole hole))] - (); - replacement - ~fresh:[Plain alpha; Plain beta] - ~fresh_stack:[gamma; delta] - ~bef:(item (or_ (var alpha) (var beta)) (stack_var gamma)) - ~aft:(stack_var delta) - ~replacement: - [Context_blind (fun () -> M.Instructions.(if_left hole hole))] - (); - replacement - ~fresh:[] - ~fresh_stack:[alpha; beta] - ~bef:(item bool (stack_var alpha)) - ~aft:(stack_var beta) - ~replacement:[Context_blind (fun () -> M.Instructions.(if_ hole hole))] - (); - replacement - ~fresh_stack:[alpha; beta] - ~bef:(stack_var alpha) - ~aft:(stack_var beta) - ~replacement: - [ - Context_blind - (fun () -> M.seq [M.Instructions.hole; M.Instructions.hole]); - ] - (); - replacement - ~fresh:[Plain alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(item (var alpha) (stack_var gamma)) - ~aft:(item (or_ (var alpha) (var beta)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.left)] - (); - replacement - ~fresh:[Plain alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(item (var beta) (stack_var gamma)) - ~aft:(item (or_ (var alpha) (var beta)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.right)] - (); - replacement - ~fresh:[Plain alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(stack_var gamma) - ~aft:(item (lambda (var alpha) (var beta)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.(lambda [hole]))] - (); - replacement - ~fresh:[Plain alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(stack_var gamma) - ~aft:(item (lambda (var alpha) (var beta)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.(lambda [hole]))] - (); - (* set/map/list*) - replacement - ~fresh:[Cmp alpha] - ~fresh_stack:[gamma] - ~bef: - (item - (var alpha) - (item bool (item (set (var alpha)) (stack_var gamma)))) - ~aft:(item (set (var alpha)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.update_set)] - (); - replacement - ~fresh:[Cmp alpha] - ~fresh_stack:[gamma] - ~bef:(stack_var gamma) - ~aft:(item (set (var alpha)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.empty_set)] - (); - replacement - ~fresh:[Cmp alpha] - ~fresh_stack:[gamma] - ~bef:(item (set (var alpha)) (stack_var gamma)) - ~aft:(stack_var gamma) - ~replacement: - [Context_blind (fun () -> M.Instructions.(iter_set [hole]))] - (); - replacement - ~fresh:[Cmp alpha] - ~fresh_stack:[gamma] - ~bef:(item (var alpha) (item (set (var alpha)) (stack_var gamma))) - ~aft:(item bool (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.mem_set)] - (); - replacement - ~fresh:[Cmp alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef: - (item - (var alpha) - (item - (option (var beta)) - (item (map (var alpha) (var beta)) (stack_var gamma)))) - ~aft:(item (map (var alpha) (var beta)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.update_map)] - (); - replacement - ~fresh:[Cmp alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(stack_var gamma) - ~aft:(item (map (var alpha) (var beta)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.empty_map)] - (); - replacement - ~fresh:[Cmp alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(item (map (var alpha) (var beta)) (stack_var gamma)) - ~aft:(stack_var gamma) - ~replacement: - [Context_blind (fun () -> M.Instructions.(iter_map [hole]))] - (); - replacement - ~fresh:[Cmp alpha; Plain beta; Plain delta] - ~fresh_stack:[gamma] - ~bef:(item (map (var alpha) (var beta)) (stack_var gamma)) - ~aft:(item (map (var alpha) (var delta)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.(map_map [hole]))] - (); - replacement - ~fresh:[Cmp alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef: - (item - (var alpha) - (item (map (var alpha) (var beta)) (stack_var gamma))) - ~aft:(item bool (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.mem_map)] - (); - replacement - ~fresh:[Cmp alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef: - (item - (var alpha) - (item (map (var alpha) (var beta)) (stack_var gamma))) - ~aft:(item (option (var beta)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.get_map)] - (); - (* lists *) - replacement - ~fresh:[Plain alpha] - ~fresh_stack:[gamma] - ~bef:(stack_var gamma) - ~aft:(item (list (var alpha)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.nil)] - (); - replacement - ~fresh:[Plain alpha] - ~fresh_stack:[gamma] - ~bef:(item (var alpha) (item (list (var alpha)) (stack_var gamma))) - ~aft:(item (list (var alpha)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.cons)] - (); - replacement - ~fresh:[Plain alpha] - ~fresh_stack:[gamma] - ~bef:(item (list (var alpha)) (stack_var gamma)) - ~aft:(stack_var gamma) - ~replacement: - [Context_blind (fun () -> M.Instructions.(iter_list [hole]))] - (); - replacement - ~fresh:[Plain alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(item (list (var alpha)) (stack_var gamma)) - ~aft:(item (list (var beta)) (stack_var gamma)) - ~replacement: - [Context_blind (fun () -> M.Instructions.(map_list [hole]))] - (); - (* sizes *) - replacement - ~fresh:[Cmp alpha] - ~fresh_stack:[gamma] - ~bef:(item (set (var alpha)) (stack_var gamma)) - ~aft:(item nat (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.size_set)] - (); - replacement - ~fresh:[Cmp alpha; Plain beta] - ~fresh_stack:[gamma] - ~bef:(item (map (var alpha) (var beta)) (stack_var gamma)) - ~aft:(item nat (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.size_map)] - (); - replacement - ~fresh:[Plain alpha] - ~fresh_stack:[gamma] - ~bef:(item (list (var alpha)) (stack_var gamma)) - ~aft:(item nat (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.size_list)] - (); - replacement - ~fresh:[] - ~fresh_stack:[gamma] - ~bef:(item string (stack_var gamma)) - ~aft:(item nat (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.size_string)] - (); - replacement - ~fresh:[] - ~fresh_stack:[gamma] - ~bef:(item bytes (stack_var gamma)) - ~aft:(item nat (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.size_bytes)] - (); - (* pack/unpack *) - replacement - ~fresh:[Plain alpha] - ~fresh_stack:[gamma] - ~bef:(item (var alpha) (stack_var gamma)) - ~aft:(item bytes (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.pack)] - (); - replacement - ~fresh:[Plain alpha] - ~fresh_stack:[gamma] - ~bef:(item bytes (stack_var gamma)) - ~aft:(item (option (var alpha)) (stack_var gamma)) - ~replacement:[Context_blind (fun () -> M.Instructions.unpack)] - (); - ] - - let rules = - [ - replace_any_instr_by_hole; - {rule_patt = match_instr_hole; replacements = instructions}; - ] -end - -module Data_rewrite_leaves - (Michelson_base : Michelson_samplers_base.S) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) = -struct - let hole_patt = - let open Patt in - prim_pred (fun prim -> prim = D_Hole) list_empty - - (* Matches a data hole *) - let match_hole = - let open Patt in - Pattern (focus hole_patt) - - (* Matches an integer literal *) - let match_int = - let open Patt in - Pattern (focus (prim_pred (fun prim -> prim = A_Int) list_any)) - - (* Matches a list literal *) - let match_list = - let open Patt in - Pattern (focus (prim_pred (fun prim -> prim = A_List) list_any)) - - (* Matches a set literal *) - let match_set = - let open Patt in - Pattern (focus (prim_pred (fun prim -> prim = A_Set) list_any)) - - (* Matches a map literal *) - let match_map = - let open Patt in - Pattern (focus (prim_pred (fun prim -> prim = A_Map) list_any)) - - (* Matches a timestamp literal *) - let match_timestamp = - let open Patt in - Pattern (focus (prim_pred (fun prim -> prim = A_Timestamp) list_any)) - - (* Matches a mutez literal *) - let match_mutez = - let open Patt in - Pattern (focus (prim_pred (fun prim -> prim = A_Mutez) list_any)) - - (* Matches a key_hash literal *) - let match_key_hash = - let open Patt in - Pattern (focus (prim_pred (fun prim -> prim = A_Key_hash) list_any)) - - let match_int_mutez_timestamp_key_hash_key_or_none = - let open Patt in - Pattern - (focus - (prim_pred - (function - | A_Int | A_Nat | A_Mutez | A_Timestamp | A_Key_hash | A_Key - | D_None -> - true - | _ -> false) - list_any)) - - (* Matches an empty list, set or map literal *) - let match_empty_list_set_or_map = - let open Patt in - Pattern - (focus - (prim_pred - (function A_List | A_Set | A_Map -> true | _ -> false) - (list_cons (seq list_empty) list_empty))) - - (* Matches a pair containing two holes*) - let match_empty_pair = - let open Patt in - Pattern - (focus - (prim_pred - (fun prim -> prim = D_Pair) - (list_cons hole_patt (list_cons hole_patt list_empty)))) - - (* Match a Some, Left or Right containing a hole *) - let match_empty_some_left_or_right = - let open Patt in - Pattern - (focus - (prim_pred - (function D_Left | D_Right | D_Some -> true | _ -> false) - (list_cons hole_patt list_empty))) - - (* Match a None constructor *) - let match_none = - let open Patt in - Pattern (focus (prim_pred (fun prim -> prim = D_None) list_empty)) - - (* rules *) - - (* fresh type variables *) - let alpha, beta = (-1, -2) - - let replacement ~fresh ~typ ~replacement = - { - type_constraint = Data_cnstrnt {cnstrnt = typ; fresh}; - replacement = [Context_blind (fun () -> replacement)]; - } - - let replacement_gen ~fresh ~typ ~replacement = - { - type_constraint = Data_cnstrnt {cnstrnt = typ; fresh}; - replacement = [Context_blind replacement]; - } - - let fill_in_hole rng_state = - let replace_by_singleton_list = - replacement - ~fresh:[alpha] - ~typ:Type.(list (var alpha)) - ~replacement:Mikhailsky.Data.(list [hole]) - in - let replace_by_empty_pair = - replacement - ~fresh:[alpha; beta] - ~typ:Type.(pair (var alpha) (var beta)) - ~replacement:Mikhailsky.Data.(pair hole hole) - in - let replace_by_singleton_set = - replacement - ~fresh:[alpha] - ~typ:Type.(set (var alpha)) - ~replacement:Mikhailsky.Data.(set [hole]) - in - let replace_by_singleton_map = - replacement - ~fresh:[alpha; beta] - ~typ:Type.(map (var alpha) (var beta)) - ~replacement:Mikhailsky.Data.(map [map_elt hole hole]) - in - let replace_by_random_int rng_state = - let type_constraint = Data_cnstrnt {cnstrnt = Type.int; fresh = []} in - let replacement = - Context_blind - (fun () -> - Mikhailsky.Data.big_integer - (Protocol.Script_int.to_zint (Michelson_base.int rng_state))) - in - {type_constraint; replacement = [replacement]} - in - let replace_by_left = - replacement - ~fresh:[alpha; beta] - ~typ:Type.(or_ (var alpha) (var beta)) - ~replacement:Mikhailsky.Data.(left hole) - in - let replace_by_right = - replacement - ~fresh:[alpha; beta] - ~typ:Type.(or_ (var alpha) (var beta)) - ~replacement:Mikhailsky.Data.(right hole) - in - let replace_by_some = - replacement - ~fresh:[alpha] - ~typ:Type.(option (var alpha)) - ~replacement:Mikhailsky.Data.(some hole) - in - let replace_by_none = - replacement - ~fresh:[alpha] - ~typ:Type.(option (var alpha)) - ~replacement:Mikhailsky.Data.none - in - let replace_by_mutez rng_state = - replacement_gen ~fresh:[] ~typ:Type.mutez ~replacement:(fun () -> - Mikhailsky.Data.mutez (Michelson_base.tez rng_state)) - in - let replace_by_key_hash rng_state = - replacement_gen ~fresh:[] ~typ:Type.key_hash ~replacement:(fun () -> - Mikhailsky.Data.key_hash (Crypto_samplers.pkh rng_state)) - in - let replace_by_key rng_state = - replacement_gen ~fresh:[] ~typ:Type.key ~replacement:(fun () -> - Mikhailsky.Data.key (Crypto_samplers.pk rng_state)) - in - { - rule_patt = match_hole; - replacements = - [ - replace_by_singleton_list; - replace_by_empty_pair; - replace_by_singleton_set; - replace_by_singleton_map; - replace_by_random_int rng_state; - replace_by_left; - replace_by_right; - replace_by_some; - replace_by_none; - replace_by_mutez rng_state; - replace_by_key_hash rng_state; - replace_by_key rng_state; - ]; - } - - let kill_empty_pair = - { - rule_patt = match_empty_pair; - replacements = - [ - { - type_constraint = No_cnstrnt; - replacement = [Context_blind (fun () -> Mikhailsky.Data.hole)]; - }; - ]; - } - - let kill_int_mutez_timestamp_key_hash_none = - { - rule_patt = match_int_mutez_timestamp_key_hash_key_or_none; - replacements = - [ - { - type_constraint = No_cnstrnt; - replacement = [Context_blind (fun () -> Mikhailsky.Data.hole)]; - }; - ]; - } - - let kill_empty_list_set_or_map = - { - rule_patt = match_empty_list_set_or_map; - replacements = - [ - { - type_constraint = No_cnstrnt; - replacement = [Context_blind (fun () -> Mikhailsky.Data.hole)]; - }; - ]; - } - - let kill_empty_some_left_or_right = - { - rule_patt = match_empty_some_left_or_right; - replacements = - [ - { - type_constraint = No_cnstrnt; - replacement = [Context_blind (fun () -> Mikhailsky.Data.hole)]; - }; - ]; - } - - let modify_set = - let grow_ungrow_set = - { - type_constraint = No_cnstrnt; - replacement = - [ - Context_aware - (fun set -> - match set with - | Micheline.Prim (_, A_Set, [Micheline.Seq (_, elements)], _) -> - Mikhailsky.Data.(set (hole :: elements)) - | _ -> assert false); - Context_aware - (fun set -> - match set with - | Micheline.Prim (_, A_Set, [Micheline.Seq (_, elements)], _) - -> ( - match elements with - | [] -> Mikhailsky.Data.hole - | _ :: tl -> Mikhailsky.Data.set tl) - | _ -> assert false); - ]; - } - in - {rule_patt = match_set; replacements = [grow_ungrow_set]} - - let modify_map = - let grow_ungrow_map = - { - type_constraint = No_cnstrnt; - replacement = - [ - Context_aware - (fun set -> - match set with - | Micheline.Prim (_, A_Map, [Micheline.Seq (_, elements)], _) -> - Mikhailsky.Data.(map (map_elt hole hole :: elements)) - | _ -> assert false); - Context_aware - (fun set -> - match set with - | Micheline.Prim (_, A_Map, [Micheline.Seq (_, elements)], _) - -> ( - match elements with - | [] -> Mikhailsky.Data.hole - | _ :: tl -> Mikhailsky.Data.map tl) - | _ -> assert false); - ]; - } - in - {rule_patt = match_map; replacements = [grow_ungrow_map]} - - let modify_list = - let grow_ungrow_list = - { - type_constraint = No_cnstrnt; - replacement = - [ - Context_aware - (fun list -> - match list with - | Micheline.Prim (_, A_List, [Micheline.Seq (_, terms)], _) -> - Mikhailsky.Data.(list (hole :: terms)) - | _ -> assert false); - Context_aware - (fun list -> - match list with - | Micheline.Prim (_, A_List, [Micheline.Seq (_, terms)], _) -> ( - match terms with - | [] -> Mikhailsky.Data.hole - | _ :: tl -> Mikhailsky.Data.list tl) - | _ -> assert false); - ]; - } - in - {rule_patt = match_list; replacements = [grow_ungrow_list]} - - let rules rng_state = - [ - fill_in_hole rng_state; - kill_empty_pair; - kill_empty_list_set_or_map; - kill_empty_some_left_or_right; - kill_int_mutez_timestamp_key_hash_none; - modify_list; - modify_set; - modify_map; - ] -end - -module Data - (Michelson_base : Michelson_samplers_base.S) - (Crypto_samplers : Crypto_samplers.Finite_key_pool_S) = -struct - let match_data_node = - let open Patt in - Pattern - (focus - (prim_pred - (function - | Mikhailsky_prim.D_Elt | D_Hole -> false - | D_False | D_Left | D_None | D_Pair | D_Right | D_Some | D_True - | D_Unit | A_Int | A_Nat | A_Set | A_List | A_Map | A_Key_hash - | A_Mutez | A_Timestamp | A_Key -> - true - | _ -> false) - list_any)) - - let match_list = - let open Patt in - Pattern (focus (prim_pred (fun prim -> prim = A_List) list_any)) - - let match_data_hole = - let open Patt in - Pattern (focus (prim_pred (fun prim -> prim = D_Hole) list_any)) - - let replace_by_hole = - let replace_by_hole = - { - type_constraint = No_cnstrnt; - replacement = [Context_blind (fun () -> Mikhailsky.Data.hole)]; - } - in - {rule_patt = match_data_node; replacements = [replace_by_hole]} - - let pack_root = - let replacement = - [ - Context_aware (fun node -> Mikhailsky.Data.list [node]); - Context_aware (fun node -> Mikhailsky.Data.(pair node hole)); - Context_aware (fun node -> Mikhailsky.Data.(pair hole node)); - ] - in - let guarded_replacements = [{type_constraint = No_cnstrnt; replacement}] in - {rule_patt = Root; replacements = guarded_replacements} - - module Data_rewrite_leaves_rules = - Data_rewrite_leaves (Michelson_base) (Crypto_samplers) - - let rules rng_state = - [ - Data_rewrite_leaves_rules.fill_in_hole rng_state; - replace_by_hole; - Data_rewrite_leaves_rules.modify_list; - Data_rewrite_leaves_rules.modify_map; - Data_rewrite_leaves_rules.modify_set; - ] -end diff --git a/src/proto_017_PtNairob/lib_benchmark/sampling_helpers.ml b/src/proto_017_PtNairob/lib_benchmark/sampling_helpers.ml deleted file mode 100644 index 8b36fc09e0bf983a58e280dd2eed654cbd151b67..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/sampling_helpers.ml +++ /dev/null @@ -1,41 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(* ------------------------------------------------------------------------- *) - -(* TODO: use Statz's def. of sampler once upstreamed. *) -type 'a sampler = Random.State.t -> 'a - -module M = struct - let ( let* ) : 'a sampler -> ('a -> 'b sampler) -> 'b sampler = - fun sampler f rng_state -> - let x = sampler rng_state in - f x rng_state - [@@inline] - - let bind = ( let* ) - - let return x _ = x -end diff --git a/src/proto_017_PtNairob/lib_benchmark/state_space.ml b/src/proto_017_PtNairob/lib_benchmark/state_space.ml deleted file mode 100644 index 60d14970e610336ca07a3b3976deb9883d38d654..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/state_space.ml +++ /dev/null @@ -1,78 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 state of rewriting is a typed term *) -type t = {typing : Inference.state lazy_t; term : Mikhailsky.node} - -let compare (term1 : t) (term2 : t) = - let tag1 = Mikhailsky.tag term1.term in - let tag2 = Mikhailsky.tag term2.term in - if tag1 < tag2 then -1 else if tag1 > tag2 then 1 else 0 - -let equal (term1 : t) (term2 : t) = - let tag1 = Mikhailsky.tag term1.term in - let tag2 = Mikhailsky.tag term2.term in - tag1 = tag2 - -let hash (t : t) = Mikhailsky.hash t.term - -type node_statistics = { - mutable size : int; - mutable bytes : int; - mutable holes : int; - mutable depth : int; -} - -let pp_statistics fmtr stats = - Format.fprintf - fmtr - "{ size = %d ; bytes = %d ; holes = %d }" - stats.size - stats.bytes - stats.holes - -let rec statistics stats depth (n : Mikhailsky.node) = - stats.size <- stats.size + 1 ; - stats.depth <- max depth stats.depth ; - match n with - | Micheline.Int (_, z) -> stats.bytes <- stats.bytes + (Z.numbits z / 8) - | Micheline.String (_, s) -> stats.bytes <- stats.bytes + String.length s - | Micheline.Bytes (_, b) -> stats.bytes <- stats.bytes + Bytes.length b - | Micheline.Prim (_, Mikhailsky_prim.I_Hole, _, _) - | Micheline.Prim (_, Mikhailsky_prim.D_Hole, _, _) -> - stats.holes <- stats.holes + 1 - | Micheline.Prim (_, _, subterms, _) | Micheline.Seq (_, subterms) -> - List.iter (statistics stats (depth + 1)) subterms - -let statistics {term; _} = - let stats = {size = 0; bytes = 0; holes = 0; depth = 0} in - statistics stats 0 term ; - stats - -let pp fmtr (state : t) = - Format.fprintf fmtr "current term:@." ; - Format.fprintf fmtr "%a@." Mikhailsky.pp state.term ; - Format.fprintf fmtr "stats:@." ; - Format.fprintf fmtr "%a:@." pp_statistics (statistics state) diff --git a/src/proto_017_PtNairob/lib_benchmark/test/dune b/src/proto_017_PtNairob/lib_benchmark/test/dune deleted file mode 100644 index 95c6cfb7bdfe0d0daac82c1316275c4b2e10c92e..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/test/dune +++ /dev/null @@ -1,40 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(executables - (names - test_sampling_data - test_sampling_code - test_autocompletion - test_distribution) - (libraries - octez-libs.base - octez-libs.micheline - tezos-micheline-rewriting - tezos-protocol-017-PtNairob.protocol - tezos-benchmark - tezos-benchmark-type-inference-017-PtNairob - tezos-benchmark-017-PtNairob - octez-protocol-017-PtNairob-libs.test-helpers - octez-libs.error-monad - prbnmcn-stats) - (link_flags - (:standard) - (:include %{workspace_root}/macos-link-flags.sexp)) - (flags - (:standard) - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_micheline - -open Tezos_protocol_017_PtNairob - -open Tezos_benchmark - -open Tezos_benchmark_type_inference_017_PtNairob - -open Tezos_benchmark_017_PtNairob - -open Tezos_017_PtNairob_test_helpers)) - -(rule - (alias runtest_micheline_rewriting_data) - (action (run %{exe:test_sampling_data.exe} 1234))) - -(rule - (alias runtest_micheline_rewriting_code) - (action (run %{exe:test_sampling_code.exe} 1234))) diff --git a/src/proto_017_PtNairob/lib_benchmark/test/test_autocompletion.ml b/src/proto_017_PtNairob/lib_benchmark/test/test_autocompletion.ml deleted file mode 100644 index c2f3e6c742956c823d50e5a08ea4aeff08fe3c19..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/test/test_autocompletion.ml +++ /dev/null @@ -1,120 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 rng_state = Random.State.make [|42; 987897; 54120|] - -module Crypto_samplers = Crypto_samplers.Make_finite_key_pool (struct - let algo = `Default - - let size = 16 -end) - -module Michelson_base_samplers = Michelson_samplers_base.Make (struct - let parameters = - let size = {Base_samplers.min = 4; max = 32} in - { - Michelson_samplers_base.int_size = size; - string_size = size; - bytes_size = size; - } -end) - -module Autocomp = Autocomp.Make (Michelson_base_samplers) (Crypto_samplers) - -let () = Format.eprintf "===============================@.%!" - -let () = Format.eprintf "Testing dummy program generator@.%!" - -let run x = x rng_state (Inference.M.empty ()) - -let invent_term bef aft = - let term, _state = run (Autocomp.invent_term bef aft) in - Mikhailsky.seq term - -let invent_term bef aft = - Format.eprintf - "requested type: %a => %a@." - Type.Stack.pp - bef - Type.Stack.pp - aft ; - let term = invent_term bef aft in - let bef', aft' = Inference.infer term in - Format.eprintf - "generated type: %a => %a@." - Type.Stack.pp - bef' - Type.Stack.pp - aft' ; - Format.eprintf "%a@." Mikhailsky.pp term - -module T = Type - -let bef = T.(item unit (item unit (item unit empty))) - -let aft = T.(item int (item unit (item (pair nat nat) empty))) - -let () = invent_term bef aft - -let () = Format.eprintf "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@.%!" - -let () = invent_term bef aft - -let () = Format.eprintf "===============================@.%!" - -let () = Format.eprintf "Testing completion@.%!" - -let complete term = - Format.eprintf "term: %a@." Mikhailsky.pp term ; - let (bef, aft), state = Inference.infer_with_state term in - Format.eprintf "Inferred type: %a => %a@." Type.Stack.pp bef Type.Stack.pp aft ; - let term, (bef', aft'), _state = - Autocomp.complete_code state term rng_state - in - Format.eprintf "completed: %a@." Mikhailsky.pp term ; - Format.eprintf - "Inferred type after generation: %a => %a@." - Type.Stack.pp - bef' - Type.Stack.pp - aft' ; - let node = - Micheline.strip_locations @@ Mikhailsky_to_michelson.convert term state - in - let bef' = Type_helpers.stack_type_to_michelson_type_list bef' in - Test_helpers.typecheck_by_tezos bef' node - -open Mikhailsky -open Instructions - -let push_int = Instructions.push int_ty (Data.big_integer (Z.of_int 100)) - -let add_ii = Instructions.(add Mikhailsky.int_ty Mikhailsky.int_ty) - -let () = complete (lambda [if_left right (dip (seq [push_int; hole]))]) - -let () = Format.eprintf "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@.%!" - -let () = complete (seq [push_int; add_ii; lambda [dip (seq [dup; dip hole])]]) diff --git a/src/proto_017_PtNairob/lib_benchmark/test/test_distribution.ml b/src/proto_017_PtNairob/lib_benchmark/test/test_distribution.ml deleted file mode 100644 index 8c9e46c21fc77c850f09f2d266dc27f401ebf9a3..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/test/test_distribution.ml +++ /dev/null @@ -1,151 +0,0 @@ -open Michelson_samplers -open Protocol -open Internal_for_tests - -let pp_type_name fmtr (t : type_name) = - Format.pp_print_string fmtr - @@ - match t with - | `TString -> "string" - | `TNat -> "nat" - | `TPair -> "pair" - | `TKey -> "key" - | `TLambda -> "lambda" - | `TOr -> "or" - | `TOperation -> "operation" - | `TOption -> "option" - | `TSapling_state -> "sapling_state" - | `TBytes -> "bytes" - | `TChain_id -> "chain_id" - | `TBool -> "bool" - | `TBls12_381_g2 -> "bls12_381_g2" - | `TTicket -> "ticket" - | `TMap -> "map" - | `TAddress -> "address" - | `TContract -> "contract" - | `TBls12_381_fr -> "bls12_381_fr" - | `TSapling_transaction -> "sapling_transaction" - | `TSapling_transaction_deprecated -> "sapling_transaction_deprecated" - | `TTimestamp -> "timestamp" - | `TKey_hash -> "key_hash" - | `TBig_map -> "big_map" - | `TSet -> "set" - | `TBls12_381_g1 -> "bls12_381_g1" - | `TList -> "list" - | `TMutez -> "mutez" - | `TSignature -> "signature" - | `TUnit -> "unit" - | `TInt -> "int" - -module Type_name = struct - type t = type_name - - let equal (x : t) (y : t) = x = y - - let pp = pp_type_name - - let hash = Stdlib.Hashtbl.hash -end - -module Type_name_hashtbl = Stdlib.Hashtbl.Make (Type_name) - -let rec tnames_of_type : - type a ac. (a, ac) Script_typed_ir.ty -> type_name list -> type_name list = - fun t acc -> - match t with - | Script_typed_ir.Unit_t -> `TUnit :: acc - | Script_typed_ir.Int_t -> `TInt :: acc - | Script_typed_ir.Nat_t -> `TNat :: acc - | Script_typed_ir.Signature_t -> `TSignature :: acc - | Script_typed_ir.String_t -> `TString :: acc - | Script_typed_ir.Bytes_t -> `TBytes :: acc - | Script_typed_ir.Mutez_t -> `TMutez :: acc - | Script_typed_ir.Key_hash_t -> `TKey_hash :: acc - | Script_typed_ir.Key_t -> `TKey :: acc - | Script_typed_ir.Timestamp_t -> `TTimestamp :: acc - | Script_typed_ir.Address_t -> `TAddress :: acc - | Script_typed_ir.Tx_rollup_l2_address_t -> assert false - | Script_typed_ir.Bool_t -> `TBool :: acc - | Script_typed_ir.Pair_t (lty, rty, _, _) -> - tnames_of_type lty (tnames_of_type rty (`TPair :: acc)) - | Script_typed_ir.Or_t (lty, rty, _, _) -> - tnames_of_type lty (tnames_of_type rty (`TOr :: acc)) - | Script_typed_ir.Lambda_t (dom, range, _) -> - tnames_of_type dom (tnames_of_type range (`TLambda :: acc)) - | Script_typed_ir.Option_t (ty, _, _) -> tnames_of_type ty (`TOption :: acc) - | Script_typed_ir.List_t (ty, _) -> tnames_of_type ty (`TList :: acc) - | Script_typed_ir.Set_t (ty, _) -> tnames_of_type ty (`TSet :: acc) - | Script_typed_ir.Map_t (kty, vty, _) -> - tnames_of_type kty (tnames_of_type vty (`TMap :: acc)) - | Script_typed_ir.Big_map_t (kty, vty, _) -> - tnames_of_type kty (tnames_of_type vty (`TBig_map :: acc)) - | Script_typed_ir.Contract_t (ty, _) -> tnames_of_type ty (`TContract :: acc) - | Script_typed_ir.Sapling_transaction_t _ -> `TSapling_transaction :: acc - | Script_typed_ir.Sapling_transaction_deprecated_t _ -> - `TSapling_transaction_deprecated :: acc - | Script_typed_ir.Sapling_state_t _ -> `TSapling_state :: acc - | Script_typed_ir.Operation_t -> `TOperation :: acc - | Script_typed_ir.Chain_id_t -> `TChain_id :: acc - | Script_typed_ir.Never_t -> assert false - | Script_typed_ir.Bls12_381_g1_t -> `TBls12_381_g1 :: acc - | Script_typed_ir.Bls12_381_g2_t -> `TBls12_381_g2 :: acc - | Script_typed_ir.Bls12_381_fr_t -> `TBls12_381_fr :: acc - | Script_typed_ir.Ticket_t (ty, _) -> tnames_of_type ty (`TTicket :: acc) - | Script_typed_ir.Chest_key_t -> assert false - | Script_typed_ir.Chest_t -> assert false - -module Crypto_samplers = Crypto_samplers.Make_finite_key_pool (struct - let algo = `Default - - let size = 16 -end) - -module Sampler = - Michelson_samplers.Make - (struct - let parameters = - { - base_parameters = - { - Michelson_samplers_base.int_size = {min = 8; max = 32}; - string_size = {min = 8; max = 128}; - bytes_size = {min = 8; max = 128}; - }; - list_size = {min = 10; max = 1000}; - set_size = {min = 10; max = 1000}; - map_size = {min = 10; max = 1000}; - } - end) - (Crypto_samplers) - -open Stats - -let tnames_dist : type_name list -> type_name Fin.Float.prb = - fun tnames -> - Emp.of_raw_data (Array.of_list tnames) - |> Fin.Float.counts_of_empirical (module Type_name_hashtbl) - |> Fin.Float.normalize - -let rec sample nsamples acc = - let open Sampling_helpers.M in - if nsamples = 0 then return acc - else - let* size = - Base_samplers.(sample_in_interval ~range:{min = 1; max = 1000}) - in - let* (Ex_ty ty) = Sampler.Random_type.m_type ~size in - let* acc = sample (nsamples - 1) acc in - return (tnames_of_type ty acc) - -let sample nsamples = sample nsamples [] - -let dist nsamples = - let open Sampling_helpers.M in - let* samples = sample nsamples in - return (tnames_dist samples) - -let () = - Format.printf - "stats:@.%a@." - (Fin.Float.pp_fin_mes Type_name.pp) - (Fin.Float.as_measure (dist 500 (Random.State.make [|0x1337; 0x533D|]))) diff --git a/src/proto_017_PtNairob/lib_benchmark/test/test_helpers.ml b/src/proto_017_PtNairob/lib_benchmark/test/test_helpers.ml deleted file mode 100644 index 8d5db86cc9ed35d7ec3d61b65cfe1fe4d0febe7f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/test/test_helpers.ml +++ /dev/null @@ -1,91 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 rng_state = Random.State.make [|42; 987897; 54120|] - -let print_script_expr fmtr (expr : Protocol.Script_repr.expr) = - Micheline_printer.print_expr - fmtr - (Micheline_printer.printable - Protocol.Michelson_v1_primitives.string_of_prim - expr) - -let print_script_expr_list fmtr (exprs : Protocol.Script_repr.expr list) = - Format.pp_print_list - ~pp_sep:(fun fmtr () -> Format.fprintf fmtr " :: ") - print_script_expr - fmtr - exprs - -let typecheck_by_tezos = - let context_init_memory ~rng_state = - Context.init_n - ~rng_state - ~bootstrap_balances: - [ - 4_000_000_000_000L; - 4_000_000_000_000L; - 4_000_000_000_000L; - 4_000_000_000_000L; - 4_000_000_000_000L; - ] - 5 - () - >>=? fun (block, _accounts) -> - Context.get_constants (B block) >>=? fun csts -> - let minimal_block_delay = - Protocol.Alpha_context.Period.to_seconds - csts.parametric.minimal_block_delay - in - Incremental.begin_construction - ~timestamp: - (Tezos_base.Time.Protocol.add - block.header.shell.timestamp - minimal_block_delay) - block - >>=? fun vs -> - let ctxt = Incremental.alpha_ctxt vs in - (* Required for eg Create_contract *) - return - @@ Protocol.Alpha_context.Origination_nonce.init - ctxt - Tezos_crypto.Hashed.Operation_hash.zero - in - fun bef node -> - Stdlib.Result.get_ok - (Lwt_main.run - ( context_init_memory ~rng_state >>=? fun ctxt -> - let (Protocol.Script_ir_translator.Ex_stack_ty bef) = - Type_helpers.michelson_type_list_to_ex_stack_ty bef ctxt - in - Protocol.Script_ir_translator.parse_instr - Protocol.Script_tc_context.data - ctxt - ~elab_conf: - (Protocol.Script_ir_translator_config.make ~legacy:false ()) - (Micheline.root node) - bef - >|= Environment.wrap_tzresult - >>=? fun _ -> return_unit )) diff --git a/src/proto_017_PtNairob/lib_benchmark/test/test_sampling_code.ml b/src/proto_017_PtNairob/lib_benchmark/test/test_sampling_code.ml deleted file mode 100644 index e5e8edf378d5c87a4ab171f387d082a782e2e89d..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/test/test_sampling_code.ml +++ /dev/null @@ -1,96 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(* Input parameter parsing *) - -let verbose = - if Array.length Sys.argv < 2 then ( - Format.eprintf "Executable expects random seed on input\n%!" ; - exit 1) - else - (Random.init (int_of_string Sys.argv.(1)) ; - List.exists (( = ) "-v")) - (Array.to_list Sys.argv) - -(* ------------------------------------------------------------------------- *) -(* Base sampler parameters *) - -let state = Random.State.make [|42; 987897; 54120|] - -module Crypto_samplers = Crypto_samplers.Make_finite_key_pool (struct - let algo = `Default - - let size = 16 -end) - -module Michelson_base_samplers = Michelson_samplers_base.Make (struct - let parameters = - let size = {Base_samplers.min = 4; max = 32} in - { - Michelson_samplers_base.int_size = size; - string_size = size; - bytes_size = size; - } -end) - -(* ------------------------------------------------------------------------- *) -(* MCMC instantiation *) - -module Code = - Michelson_mcmc_samplers.Make_code_sampler - (Michelson_base_samplers) - (Crypto_samplers) - (struct - let rng_state = state - - let target_size = 500 - - let verbosity = if verbose then `Trace else `Silent - end) - -let start = Unix.gettimeofday () - -let generator = Code.generator ~burn_in:(500 * 7) state - -let stop = Unix.gettimeofday () - -let () = Format.printf "Burn in time: %f seconds@." (stop -. start) - -let _ = - for i = 1 to 1000 do - let Michelson_mcmc_samplers.{term = michelson; bef; aft} = - generator state - in - Test_helpers.typecheck_by_tezos bef michelson ; - if verbose then ( - Format.eprintf "result %d/1000:@." i ; - Format.eprintf - "type: %a => %a@." - Test_helpers.print_script_expr_list - bef - Test_helpers.print_script_expr_list - aft ; - Format.eprintf "%a@." Test_helpers.print_script_expr michelson) - done diff --git a/src/proto_017_PtNairob/lib_benchmark/test/test_sampling_data.ml b/src/proto_017_PtNairob/lib_benchmark/test/test_sampling_data.ml deleted file mode 100644 index fb67a046d1ef33ccfd2970c4419e48a293c74273..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/test/test_sampling_data.ml +++ /dev/null @@ -1,85 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(* Input parameter parsing *) - -let verbose = - if Array.length Sys.argv < 2 then ( - Format.eprintf "Executable expects random seed on input\n%!" ; - exit 1) - else - (Random.init (int_of_string Sys.argv.(1)) ; - List.exists (( = ) "-v")) - (Array.to_list Sys.argv) - -(* ------------------------------------------------------------------------- *) -(* MCMC instantiation *) - -let state = Random.State.make [|42; 987897; 54120|] - -module Crypto_samplers = Crypto_samplers.Make_finite_key_pool (struct - let algo = `Default - - let size = 16 -end) - -module Michelson_base_samplers = Michelson_samplers_base.Make (struct - let parameters = - let size = {Base_samplers.min = 4; max = 32} in - { - Michelson_samplers_base.int_size = size; - string_size = size; - bytes_size = size; - } -end) - -module Data = - Michelson_mcmc_samplers.Make_data_sampler - (Michelson_base_samplers) - (Crypto_samplers) - (struct - let rng_state = state - - let target_size = 500 - - let verbosity = if verbose then `Trace else `Silent - end) - -let start = Unix.gettimeofday () - -let generator = Data.generator ~burn_in:(200 * 7) state - -let stop = Unix.gettimeofday () - -let () = Format.printf "Burn in time: %f seconds@." (stop -. start) - -let _ = - for _i = 0 to 1000 do - let Michelson_mcmc_samplers.{term = michelson; typ} = generator state in - if verbose then ( - Format.eprintf "result:@." ; - Format.eprintf "type: %a@." Test_helpers.print_script_expr typ ; - Format.eprintf "%a@." Test_helpers.print_script_expr michelson) - done diff --git a/src/proto_017_PtNairob/lib_benchmark/type_helpers.ml b/src/proto_017_PtNairob/lib_benchmark/type_helpers.ml deleted file mode 100644 index 989ee77829014888dcff9f722c83d51cafbb474b..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/type_helpers.ml +++ /dev/null @@ -1,88 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 conversion helpers *) - -open Protocol - -exception Type_helpers_error of string - -let helpers_error msg = raise (Type_helpers_error msg) - -(* Convert a Micheline-encoded type to its internal GADT format. *) -let michelson_type_to_ex_ty (typ : Alpha_context.Script.expr) - (ctxt : Alpha_context.t) = - Script_ir_translator.parse_ty - ctxt - ~legacy:false - ~allow_lazy_storage:false - ~allow_operation:false - ~allow_contract:false - ~allow_ticket:false - (Micheline.root typ) - |> Environment.wrap_tzresult - |> function - | Ok (ex_ty, _ctxt) -> ex_ty - | Error errs -> - let msg = - Format.asprintf - "Michelson_generation.michelson_type_to_ex_ty (%a)" - Error_monad.pp_print_trace - errs - in - helpers_error msg - -(* Convert a list of Micheline-encoded Michelson types to the - internal GADT format. *) -let rec michelson_type_list_to_ex_stack_ty - (stack_ty : Alpha_context.Script.expr list) ctxt = - let open Script_ir_translator in - let open Script_typed_ir in - match stack_ty with - | [] -> Ex_stack_ty Bot_t - | hd :: tl -> ( - let ex_ty = michelson_type_to_ex_ty hd ctxt in - match ex_ty with - | Ex_ty ty -> ( - let ex_stack_ty = michelson_type_list_to_ex_stack_ty tl ctxt in - match ex_stack_ty with - | Ex_stack_ty tl -> Ex_stack_ty (Item_t (ty, tl)))) - -let base_type_to_michelson_type (typ : Type.Base.t) = - let typ = Mikhailsky.map_var (fun _ -> Mikhailsky.unit_ty) typ in - Mikhailsky.to_michelson typ - -(* Convert a Mikhailsky stack to a list of Micheline-encoded types *) -let rec stack_type_to_michelson_type_list (typ : Type.Stack.t) = - let node = typ.node in - match node with - | Type.Stack.Stack_var_t _ -> - helpers_error "stack_type_to_michelson_type_list: bug found" - | Type.Stack.Empty_t -> [] - | Type.Stack.Item_t (ty, tl) -> - base_type_to_michelson_type ty :: stack_type_to_michelson_type_list tl - -let base_type_to_ex_ty ty = - michelson_type_to_ex_ty (base_type_to_michelson_type ty) diff --git a/src/proto_017_PtNairob/lib_benchmark/type_helpers.mli b/src/proto_017_PtNairob/lib_benchmark/type_helpers.mli deleted file mode 100644 index 0cf310d3afcfead9e171aa0b5cb171527a7c07e1..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmark/type_helpers.mli +++ /dev/null @@ -1,57 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 conversion helpers *) - -open Protocol - -(** Exception raised in case an error occurs in this module. *) -exception Type_helpers_error of string - -(** [michelson_type_list_to_ex_stack_ty] converts a list of types in - Micheline form to a stack type in IR form. - - @raise Type_helpers_error if parsing the Michelson type fails. - *) -val michelson_type_list_to_ex_stack_ty : - Alpha_context.Script.expr list -> - Alpha_context.t -> - Script_ir_translator.ex_stack_ty - -(** [michelson_type_to_ex_ty ty ctxt] parses the type [ty]. - - @raise Type_helpers_error if an error arises during parsing. *) -val michelson_type_to_ex_ty : - Alpha_context.Script.expr -> Alpha_context.t -> Script_typed_ir.ex_ty - -(** [stack_type_to_michelson_type_list] converts a Mikhailsky stack type - to a stack represented as a list of Micheline expressions, each - element denoting a type on the stack type. - - @raise Type_helpers_error if the stack type contains variables. *) -val stack_type_to_michelson_type_list : Type.Stack.t -> Script_repr.expr list - -(** [base_type_to_ex_ty] converts a Mikhailsky type to a Michelson one. *) -val base_type_to_ex_ty : Type.Base.t -> Alpha_context.t -> Script_typed_ir.ex_ty diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/apply_benchmarks.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/apply_benchmarks.ml deleted file mode 100644 index 56f9a8783e51d5a0008005112fcc7ba1bd891e7d..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/apply_benchmarks.ml +++ /dev/null @@ -1,152 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* *) -(* 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 Tezos_benchmark - -let ns = Namespace.make Registration_helpers.ns "apply" - -let fv s = Free_variable.of_namespace (ns s) - -let initial_balance = 4_000_000_000_000L - -let make_context ~rng_state = - let open Lwt_result_syntax in - let* block, (_, src, dst) = - Context.init3 - ~rng_state - ~bootstrap_balances:[initial_balance; initial_balance; initial_balance] - () - in - Context.get_constants (B block) >>=? fun csts -> - let minimal_block_delay = - Protocol.Alpha_context.Period.to_seconds csts.parametric.minimal_block_delay - in - Incremental.begin_construction - ~timestamp: - (Time.Protocol.add block.header.shell.timestamp minimal_block_delay) - block - >>=? fun vs -> - let ctxt = Incremental.alpha_ctxt vs in - let ctxt = - (* Required for eg Create_contract *) - Protocol.Alpha_context.Origination_nonce.init - ctxt - Tezos_crypto.Hashed.Operation_hash.zero - in - return (ctxt, src, dst) - -module Take_fees_benchmark = struct - let name = ns "Take_fees" - - let info = "Benchmark for take_fees" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let tags = ["apply"] - - type config = unit - - let config_encoding = Data_encoding.unit - - let default_config = () - - type workload = {batch_length : int} - - let workload_encoding = - let open Data_encoding in - conv - (fun {batch_length} -> batch_length) - (fun batch_length -> {batch_length}) - (obj1 (req "batch_length" int31)) - - let workload_to_vector {batch_length} = - Sparse_vec.String.of_list [("batch_length", float_of_int batch_length)] - - let model = - Model.make - ~conv:(fun {batch_length} -> (batch_length, ())) - (Model.affine - ~name - ~intercept:(fv "take_fees_const") - ~coeff:(fv "take_fees_coeff")) - - let models = [("take_fees", model)] - - let benchmark rng_state _conf () = - let open Annotated_manager_operation in - let open Alpha_context in - let open Lwt_result_syntax in - let batch_length = - Base_samplers.sample_in_interval ~range:{min = 1; max = 100} rng_state - in - let workload = {batch_length} in - let closure_result = - Lwt_main.run - (let* ctxt, src, dest = make_context ~rng_state in - let* parameters = Client_proto_context.parse_arg_transfer None in - let transaction = - Transaction - { - amount = Tez.one; - parameters; - entrypoint = Entrypoint_repr.default; - destination = dest; - } - in - let pkh = match src with Implicit pkh -> pkh | _ -> assert false in - let manager_info = - Manager_info - { - source = Some pkh; - fee = Limit.known Tez.one; - gas_limit = Limit.known (Gas.Arith.integral_exn (Z.of_int 2000)); - storage_limit = Limit.known (Z.of_int 10); - counter = Some (Manager_counter.Internal_for_tests.of_int 0); - operation = transaction; - } - in - let tr = Annotated_manager_operation manager_info in - let transaction_list = List.repeat batch_length tr in - let (Manager_list annotated_list) = manager_of_list transaction_list in - let* batch = Lwt.return (manager_list_from_annotated annotated_list) in - let closure () = - Protocol.Apply.Internal_for_benchmark.take_fees ctxt batch - in - return closure) - in - let closure = - match closure_result with - | Ok c -> c - | Error _ -> assert false (* TODO better error *) - in - Generator.Plain {workload; closure} - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (benchmark rng_state config) -end - -let () = Registration_helpers.register (module Take_fees_benchmark) diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/benchmarks_proto.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/benchmarks_proto.ml deleted file mode 100644 index c2cc3a351806b1c8c5de2f44ba001bff77bc0088..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/benchmarks_proto.ml +++ /dev/null @@ -1,125 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* *) -(* 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 Benchmark_base = Benchmark - -module Benchmark = struct - module type S = sig - val name : Namespace.t - - val info : string - - val module_filename : string - - val tags : string list - - type config - - val default_config : config - - val config_encoding : config Data_encoding.t - - type workload - - val workload_encoding : workload Data_encoding.t - - val workload_to_vector : workload -> Sparse_vec.String.t - - val model : name:Namespace.t -> workload Model.t - - val generated_code_destination : string option - - val create_benchmark : - rng_state:Random.State.t -> config -> workload Generator.benchmark - end - - type t = (module S) -end - -module Registration = struct - let ns = Namespace.root - - let register ((module Bench) : Benchmark.t) = - let module B : Benchmark_base.S = struct - include Bench - - let purpose = - match generated_code_destination with - | Some x -> Benchmark_base.Generate_code x - | None -> Other_purpose "unused" - - let models = - [(Namespace.(cons name "model" |> to_string), Bench.model ~name)] - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (fun () -> - Bench.create_benchmark ~rng_state config) - end in - Registration_helpers.register (module B : Benchmark_base.S) - - let register_simple_with_num ((module Bench) : Benchmark_base.simple_with_num) - = - let module B : Benchmark_base.Simple_with_num = struct - include Bench - - let tags = Tags.common :: tags - end in - Registration.register_simple_with_num - (module B : Benchmark_base.Simple_with_num) - - let register_as_simple_with_num (module B : Benchmark_base.S) = - let modules = - List.map - (fun (model_name, model) : (module Benchmark_base.Simple_with_num) -> - (module struct - include B - - let name = Namespace.cons name model_name - - let group = Benchmark_base.Group model_name - - let model = model - end)) - B.models - in - List.iter (fun x -> register_simple_with_num x) modules -end - -module Model = struct - include Model - - let make ~name ~conv model = make ~conv (model name) - - let affine ?intercept ?coeff name = - let ns s = Free_variable.of_namespace (Namespace.cons name s) in - let intercept = Option.value ~default:(ns "intercept") intercept in - let coeff = Option.value ~default:(ns "coeff") coeff in - affine ~name ~intercept ~coeff - - let logn ?coeff name = - let ns s = Free_variable.of_namespace (Namespace.cons name s) in - let coeff = Option.value ~default:(ns "coeff") coeff in - logn ~name ~coeff -end diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/benchmarks_proto.mli b/src/proto_017_PtNairob/lib_benchmarks_proto/benchmarks_proto.mli deleted file mode 100644 index 0a716d7b749711142dce7a2b3dd10cfa7c5badc7..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/benchmarks_proto.mli +++ /dev/null @@ -1,106 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* *) -(* 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 Benchmark_base = Benchmark - -module Benchmark : sig - (** The module type of benchmarks, a simplification of {!Benchmark.S} used by - [registration_simple] below. *) - module type S = sig - (** Name of the benchmark *) - val name : Namespace.t - - (** Description of the benchmark *) - val info : string - - (** Filename of the benchmark module *) - val module_filename : string - - (** Tags of the benchmark *) - val tags : string list - - (** Configuration of the benchmark (eg sampling parameters, paths, etc) *) - type config - - (** Default configuration of the benchmark *) - val default_config : config - - (** Configuration encoding *) - val config_encoding : config Data_encoding.t - - (** Benchmark workload *) - type workload - - (** Workload encoding *) - val workload_encoding : workload Data_encoding.t - - (** Optional conversion to vector, for report generation purposes *) - val workload_to_vector : workload -> Sparse_vec.String.t - - (** Cost model *) - val model : name:Namespace.t -> workload Model.t - - (** Generated code file location, automatically prefix by - "src/proto_alpha/lib_protocol/" - and suffixed by - "_costs_generated.ml". - It is optional in case some benchmarks don't output code, but are used - for verification purposes. *) - val generated_code_destination : string option - - (** Creates a benchmark, ready to be run. - The benchmarks are thunked to prevent evaluating the workload until - needed. *) - val create_benchmark : - rng_state:Random.State.t -> config -> workload Generator.benchmark - end - - type t = (module S) -end - -module Registration : sig - val ns : Namespace.cons - - (** Registers a benchmark with a model, model names are uniformely generated - *) - val register : Benchmark.t -> unit - - val register_as_simple_with_num : Benchmark_base.t -> unit -end - -module Model : sig - open Model - - val make : - name:Namespace.t -> conv:('a -> 'b) -> (Namespace.t -> 'b model) -> 'a t - - val affine : - ?intercept:Free_variable.t -> - ?coeff:Free_variable.t -> - Namespace.t -> - (int * unit) model - - val logn : ?coeff:Free_variable.t -> Namespace.t -> (int * unit) model -end diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/cache_benchmarks.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/cache_benchmarks.ml deleted file mode 100644 index 2d804f5c39f5c5e67a93357bf654456af5b600ea..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/cache_benchmarks.ml +++ /dev/null @@ -1,205 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 ns = Namespace.make Registration_helpers.ns "cache" - -let fv s = Free_variable.of_namespace (ns s) - -(** {2 [Alpha_context.Cache]-related benchmarks} *) - -let assert_ok_lwt x = - match Lwt_main.run x with Ok x -> x | Error _ -> assert false - -let assert_ok = function Ok x -> x | Error _ -> assert false - -module Admin = Alpha_context.Cache.Admin - -(** We can't construct a dummy cache client from outside the protocol. - We'll have to benchmark the {!Environment_cache} through the interface - exposed by {!Script_cache}. *) -module Cache = Script_cache - -(** {2 Constructing a dummy cached value} *) - -let make_context ~rng_state = - Execution_context.make ~rng_state |> assert_ok_lwt |> fst - -let throwaway_context = - let rng_state = Random.State.make [|0x1337; 0x533D|] in - make_context ~rng_state - -let dummy_script : Cache.cached_contract = - let str = "{ parameter unit; storage unit; code FAILWITH }" in - let storage = - let parsed, _ = Michelson_v1_parser.parse_expression "Unit" in - Alpha_context.Script.lazy_expr parsed.expanded - in - let code = - let parsed, _ = Michelson_v1_parser.parse_expression ~check:false str in - Alpha_context.Script.lazy_expr parsed.expanded - in - let script = Alpha_context.Script.{code; storage} in - let ex_script, _ = - Script_ir_translator.parse_script - throwaway_context - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) - ~allow_forged_in_storage:false - script - |> assert_ok_lwt - in - (script, ex_script) - -(** {2 Creating dummy cache value identifiers.} *) - -(** Configuration shared among all cache benchmarks. *) -module Cache_shared_config = struct - type config = unit - - let config_encoding = Data_encoding.unit - - let default_config = () - - type workload = {cache_cardinal : int} - - let workload_encoding = - let open Data_encoding in - conv - (fun {cache_cardinal} -> cache_cardinal) - (fun cache_cardinal -> {cache_cardinal}) - (obj1 (req "cache_cardinal" int31)) - - let tags = [Tags.cache] - - let workload_to_vector {cache_cardinal} = - Sparse_vec.String.of_list [("cache_cardinal", float_of_int cache_cardinal)] -end - -(* We can't produce a Script_cache.identifier without calling [Script_cache.find]. *) -let identifier_of_contract (c : Contract_hash.t) : Cache.identifier = - let _, id, _ = Cache.find throwaway_context c |> assert_ok_lwt in - id - -let contract_of_int i : Contract_hash.t = - Contract_hash.(of_b58check_exn (to_b58check (hash_string [string_of_int i]))) - -let identifier_of_int i = identifier_of_contract @@ contract_of_int i - -(** Prepare a context with a cache of the prescribed cardinality. A key in the domain of - the cache is returned along the context: this key is used to benchmark - (successful) cache accesses. *) -let prepare_context rng_state cache_cardinal = - assert (cache_cardinal > 0) ; - let ctxt = make_context ~rng_state in - let some_key_in_domain = identifier_of_int 0 in - let rec loop i ctxt = - if Compare.Int.(i = cache_cardinal) then ctxt - else - let key = identifier_of_int i in - loop (i + 1) (Cache.update ctxt key dummy_script 1 |> assert_ok) - in - (loop 0 ctxt, some_key_in_domain) - -(** Benchmark {!Script_cache.update}. This almost directly calls {!Environment_cache.update}. - We also use the result of this benchmark to assign a cost to {!Environment_cache.find}, - which alas can't be directly benchmarked from the interface provided by {!Script_cache}. *) -module Cache_update_benchmark : Benchmark.S = struct - include Cache_shared_config - - let name = ns "CACHE_UPDATE" - - let info = "Benchmarking the time it takes to update a key in the cache" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - (** It is expected that cache keys are non-adversarial, - ie do not share a long common prefix. This is the case for [Script_cache], - for which the keys are B58-encoded contract hashes. - - To rephrase: with high probability, comparing two keys in the domain of the cache is - a constant-time operation (two keys will differ after the first few characters). - We therefore do not take into account the length of the key in the model. *) - let model = - let affine_logn ~intercept ~coeff = - let open Model in - let module M = struct - let name = name - - type arg_type = int * unit - - let takes_saturation_reprs = false - - module Def (X : Costlang.S) = struct - open X - - type model_type = size -> size - - let arity = arity_1 - - let model = - lam ~name:"size" @@ fun size -> - free ~name:intercept + (free ~name:coeff * log2 (int 1 + size)) - end - end in - (module M : Model_impl with type arg_type = int * unit) - in - (* Looking at the plots, it looks like this benchmark underestimates the constant term. - In the interpreter, this would warrant a dedicated benchmark for the intercept. *) - let intercept_variable = - fv (Format.asprintf "%s_const" (Namespace.basename name)) - in - let coeff_variable = - fv (Format.asprintf "%s_coeff" (Namespace.basename name)) - in - Model.make - ~conv:(function {cache_cardinal} -> (cache_cardinal, ())) - (affine_logn ~intercept:intercept_variable ~coeff:coeff_variable) - - let models = [("cache_model", model)] - - let cache_update_benchmark ctxt some_key_in_domain cache_cardinal = - let workload = {cache_cardinal} in - let closure () = - ignore (Cache.update ctxt some_key_in_domain dummy_script 1) - in - Generator.Plain {workload; closure} - - (** At the time of writing (Protocol H) the worst case execution path for - [Cache.update] is to update a key which is already present. *) - let make_bench rng_state _cfg () = - let cache_cardinal = - Base_samplers.sample_in_interval ~range:{min = 1; max = 100_000} rng_state - in - let ctxt, some_key_in_domain = prepare_context rng_state cache_cardinal in - cache_update_benchmark ctxt some_key_in_domain cache_cardinal - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (make_bench rng_state config) -end - -let () = Registration_helpers.register (module Cache_update_benchmark) diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/carbonated_map_benchmarks.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/carbonated_map_benchmarks.ml deleted file mode 100644 index e47ec1e66f221e6d9b4c6c8e48fb25fb0741d11c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/carbonated_map_benchmarks.ml +++ /dev/null @@ -1,352 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Tezos_benchmark - -let ns = Namespace.make Registration_helpers.ns "carbonated_map" - -let fv s = Free_variable.of_namespace (ns s) - -let make_context ~rng_state = - match Lwt_main.run @@ Execution_context.make ~rng_state with - | Ok (ctxt, _) -> ctxt - | Error _ -> assert false - -module Config_and_workload = struct - type config = {size : int} - - let config_encoding = - let open Data_encoding in - conv (fun {size} -> size) (fun size -> {size}) (obj1 (req "size" int31)) - - let default_config = {size = 100_000} - - type workload = config - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let tags = ["carbonated_map"] - - let workload_encoding = config_encoding - - let workload_to_vector {size} = - Sparse_vec.String.of_list [("size", float_of_int size)] -end - -module Alpha_context_gas = struct - type context = Alpha_context.context - - let consume = Alpha_context.Gas.consume -end - -(** - Benchmarks the [fold] functions of [Carbonated_map]. - This benchmark does not depend on the size of the keys or types of elements. -*) -module Fold_benchmark : Benchmark.S = struct - include Config_and_workload - - module Int = struct - include Int - - (** Dummy value *) - let compare_cost _ = Saturation_repr.safe_int 0 - end - - let name = ns "fold" - - let info = "Carbonated map to list" - - let fold_model = - Model.make - ~conv:(fun {size} -> (size, ())) - (Model.affine - ~name - ~intercept:(fv "fold_const") - ~coeff:(fv "fold_cost_per_item")) - - let models = [("carbonated_map", fold_model)] - - let benchmark rng_state config () = - let module M = Carbonated_map.Make (Alpha_context_gas) (Int) in - let _, list = - let sampler rng_state = - let key = Base_samplers.int rng_state ~size:{min = 1; max = 5} in - (* Value should not be important *) - let value = () in - (Z.to_int key, value) - in - Structure_samplers.list - rng_state - ~range:{min = 1; max = config.size} - ~sampler - in - let ctxt = make_context ~rng_state in - let map = - match - M.of_list - ctxt - ~merge_overlap:(fun ctxt _left right -> Ok (right, ctxt)) - list - with - | Ok (map, _) -> map - | _ -> assert false - in - let workload = {size = M.size map} in - let closure () = - ignore @@ M.fold_e ctxt (fun ctxt _ _ _ -> ok ((), ctxt)) () map - in - Generator.Plain {workload; closure} - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (benchmark rng_state config) -end - -(** Module type that consists of a comparable type along with a sampler - function. *) -module type COMPARABLE_SAMPLER = sig - include Compare.COMPARABLE - - val type_name : string - - val sampler : t Base_samplers.sampler -end - -(** - Functor for constructing a benchmark for the cost of comparing values. This - functor can be used to generate [compare_cost] data for a particular - key-type for [Carbonated_map] instances. -*) -module Make (CS : COMPARABLE_SAMPLER) = struct - let compare_var type_name = fv (Printf.sprintf "compare_%s" type_name) - - module Compare = struct - type config = unit - - let config_encoding = Data_encoding.unit - - let default_config = () - - type workload = config - - let tags = ["carbonated_map"] - - let workload_encoding = config_encoding - - let workload_to_vector () = Sparse_vec.String.of_list [] - - let name = ns @@ Printf.sprintf "compare_%s" CS.type_name - - let info = - Printf.sprintf "Carbonated map compare cost for %s keys" CS.type_name - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let models = - [ - ( "carbonated_map", - Model.make - ~conv:(fun () -> ()) - (Model.unknown_const1 ~name ~const:(compare_var CS.type_name)) ); - ] - - let benchmark rng_state _conf () = - let key = CS.sampler rng_state in - let workload = () in - let closure () = ignore (CS.compare key key) in - Generator.Plain {workload; closure} - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (benchmark rng_state config) - end - - module Find = struct - include Config_and_workload - - module M = - Carbonated_map.Make - (Alpha_context_gas) - (struct - include CS - - (** Dummy cost*) - let compare_cost _ = Saturation_repr.safe_int 0 - end) - - let name = ns "find" - - let info = Printf.sprintf "Carbonated find model" - - (** - Given the cost of comparing keys, the model is used for deducing [intercept] - and [traverse_overhead] from: - - [intercept + (log2 size * compare_cost) + (log2 size * traversal_overhead)] - *) - let find_model ~name ~intercept ~traverse_overhead = - let module M = struct - type arg_type = int * unit - - let name = name - - let takes_saturation_reprs = false - - module Def (L : Costlang.S) = struct - type model_type = L.size -> L.size - - let arity = Model.arity_1 - - let model = - let open L in - lam ~name:"size" @@ fun size -> - let compare_cost = - log2 size * free ~name:(compare_var CS.type_name) - in - let traversal_overhead = log2 size * free ~name:traverse_overhead in - free ~name:intercept + compare_cost + traversal_overhead - end - end in - (module M : Model.Model_impl with type arg_type = int * unit) - - let models = - [ - ( "carbonated_map", - Model.make - ~conv:(fun {size} -> (size, ())) - (find_model - ~name - ~intercept:(fv "intercept") - ~traverse_overhead:(fv "traversal_overhead")) ); - ] - - let benchmark rng_state (config : config) () = - let _, list = - let sampler rng_state = (CS.sampler rng_state, ()) in - Structure_samplers.list - rng_state - ~range:{min = 1; max = config.size} - ~sampler - in - let ctxt = make_context ~rng_state in - let map = - match - M.of_list ctxt ~merge_overlap:(fun ctxt _ _ -> Ok ((), ctxt)) list - with - | Ok (map, _) -> map - | _ -> assert false - in - (* Pick the min binding from the map to guarantee longest path. *) - let key = - match M.to_list ctxt map with - | Ok (kvs, _) -> ( - match List.hd kvs with Some (k, _) -> k | None -> assert false) - | Error _ -> assert false - in - let workload = {size = M.size map} in - let closure () = ignore @@ M.find ctxt key map in - Generator.Plain {workload; closure} - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (benchmark rng_state config) - end - - module Find_intercept = struct - type config = unit - - let config_encoding = Data_encoding.unit - - let default_config = () - - type workload = config - - let tags = ["carbonated_map"] - - let workload_encoding = config_encoding - - let workload_to_vector () = Sparse_vec.String.of_list [] - - module M = - Carbonated_map.Make - (Alpha_context_gas) - (struct - include CS - - (** Dummy cost*) - let compare_cost _ = Saturation_repr.safe_int 0 - end) - - let name = ns "find_intercept" - - let info = Printf.sprintf "Carbonated find model (intercept case)" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let models = - [ - ( "carbonated_map", - Model.make - ~conv:(fun () -> ()) - (Model.unknown_const1 ~name ~const:(fv "intercept")) ); - ] - - let benchmark rng_state (_config : config) () = - let ctxt = make_context ~rng_state in - let map = M.empty in - let key = CS.sampler rng_state in - let workload = () in - let closure () = ignore @@ M.find ctxt key map in - Generator.Plain {workload; closure} - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (benchmark rng_state config) - end -end - -(** A comparable and a sampler for [int] values. *) -module Int = struct - type t = int - - let compare = Int.compare - - let type_name = "int" - - let sampler rng_state = - Z.to_int @@ Base_samplers.int rng_state ~size:{min = 1; max = 6} -end - -module Benchmarks_int = Make (Int) - -let () = - let open Registration_helpers in - register (module Fold_benchmark) ; - register (module Benchmarks_int.Compare) ; - register (module Benchmarks_int.Find) ; - register (module Benchmarks_int.Find_intercept) diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/dune b/src/proto_017_PtNairob/lib_benchmarks_proto/dune deleted file mode 100644 index 804f0ea1e15e5cc003dd11154d5e06918d5e4427..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/dune +++ /dev/null @@ -1,45 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name tezos_benchmarks_proto_017_PtNairob) - (public_name tezos-benchmarks-proto-017-PtNairob) - (instrumentation (backend bisect_ppx)) - (libraries - str - octez-libs.stdlib - octez-libs.base - octez-libs.error-monad - tezos-protocol-017-PtNairob.parameters - octez-libs.lazy-containers - tezos-benchmark - tezos-benchmark-017-PtNairob - tezos-benchmark-type-inference-017-PtNairob - tezos-protocol-017-PtNairob.protocol - octez-libs.crypto - octez-shell-libs.shell-benchmarks - octez-libs.micheline - octez-protocol-017-PtNairob-libs.test-helpers - octez-libs.tezos-sapling - octez-protocol-017-PtNairob-libs.client - octez-protocol-017-PtNairob-libs.plugin - octez-proto-libs.protocol-environment) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezos_stdlib - -open Tezos_base - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_error_monad - -open Tezos_protocol_017_PtNairob_parameters - -open Tezos_lazy_containers - -open Tezos_benchmark - -open Tezos_benchmark_017_PtNairob - -open Tezos_benchmark_type_inference_017_PtNairob - -open Tezos_protocol_017_PtNairob - -open Tezos_protocol_017_PtNairob.Protocol - -open Tezos_micheline - -open Tezos_017_PtNairob_test_helpers - -open Tezos_client_017_PtNairob - -open Tezos_protocol_plugin_017_PtNairob)) diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/encodings_benchmarks.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/encodings_benchmarks.ml deleted file mode 100644 index 3be160f66ff01ac4dec88277312af09506b145f6..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/encodings_benchmarks.ml +++ /dev/null @@ -1,501 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 - -module Encodings = -Tezos_shell_benchmarks.Encoding_benchmarks_helpers.Make (struct - let file = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" -end) - -module Size = Gas_input_size - -let ns = Namespace.make Registration_helpers.ns "encoding" - -let fv s = Free_variable.of_namespace (ns s) - -module Micheline_common = struct - let make_printable node = - Micheline_printer.printable - Michelson_v1_primitives.string_of_prim - (Micheline.strip_locations node) - - type phase = Trace_production | In_protocol | Global - - type error = - | Bad_micheline of { - benchmark_name : Namespace.t; - micheline : Alpha_context.Script.node; - phase : phase; - } - - exception Micheline_benchmark of error - - let pp_phase fmtr (phase : phase) = - match phase with - | Trace_production -> Format.fprintf fmtr "trace production" - | In_protocol -> Format.fprintf fmtr "in protocol" - | Global -> Format.fprintf fmtr "global" - - let pp_error fmtr = function - | Bad_micheline {benchmark_name; micheline; phase} -> - Format.open_vbox 1 ; - Format.fprintf fmtr "Bad micheline:@," ; - Format.fprintf fmtr "benchmark = %a@," Namespace.pp benchmark_name ; - Format.fprintf - fmtr - "expression = @[%a@]@," - Micheline_printer.print_expr - (make_printable micheline) ; - Format.fprintf fmtr "phase = %a@," pp_phase phase ; - Format.close_box () - - let bad_micheline benchmark_name micheline phase = - raise - (Micheline_benchmark (Bad_micheline {benchmark_name; micheline; phase})) - - type workload = {size : Size.micheline_size; bytes : int} - - let workload_encoding = - let open Data_encoding in - def "encoding_micheline_trace" - @@ conv - (fun {size; bytes} -> (size, bytes)) - (fun (size, bytes) -> {size; bytes}) - (obj2 - (req "micheline_size" Size.micheline_size_encoding) - (req "micheline_bytes" Size.encoding)) - - let workload_to_vector (workload : workload) = - let keys = - [ - ( "encoding_micheline_traversal", - float_of_int (Size.to_int workload.size.traversal) ); - ( "encoding_micheline_int_bytes", - float_of_int (Size.to_int workload.size.int_bytes) ); - ( "encoding_micheline_string_bytes", - float_of_int (Size.to_int workload.size.string_bytes) ); - ("encoding_micheline_bytes", float_of_int (Size.to_int workload.bytes)); - ] - in - Sparse_vec.String.of_list keys - - let tags = [Tags.encoding] - - let model_size name = - Model.make - ~conv:(fun {size = {Size.traversal; int_bytes; string_bytes}; _} -> - (traversal, (int_bytes, (string_bytes, ())))) - (Model.trilinear - ~name:(ns name) - ~coeff1:(fv (Format.asprintf "%s_micheline_traversal" name)) - ~coeff2:(fv (Format.asprintf "%s_micheline_int_bytes" name)) - ~coeff3:(fv (Format.asprintf "%s_micheline_string_bytes" name))) - - let model_bytes name = - Model.make - ~conv:(fun {bytes; _} -> (bytes, ())) - (Model.linear - ~name:(ns name) - ~coeff:(fv (Format.asprintf "%s_micheline_bytes" name))) - - let models name = - [("micheline", model_size name); ("micheline_bytes", model_bytes name)] -end - -module Encoding_micheline : Benchmark.S = struct - include Translator_benchmarks.Config - include Micheline_common - - let name = ns "ENCODING_MICHELINE" - - let info = "Benchmarking strip_location + encoding of Micheline to bytes" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let micheline_serialization_trace (micheline_node : Alpha_context.Script.node) - = - match - Data_encoding.Binary.to_string - Protocol.Script_repr.expr_encoding - (Micheline.strip_locations micheline_node) - with - | Error err -> - Format.eprintf - "micheline_serialization_trace: %a@." - Data_encoding.Binary.pp_write_error - err ; - None - | Ok str -> - let micheline_size = Size.of_micheline micheline_node in - Some {size = micheline_size; bytes = Size.string str} - - let encoding_micheline_benchmark (node : Protocol.Script_repr.expr) = - let node = Micheline.root node in - let workload = - match micheline_serialization_trace node with - | None -> Micheline_common.bad_micheline name node Trace_production - | Some trace -> trace - in - let closure () = - try - ignore - (Data_encoding.Binary.to_string_exn - Protocol.Script_repr.expr_encoding - (Micheline.strip_locations node)) - with _ -> Micheline_common.bad_micheline name node In_protocol - in - Generator.Plain {workload; closure} - - let make_bench rng_state cfg () = - let Michelson_mcmc_samplers.{term; typ = _} = - Michelson_generation.make_data_sampler rng_state cfg.generator_config - in - encoding_micheline_benchmark term - - let create_benchmarks ~rng_state ~bench_num config = - match config.michelson_terms_file with - | Some file -> - Format.eprintf "Loading terms from %s@." file ; - let terms = Michelson_mcmc_samplers.load ~filename:file in - List.map - (function - | Michelson_mcmc_samplers.Data {term; typ = _} - | Michelson_mcmc_samplers.Code {term; bef = _; aft = _} -> - fun () -> encoding_micheline_benchmark term) - terms - | None -> List.repeat bench_num (make_bench rng_state config) - - let models = models (Namespace.basename name) -end - -let () = - Benchmarks_proto.Registration.register_as_simple_with_num - (module Encoding_micheline) - -module Decoding_micheline : Benchmark.S = struct - include Translator_benchmarks.Config - include Micheline_common - - let name = ns "DECODING_MICHELINE" - - let info = "Decoding of bytes to Micheline" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let micheline_deserialization_trace (micheline_str : string) = - match - Data_encoding.Binary.of_string - Protocol.Script_repr.expr_encoding - micheline_str - with - | Error err -> - Format.eprintf - "micheline_deserialization_trace: %a@." - Data_encoding.Binary.pp_read_error - err ; - None - | Ok micheline_node -> - let micheline_size = - Size.of_micheline (Micheline.root micheline_node) - in - Some {size = micheline_size; bytes = Size.string micheline_str} - - let decoding_micheline_benchmark (node : Protocol.Script_repr.expr) = - let encoded = - Data_encoding.Binary.to_string_exn Protocol.Script_repr.expr_encoding node - in - let node = Micheline.root node in - let workload = - match micheline_deserialization_trace encoded with - | None -> bad_micheline name node Trace_production - | Some trace -> trace - in - let closure () = - try - ignore - (Data_encoding.Binary.of_string_exn - Protocol.Script_repr.expr_encoding - encoded) - with _ -> bad_micheline name node In_protocol - in - Generator.Plain {workload; closure} - - let make_bench rng_state cfg () = - let Michelson_mcmc_samplers.{term; typ = _} = - Michelson_generation.make_data_sampler rng_state cfg.generator_config - in - decoding_micheline_benchmark term - - let create_benchmarks ~rng_state ~bench_num config = - match config.michelson_terms_file with - | Some file -> - Format.eprintf "Loading terms from %s@." file ; - let terms = Michelson_mcmc_samplers.load ~filename:file in - List.map - (function - | Michelson_mcmc_samplers.Data {term; typ = _} - | Michelson_mcmc_samplers.Code {term; bef = _; aft = _} -> - fun () -> decoding_micheline_benchmark term) - terms - | None -> List.repeat bench_num (make_bench rng_state config) - - let models = models (Namespace.basename name) -end - -let () = - Benchmarks_proto.Registration.register_as_simple_with_num - (module Decoding_micheline) - -module Timestamp = struct - open Encodings - - let () = - Registration_helpers.register_simple_with_num - @@ fixed_size_shared - ~name:"TIMESTAMP_READABLE_ENCODING" - ~generator:(fun rng_state -> - let seconds_in_year = 30_000_000 in - let offset = Random.State.int rng_state seconds_in_year in - Script_timestamp.of_zint (Z.of_int (1597764116 + offset))) - ~make_bench:(fun generator () -> - let tstamp_string = generator () in - let closure () = - ignore (Script_timestamp.to_notation tstamp_string) - in - Generator.Plain {workload = (); closure}) - () - - let () = - let b, b_intercept = - nsqrtn_shared_with_intercept - ~name:"TIMESTAMP_READABLE_DECODING" - ~generator:(fun rng_state -> - let offset = - Base_samplers.nat ~size:{min = 1; max = 100_000} rng_state - in - let tstamp = - Script_timestamp.of_zint Z.(of_int 1597764116 + offset) - in - Script_timestamp.to_string tstamp) - ~make_bench:(fun generator -> - let tstamp_string = generator () in - let bytes = String.length tstamp_string in - let closure () = ignore (Script_timestamp.of_string tstamp_string) in - Generator.Plain {workload = {bytes}; closure}) - ~generator_intercept:(fun rng_state -> - let seconds_in_year = 30_000_000 in - let offset = Random.State.int rng_state seconds_in_year in - let tstamp = - Script_timestamp.of_zint (Z.of_int (1597764116 + offset)) - in - Script_timestamp.to_string tstamp) - ~make_bench_intercept:(fun generator -> - let tstamp_string = generator () in - let closure () = ignore (Script_timestamp.of_string tstamp_string) in - Generator.Plain {workload = {bytes = 0}; closure}) - in - Registration_helpers.register_simple b ; - Registration_helpers.register_simple b_intercept -end - -(* when benchmarking, compile bls12-381 without ADX, see - https://gitlab.com/dannywillems/ocaml-bls12-381/-/blob/71d0b4d467fbfaa6452d702fcc408d7a70916a80/README.md#install -*) -module BLS = struct - open Encodings - - let check () = - if not Bls12_381.built_with_blst_portable then ( - Format.eprintf - "BLS must be built without ADX to run the BLS benchmarks. Try \ - compiling again after setting the environment variable BLST_PORTABLE. \ - Aborting.@." ; - Stdlib.failwith "bls_not_built_with_blst_portable") - - let () = - Registration_helpers.register_simple_with_num - @@ make_encode_fixed_size_to_bytes - ~check - ~name:"ENCODING_BLS_FR" - ~to_bytes:Bls12_381.Fr.to_bytes - ~generator:(fun rng_state -> Bls12_381.Fr.random ~state:rng_state ()) - () - - let () = - Registration_helpers.register_simple_with_num - @@ make_encode_fixed_size_to_bytes - ~check - ~name:"ENCODING_BLS_G1" - ~to_bytes:Bls12_381.G1.to_bytes - ~generator:(fun rng_state -> Bls12_381.G1.random ~state:rng_state ()) - () - - let () = - Registration_helpers.register_simple_with_num - @@ make_encode_fixed_size_to_bytes - ~check - ~name:"ENCODING_BLS_G2" - ~to_bytes:Bls12_381.G2.to_bytes - ~generator:(fun rng_state -> Bls12_381.G2.random ~state:rng_state ()) - () - - let () = - Registration_helpers.register_simple_with_num - @@ make_decode_fixed_size_from_bytes - ~check - ~name:"DECODING_BLS_FR" - ~to_bytes:Bls12_381.Fr.to_bytes - ~from_bytes:Bls12_381.Fr.of_bytes_exn - ~generator:(fun rng_state -> Bls12_381.Fr.random ~state:rng_state ()) - () - - let () = - Registration_helpers.register_simple_with_num - @@ make_decode_fixed_size_from_bytes - ~check - ~name:"DECODING_BLS_G1" - ~to_bytes:Bls12_381.G1.to_bytes - ~from_bytes:Bls12_381.G1.of_bytes_exn - ~generator:(fun rng_state -> Bls12_381.G1.random ~state:rng_state ()) - () - - let () = - Registration_helpers.register_simple_with_num - @@ make_decode_fixed_size_from_bytes - ~check - ~name:"DECODING_BLS_G2" - ~to_bytes:Bls12_381.G2.to_bytes - ~from_bytes:Bls12_381.G2.of_bytes_exn - ~generator:(fun rng_state -> Bls12_381.G2.random ~state:rng_state ()) - () - - let () = - Registration_helpers.register_simple_with_num - @@ fixed_size_shared - ~check - ~name:"BLS_FR_FROM_Z" - ~generator:(fun rng_state -> Bls12_381.Fr.random ~state:rng_state ()) - ~make_bench:(fun generator () -> - let generated = generator () in - let z = Bls12_381.Fr.to_z generated in - let closure () = ignore (Bls12_381.Fr.of_z z) in - Generator.Plain {workload = (); closure}) - () - - let () = - Registration_helpers.register_simple_with_num - @@ fixed_size_shared - ~check - ~name:"BLS_FR_TO_Z" - ~generator:(fun rng_state -> Bls12_381.Fr.random ~state:rng_state ()) - ~make_bench:(fun generator () -> - let generated = generator () in - let closure () = ignore (Bls12_381.Fr.to_z generated) in - Generator.Plain {workload = (); closure}) - () -end - -module Timelock = struct - open Encodings - - let generator rng_state = - let log_time = - Base_samplers.sample_in_interval ~range:{min = 0; max = 29} rng_state - in - let time = Random.State.int rng_state (Int.shift_left 1 log_time) in - let plaintext_size = - Base_samplers.sample_in_interval ~range:{min = 1; max = 10000} rng_state - in - let chest, chest_key = - Tezos_crypto.Timelock.chest_sampler ~plaintext_size ~time ~rng_state - in - ((chest, chest_key), plaintext_size) - - let () = - Registration_helpers.register_simple_with_num - @@ make_encode_variable_size_to_string - ~name:"ENCODING_Chest" - ~to_string: - (Data_encoding.Binary.to_string_exn - Tezos_crypto.Timelock.chest_encoding) - ~generator:(fun rng_state -> - let (chest, _), plaintext_size = generator rng_state in - (chest, {bytes = plaintext_size})) - () - - let () = - Registration_helpers.register_simple_with_num - @@ make_encode_fixed_size_to_string - ~name:"ENCODING_Chest_key" - ~to_string: - (Data_encoding.Binary.to_string_exn - Tezos_crypto.Timelock.chest_key_encoding) - ~generator:(fun rng_state -> - let (_, chest_key), _w = generator rng_state in - chest_key) - () - - let () = - Registration_helpers.register_simple_with_num - @@ make_decode_variable_size_from_bytes - ~name:"DECODING_Chest" - ~to_bytes: - (Data_encoding.Binary.to_bytes_exn - Tezos_crypto.Timelock.chest_encoding) - ~from_bytes: - (Data_encoding.Binary.of_bytes_exn - Tezos_crypto.Timelock.chest_encoding) - ~generator:(fun rng_state -> - let (chest, _), _ = generator rng_state in - let b = - Data_encoding.Binary.to_bytes_exn - Tezos_crypto.Timelock.chest_encoding - chest - in - (chest, {bytes = Bytes.length b})) - () - - let () = - Registration_helpers.register_simple_with_num - @@ make_decode_fixed_size_from_bytes - ~name:"DECODING_Chest_key" - ~to_bytes: - (Data_encoding.Binary.to_bytes_exn - Tezos_crypto.Timelock.chest_key_encoding) - ~from_bytes: - (Data_encoding.Binary.of_bytes_exn - Tezos_crypto.Timelock.chest_key_encoding) - ~generator:(fun rng_state -> - let (_, chest_key), _w = generator rng_state in - chest_key) - () -end diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/gas_helpers.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/gas_helpers.ml deleted file mode 100644 index bf8bcde60256bf7b86af90fa07d8cddfb812d6b6..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/gas_helpers.ml +++ /dev/null @@ -1,36 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 set_limit ctxt = - Alpha_context.Gas.set_limit - ctxt - (Alpha_context.Gas.Arith.integral_of_int_exn 999_999_999_999) - -let fp_to_z (fp : Alpha_context.Gas.Arith.fp) = - let open Data_encoding in - Binary.to_bytes_exn Alpha_context.Gas.Arith.z_fp_encoding fp - |> Binary.of_bytes_exn z diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/global_constants_storage_benchmarks.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/global_constants_storage_benchmarks.ml deleted file mode 100644 index 84dd9aaefa117f56f676215fe8d52c86522b12cc..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/global_constants_storage_benchmarks.ml +++ /dev/null @@ -1,708 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Marigold *) -(* *) -(* 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 module includes benchmarks for [Global_constants_storage.expand] - and [Global_constants_storage.Internal_for_tests.expr_to_address_in_context]. - The other main function exported by [Global_constants_storage] is [register]; - however, [register] calls [expand] and does little else, and thus does - not need to be further carbonated. - - In the process of creating these benchmarks, we benchmarked several OCaml - stdlib functions and [Script_expr_hash.of_b58check_opt]. While these cost - models are not used in the protocol, they are kept here to ensure the - assumptions underlying [register] and [expand] don't change out - from under us.*) - -open Tezos_benchmark -open Tezos_micheline -open Protocol - -let ns = Namespace.make Registration_helpers.ns "global_constants_storage" - -let fv s = Free_variable.of_namespace (ns s) - -let assert_ok_lwt x = - match Lwt_main.run x with - | Ok x -> x - | Error errs -> - Format.eprintf "%a@." pp_print_trace errs ; - exit 1 - -let assert_ok = function - | Ok x -> x - | Error errs -> - Format.eprintf "%a@." pp_print_trace errs ; - exit 1 - -(** [seq_of_n_constants n hash] generates a Seq filled - with [n] constant primitives containing [hash] *) -let seq_of_n_constants n hash = - let open Micheline in - Seq - ( -1, - Stdlib.List.init n (fun _ -> - Prim (-1, Michelson_v1_primitives.H_constant, [String (-1, hash)], [])) - ) - -(** Computes the b58check hash of a Micheline node as a string. *) -let node_to_hash node = - let expr_bytes = - Micheline.strip_locations node - |> Script_repr.lazy_expr |> Script_repr.force_bytes |> Stdlib.Result.get_ok - in - Script_expr_hash.hash_bytes [expr_bytes] |> Script_expr_hash.to_b58check - -(* An ad-hoc sampler for Micheline values. Boltzmann sampling would do well - here. - - Copied from lib_micheline and modified to use [Michelson_v1_primitives.prim]. *) -module Micheline_sampler = struct - type node = Alpha_context.Script.node - - let prims = - let open Protocol.Michelson_v1_primitives in - [| - 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_CHAIN_ID; - 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_BIG_MAP; - I_EMPTY_MAP; - I_EMPTY_SET; - I_EQ; - I_EXEC; - I_APPLY; - I_FAILWITH; - I_GE; - I_GET; - I_GET_AND_UPDATE; - 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_LEVEL; - 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_UNPAIR; - I_PUSH; - I_RIGHT; - I_SIZE; - I_SOME; - I_SOURCE; - I_SENDER; - I_SELF; - I_SELF_ADDRESS; - 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; - I_SAPLING_EMPTY_STATE; - I_SAPLING_VERIFY_UPDATE; - I_DIG; - I_DUG; - I_NEVER; - I_VOTING_POWER; - I_TOTAL_VOTING_POWER; - I_KECCAK; - I_SHA3; - I_PAIRING_CHECK; - I_TICKET; - I_READ_TICKET; - I_SPLIT_TICKET; - I_JOIN_TICKETS; - 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; - T_sapling_transaction_deprecated; - T_sapling_state; - T_chain_id; - T_never; - T_bls12_381_g1; - T_bls12_381_g2; - T_bls12_381_fr; - T_ticket - (* We don't want constants in our generator, else the constants - functions might fail because it's ill-formed. *) - (* H_constant; *); - |] - - module Sampler = Micheline_sampler.Make (struct - type prim = Michelson_v1_primitives.prim - - let sample_prim : Michelson_v1_primitives.prim Base_samplers.sampler = - fun rng_state -> - let i = Random.State.int rng_state (Array.length prims) in - prims.(i) - - let sample_annots : string list Base_samplers.sampler = fun _rng_state -> [] - - let sample_string _ = "" - - let sample_bytes _ = Bytes.empty - - let sample_z _ = Z.zero - - let width_function = Micheline_sampler.reasonable_width_function - end) - - let sample = Sampler.sample - - type size = {nodes : int; bytes : int} - - let int z = {nodes = 1; bytes = (Z.numbits z + 7) / 8} - - let string s = {nodes = 1; bytes = String.length s} - - let bytes b = {nodes = 1; bytes = Bytes.length b} - - let node = {nodes = 1; bytes = 0} - - let ( @+ ) x y = {nodes = x.nodes + y.nodes; bytes = x.bytes + y.bytes} - - let micheline_size (n : node) = - let rec micheline_size n acc = - let open Micheline in - match n with - | Int (_, i) -> acc @+ int i - | String (_, s) -> acc @+ string s - | Bytes (_, b) -> acc @+ bytes b - | Seq (_, terms) -> - List.fold_left - (fun acc term -> micheline_size term acc) - (acc @+ node) - terms - | Prim (_, _, terms, _) -> - List.fold_left - (fun acc term -> micheline_size term acc) - (acc @+ node) - terms - in - micheline_size n {nodes = 0; bytes = 0} -end - -(** Cost model and benchmarks for set element addition from the - OCaml stdlib. - - The cost model is not currently used - in the protocol, but we include the benchmarks to validate our - assumptions about functions that use this. *) -module Set_add : Benchmark.S = struct - let name = ns "Set_add" - - let info = - "Benchmarks and cost model for set element addition from OCaml stdlib." - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let tags = ["global_constants"] - - type config = unit - - let config_encoding = Data_encoding.unit - - let default_config = () - - type workload = int - - let workload_encoding = Data_encoding.int31 - - let workload_to_vector : workload -> Sparse_vec.String.t = - fun size -> Sparse_vec.String.of_list [("size", float_of_int size)] - - (* As an OCaml set is a balanced binary tree, complexity is O(log n). *) - let models = - [ - ( "Set_add", - Model.( - make - ~conv:(fun size -> (size, ())) - (logn ~name ~coeff:(fv "set_add_coeff"))) ); - ] - - module Int_set = Set.Make (Int) - - let create_benchmark rng_state _config () = - let range : Base_samplers.range = {min = 0; max = 10_000} in - let size = Base_samplers.sample_in_interval ~range rng_state in - let set = Stdlib.List.init size Fun.id |> Int_set.of_list in - let closure () = ignore (Int_set.add (size + 1) set) in - Generator.Plain {workload = size; closure} - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (create_benchmark rng_state config) -end - -let () = Registration_helpers.register (module Set_add) - -(** Cost model and benchmarks for set elements from the - OCaml stdlib. - - The cost model is not currently used - in the protocol, but we include the benchmarks to validate our - assumptions about functions that use this. *) -module Set_elements : Benchmark.S = struct - let name = ns "Set_elements" - - let info = "Benchmarks and cost model for set elements from OCaml stdlib." - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let tags = ["global_constants"] - - type config = unit - - let config_encoding = Data_encoding.unit - - let default_config = () - - type workload = int - - let workload_encoding = Data_encoding.int31 - - let workload_to_vector : workload -> Sparse_vec.String.t = - fun size -> Sparse_vec.String.of_list [("size", float_of_int size)] - - (* Cost of retrieving all elements from the set is linear with the size - of the set.*) - let models = - [ - ( "Set_elements", - Model.( - make - ~conv:(fun size -> (size, ())) - (linear ~name ~coeff:(fv "set_elements_coeff"))) ); - ] - - module Int_set = Set.Make (Int) - - let create_benchmark rng_state _config () = - let range : Base_samplers.range = {min = 0; max = 10_000} in - let size = Base_samplers.sample_in_interval ~range rng_state in - let set = Stdlib.List.init size (fun x -> x) |> Int_set.of_list in - let closure () = ignore (Int_set.elements set) in - Generator.Plain {workload = size; closure} - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (create_benchmark rng_state config) -end - -let () = Registration_helpers.register (module Set_elements) - -(** Cost model and benchmarks for [Script_expr_hash.of_b58_check_opt]. - Under the hood this function uses the [Blake2b] functor, which uses - the HACL* crypto library. - - The cost model is not currently used - in the protocol, but we include the benchmarks to validate our - assumptions about functions that use this. *) -module Script_expr_hash_of_b58check_opt : Benchmark.S = struct - let name = ns "Script_expr_hash_of_b58check_opt" - - let info = "Benchmark for Script_expr_hash.of_b58check_opt" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let tags = ["global_constants"] - - type config = unit - - let config_encoding = Data_encoding.unit - - let default_config = () - - type workload = Micheline_sampler.size - - let workload_encoding = - let open Data_encoding in - conv - (fun Micheline_sampler.{nodes; bytes} -> (nodes, bytes)) - (fun (nodes, bytes) -> {nodes; bytes}) - (obj2 (req "nodes" int31) (req "bytes" int31)) - - let workload_to_vector Micheline_sampler.{nodes; bytes} = - Sparse_vec.String.of_list - [("nodes", float_of_int nodes); ("bytes", float_of_int bytes)] - - (* On testing we found that this function is a constant - time operation. However, to test this, we use an affine model. If - our assumption holds, the coefficient should be near zero. *) - let models = - [ - ( "Script_expr_hash_of_b58check_opt", - Model.( - make - ~conv:(fun Micheline_sampler.{nodes; _} -> (nodes, ())) - (Model.affine - ~name - ~intercept:(fv "b58_check_intercept") - ~coeff:(fv "b58_check_coeff"))) ); - ] - - (* To create realistic benchmarks, we generate a random Micheline expression, - hash it, then benchmark the cost of validating the hash. *) - let create_benchmark rng_state _config () = - let open Protocol in - let term = Micheline_sampler.sample rng_state in - let size = Micheline_sampler.micheline_size term in - let expr_encoding = Alpha_context.Script.expr_encoding in - let lazy_expr = - Data_encoding.make_lazy expr_encoding (Micheline.strip_locations term) - in - let expr_bytes = Data_encoding.force_bytes lazy_expr in - let hash = Script_expr_hash.hash_bytes [expr_bytes] in - let hash_str = Script_expr_hash.to_b58check hash in - let closure () = ignore (Script_expr_hash.of_b58check_opt hash_str) in - Generator.Plain {workload = size; closure} - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (create_benchmark rng_state config) -end - -let () = Registration_helpers.register (module Script_expr_hash_of_b58check_opt) - -module Global_constants_storage_expr_to_address_in_context : Benchmark.S = -struct - let name = ns "Global_constants_storage_expr_to_address_in_context" - - let info = - "Benchmark for the \ - Global_constants_storage.Internal_for_tests.expr_to_address_in_context \ - function" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let tags = ["global_constants"] - - type config = unit - - let config_encoding = Data_encoding.unit - - let default_config = () - - type workload = int - - let workload_encoding = Data_encoding.int31 - - let workload_to_vector : workload -> Sparse_vec.String.t = - fun size -> Sparse_vec.String.of_list [("size", float_of_int size)] - - (** The cost of a Blake2b hashing function is linear with the size of the input *) - let models = - [ - ( "Global_constants_storage_expr_to_address_in_context", - Model.( - make - ~conv:(fun size -> (size, ())) - (linear ~name ~coeff:(fv "blake2b_hash_coeff"))) ); - ] - - let create_benchmark rng_state _config () = - let open Micheline in - let expr = Micheline_sampler.sample rng_state |> strip_locations in - let b = - Script_repr.lazy_expr expr |> Script_repr.force_bytes - |> Environment.wrap_tzresult |> assert_ok - in - let size = Bytes.length b in - - let closure () = ignore (Script_expr_hash.hash_bytes [b]) in - Generator.Plain {workload = size; closure} - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (create_benchmark rng_state config) -end - -let () = - Registration_helpers.register - (module Global_constants_storage_expr_to_address_in_context) - -(** [Global_constants_storage.expand] traverses a Micheline node, - searching for constants and replacing them with their values - retrieved from storage. - - There are three branches in the iterations of [Global_constants_storage.expand] - can take, each with different costs: - - Branch 1: The first time a particular constant is found, the hash is parsed with - [Script_expr_hash.of_b58check_opt], and its value is retrieved - from storage. This storage call (implemented [Global_constants_storage.get]) - is already carbonated and dominates the cost in this case, so do not need to - benchmark Branch 1 - the benchmarks for storage access are sufficient. - - Branch 2: If the same constant is found a subsequent time, its value is looked up - in a map. On testing we determined that the cost of [Script_expr_hash.of_b58check_opt] - dominates the cost of this branch - the cost of an OCaml map lookup is O(log 2 n), and - n has to be unreasonably large to catch up to the constant time cost of validating the - hash. - - Branch 3: When no constant is found, the cost is merely that of pattern matching - and calling the continuation (similar to that of [Micheline.strip_locations]). - - Because we don't know the full size of node being traversed ahead of time (because they - are retrieved from storage), it is impossible to calculate the full gas cost upfront. - However, each time we find a new expression to traverse, we can calculate its size upfront - and charge the cost of all Branch 3 cases. We can then do an additional charge for Branch 2 - each time we find a constant, and let storage handle charging for Branch 1. - - Below are models for Branch 2 and 3 respectively. - *) -module Global_constants_storage_expand_models = struct - module Global_constants_storage_expand_constant_branch : Benchmark.S = struct - let name = ns "Global_constants_storage_expand_constant_branch" - - let info = - "Benchmark for the constant branch Global_constants_storage.expand \ - function" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let tags = ["global_constants"] - - type config = unit - - let config_encoding = Data_encoding.unit - - let default_config = () - - type workload = int - - let workload_encoding = Data_encoding.int31 - - let workload_to_vector : workload -> Sparse_vec.String.t = - fun constants -> - Sparse_vec.String.of_list - [("number_of_constants", float_of_int constants)] - - (** The cost of Branch 2 is linear to the number of constants in the expression. As - discussed above, the constant time operation [Script_expr_hash.of_b58check_opt] - dominates the cost of each iteration. *) - let models = - [ - ( "Global_constants_storage_expand_constant_branch", - Model.( - make - ~conv:(fun size -> (size, ())) - (linear ~name ~coeff:(fv "storage_exp_cst_coeff"))) ); - ] - - (* To test Branch 2 as nearly as possible, we generate a Micheline Seq - consisting of the same constant repeated n times. As n increases, - the benchmark more closely approximates the true cost of Branch 2. *) - let create_benchmark rng_state _config () = - let open Micheline in - let node = Micheline_sampler.sample rng_state in - let size = (Micheline_sampler.micheline_size node).nodes in - let registered_constant = Int (-1, Z.of_int 1) in - let hash = registered_constant |> node_to_hash in - let context, _ = Execution_context.make ~rng_state |> assert_ok_lwt in - let context, _, _ = - Alpha_context.Global_constants_storage.register - context - (strip_locations registered_constant) - >|= Environment.wrap_tzresult |> assert_ok_lwt - in - let node = seq_of_n_constants size hash in - let closure () = - ignore - (Lwt_main.run - @@ Alpha_context.Global_constants_storage.expand - context - (strip_locations node)) - in - Generator.Plain {workload = size; closure} - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (create_benchmark rng_state config) - end - - let () = - Registration_helpers.register - (module Global_constants_storage_expand_constant_branch) - - module Global_constants_storage_expand_no_constant_branch : Benchmark.S = - struct - let name = ns "Global_constants_storage_expand_no_constant_branch" - - let info = - "Benchmark for the Global_constants_storage.expand function on the case \ - without constants" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let tags = ["global_constants"] - - type config = unit - - let config_encoding = Data_encoding.unit - - let default_config = () - - type workload = int - - let workload_encoding = Data_encoding.int31 - - let workload_to_vector : workload -> Sparse_vec.String.t = - fun size -> - Sparse_vec.String.of_list [("number_of_nodes", float_of_int size)] - - (* The cost of Branch 3 is the cost of traversing a single node. It - is therefore linear to the number of nodes being traversed. This is - very similar to [Micheline.strip_locations]. - - On testing I observed that while the linear model was accurate - for small numbers of nodes, after 1000 nodes the cost seems to increase more - than linearly. I think I would have to fine tune the sampler to better test - past this amount; however, I don't think it's necessary - to get large orders - of nodes, you need to use constants, in which case the cost of - [Script_expr_hash.of_b58check_opt] will dominate. A n*log(n) model seems - accurate enough for the range of values tested. - *) - let models = - [ - ( "Global_constants_storage_expand_no_constant_branch", - Model.( - make - ~conv:(fun size -> (size, ())) - (nlogn - ~name - ~intercept:(fv "storage_exp_no_cst_intercept") - ~coeff:(fv "storage_exp_no_cst_coeff"))) ); - ] - - (** We benchmark this by generating a random Micheline expression without constants - and calling [expand] on it. This causes the function to spend all its time in - Branch 3. *) - let create_benchmark rng_state _config () = - let open Micheline in - let node = Micheline_sampler.sample rng_state in - let size = (Micheline_sampler.micheline_size node).nodes in - let context, _ = Execution_context.make ~rng_state |> assert_ok_lwt in - let expr = strip_locations node in - let closure () = - ignore - (Lwt_main.run - @@ Alpha_context.Global_constants_storage.expand context expr) - in - Generator.Plain {workload = size; closure} - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (create_benchmark rng_state config) - end - - let () = - Registration_helpers.register - (module Global_constants_storage_expand_no_constant_branch) -end diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/interpreter_benchmarks.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/interpreter_benchmarks.ml deleted file mode 100644 index 6e8c69ee6e18d816bdfca688c8ea4024720fc639..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/interpreter_benchmarks.ml +++ /dev/null @@ -1,3555 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021-2022 Nomadic Labs *) -(* Copyright (c) 2022 DaiLambda, 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 ns = Interpreter_model.ns - -let fv = Interpreter_model.fv - -module Timelock_samplers = Tezos_crypto.Timelock_legacy -open Protocol - -(* ------------------------------------------------------------------------- *) - -type ex_stack_and_kinstr = - | Ex_stack_and_kinstr : { - stack : 'a * 'b; - stack_type : ('a, 'b) Script_typed_ir.stack_ty; - kinstr : ('a, 'b, 'c, 'd) Script_typed_ir.kinstr; - } - -> ex_stack_and_kinstr - -type ex_stack_and_continuation = - | Ex_stack_and_cont : { - stack : 'a * 'b; - stack_type : ('a, 'b) Script_typed_ir.stack_ty; - cont : ('a, 'b, 'c, 'd) Script_typed_ir.continuation; - } - -> ex_stack_and_continuation - -type ex_value = - | Ex_value : {value : 'a; ty : ('a, _) Script_typed_ir.ty} -> ex_value - -(* ------------------------------------------------------------------------- *) - -let sf = Printf.sprintf - -(* End of Stack *) -let eos = Script_typed_ir.(EmptyCell, EmptyCell) - -let info_and_name ~intercept ?(salt = "") s = - let s = s ^ salt in - if intercept then - (sf "Benchmark %s (intercept case)" s, Namespace.make ns s "intercept") - else (sf "Benchmark %s" s, ns s) - -module Default_boilerplate = struct - type workload = Interpreter_workload.t - - let workload_encoding = Interpreter_workload.encoding - - let workload_to_vector = Interpreter_workload.trace_to_sparse_vec - - let tags = [Tags.interpreter] -end - -module Default_config = struct - (* Configuration specific to sapling benchmarks *) - type sapling_config = {sapling_txs_file : string; seed : int option} - - (* Configuration specific to benchmarking Dign/Dipn/Dupn/Dropn/Combs *) - type comb_config = {max_depth : int} - - (* Configuration specific to benchmarking ICompare *) - type compare_config = {type_size : Base_samplers.range} - - type config = { - sampler : Michelson_samplers.parameters; - sapling : sapling_config; - comb : comb_config; - compare : compare_config; - } - - let default_config = - let open Michelson_samplers in - let open Michelson_samplers_base in - let sampler = - { - base_parameters = - { - int_size = {min = 8; max = 100_000}; - string_size = {min = 1 lsl 10; max = 1 lsl 17}; - bytes_size = {min = 1 lsl 10; max = 1 lsl 17}; - }; - list_size = {min = 10; max = 1000}; - set_size = {min = 10; max = 1000}; - map_size = {min = 10; max = 1000}; - } - in - { - sampler; - sapling = {sapling_txs_file = {|/no/such/file|}; seed = None}; - comb = {max_depth = 1000}; - compare = {type_size = {min = 1; max = 15}}; - } - - let sapling_config_encoding = - let open Data_encoding in - conv - (fun {sapling_txs_file; seed} -> (sapling_txs_file, seed)) - (fun (sapling_txs_file, seed) -> {sapling_txs_file; seed}) - (obj2 (req "sapling_txs_file" string) (req "seed" (option int31))) - - let comb_config_encoding = - let open Data_encoding in - conv - (fun {max_depth} -> max_depth) - (fun max_depth -> {max_depth}) - (obj1 (req "max_depth" int31)) - - let compare_config_encoding = - let open Data_encoding in - conv - (fun {type_size} -> type_size) - (fun type_size -> {type_size}) - (obj1 (req "type_size" Base_samplers.range_encoding)) - - let config_encoding = - let open Data_encoding in - conv - (fun {sampler; sapling; comb; compare} -> - (sampler, sapling, comb, compare)) - (fun (sampler, sapling, comb, compare) -> - {sampler; sapling; comb; compare}) - (obj4 - (req "sampler" Michelson_samplers.parameters_encoding) - (req "sapling" sapling_config_encoding) - (req "comb" comb_config_encoding) - (req "compare" compare_config_encoding)) -end - -let make_default_samplers ?(algo = `Default) cfg : - (module Crypto_samplers.Finite_key_pool_S) * (module Michelson_samplers.S) = - let module Crypto_samplers = Crypto_samplers.Make_finite_key_pool (struct - let size = 16 - - let algo = algo - end) in - let module Michelson_samplers = - Michelson_samplers.Make - (struct - let parameters = cfg - end) - (Crypto_samplers) - in - ((module Crypto_samplers), (module Michelson_samplers)) - -(* ------------------------------------------------------------------------- *) -(* Helpers for creating benchmarks for the interpreter *) - -let benchmark_from_kinstr_and_stack : - ?amplification:int -> - Alpha_context.context -> - Protocol.Script_interpreter.step_constants -> - ex_stack_and_kinstr -> - Interpreter_workload.ir_sized_step list Generator.benchmark = - fun ?amplification ctxt step_constants stack_kinstr -> - let ctxt = Gas_helpers.set_limit ctxt in - match stack_kinstr with - | Ex_stack_and_kinstr {stack = bef_top, bef; stack_type; kinstr} -> - let workload, closure = - match amplification with - | None -> - let workload = - Interpreter_workload.extract_deps - ctxt - step_constants - stack_type - kinstr - (bef_top, bef) - in - let _gas_counter, outdated_ctxt = - Local_gas_counter.local_gas_counter_and_outdated_context ctxt - in - let closure () = - ignore - (* Lwt_main.run *) - (Script_interpreter.Internals.step - (outdated_ctxt, step_constants) - (Local_gas_counter 9_999_999_999) - kinstr - bef_top - bef) - in - (workload, closure) - | Some amplification_factor -> - assert (amplification_factor > 0) ; - let workload = - Interpreter_workload.extract_deps - ctxt - step_constants - stack_type - kinstr - (bef_top, bef) - in - let workload = - List.repeat amplification_factor workload |> List.flatten - in - let _gas_counter, outdated_ctxt = - Local_gas_counter.local_gas_counter_and_outdated_context ctxt - in - let closure () = - for _i = 1 to amplification_factor do - ignore - (* Lwt_main.run *) - (Script_interpreter.Internals.step - (outdated_ctxt, step_constants) - (Local_gas_counter 9_999_999_999) - kinstr - bef_top - bef) - done - in - (workload, closure) - in - Generator.Plain {workload; closure} - -let make_benchmark : - ?amplification:int -> - ?intercept:bool -> - ?salt:string -> - ?more_tags:string list -> - ?check:(unit -> unit) -> - name:Interpreter_workload.instruction_name -> - kinstr_and_stack_sampler: - (Default_config.config -> Random.State.t -> unit -> ex_stack_and_kinstr) -> - unit -> - Benchmark.t = - fun ?amplification - ?(intercept = false) - ?salt - ?(more_tags = []) - ?(check = fun () -> ()) - ~name - ~kinstr_and_stack_sampler - () -> - let module B : Benchmark.S = struct - include Default_config - include Default_boilerplate - - let tags = tags @ more_tags - - let models = - (* [intercept = true] implies there's a benchmark with [intercept = false]. - No need to register the model twice. *) - Interpreter_model.make_model ?amplification (Instr_name name) - - let info, name = - info_and_name - ~intercept - ?salt - (Interpreter_workload.string_of_instruction_name name) - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let benchmark kinstr_and_stack_sampler ctxt step_constants () = - let stack_instr = kinstr_and_stack_sampler () in - benchmark_from_kinstr_and_stack - ?amplification - ctxt - step_constants - stack_instr - - let create_benchmarks ~rng_state ~bench_num (config : config) = - check () ; - match Lwt_main.run (Execution_context.make ~rng_state) with - | Error _errs -> assert false - | Ok (ctxt, step_constants) -> - let kinstr_and_stack_sampler = - kinstr_and_stack_sampler config rng_state - in - List.repeat - bench_num - (benchmark kinstr_and_stack_sampler ctxt step_constants) - end in - (module B : Benchmark.S) - -let make_simple_benchmark : - type bef_top bef res_top res. - ?amplification:int -> - ?intercept:bool -> - ?more_tags:string list -> - ?salt:string -> - ?check:(unit -> unit) -> - name:Interpreter_workload.instruction_name -> - stack_type:(bef_top, bef) Script_typed_ir.stack_ty -> - kinstr:(bef_top, bef, res_top, res) Script_typed_ir.kinstr -> - unit -> - Benchmark.t = - fun ?amplification - ?intercept - ?more_tags - ?salt - ?check - ~name - ~stack_type - ~kinstr - () -> - let kinstr_and_stack_sampler config rng_state = - let _, (module Samplers) = - make_default_samplers config.Default_config.sampler - in - fun () -> - Ex_stack_and_kinstr - { - stack = Samplers.Random_value.stack stack_type rng_state; - stack_type; - kinstr; - } - in - make_benchmark - ?amplification - ?intercept - ?more_tags - ?salt - ?check - ~name - ~kinstr_and_stack_sampler - () - -let benchmark ?amplification ?intercept ?more_tags ?salt ?check ~name - ~kinstr_and_stack_sampler () = - let bench = - make_benchmark - ?amplification - ?intercept - ?more_tags - ?salt - ?check - ~name - ~kinstr_and_stack_sampler - () - in - Registration_helpers.register bench - -let benchmark_with_stack_sampler ?amplification ?intercept ?more_tags ?salt - ?check ~stack_type ~name ~kinstr ~stack_sampler () = - let kinstr_and_stack_sampler config rng_state = - let stack_sampler = stack_sampler config rng_state in - fun () -> Ex_stack_and_kinstr {stack = stack_sampler (); stack_type; kinstr} - in - let bench = - make_benchmark - ?amplification - ?intercept - ?more_tags - ?salt - ?check - ~name - ~kinstr_and_stack_sampler - () - in - Registration_helpers.register bench - -let benchmark_with_fixed_stack ?amplification ?intercept ?more_tags ?salt ?check - ~name ~stack ~kinstr () = - benchmark_with_stack_sampler - ?amplification - ?intercept - ?more_tags - ?salt - ?check - ~name - ~kinstr - ~stack_sampler:(fun _cfg _rng_state () -> stack) - () - -let simple_benchmark_with_stack_sampler ?amplification ?intercept_stack ?salt - ?more_tags ?check ~name ~stack_type ~kinstr ~stack_sampler () = - benchmark_with_stack_sampler - ?amplification - ~intercept:false - ?salt - ?more_tags - ?check - ~name - ~stack_type - ~kinstr - ~stack_sampler - () ; - Option.iter - (fun stack -> - benchmark_with_fixed_stack - ?amplification - ~intercept:true - ?more_tags - ?salt - ?check - ~name - ~stack_type - ~stack - ~kinstr - ()) - intercept_stack - -let simple_benchmark ?amplification ?intercept_stack ?more_tags ?salt ?check - ~name ~stack_type ~kinstr () = - let bench = - make_simple_benchmark - ?amplification - ~intercept:false - ?more_tags - ?salt - ?check - ~name - ~stack_type - ~kinstr - () - in - Registration_helpers.register bench ; - Option.iter - (fun stack -> - benchmark_with_fixed_stack - ?amplification - ~intercept:true - ?more_tags - ?salt - ?check - ~name - ~stack_type - ~stack - ~kinstr - ()) - intercept_stack - -(* ------------------------------------------------------------------------- *) -(* Helpers for creating benchmarks for [Script_interpreter.next] *) - -let benchmark_from_continuation : - ?amplification:int -> - Alpha_context.context -> - Protocol.Script_interpreter.step_constants -> - ex_stack_and_continuation -> - Interpreter_workload.ir_sized_step list Generator.benchmark = - fun ?amplification ctxt step_constants stack_cont -> - let ctxt = Gas_helpers.set_limit ctxt in - match stack_cont with - | Ex_stack_and_cont {stack = bef_top, bef; cont; stack_type} -> - let workload, closure = - match amplification with - | None -> - let workload = - Interpreter_workload.extract_deps_continuation - ctxt - step_constants - stack_type - cont - (bef_top, bef) - in - let _gas_counter, outdated_ctxt = - Local_gas_counter.local_gas_counter_and_outdated_context ctxt - in - let closure () = - ignore - (* Lwt_main.run *) - (Script_interpreter.Internals.next - None - (outdated_ctxt, step_constants) - (Local_gas_counter 9_999_999_999) - stack_type - cont - bef_top - bef) - in - (workload, closure) - | Some amplification_factor -> - assert (amplification_factor > 0) ; - let workload = - Interpreter_workload.extract_deps_continuation - ctxt - step_constants - stack_type - cont - (bef_top, bef) - in - let workload = - List.repeat amplification_factor workload |> List.flatten - in - let _gas_counter, outdated_ctxt = - Local_gas_counter.local_gas_counter_and_outdated_context ctxt - in - let closure () = - for _i = 1 to amplification_factor do - ignore - (* Lwt_main.run *) - (Script_interpreter.Internals.next - None - (outdated_ctxt, step_constants) - (Local_gas_counter 9_999_999_999) - stack_type - cont - bef_top - bef) - done - in - (workload, closure) - in - Generator.Plain {workload; closure} - -let make_continuation_benchmark : - ?amplification:int -> - ?intercept:bool -> - ?salt:string -> - ?more_tags:string list -> - ?check:(unit -> unit) -> - name:Interpreter_workload.continuation_name -> - cont_and_stack_sampler: - (Default_config.config -> - Random.State.t -> - unit -> - ex_stack_and_continuation) -> - unit -> - Benchmark.t = - fun ?amplification - ?(intercept = false) - ?salt - ?(more_tags = []) - ?(check = fun () -> ()) - ~name - ~cont_and_stack_sampler - () -> - let module B : Benchmark.S = struct - include Default_config - include Default_boilerplate - - let tags = tags @ more_tags - - let models = Interpreter_model.make_model ?amplification (Cont_name name) - - let info, name = - info_and_name - ~intercept - ?salt - (Interpreter_workload.string_of_continuation_name name) - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let benchmark cont_and_stack_sampler ctxt step_constants () = - let stack_instr = cont_and_stack_sampler () in - benchmark_from_continuation ?amplification ctxt step_constants stack_instr - - let create_benchmarks ~rng_state ~bench_num (config : config) = - check () ; - match Lwt_main.run (Execution_context.make ~rng_state) with - | Error _errs -> assert false - | Ok (ctxt, step_constants) -> - let cont_and_stack_sampler = - cont_and_stack_sampler config rng_state - in - List.repeat - bench_num - (benchmark cont_and_stack_sampler ctxt step_constants) - end in - (module B : Benchmark.S) - -let continuation_benchmark ?amplification ?intercept ?salt ?more_tags ?check - ~name ~cont_and_stack_sampler () = - let bench = - make_continuation_benchmark - ?amplification - ?intercept - ?salt - ?more_tags - ?check - ~name - ~cont_and_stack_sampler - () - in - Registration_helpers.register bench - -(* ------------------------------------------------------------------------- *) -(* Sampling helpers *) - -let nat_of_positive_int (i : int) = - let open Script_int in - match is_nat (of_int i) with None -> assert false | Some x -> x - -let adversarial_ints rng_state (cfg : Default_config.config) n = - let _common_prefix, ls = - Base_samplers.Adversarial.integers - ~prefix_size:cfg.sampler.base_parameters.int_size - ~card:n - rng_state - in - List.map Script_int.of_zint ls - -(* ------------------------------------------------------------------------- *) -(* Error helpers *) - -let raise_if_error = function - | Ok x -> x - | Error e -> - Format.eprintf "%a@." (Error_monad.TzTrace.pp_print Error_monad.pp) e ; - Stdlib.failwith "raise_if_error" - -(* ------------------------------------------------------------------------- *) - -(** [Registration_section] contains all interpreter benchmarks. The goal of - a benchmark is to gather enough data to reliably estimate the parameters - of the cost model associated to each instruction. In general, it can - take several distinct benchmarks to properly cover all the execution - paths. - - In particular, for affine cost model, it is often worth estimating the - intercept separately from the size-dependent coefficients. - *) - -module Registration_section = struct - open Script_typed_ir - open Michelson_types - - let sf = Printf.sprintf - - let dummy_loc = 0 - - let halt = IHalt dummy_loc - - let () = - (* KHalt *) - simple_benchmark - ~amplification:100 - ~name:Interpreter_workload.N_IHalt - ~stack_type:(unit @$ bot) - ~kinstr:halt - () - - module Amplification = struct - module Loop : Benchmark.S = struct - let name = ns "amplification_loop" - - let info = "Benchmarking the cost of an empty loop" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let tags = [Tags.interpreter] - - type config = {max_iterations : int} - - let config_encoding = - let open Data_encoding in - conv - (fun {max_iterations} -> max_iterations) - (fun max_iterations -> {max_iterations}) - (obj1 (req "max_iterations" int31)) - - let default_config = {max_iterations = 100000} - - type workload = int - - let workload_encoding = Data_encoding.int31 - - let workload_to_vector n = - Sparse_vec.String.of_list [("iterations", float_of_int n)] - - let models = [("interpreter", Interpreter_model.amplification_loop_model)] - - let benchmark rng_state config () = - let workload = Random.State.int rng_state config.max_iterations in - let closure () = - for _i = 1 to workload do - Sys.opaque_identity () - done - in - Generator.Plain {workload; closure} - - let create_benchmarks ~rng_state ~bench_num (config : config) = - List.repeat bench_num (benchmark rng_state config) - end - end - - let () = Registration_helpers.register (module Amplification.Loop) - - module Stack = struct - let () = - (* KDrop ; KHalt *) - simple_benchmark - ~amplification:100 - ~name:Interpreter_workload.N_IDrop - ~stack_type:(unit @$ unit @$ bot) - ~kinstr:(IDrop (dummy_loc, halt)) - () - - let () = - (* IDup ; IHalt *) - simple_benchmark - ~amplification:100 - ~name:Interpreter_workload.N_IDup - ~stack_type:(unit @$ unit @$ bot) - ~kinstr:(IDup (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~amplification:100 - ~name:Interpreter_workload.N_ISwap - ~stack_type:(unit @$ unit @$ bot) - ~kinstr:(ISwap (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~amplification:100 - ~name:Interpreter_workload.N_IPush - ~stack_type:(unit @$ unit @$ bot) - ~kinstr:(IPush (dummy_loc, unit, (), halt)) - () - - (* deep stack manipulation *) - - (* Constructing these instructions is made especially painful by the - fact that they include "stack preservation witnesses", which are not - exposed in Script_ir_translator. - We must go through [Script_ir_translator.parse_instr] to construct - the corresponding terms. *) - type ex_stack = - | Ex_stack : ('a, 'b) Script_typed_ir.stack_ty * ('a * 'b) -> ex_stack - - let rec make_stack (depth : int) = - if depth = 0 then assert false - else if depth = 1 then Ex_stack (unit @$ Script_typed_ir.Bot_t, ((), eos)) - else - let stack = make_stack (depth - 1) in - match stack with - | Ex_stack (stack_ty, stack) -> Ex_stack (unit @$ stack_ty, ((), stack)) - - let parse_instr rng_state node stack = - match stack with - | Ex_stack (stack_ty, stack) -> - raise_if_error - (Lwt_main.run - ( Execution_context.make ~rng_state - >>=? fun (ctxt, _step_constants) -> - Script_ir_translator.parse_instr - Script_tc_context.data - ctxt - ~elab_conf: - (Script_ir_translator_config.make ~legacy:false ()) - node - stack_ty - >|= Environment.wrap_tzresult - >>=? fun (judgement, _) -> - match judgement with - | Script_ir_translator.Typed descr -> - let kinstr = descr.instr.apply (IHalt dummy_loc) in - return - (Ex_stack_and_kinstr - {stack; kinstr; stack_type = descr.bef}) - | Script_ir_translator.Failed _ -> assert false )) - - open Protocol.Michelson_v1_primitives - - (* The size parameter of a deep stack instruction must fit on 10 bits. See - [Script_ir_translator.parse_uint10]. *) - let stack_size = 1023 - - let long_stack = make_stack stack_size - - let sample_depth rng_state = - Base_samplers.( - sample_in_interval rng_state ~range:{min = 0; max = stack_size - 2}) - - let () = - let dig = Micheline.(Prim (0, I_DIG, [Int (0, Z.of_int 0)], [])) in - benchmark - ~amplification:100 - ~intercept:true - ~name:Interpreter_workload.N_IDig - ~kinstr_and_stack_sampler:(fun _cfg rng_state () -> - let node = dig in - parse_instr rng_state node long_stack) - () - - let () = - let dig n = Micheline.(Prim (0, I_DIG, [Int (0, Z.of_int n)], [])) in - benchmark - ~name:Interpreter_workload.N_IDig - ~kinstr_and_stack_sampler:(fun _cfg rng_state () -> - let node = dig (sample_depth rng_state) in - parse_instr rng_state node long_stack) - () - - let () = - let dug = Micheline.(Prim (0, I_DUG, [Int (0, Z.of_int 0)], [])) in - benchmark - ~intercept:true - ~name:Interpreter_workload.N_IDug - ~kinstr_and_stack_sampler:(fun _cfg rng_state () -> - let node = dug in - parse_instr rng_state node long_stack) - () - - let () = - let dug n = Micheline.(Prim (0, I_DUG, [Int (0, Z.of_int n)], [])) in - benchmark - ~name:Interpreter_workload.N_IDug - ~kinstr_and_stack_sampler:(fun _cfg rng_state () -> - let node = dug (sample_depth rng_state) in - parse_instr rng_state node long_stack) - () - - let () = - let nop = Micheline.Seq (0, []) in - let dip = Micheline.(Prim (0, I_DIP, [Int (0, Z.of_int 0); nop], [])) in - benchmark - ~intercept:true - ~name:Interpreter_workload.N_IDipN - ~kinstr_and_stack_sampler:(fun _cfg rng_state () -> - let node = dip in - parse_instr rng_state node long_stack) - () - - let () = - let nop = Micheline.Seq (0, []) in - let dip n = Micheline.(Prim (0, I_DIP, [Int (0, Z.of_int n); nop], [])) in - benchmark - ~name:Interpreter_workload.N_IDipN - ~kinstr_and_stack_sampler:(fun _cfg rng_state () -> - let node = dip (sample_depth rng_state) in - parse_instr rng_state node long_stack) - () - - let () = - let drop = Micheline.(Prim (0, I_DROP, [Int (0, Z.of_int 0)], [])) in - benchmark - ~intercept:true - ~name:Interpreter_workload.N_IDropN - ~kinstr_and_stack_sampler:(fun _cfg rng_state () -> - let node = drop in - parse_instr rng_state node long_stack) - () - - let () = - let drop n = Micheline.(Prim (0, I_DROP, [Int (0, Z.of_int n)], [])) in - benchmark - ~name:Interpreter_workload.N_IDropN - ~kinstr_and_stack_sampler:(fun _cfg rng_state () -> - let node = drop (sample_depth rng_state) in - parse_instr rng_state node long_stack) - () - - let () = - let pair n = Micheline.(Prim (0, I_PAIR, [Int (0, Z.of_int n)], [])) in - benchmark - ~name:Interpreter_workload.N_IComb - ~kinstr_and_stack_sampler:(fun cfg rng_state () -> - let width = - Base_samplers.( - sample_in_interval - rng_state - ~range:{min = 2; max = cfg.comb.max_depth}) - in - let node = pair width in - parse_instr rng_state node long_stack) - () - - let rec make_comb_stack (comb_width : int) (depth : int) acc = - if depth = 0 then - match acc with - | Ex_stack (stack_ty, stack) -> ( - match make_comb comb_width (Ex_value {value = (); ty = unit}) with - | Ex_value {value; ty} -> Ex_stack (ty @$ stack_ty, (value, stack))) - else - match acc with - | Ex_stack (stack_ty, stack) -> - make_comb_stack - comb_width - (depth - 1) - (Ex_stack (unit @$ stack_ty, ((), stack))) - - and make_comb comb_width comb_acc = - if comb_width = 0 then assert false - else if comb_width = 1 then comb_acc - else - match comb_acc with - | Ex_value {value; ty} -> - let (Ty_ex_c ty) = pair unit ty in - make_comb (comb_width - 1) (Ex_value {value = ((), value); ty}) - - let () = - let unpair n = - Micheline.(Prim (0, I_UNPAIR, [Int (0, Z.of_int n)], [])) - in - benchmark - ~name:Interpreter_workload.N_IUncomb - ~kinstr_and_stack_sampler:(fun cfg rng_state () -> - let width = - Base_samplers.( - sample_in_interval - rng_state - ~range:{min = 2; max = cfg.comb.max_depth - 2}) - in - let node = unpair width in - let stack = - make_comb_stack width 1 (Ex_stack (unit @$ bot, ((), eos))) - in - parse_instr rng_state node stack) - () - - let () = - let comb_get n = Micheline.(Prim (0, I_GET, [Int (0, Z.of_int n)], [])) in - benchmark - ~name:Interpreter_workload.N_IComb_get - ~kinstr_and_stack_sampler:(fun cfg rng_state () -> - let width = - Base_samplers.( - sample_in_interval - rng_state - ~range:{min = 2; max = cfg.comb.max_depth - 2}) - in - let index = - Base_samplers.( - sample_in_interval rng_state ~range:{min = 0; max = width}) - in - let node = comb_get index in - let stack = - make_comb_stack width 1 (Ex_stack (unit @$ bot, ((), eos))) - in - parse_instr rng_state node stack) - () - - let () = - let comb_set n = - Micheline.(Prim (0, I_UPDATE, [Int (0, Z.of_int n)], [])) - in - benchmark - ~name:Interpreter_workload.N_IComb_set - ~kinstr_and_stack_sampler:(fun cfg rng_state () -> - let width = - Base_samplers.( - sample_in_interval - rng_state - ~range:{min = 2; max = cfg.comb.max_depth - 2}) - in - let index = - Base_samplers.( - sample_in_interval rng_state ~range:{min = 0; max = width}) - in - let node = comb_set index in - let stack = - let (Ex_stack (stack_ty, stack)) = - make_comb_stack width 1 (Ex_stack (unit @$ bot, ((), eos))) - in - Ex_stack (unit @$ stack_ty, ((), stack)) - in - parse_instr rng_state node stack) - () - - let () = - let dup n = Micheline.(Prim (0, I_DUP, [Int (0, Z.of_int n)], [])) in - benchmark - ~name:Interpreter_workload.N_IDupN - ~kinstr_and_stack_sampler:(fun _cfg rng_state () -> - let node = dup (1 + sample_depth rng_state) in - parse_instr rng_state node long_stack) - () - end - - module Pairs = struct - let () = - simple_benchmark - ~name:Interpreter_workload.N_ICons_pair - ~stack_type:(unit @$ unit @$ bot) - ~kinstr:(ICons_pair (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_ICar - ~stack_type:(cpair unit unit @$ bot) - ~kinstr:(ICar (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_ICdr - ~stack_type:(cpair unit unit @$ bot) - ~kinstr:(ICdr (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IUnpair - ~stack_type:(cpair unit unit @$ bot) - ~kinstr:(IUnpair (dummy_loc, halt)) - () - end - - module Options = struct - let () = - simple_benchmark - ~name:Interpreter_workload.N_ICons_some - ~stack_type:(unit @$ bot) - ~kinstr:(ICons_some (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_ICons_none - ~stack_type:(unit @$ bot) - ~kinstr:(ICons_none (dummy_loc, unit, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IIf_none - ~stack_type:(option unit @$ bot) - ~kinstr: - (IIf_none - { - loc = dummy_loc; - branch_if_none = halt; - branch_if_some = IDrop (dummy_loc, halt); - k = halt; - }) - () - - let () = - benchmark_with_fixed_stack - ~name:Interpreter_workload.N_IOpt_map - ~salt:"none" - ~stack:(None, ((), eos)) - ~stack_type:(option unit @$ unit @$ bot) - ~kinstr:(IOpt_map {loc = dummy_loc; body = halt; k = halt}) - () - - let () = - benchmark_with_fixed_stack - ~name:Interpreter_workload.N_IOpt_map - ~salt:"some" - ~stack:(Some (), ((), eos)) - ~stack_type:(option unit @$ unit @$ bot) - ~kinstr:(IOpt_map {loc = dummy_loc; body = halt; k = halt}) - () - end - - module Ors = struct - let () = - simple_benchmark - ~name:Interpreter_workload.N_ILeft - ~stack_type:(unit @$ bot) - ~kinstr:(ICons_left (dummy_loc, unit, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IRight - ~stack_type:(unit @$ bot) - ~kinstr:(ICons_right (dummy_loc, unit, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IIf_left - ~stack_type:(cor unit unit @$ bot) - ~kinstr: - (IIf_left - { - loc = dummy_loc; - branch_if_left = halt; - branch_if_right = halt; - k = halt; - }) - () - end - - module Lists = struct - let () = - simple_benchmark - ~name:Interpreter_workload.N_ICons_list - ~stack_type:(unit @$ list unit @$ bot) - ~kinstr:(ICons_list (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_INil - ~stack_type:(unit @$ bot) - ~kinstr:(INil (dummy_loc, unit, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IIf_cons - ~stack_type:(list unit @$ unit @$ bot) - ~kinstr: - (IIf_cons - { - loc = dummy_loc; - branch_if_cons = IDrop (dummy_loc, IDrop (dummy_loc, halt)); - branch_if_nil = halt; - k = halt; - }) - () - - module Mapping = struct - let () = - (* - IList_map -> - IList_enter_body (empty case) -> - IHalt - *) - benchmark_with_fixed_stack - ~name:Interpreter_workload.N_IList_map - ~stack:(Script_list.empty, ((), eos)) - ~stack_type:(list unit @$ unit @$ bot) - ~kinstr:(IList_map (dummy_loc, halt, Some (list unit), halt)) - () - end - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IList_size - ~stack_type:(list unit @$ bot) - ~kinstr:(IList_size (dummy_loc, halt)) - () - - let () = - (* - IList_iter -> - IIter (empty case) -> - IHalt - *) - benchmark_with_fixed_stack - ~name:Interpreter_workload.N_IList_iter - ~stack:(Script_list.empty, ((), eos)) - ~stack_type:(list unit @$ unit @$ bot) - ~kinstr: - (IList_iter (dummy_loc, Some unit, IDrop (dummy_loc, halt), halt)) - () - end - - module Sets = struct - let () = - simple_benchmark - ~name:Interpreter_workload.N_IEmpty_set - ~stack_type:(unit @$ bot) - ~kinstr:(IEmpty_set (dummy_loc, unit, halt)) - () - - let set_iter_code = - ISet_iter (dummy_loc, Some int, IDrop (dummy_loc, halt), halt) - - let () = - (* - ISet_iter -> - (List.rev (set_fold)) -> - { - IIter -> - IDrop -> - ICons -> - ... - } - *) - simple_benchmark - ~name:Interpreter_workload.N_ISet_iter - ~intercept_stack:(Script_set.empty int, ((), eos)) - ~stack_type:(set int @$ unit @$ bot) - ~kinstr:set_iter_code - () - - let () = - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_ISet_mem - ~stack_type:(int @$ set int @$ unit @$ bot) - ~kinstr:(ISet_mem (dummy_loc, halt)) - ~intercept_stack:(Script_int.zero, (Script_set.empty int, ((), eos))) - ~stack_sampler:(fun cfg rng_state () -> - assert (cfg.sampler.set_size.min >= 1) ; - let n = - Base_samplers.sample_in_interval - rng_state - ~range:cfg.sampler.set_size - in - let elts = adversarial_ints rng_state cfg n in - let set = - List.fold_left - (fun set elt -> Script_set.update elt true set) - (Script_set.empty int) - elts - in - let elt = - List.nth_opt elts (Random.State.int rng_state n) - |> WithExceptions.Option.get ~loc:__LOC__ - in - (elt, (set, ((), eos)))) - () - - let () = - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_ISet_update - ~stack_type:(int @$ bool @$ set int @$ bot) - ~kinstr:(ISet_update (dummy_loc, halt)) - ~intercept_stack:(Script_int.zero, (false, (Script_set.empty int, eos))) - ~stack_sampler:(fun cfg rng_state () -> - assert (cfg.sampler.set_size.min >= 2) ; - let n = - Base_samplers.sample_in_interval - rng_state - ~range:cfg.sampler.set_size - in - let elts = adversarial_ints rng_state cfg (n + 1) in - let out_of_set, in_set = - match elts with [] -> assert false | hd :: tl -> (hd, tl) - in - let set = - List.fold_left - (fun set elt -> Script_set.update elt true set) - (Script_set.empty int) - in_set - in - let stack = - let flip = Random.State.bool rng_state in - if flip then - (* add an element not in the set *) - (out_of_set, (true, (set, eos))) - else - (* remove an element in the set *) - let elt = out_of_set in - let set = Script_set.update elt true set in - (elt, (flip, (set, eos))) - in - stack) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_ISet_size - ~stack_type:(set unit @$ bot) - ~kinstr:(ISet_size (dummy_loc, halt)) - () - end - - module Maps = struct - let generate_map_and_key_in_map (cfg : Default_config.config) rng_state = - let n = - Base_samplers.sample_in_interval rng_state ~range:cfg.sampler.set_size - in - let keys = adversarial_ints rng_state cfg n in - let map = - List.fold_left - (fun map i -> Script_map.update i (Some ()) map) - (Script_map.empty int) - keys - in - let (module M) = Script_map.get_module map in - let key = - M.OPS.fold (fun k _ -> function None -> Some k | x -> x) M.boxed None - |> WithExceptions.Option.get ~loc:__LOC__ - in - (key, map) - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IEmpty_map - ~stack_type:(unit @$ bot) - ~kinstr:(IEmpty_map (dummy_loc, unit, Some unit, halt)) - () - - (* - let map_map_code = - IMap_map - ( dummy_loc, - ICdr (dummy_loc, halt_unitunit), - halt ) - *) - - let map_map_code () = - IMap_map - ( dummy_loc, - Some (map int unit), - IFailwith (dummy_loc, cpair int unit), - halt ) - - let () = - (* - Map_map (nonempty case) -> - (List.rev (map_fold nonempty_map)) -> - KMap_enter_body (nonempty case) -> - fail (early interruption) - *) - simple_benchmark - ~name:Interpreter_workload.N_IMap_map - ~intercept_stack: - (let map = Script_map.empty int in - (map, ((), eos))) - ~stack_type:(map int unit @$ unit @$ bot) - ~kinstr:(map_map_code ()) - () - - let kmap_iter_code = - IMap_iter (dummy_loc, Some (cpair int unit), IDrop (dummy_loc, halt), halt) - - let () = - (* - IMap_iter (nonempty case) -> - (List.rev (map_fold (nonempty))) -> - IIter (nonempty case) -> - ... - *) - simple_benchmark - ~name:Interpreter_workload.N_IMap_iter - ~intercept_stack: - (let map = Script_map.empty int in - (map, ((), eos))) - ~stack_type:(map int unit @$ unit @$ bot) - ~kinstr:kmap_iter_code - () - - let () = - (* - IMap_mem -> - (map_mem) -> - IHalt - *) - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_IMap_mem - ~stack_type:(int @$ map int unit @$ unit @$ bot) - ~kinstr:(IMap_mem (dummy_loc, halt)) - ~intercept_stack: - (let map = Script_map.empty int in - (Script_int.zero, (map, ((), eos)))) - ~stack_sampler:(fun cfg rng_state () -> - let key, map = generate_map_and_key_in_map cfg rng_state in - (key, (map, ((), eos)))) - () - - let () = - (* - IMap_get -> - (map_get) -> - IHalt - *) - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_IMap_get - ~stack_type:(int @$ map int unit @$ unit @$ bot) - ~kinstr:(IMap_get (dummy_loc, halt)) - ~intercept_stack: - (let map = Script_map.empty int in - (Script_int.zero, (map, ((), eos)))) - ~stack_sampler:(fun cfg rng_state () -> - let key, map = generate_map_and_key_in_map cfg rng_state in - (key, (map, ((), eos)))) - () - - let () = - (* - IMap_update -> - (map_update) -> - IHalt - *) - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_IMap_update - ~stack_type:(int @$ option unit @$ map int unit @$ bot) - ~kinstr:(IMap_update (dummy_loc, halt)) - ~intercept_stack: - (let map = Script_map.empty int in - (Script_int.zero, (None, (map, eos)))) - ~stack_sampler:(fun cfg rng_state () -> - let key, map = generate_map_and_key_in_map cfg rng_state in - (key, (Some (), (map, eos)))) - () - - let () = - (* - IMap_get_and_update -> - (map_update) -> - (map_get) -> - IHalt - *) - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_IMap_get_and_update - ~stack_type:(int @$ option unit @$ map int unit @$ bot) - ~kinstr:(IMap_get_and_update (dummy_loc, halt)) - ~intercept_stack: - (let map = Script_map.empty int in - (Script_int.zero, (None, (map, eos)))) - ~stack_sampler:(fun cfg rng_state () -> - let key, map = generate_map_and_key_in_map cfg rng_state in - (key, (Some (), (map, eos)))) - () - - let () = - (* - IMap_size -> - (map_update) -> - (map_get) -> - IHalt - *) - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_IMap_size - ~stack_type:(map int unit @$ bot) - ~kinstr:(IMap_size (dummy_loc, halt)) - ~stack_sampler:(fun _cfg _rng_state -> - let map = Script_map.empty int in - fun () -> (map, eos)) - () - end - - module Big_maps = struct - let generate_big_map_and_key_in_map (cfg : Default_config.config) rng_state - = - let n = - Base_samplers.sample_in_interval rng_state ~range:cfg.sampler.set_size - in - let keys = adversarial_ints rng_state cfg n in - let map = - List.fold_left - (fun map i -> Script_map.update i (Some (Some ())) map) - (Script_map.empty int) - keys - in - let (module M) = Script_map.get_module map in - let key = - M.OPS.fold (fun k _ -> function None -> Some k | x -> x) M.boxed None - |> WithExceptions.Option.get ~loc:__LOC__ - in - let big_map = - raise_if_error - (Lwt_main.run - ( Execution_context.make ~rng_state >>=? fun (ctxt, _) -> - let big_map = Script_big_map.empty int unit_t in - Script_map.fold - (fun k v acc -> - acc >>=? fun (bm, ctxt_acc) -> - Script_big_map.update ctxt_acc k v bm) - map - (return (big_map, ctxt)) - >|= Environment.wrap_tzresult - >>=? fun (big_map, _) -> return big_map )) - in - (key, big_map) - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IEmpty_big_map - ~stack_type:(unit @$ bot) - ~kinstr:(IEmpty_big_map (dummy_loc, unit, unit, halt)) - () - - let () = - (* - IBig_map_mem -> - (update context with gas) - (big_map_mem) -> - IHalt - *) - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_IBig_map_mem - ~stack_type:(int @$ big_map int unit @$ unit @$ bot) - ~kinstr:(IBig_map_mem (dummy_loc, halt)) - ~intercept_stack: - (let map = Script_big_map.empty int unit in - (Script_int.zero, (map, ((), eos)))) - ~stack_sampler:(fun cfg rng_state () -> - let key, map = generate_big_map_and_key_in_map cfg rng_state in - (key, (map, ((), eos)))) - () - - let () = - (* - IBig_map_get -> - (big_map_get) -> - IHalt - *) - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_IBig_map_get - ~stack_type:(int @$ big_map int unit @$ unit @$ bot) - ~kinstr:(IBig_map_get (dummy_loc, halt)) - ~intercept_stack: - (let map = Script_big_map.empty int unit in - (Script_int.zero, (map, ((), eos)))) - ~stack_sampler:(fun cfg rng_state () -> - let key, map = generate_big_map_and_key_in_map cfg rng_state in - (key, (map, ((), eos)))) - () - - let () = - (* - IBig_map_update -> - (big_map_update) -> - IHalt - *) - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_IBig_map_update - ~stack_type:(int @$ option unit @$ big_map int unit @$ bot) - ~kinstr:(IBig_map_update (dummy_loc, halt)) - ~intercept_stack: - (let map = Script_big_map.empty int unit in - (Script_int.zero, (None, (map, eos)))) - ~stack_sampler:(fun cfg rng_state () -> - let key, map = generate_big_map_and_key_in_map cfg rng_state in - (key, (Some (), (map, eos)))) - () - - let () = - (* - IBig_map_get_and_update -> - (big_map_update) -> - (big_map_get) -> - IHalt - *) - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_IBig_map_get_and_update - ~stack_type:(int @$ option unit @$ big_map int unit @$ bot) - ~kinstr:(IBig_map_get_and_update (dummy_loc, halt)) - ~intercept_stack: - (let map = Script_big_map.empty int unit in - (Script_int.zero, (None, (map, eos)))) - ~stack_sampler:(fun cfg rng_state () -> - let key, map = generate_big_map_and_key_in_map cfg rng_state in - (key, (Some (), (map, eos)))) - () - end - - module Strings = struct - open Script_string - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IConcat_string - ~intercept_stack:(Script_list.empty, eos) - ~stack_type:(list string @$ bot) - ~kinstr:(IConcat_string (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IConcat_string_pair - ~intercept_stack:(empty, (empty, eos)) - ~stack_type:(string @$ string @$ bot) - ~kinstr:(IConcat_string_pair (dummy_loc, halt)) - () - - let () = - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_ISlice_string - ~stack_type:(nat @$ nat @$ string @$ bot) - ~kinstr:(ISlice_string (dummy_loc, halt)) - ~intercept_stack: - (let z = Script_int.zero_n in - (z, (z, (empty, eos)))) - ~stack_sampler:(fun cfg rng_state -> - let _, (module Samplers) = make_default_samplers cfg.sampler in - fun () -> - let string = - Samplers.Random_value.value Script_typed_ir.string_t rng_state - in - let len = nat_of_positive_int (length string) in - (* worst case: offset = 0 *) - (nat_of_positive_int 0, (len, (string, eos)))) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IString_size - ~stack_type:(string @$ bot) - ~kinstr:(IString_size (dummy_loc, halt)) - () - end - - module Bytes = struct - (* Copy of [String] modulo renaming string to bytes. *) - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IConcat_bytes - ~intercept_stack:(Script_list.empty, eos) - ~stack_type:(list bytes @$ bot) - ~kinstr:(IConcat_bytes (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IConcat_bytes_pair - ~intercept_stack:(Bytes.empty, (Bytes.empty, eos)) - ~stack_type:(bytes @$ bytes @$ bot) - ~kinstr:(IConcat_bytes_pair (dummy_loc, halt)) - () - - let () = - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_ISlice_bytes - ~stack_type:(nat @$ nat @$ bytes @$ bot) - ~kinstr:(ISlice_bytes (dummy_loc, halt)) - ~intercept_stack: - (let z = Script_int.zero_n in - (z, (z, (Bytes.empty, eos)))) - ~stack_sampler:(fun cfg rng_state -> - let _, (module Samplers) = make_default_samplers cfg.sampler in - fun () -> - let bytes = - Samplers.Random_value.value Script_typed_ir.bytes_t rng_state - in - let len = nat_of_positive_int (Bytes.length bytes) in - (* worst case: offset = 0 *) - (nat_of_positive_int 0, (len, (bytes, eos)))) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IBytes_size - ~stack_type:(bytes @$ bot) - ~kinstr:(IBytes_size (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IAnd_bytes - ~intercept_stack:(Bytes.empty, (Bytes.empty, eos)) - ~stack_type:(bytes @$ bytes @$ bot) - ~kinstr:(IAnd_bytes (dummy_loc, halt)) - () - - let stack_sampler_for_or_and_xor_on_bytes cfg rng_state = - let _, (module Samplers) = - make_default_samplers cfg.Default_config.sampler - in - fun () -> - (* We benchmark the worst cases: when the two bytes have - the same length *) - let bytes1 = - Samplers.Random_value.value Script_typed_ir.bytes_t rng_state - in - let bytes2 = - Bytes.init (Bytes.length bytes1) (fun _ -> - Char.chr (Random.State.int rng_state 256)) - in - (bytes1, (bytes2, eos)) - - let () = - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_IOr_bytes - ~intercept_stack:(Bytes.empty, (Bytes.empty, eos)) - ~stack_type:(bytes @$ bytes @$ bot) - ~kinstr:(IOr_bytes (dummy_loc, halt)) - ~stack_sampler:stack_sampler_for_or_and_xor_on_bytes - () - - let () = - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_IXor_bytes - ~intercept_stack:(Bytes.empty, (Bytes.empty, eos)) - ~stack_type:(bytes @$ bytes @$ bot) - ~kinstr:(IXor_bytes (dummy_loc, halt)) - ~stack_sampler:stack_sampler_for_or_and_xor_on_bytes - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_INot_bytes - ~intercept_stack:(Bytes.empty, eos) - ~stack_type:(bytes @$ bot) - ~kinstr:(INot_bytes (dummy_loc, halt)) - () - - let () = - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_ILsl_bytes - ~intercept_stack:(Bytes.empty, (Script_int.one_n, eos)) - ~stack_type:(bytes @$ nat @$ bot) - ~kinstr:(ILsl_bytes (dummy_loc, halt)) - ~stack_sampler:(fun cfg rng_state -> - let _, (module Samplers) = make_default_samplers cfg.sampler in - fun () -> - let bytes = - Samplers.Random_value.value Script_typed_ir.bytes_t rng_state - in - (* Avoid [n mod 8 = 0] which runs faster than the others. *) - let n = - (* 0-63999 without multiples of 8 *) - let n = Random.State.int rng_state 56000 in - (n / 7 * 8) + (n mod 7) + 1 - in - let shift = Script_int.(abs (of_int n)) in - (bytes, (shift, eos))) - () - - let () = - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_ILsr_bytes - ~intercept_stack:(Bytes.empty, (Script_int.one_n, eos)) - ~stack_type:(bytes @$ nat @$ bot) - ~kinstr:(ILsr_bytes (dummy_loc, halt)) - ~stack_sampler:(fun cfg rng_state -> - let _, (module Samplers) = make_default_samplers cfg.sampler in - fun () -> - let bytes = - Samplers.Random_value.value Script_typed_ir.bytes_t rng_state - in - (* No need of samples of shift > bytes * 8 which are equivalent with - the case of shift = bytes * 8 where LSR returns empty bytes immediately *) - (* Avoid [n mod 8 = 0] which runs faster than the others. *) - let n = - let n = - Random.State.int rng_state ((Bytes.length bytes * 7) + 1) - in - (n / 7 * 8) + (n mod 7) + 1 - in - let shift = Script_int.(abs (of_int n)) in - (bytes, (shift, eos))) - () - - let () = - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_IBytes_nat - ~stack_type:(nat @$ bot) - ~kinstr:(IBytes_nat (dummy_loc, halt)) - ~intercept_stack:(Script_int.one_n, eos) - (* Avoid the optimized case of 0 *) - ~stack_sampler:(fun cfg rng_state -> - let base_parameters = - {cfg.sampler.base_parameters with int_size = {min = 0; max = 4096}} - in - let sampler = {cfg.sampler with base_parameters} in - let _, (module Samplers) = make_default_samplers sampler in - fun () -> - let nat = - Samplers.Random_value.value Script_typed_ir.nat_t rng_state - in - (nat, eos)) - () - - let () = - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_INat_bytes - ~stack_type:(bytes @$ bot) - ~kinstr:(INat_bytes (dummy_loc, halt)) - ~intercept_stack:(Bytes.empty, eos) - ~stack_sampler:(fun cfg rng_state -> - let base_parameters = - { - cfg.sampler.base_parameters with - bytes_size = {min = 0; max = 4096}; - } - in - let sampler = {cfg.sampler with base_parameters} in - let _, (module Samplers) = make_default_samplers sampler in - fun () -> - let bytes = - Samplers.Random_value.value Script_typed_ir.bytes_t rng_state - in - (bytes, eos)) - () - - let () = - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_IBytes_int - ~stack_type:(int @$ bot) - ~kinstr:(IBytes_int (dummy_loc, halt)) - ~intercept_stack:(Script_int.one, eos) - (* Avoid the optimized case of 0 *) - ~stack_sampler:(fun cfg rng_state -> - let base_parameters = - {cfg.sampler.base_parameters with int_size = {min = 0; max = 4096}} - in - let sampler = {cfg.sampler with base_parameters} in - let _, (module Samplers) = make_default_samplers sampler in - fun () -> - let int = - Samplers.Random_value.value Script_typed_ir.int_t rng_state - in - (int, eos)) - () - - let () = - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_IInt_bytes - ~stack_type:(bytes @$ bot) - ~kinstr:(IInt_bytes (dummy_loc, halt)) - ~intercept_stack:(Bytes.empty, eos) - ~stack_sampler:(fun cfg rng_state -> - let base_parameters = - { - cfg.sampler.base_parameters with - bytes_size = {min = 0; max = 4096}; - } - in - let sampler = {cfg.sampler with base_parameters} in - let _, (module Samplers) = make_default_samplers sampler in - fun () -> - let bytes = - Samplers.Random_value.value Script_typed_ir.bytes_t rng_state - in - (bytes, eos)) - () - end - - module Timestamps = struct - let zero_timestamp = Script_timestamp.of_zint Z.zero - - let zero_int = Script_int.zero - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IAdd_seconds_to_timestamp - ~intercept_stack:(zero_int, (zero_timestamp, eos)) - ~stack_type:(int @$ timestamp @$ bot) - ~kinstr:(IAdd_seconds_to_timestamp (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IAdd_timestamp_to_seconds - ~intercept_stack:(zero_timestamp, (zero_int, eos)) - ~stack_type:(timestamp @$ int @$ bot) - ~kinstr:(IAdd_timestamp_to_seconds (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_ISub_timestamp_seconds - ~intercept_stack:(zero_timestamp, (zero_int, eos)) - ~stack_type:(timestamp @$ int @$ bot) - ~kinstr:(ISub_timestamp_seconds (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IDiff_timestamps - ~intercept_stack:(zero_timestamp, (zero_timestamp, eos)) - ~stack_type:(timestamp @$ timestamp @$ bot) - ~kinstr:(IDiff_timestamps (dummy_loc, halt)) - () - end - - module Tez = struct - let () = - simple_benchmark - ~name:Interpreter_workload.N_IAdd_tez - ~stack_type:(mutez @$ mutez @$ bot) - ~kinstr:(IAdd_tez (dummy_loc, halt)) - () - - let () = - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_ISub_tez - ~stack_type:(mutez @$ mutez @$ bot) - ~kinstr:(ISub_tez (dummy_loc, halt)) - ~stack_sampler:(fun cfg rng_state -> - let _, (module Samplers) = - make_default_samplers cfg.Default_config.sampler - in - fun () -> - let a = Samplers.Random_value.value mutez rng_state in - let b = - match Alpha_context.Tez.(a /? 2L) with - | Error _ -> assert false - | Ok x -> x - in - (a, (b, eos))) - () - - let () = - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_ISub_tez_legacy - ~stack_type:(mutez @$ mutez @$ bot) - ~kinstr:(ISub_tez_legacy (dummy_loc, halt)) - ~stack_sampler:(fun cfg rng_state -> - let _, (module Samplers) = - make_default_samplers cfg.Default_config.sampler - in - fun () -> - let a = Samplers.Random_value.value mutez rng_state in - let b = - match Alpha_context.Tez.(a /? 2L) with - | Error _ -> assert false - | Ok x -> x - in - (a, (b, eos))) - () - - let sample_tez_nat (module Samplers : Michelson_samplers.S) rng_state = - let mutez = Samplers.Random_value.value mutez rng_state in - let mutez_int64 = Alpha_context.Tez.to_mutez mutez in - let int64 = Int64.(div max_int (mul mutez_int64 2L)) in - let nat = - match Script_int.(is_nat (of_int64 int64)) with - | None -> assert false - | Some nat -> nat - in - (mutez, nat) - - let () = - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_IMul_teznat - ~stack_type:(mutez @$ nat @$ bot) - ~kinstr:(IMul_teznat (dummy_loc, halt)) - ~stack_sampler:(fun cfg rng_state -> - let _, samplers = make_default_samplers cfg.sampler in - fun () -> - let mutez, nat = sample_tez_nat samplers rng_state in - (mutez, (nat, eos))) - () - - let () = - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_IMul_nattez - ~stack_type:(nat @$ mutez @$ bot) - ~kinstr:(IMul_nattez (dummy_loc, halt)) - ~stack_sampler:(fun cfg rng_state -> - let _, samplers = make_default_samplers cfg.sampler in - fun () -> - let mutez, nat = sample_tez_nat samplers rng_state in - (nat, (mutez, eos))) - () - - let () = - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_IEdiv_teznat - ~stack_type:(mutez @$ nat @$ bot) - ~kinstr:(IEdiv_teznat (dummy_loc, halt)) - ~stack_sampler:(fun cfg rng_state -> - let _, samplers = make_default_samplers cfg.sampler in - fun () -> - let mutez, nat = sample_tez_nat samplers rng_state in - (mutez, (nat, eos))) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IEdiv_tez - ~intercept_stack:(Alpha_context.Tez.zero, (Alpha_context.Tez.zero, eos)) - ~stack_type:(mutez @$ mutez @$ bot) - ~kinstr:(IEdiv_tez (dummy_loc, halt)) - () - end - - module Booleans = struct - let () = - simple_benchmark - ~name:Interpreter_workload.N_IOr - ~stack_type:(bool @$ bool @$ bot) - ~kinstr:(IOr (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IAnd - ~stack_type:(bool @$ bool @$ bot) - ~kinstr:(IAnd (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IXor - ~stack_type:(bool @$ bool @$ bot) - ~kinstr:(IXor (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_INot - ~stack_type:(bool @$ bot) - ~kinstr:(INot (dummy_loc, halt)) - () - end - - module Integers = struct - let zero = Script_int.zero - - let zero_n = Script_int.zero_n - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IIs_nat - ~intercept_stack:(zero, eos) - ~stack_type:(int @$ bot) - ~kinstr:(IIs_nat (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_INeg - ~intercept_stack:(zero, eos) - ~stack_type:(int @$ bot) - ~kinstr:(INeg (dummy_loc, halt)) - () - - let () = - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_IAbs_int - ~stack_type:(int @$ bot) - ~kinstr:(IAbs_int (dummy_loc, halt)) - ~intercept_stack:(zero, eos) - ~stack_sampler:(fun cfg rng_state -> - let _, (module Samplers) = make_default_samplers cfg.sampler in - fun () -> - let x = Samplers.Michelson_base.nat rng_state in - let neg_x = Script_int.neg x in - (neg_x, eos)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IInt_nat - ~intercept_stack:(zero_n, eos) - ~stack_type:(nat @$ bot) - ~kinstr:(IInt_nat (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IAdd_int - ~intercept_stack:(zero, (zero, eos)) - ~stack_type:(int @$ int @$ bot) - ~kinstr:(IAdd_int (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IAdd_nat - ~intercept_stack:(zero_n, (zero_n, eos)) - ~stack_type:(nat @$ nat @$ bot) - ~kinstr:(IAdd_nat (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_ISub_int - ~intercept_stack:(zero, (zero, eos)) - ~stack_type:(int @$ int @$ bot) - ~kinstr:(ISub_int (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IMul_int - ~intercept_stack:(zero, (zero, eos)) - ~stack_type:(int @$ int @$ bot) - ~kinstr:(IMul_int (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IMul_nat - ~intercept_stack:(zero_n, (zero, eos)) - ~stack_type:(nat @$ int @$ bot) - ~kinstr:(IMul_nat (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IEdiv_int - ~intercept_stack:(zero, (zero, eos)) - ~stack_type:(int @$ int @$ bot) - ~kinstr:(IEdiv_int (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IEdiv_nat - ~intercept_stack:(zero_n, (zero, eos)) - ~stack_type:(nat @$ int @$ bot) - ~kinstr:(IEdiv_nat (dummy_loc, halt)) - () - - let () = - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_ILsl_nat - ~intercept_stack:(zero_n, (zero_n, eos)) - ~stack_type:(nat @$ nat @$ bot) - ~kinstr:(ILsl_nat (dummy_loc, halt)) - ~stack_sampler:(fun cfg rng_state -> - let _, (module Samplers) = make_default_samplers cfg.sampler in - fun () -> - let x = Samplers.Michelson_base.nat rng_state in - (* shift must be in [0;256]: 1 byte max *) - let shift = - Script_int.(abs (of_int (Random.State.int rng_state 256))) - in - (x, (shift, eos))) - () - - let () = - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_ILsr_nat - ~intercept_stack:(zero_n, (zero_n, eos)) - ~stack_type:(nat @$ nat @$ bot) - ~kinstr:(ILsr_nat (dummy_loc, halt)) - ~stack_sampler:(fun cfg rng_state -> - let _, (module Samplers) = make_default_samplers cfg.sampler in - fun () -> - let x = Samplers.Michelson_base.nat rng_state in - (* shift must be in [0;256]: 1 byte max *) - let shift = - Script_int.(abs (of_int (Random.State.int rng_state 256))) - in - (x, (shift, eos))) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IOr_nat - ~intercept_stack:(zero_n, (zero_n, eos)) - ~stack_type:(nat @$ nat @$ bot) - ~kinstr:(IOr_nat (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IAnd_nat - ~intercept_stack:(zero_n, (zero_n, eos)) - ~stack_type:(nat @$ nat @$ bot) - ~kinstr:(IAnd_nat (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IAnd_int_nat - ~intercept_stack:(zero, (zero_n, eos)) - ~stack_type:(int @$ nat @$ bot) - ~kinstr:(IAnd_int_nat (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IXor_nat - ~intercept_stack:(zero_n, (zero_n, eos)) - ~stack_type:(nat @$ nat @$ bot) - ~kinstr:(IXor_nat (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_INot_int - ~intercept_stack:(zero, eos) - ~stack_type:(int @$ bot) - ~kinstr:(INot_int (dummy_loc, halt)) - () - end - - module Control = struct - let () = - simple_benchmark - ~name:Interpreter_workload.N_IIf - ~stack_type:(bool @$ unit @$ bot) - ~kinstr: - (IIf - { - loc = dummy_loc; - branch_if_true = halt; - branch_if_false = halt; - k = halt; - }) - () - - let () = - (* - ILoop -> - either - - IHalt (false on top of stack) - - IPush false ; IHalt (true on top of stack) - *) - let push_false = IPush (dummy_loc, bool, false, halt) in - simple_benchmark - ~name:Interpreter_workload.N_ILoop - ~stack_type:(bool @$ bot) - ~kinstr:(ILoop (dummy_loc, push_false, halt)) - () - - let () = - (* - ILoop_left -> - ICons_right -> - IHalt - *) - let cons_r = ICons_right (dummy_loc, unit, halt) in - simple_benchmark - ~name:Interpreter_workload.N_ILoop_left - ~stack_type:(cor unit unit @$ bot) - ~kinstr:(ILoop_left (dummy_loc, cons_r, halt)) - () - - let () = - (* - IDip -> - IHalt -> - IPush -> - IHalt - *) - simple_benchmark - ~name:Interpreter_workload.N_IDip - ~stack_type:(unit @$ unit @$ bot) - ~kinstr:(IDip (dummy_loc, halt, Some unit, halt)) - () - - let dummy_lambda = - let open Script_typed_ir in - let descr = - { - kloc = dummy_loc; - kbef = unit @$ bot; - kaft = unit @$ bot; - kinstr = halt; - } - in - Lam (descr, Micheline.Int (dummy_loc, Z.zero)) - - let dummy_lambda_rec = - let open Script_typed_ir in - let descr = - { - kloc = dummy_loc; - kbef = unit @$ lambda unit unit @$ bot; - kaft = unit @$ bot; - kinstr = - IDrop - (dummy_loc, IDrop (dummy_loc, IPush (dummy_loc, unit, (), halt))); - } - in - LamRec (descr, Micheline.Int (dummy_loc, Z.zero)) - - let () = - (* - IExec -> - (switch to in-context gas-counting) -> - interp lambda code -> - IHalt - *) - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_IExec - ~stack_type:(unit @$ lambda unit unit @$ bot) - ~kinstr:(IExec (dummy_loc, Some (unit @$ bot), halt)) - ~stack_sampler:(fun _cfg rng_state () -> - if Base_samplers.uniform_bool rng_state then ((), (dummy_lambda, eos)) - else ((), (dummy_lambda_rec, eos))) - () - - let () = - (* - IApply -> - unparse unit -> - unparse unit_ty -> - construct term -> - IHalt - *) - let dummy_lambda_pair = - let open Script_typed_ir in - let descr = - { - kloc = dummy_loc; - kbef = cpair unit unit @$ bot; - kaft = unit @$ bot; - kinstr = ICdr (dummy_loc, halt); - } - in - Lam (descr, Micheline.Int (dummy_loc, Z.zero)) - in - let dummy_lambda_pair_rec = - let open Script_typed_ir in - let descr = - { - kloc = dummy_loc; - kbef = cpair unit unit @$ lambda (cpair unit unit) unit @$ bot; - kaft = unit @$ bot; - kinstr = - IDrop - (dummy_loc, IDrop (dummy_loc, IPush (dummy_loc, unit, (), halt))); - } - in - LamRec (descr, Micheline.Int (dummy_loc, Z.zero)) - in - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_IApply - ~stack_type:(unit @$ lambda (cpair unit unit) unit @$ bot) - ~kinstr:(IApply (dummy_loc, unit, halt)) - ~stack_sampler:(fun _cfg rng_state () -> - if Base_samplers.uniform_bool rng_state then - ((), (dummy_lambda_pair, eos)) - else ((), (dummy_lambda_pair_rec, eos))) - () - - let () = - (* - ILambda -> - IHalt - *) - simple_benchmark - ~name:Interpreter_workload.N_ILambda - ~stack_type:(unit @$ bot) - ~kinstr:(ILambda (dummy_loc, dummy_lambda, halt)) - () - - let () = - (* - ILambda (rec) -> - IHalt - *) - simple_benchmark - ~name:Interpreter_workload.N_ILambda - ~salt:"_rec" - ~stack_type:(unit @$ bot) - ~kinstr:(ILambda (dummy_loc, dummy_lambda_rec, halt)) - () - - let () = - (* - IFailwith -> - (unparse_data Unit) -> - (strip_locations) -> - fail - *) - simple_benchmark - ~name:Interpreter_workload.N_IFailwith - ~amplification:100 - ~stack_type:(unit @$ bot) - ~kinstr:(IFailwith (dummy_loc, unit)) - () - end - - module Comparison = struct - let () = - benchmark - ~name:Interpreter_workload.N_ICompare - ~kinstr_and_stack_sampler:(fun cfg rng_state -> - let _, (module Samplers) = make_default_samplers cfg.sampler in - fun () -> - let size = - Base_samplers.sample_in_interval - rng_state - ~range:cfg.compare.type_size - in - let (Script_ir_translator.Ex_comparable_ty ty) = - Samplers.Random_type.m_comparable_type ~size rng_state - in - let value = Samplers.Random_value.comparable ty rng_state in - let kinstr = ICompare (dummy_loc, ty, halt) in - Ex_stack_and_kinstr - { - stack = (value, (value, eos)); - stack_type = ty @$ ty @$ bot; - kinstr; - }) - () - end - - module Comparators = struct - let () = - simple_benchmark - ~name:Interpreter_workload.N_IEq - ~stack_type:(int @$ bot) - ~kinstr:(IEq (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_INeq - ~stack_type:(int @$ bot) - ~kinstr:(INeq (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_ILt - ~stack_type:(int @$ bot) - ~kinstr:(ILt (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IGt - ~stack_type:(int @$ bot) - ~kinstr:(IGt (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_ILe - ~stack_type:(int @$ bot) - ~kinstr:(ILe (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IGe - ~stack_type:(int @$ bot) - ~kinstr:(IGe (dummy_loc, halt)) - () - end - - module Proto = struct - let () = - simple_benchmark - ~name:Interpreter_workload.N_IAddress - ~stack_type:(contract unit @$ bot) - ~kinstr:(IAddress (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IContract - ~stack_type:(address @$ bot) - ~kinstr: - (IContract (dummy_loc, unit, Alpha_context.Entrypoint.default, halt)) - () - - let () = - simple_benchmark_with_stack_sampler - ~name:Interpreter_workload.N_ITransfer_tokens - ~stack_type:(unit @$ mutez @$ contract unit @$ bot) - ~kinstr:(ITransfer_tokens (dummy_loc, halt)) - ~stack_sampler:(fun cfg rng_state -> - let _, (module Samplers) = make_default_samplers cfg.sampler in - fun () -> - let contract = - Samplers.Random_value.value (contract unit) rng_state - in - let amount = - match contract with - | Typed_implicit _ | Typed_originated _ -> - Samplers.Random_value.value mutez rng_state - | Typed_sc_rollup _ -> Alpha_context.Tez.zero - in - ((), (amount, (contract, eos)))) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IImplicit_account - ~stack_type:(key_hash @$ bot) - ~kinstr:(IImplicit_account (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_ICreate_contract - ~stack_type:(option key_hash @$ mutez @$ unit @$ bot) - ~kinstr: - (ICreate_contract - { - loc = dummy_loc; - storage_type = unit; - code = Micheline.(strip_locations @@ Seq (0, [])); - k = halt; - }) - () - - let () = - let name = - match Protocol.Script_string.of_string "view" with - | Ok s -> s - | Error _ -> assert false - in - simple_benchmark - ~name:Interpreter_workload.N_IView - ~stack_type:(unit @$ address @$ bot) - ~kinstr: - (IView - ( dummy_loc, - View_signature {name; input_ty = unit; output_ty = unit}, - Some bot, - halt )) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_ISet_delegate - ~stack_type:(option key_hash @$ bot) - ~kinstr:(ISet_delegate (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_INow - ~stack_type:(unit @$ bot) - ~kinstr:(INow (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IMin_block_time - ~stack_type:bot - ~kinstr:(IMin_block_time (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IBalance - ~stack_type:(unit @$ bot) - ~kinstr:(IBalance (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_ILevel - ~stack_type:(unit @$ bot) - ~kinstr:(ILevel (dummy_loc, halt)) - () - - let check_signature (algo : Signature.algo) ~for_intercept = - let name = - match algo with - | Signature.Ed25519 -> Interpreter_workload.N_ICheck_signature_ed25519 - | Signature.Secp256k1 -> - Interpreter_workload.N_ICheck_signature_secp256k1 - | Signature.P256 -> Interpreter_workload.N_ICheck_signature_p256 - | Signature.Bls -> Interpreter_workload.N_ICheck_signature_bls - in - benchmark_with_stack_sampler - ~intercept:for_intercept - ~name - ~stack_type:(public_key @$ signature @$ bytes @$ bot) - ~kinstr:(ICheck_signature (dummy_loc, halt)) - ~stack_sampler:(fun cfg rng_state -> - let (module Crypto_samplers), (module Samplers) = - make_default_samplers ~algo:(`Algo algo) cfg.Default_config.sampler - in - fun () -> - let _pkh, pk, sk = Crypto_samplers.all rng_state in - let unsigned_message = - if for_intercept then Environment.Bytes.empty - else Samplers.Random_value.value Script_typed_ir.bytes_t rng_state - in - let signed_message = Signature.sign sk unsigned_message in - let signed_message = Script_signature.make signed_message in - (pk, (signed_message, (unsigned_message, eos)))) - () - - let check_signature algo = - check_signature algo ~for_intercept:true ; - check_signature algo ~for_intercept:false - - let () = check_signature Signature.Ed25519 - - let () = check_signature Signature.Secp256k1 - - let () = check_signature Signature.P256 - - let () = check_signature Signature.Bls - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IHash_key - ~stack_type:(public_key @$ bot) - ~kinstr:(IHash_key (dummy_loc, halt)) - () - - let () = - benchmark - ~name:Interpreter_workload.N_IPack - ~kinstr_and_stack_sampler:(fun _cfg _rng_state -> - let kinstr = IPack (dummy_loc, unit, halt) in - fun () -> - Ex_stack_and_kinstr - {stack = ((), eos); stack_type = unit @$ bot; kinstr}) - () - - let () = - benchmark - ~name:Interpreter_workload.N_IUnpack - ~kinstr_and_stack_sampler:(fun _cfg rng_state -> - let b = - raise_if_error - (Lwt_main.run - ( Execution_context.make ~rng_state >>=? fun (ctxt, _) -> - Script_ir_translator.pack_data ctxt unit () - >|= Environment.wrap_tzresult - >>=? fun (bytes, _) -> return bytes )) - in - let kinstr = IUnpack (dummy_loc, unit, halt) in - fun () -> - Ex_stack_and_kinstr - {stack = (b, eos); stack_type = bytes @$ bot; kinstr}) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IBlake2b - ~intercept_stack:(Environment.Bytes.empty, eos) - ~stack_type:(bytes @$ bot) - ~kinstr:(IBlake2b (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_ISha256 - ~intercept_stack:(Environment.Bytes.empty, eos) - ~stack_type:(bytes @$ bot) - ~kinstr:(ISha256 (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_ISha512 - ~intercept_stack:(Environment.Bytes.empty, eos) - ~stack_type:(bytes @$ bot) - ~kinstr:(ISha512 (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IKeccak - ~intercept_stack:(Environment.Bytes.empty, eos) - ~stack_type:(bytes @$ bot) - ~kinstr:(IKeccak (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_ISha3 - ~intercept_stack:(Environment.Bytes.empty, eos) - ~stack_type:(bytes @$ bot) - ~kinstr:(ISha3 (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_ISource - ~stack_type:(unit @$ bot) - ~kinstr:(ISource (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_ISender - ~stack_type:(unit @$ bot) - ~kinstr:(ISender (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_ISelf - ~stack_type:(unit @$ bot) - ~kinstr: - (ISelf (dummy_loc, unit, Alpha_context.Entrypoint.default, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_ISelf_address - ~stack_type:(unit @$ bot) - ~kinstr:(ISelf_address (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IAmount - ~stack_type:(unit @$ bot) - ~kinstr:(IAmount (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IChainId - ~stack_type:(unit @$ bot) - ~kinstr:(IChainId (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IVoting_power - ~stack_type:(key_hash @$ bot) - ~kinstr:(IVoting_power (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_ITotal_voting_power - ~stack_type:(unit @$ bot) - ~kinstr:(ITotal_voting_power (dummy_loc, halt)) - () - end - - let () = - let memo_size = - match Alpha_context.Sapling.Memo_size.parse_z Z.zero with - | Error _ -> assert false - | Ok sz -> sz - in - simple_benchmark - ~name:Interpreter_workload.N_ISapling_empty_state - ~stack_type:(unit @$ bot) - ~kinstr:(ISapling_empty_state (dummy_loc, memo_size, halt)) - () - - module type Type_transaction = sig - val type_transaction : Sapling_generation.type_transaction - - val suffix : string - end - - module Register_Sapling_benchmark (Type_transaction : Type_transaction) = - struct - let is_empty = - match Type_transaction.type_transaction with Empty -> true | _ -> false - - let () = - (* Note that memo_size is hardcoded to 0 in module [Sapling_generation]. *) - let memo_size = - match Alpha_context.Sapling.Memo_size.parse_z Z.zero with - | Error _ -> assert false - | Ok sz -> sz - in - let info, name = - info_and_name - ~intercept:is_empty - ("ISapling_verify_update_" ^ Type_transaction.suffix) - in - let module B : Benchmark.S = struct - let name = name - - let info = info - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - include Default_config - include Default_boilerplate - - let models = - Interpreter_model.make_model - (Instr_name Interpreter_workload.N_ISapling_verify_update) - - let stack_type = - let spl_state = sapling_state memo_size in - let spl_tx = sapling_transaction memo_size in - spl_tx @$ spl_state @$ bot - - let kinstr = ISapling_verify_update (dummy_loc, halt) - - let prepare_sapling_execution_environment sapling_forge_rng_seed - sapling_transition = - let sapling_forge_rng_state = - Random.State.make - @@ Option.fold - ~none:Sapling_generation.shared_seed - ~some:(fun seed -> [|seed|]) - sapling_forge_rng_seed - in - (* Prepare context. We _must_ reuse the same seed as the one used for - the context when generating the transactions. This ensures that the - bootstrap account match and that the transactions can be replayed. *) - let result = - Lwt_main.run - ( Execution_context.make ~rng_state:sapling_forge_rng_state - >>=? fun (ctxt, step_constants) -> - (* Prepare a sapling state able to replay the transition. *) - Sapling_generation.prepare_seeded_state sapling_transition ctxt - >>=? fun (_, _, _, _, ctxt, state_id) -> - Alpha_context.Sapling.(state_from_id ctxt (Id.parse_z state_id)) - >|= Environment.wrap_tzresult - >>=? fun (state, ctxt) -> return (ctxt, state, step_constants) - ) - in - match result with - | Ok r -> r - | Error _ -> - Format.eprintf - "Error in prepare_sapling_execution_environment, aborting@." ; - Stdlib.failwith "prepare_sapling_execution_environment" - - let create_benchmarks ~rng_state ~bench_num (config : config) = - ignore rng_state ; - match config.sapling with - | {sapling_txs_file; seed} -> - let transitions = - Sapling_generation.load - ~filename:sapling_txs_file - Type_transaction.type_transaction - in - let length = List.length transitions in - if length < bench_num && not is_empty then - Format.eprintf - "ISapling_verify_update: warning, only %d available \ - transactions (requested %d)@." - length - bench_num ; - let transitions = - List.take_n (min bench_num length) transitions - in - List.map - (fun (_, transition) () -> - let ctxt, state, step_constants = - prepare_sapling_execution_environment seed transition - in - let address = - Alpha_context.Contract.( - to_b58check (Originated step_constants.self)) - in - let chain_id = - Environment.Chain_id.to_b58check step_constants.chain_id - in - let anti_replay = address ^ chain_id in - (* Checks that the transaction is correct*) - let () = - match - Sapling_validator.verify_update - (Sapling_generation.alpha_to_raw ctxt) - (Obj.magic state) - transition.sapling_tx - anti_replay - |> Lwt_main.run - with - | Ok (_, Some _) -> () - | Ok (_, None) -> - Stdlib.failwith "benchmarked transaction is incorrect" - | _ -> assert false - in - let stack_instr = - Ex_stack_and_kinstr - { - stack = (transition.sapling_tx, (state, eos)); - stack_type; - kinstr; - } - in - benchmark_from_kinstr_and_stack - ctxt - step_constants - stack_instr) - transitions - end in - Registration_helpers.register (module B) - end - - module Sapling_empty = struct - let module A = Register_Sapling_benchmark (struct - let type_transaction = Sapling_generation.Empty - - let suffix = "empty" - end) in - () - end - - module Sapling_no_inputs = struct - let module A = Register_Sapling_benchmark (struct - let type_transaction = Sapling_generation.No_inputs - - let suffix = "no_inputs" - end) in - () - end - - module Sapling_no_outputs = struct - let module A = Register_Sapling_benchmark (struct - let type_transaction = Sapling_generation.No_outputs - - let suffix = "no_output" - end) in - () - end - - module Sapling_full = struct - let module A = Register_Sapling_benchmark (struct - let type_transaction = Sapling_generation.Full_transaction - - let suffix = "full" - end) in - () - end - - (* when benchmarking, compile bls12-381-unix without ADX, see - https://gitlab.com/dannywillems/ocaml-bls12-381/-/blob/71d0b4d467fbfaa6452d702fcc408d7a70916a80/README.md#install - *) - module Bls12_381 = struct - let check () = - if not Bls12_381.built_with_blst_portable then ( - Format.eprintf - "BLS must be built without ADX to run the BLS benchmarks. Try \ - compiling again after setting the environment variable \ - BLST_PORTABLE. Aborting.@." ; - Stdlib.failwith "bls_not_built_with_blst_portable") - - let () = - simple_benchmark - ~check - ~name:Interpreter_workload.N_IAdd_bls12_381_g1 - ~stack_type:(bls12_381_g1 @$ bls12_381_g1 @$ bot) - ~kinstr:(IAdd_bls12_381_g1 (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~check - ~name:Interpreter_workload.N_IAdd_bls12_381_g2 - ~stack_type:(bls12_381_g2 @$ bls12_381_g2 @$ bot) - ~kinstr:(IAdd_bls12_381_g2 (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~check - ~name:Interpreter_workload.N_IAdd_bls12_381_fr - ~stack_type:(bls12_381_fr @$ bls12_381_fr @$ bot) - ~kinstr:(IAdd_bls12_381_fr (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~check - ~name:Interpreter_workload.N_IMul_bls12_381_g1 - ~stack_type:(bls12_381_g1 @$ bls12_381_fr @$ bot) - ~kinstr:(IMul_bls12_381_g1 (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~check - ~name:Interpreter_workload.N_IMul_bls12_381_g2 - ~stack_type:(bls12_381_g2 @$ bls12_381_fr @$ bot) - ~kinstr:(IMul_bls12_381_g2 (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~check - ~name:Interpreter_workload.N_IMul_bls12_381_fr - ~stack_type:(bls12_381_fr @$ bls12_381_fr @$ bot) - ~kinstr:(IMul_bls12_381_fr (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~check - ~name:Interpreter_workload.N_IMul_bls12_381_z_fr - ~stack_type:(bls12_381_fr @$ int @$ bot) - ~kinstr:(IMul_bls12_381_z_fr (dummy_loc, halt)) - () - - let () = - benchmark_with_stack_sampler - ~check - ~name:Interpreter_workload.N_IMul_bls12_381_z_fr - ~intercept:true - ~stack_type:(bls12_381_fr @$ int @$ bot) - ~kinstr:(IMul_bls12_381_z_fr (dummy_loc, halt)) - ~stack_sampler:(fun cfg rng_state -> - let _, (module Samplers) = make_default_samplers cfg.sampler in - let fr_sampler = Samplers.Random_value.value bls12_381_fr in - let zero = Script_int.zero in - fun () -> (fr_sampler rng_state, (zero, eos))) - () - - let () = - simple_benchmark - ~check - ~name:Interpreter_workload.N_IMul_bls12_381_fr_z - ~stack_type:(int @$ bls12_381_fr @$ bot) - ~kinstr:(IMul_bls12_381_fr_z (dummy_loc, halt)) - () - - let () = - benchmark_with_stack_sampler - ~check - ~name:Interpreter_workload.N_IMul_bls12_381_fr_z - ~intercept:true - ~stack_type:(int @$ bls12_381_fr @$ bot) - ~kinstr:(IMul_bls12_381_fr_z (dummy_loc, halt)) - ~stack_sampler:(fun cfg rng_state -> - let _, (module Samplers) = make_default_samplers cfg.sampler in - let fr_sampler = Samplers.Random_value.value bls12_381_fr in - let zero = Script_int.zero in - fun () -> (zero, (fr_sampler rng_state, eos))) - () - - let () = - simple_benchmark - ~check - ~name:Interpreter_workload.N_IInt_bls12_381_z_fr - ~stack_type:(bls12_381_fr @$ bot) - ~kinstr:(IInt_bls12_381_fr (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~check - ~name:Interpreter_workload.N_INeg_bls12_381_g1 - ~stack_type:(bls12_381_g1 @$ bot) - ~kinstr:(INeg_bls12_381_g1 (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~check - ~name:Interpreter_workload.N_INeg_bls12_381_g2 - ~stack_type:(bls12_381_g2 @$ bot) - ~kinstr:(INeg_bls12_381_g2 (dummy_loc, halt)) - () - - let () = - simple_benchmark - ~check - ~name:Interpreter_workload.N_INeg_bls12_381_fr - ~stack_type:(bls12_381_fr @$ bot) - ~kinstr:(INeg_bls12_381_fr (dummy_loc, halt)) - () - - let () = - let (Ty_ex_c p) = pair bls12_381_g1 bls12_381_g2 in - simple_benchmark - ~check - ~name:Interpreter_workload.N_IPairing_check_bls12_381 - ~stack_type:(list p @$ bot) - ~kinstr:(IPairing_check_bls12_381 (dummy_loc, halt)) - () - end - - module Tickets = struct - let () = - simple_benchmark - ~name:Interpreter_workload.N_ITicket - ~stack_type:(unit @$ nat @$ bot) - ~kinstr:(ITicket (dummy_loc, Some unit, halt)) - () - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IRead_ticket - ~stack_type:(ticket unit @$ bot) - ~kinstr:(IRead_ticket (dummy_loc, Some unit, halt)) - () - - let split_ticket_instr = ISplit_ticket (dummy_loc, halt) - - let stack_type = ticket unit @$ cpair nat nat @$ bot - - let () = - let one = Script_int.one_n in - let ticket = - { - ticketer = - Alpha_context.Contract.Implicit - Environment.Signature.Public_key_hash.zero; - contents = (); - amount = Ticket_amount.(add one one); - } - in - benchmark_with_fixed_stack - ~intercept:true - ~name:Interpreter_workload.N_ISplit_ticket - ~stack_type - ~stack:(ticket, ((one, one), eos)) - ~kinstr:split_ticket_instr - () - - let () = - benchmark - ~name:Interpreter_workload.N_ISplit_ticket - ~kinstr_and_stack_sampler:(fun config rng_state -> - let _, (module Samplers) = - make_default_samplers config.Default_config.sampler - in - fun () -> - let x_amount = - Script_int.succ_n @@ Samplers.Random_value.value nat rng_state - in - let y_amount = - Script_int.succ_n @@ Samplers.Random_value.value nat rng_state - in - let amount = Script_int.add_n x_amount y_amount in - let amount = - (* this is safe because x_amount > 0 and y_amount > 0 *) - WithExceptions.Option.get ~loc:__LOC__ - @@ Ticket_amount.of_n amount - in - let ticket = Samplers.Random_value.value (ticket unit) rng_state in - let ticket = {ticket with amount} in - Ex_stack_and_kinstr - { - stack = (ticket, ((x_amount, y_amount), eos)); - stack_type; - kinstr = split_ticket_instr; - }) - () - - let join_tickets_instr = IJoin_tickets (dummy_loc, string, halt) - - let ticket_str = ticket string - - let stack_type = - let (Ty_ex_c p) = pair ticket_str ticket_str in - p @$ bot - - let () = - benchmark - ~intercept:true - ~name:Interpreter_workload.N_IJoin_tickets - ~kinstr_and_stack_sampler:(fun config rng_state -> - let _, (module Samplers) = - make_default_samplers config.Default_config.sampler - in - fun () -> - let ticket = - Samplers.Random_value.value (ticket string) rng_state - in - let ticket = - { - ticket with - contents = Script_string.empty; - amount = Ticket_amount.one; - } - in - Ex_stack_and_kinstr - { - stack = ((ticket, ticket), eos); - stack_type; - kinstr = join_tickets_instr; - }) - () - - let () = - benchmark - ~name:Interpreter_workload.N_IJoin_tickets - ~kinstr_and_stack_sampler:(fun config rng_state -> - let _, (module Samplers) = - make_default_samplers config.Default_config.sampler - in - fun () -> - let ticket = - Samplers.Random_value.value (ticket string) rng_state - in - let alt_amount = - let amount = Samplers.Random_value.value nat rng_state in - let open Ticket_amount in - match of_n amount with - | Some amount -> add amount one - | None -> one - in - let ticket' = {ticket with amount = alt_amount} in - Ex_stack_and_kinstr - { - stack = ((ticket, ticket'), eos); - stack_type; - kinstr = join_tickets_instr; - }) - () - end - - module Timelock = struct - let name = Interpreter_workload.N_IOpen_chest - - let stack_type = - Michelson_types.chest_key @$ Michelson_types.chest @$ nat @$ bot - - let kinstr = IOpen_chest (dummy_loc, halt) - - let resulting_stack chest chest_key time = - let chest = Script_timelock.make_chest chest in - let chest_key = Script_timelock.make_chest_key chest_key in - ( chest_key, - ( chest, - ( Script_int.is_nat (Script_int.of_int time) - |> WithExceptions.Option.get ~loc:"Timelock:gas benchmarks", - eos ) ) ) - - let () = - benchmark_with_stack_sampler - ~intercept:true - ~name - ~kinstr - ~stack_type - ~stack_sampler:(fun _ rng_state () -> - let chest, chest_key = - Timelock_samplers.chest_sampler ~plaintext_size:1 ~time:0 ~rng_state - in - resulting_stack chest chest_key 0) - () - - let () = - benchmark_with_stack_sampler - ~name - ~kinstr - ~stack_type - ~stack_sampler:(fun _ rng_state () -> - let log_time = - Base_samplers.sample_in_interval - ~range:{min = 0; max = 29} - rng_state - in - let time = Random.State.int rng_state (Int.shift_left 1 log_time) in - let plaintext_size = - Base_samplers.sample_in_interval - ~range:{min = 1; max = 10000} - rng_state - in - - let chest, chest_key = - Timelock_samplers.chest_sampler ~plaintext_size ~time ~rng_state - in - resulting_stack chest chest_key time) - () - end - - module Continuations = struct - let () = - (* - KNil - *) - continuation_benchmark - ~amplification:100 - ~name:Interpreter_workload.N_KNil - ~cont_and_stack_sampler:(fun _cfg _rng_state -> - let cont = KNil in - let stack = eos in - let stack_type = bot in - fun () -> Ex_stack_and_cont {stack; cont; stack_type}) - () - - let () = - (* - KCons -> step - KHalt -> next - KNil - *) - continuation_benchmark - ~amplification:100 - ~name:Interpreter_workload.N_KCons - ~cont_and_stack_sampler:(fun _cfg _rng_state -> - let cont = KCons (halt, KNil) in - let stack = ((), eos) in - let stack_type = unit @$ bot in - fun () -> Ex_stack_and_cont {stack; cont; stack_type}) - () - - let () = - (* - KReturn -> next - KNil - *) - continuation_benchmark - ~amplification:100 - ~name:Interpreter_workload.N_KReturn - ~cont_and_stack_sampler:(fun _cfg _rng_state -> - let cont = KReturn (eos, Some (unit @$ bot), KNil) in - let stack = ((), eos) in - let stack_type = unit @$ bot in - fun () -> Ex_stack_and_cont {stack; cont; stack_type}) - () - - let () = - (* - KView_exit -> next - KNil - *) - continuation_benchmark - ~amplification:100 - ~name:Interpreter_workload.N_KView_exit - ~cont_and_stack_sampler:(fun _cfg _rng_state -> - let open Script_typed_ir in - let open Alpha_context in - let step_constants = - { - source = Contract (Implicit Signature.Public_key_hash.zero); - payer = Signature.Public_key_hash.zero; - self = Contract_hash.zero; - amount = Tez.zero; - balance = Tez.zero; - chain_id = Chain_id.zero; - now = Script_timestamp.of_zint Z.zero; - level = Script_int.zero_n; - } - in - let cont = KView_exit (step_constants, KNil) in - let stack = ((), eos) in - let stack_type = unit @$ bot in - fun () -> Ex_stack_and_cont {stack; cont; stack_type}) - () - - let () = - (* - KLoop_in -> next - KNil - *) - continuation_benchmark - ~amplification:100 - ~name:Interpreter_workload.N_KLoop_in - ~cont_and_stack_sampler:(fun _cfg _rng_state -> - let cont = KLoop_in (IPush (dummy_loc, bool, false, halt), KNil) in - let stack = (false, ((), eos)) in - let stack_type = bool @$ unit @$ bot in - fun () -> Ex_stack_and_cont {stack; cont; stack_type}) - () - - let () = - (* - KLoop_in_left -> next - KNil - *) - continuation_benchmark - ~amplification:100 - ~name:Interpreter_workload.N_KLoop_in_left - ~cont_and_stack_sampler:(fun _cfg _rng_state -> - let cont = - KLoop_in_left (ICons_right (dummy_loc, unit, halt), KNil) - in - let stack = (R (), eos) in - let stack_type = cor unit unit @$ bot in - fun () -> Ex_stack_and_cont {stack; cont; stack_type}) - () - - let () = - (* - KUndip -> next - KNil - *) - continuation_benchmark - ~amplification:100 - ~name:Interpreter_workload.N_KUndip - ~cont_and_stack_sampler:(fun _cfg _rng_state -> - let cont = KUndip ((), Some unit, KNil) in - let stack = eos in - let stack_type = bot in - fun () -> Ex_stack_and_cont {stack; cont; stack_type}) - () - - let () = - (* - KIter (empty case) -> next - KNil - *) - continuation_benchmark - ~amplification:100 - ~name:Interpreter_workload.N_KIter - ~salt:"_empty" - ~cont_and_stack_sampler:(fun _cfg _rng_state -> - let cont = KIter (IDrop (dummy_loc, halt), Some unit, [], KNil) in - let stack = ((), eos) in - let stack_type = unit @$ bot in - fun () -> Ex_stack_and_cont {stack; cont; stack_type}) - () - - let () = - (* - KIter (nonempty case) -> step - KDrop -> step - KHalt -> next - KIter (empty case) -> next - KNil - *) - continuation_benchmark - ~amplification:100 - ~name:Interpreter_workload.N_KIter - ~salt:"_nonempty" - ~cont_and_stack_sampler:(fun _cfg _rng_state -> - let cont = KIter (IDrop (dummy_loc, halt), Some unit, [()], KNil) in - let stack = ((), eos) in - let stack_type = unit @$ bot in - fun () -> Ex_stack_and_cont {stack; cont; stack_type}) - () - - let () = - (* - KList_enter_body ([()], bot accumulator case) -> step - KHalt -> next - KList_exit_body ([], []) -> - KList_enter_body ([], [()] -> - List.rev singleton - KNil - *) - continuation_benchmark - ~amplification:100 - ~name:Interpreter_workload.N_KList_enter_body - ~salt:"_singleton_list" - ~cont_and_stack_sampler:(fun _cfg _rng_state -> - let kbody = halt in - fun () -> - let cont = - KList_enter_body - (kbody, [()], Script_list.empty, Some (list unit), 1, KNil) - in - Ex_stack_and_cont - {stack = ((), eos); stack_type = unit @$ bot; cont}) - () - - let () = - (* - KList_enter_body (empty list, nonempty accumulator case) -> - {List.rev n elements} -> next - KNil - *) - continuation_benchmark - ~amplification:100 - ~name:Interpreter_workload.N_KList_enter_body - ~salt:"_terminal" - ~cont_and_stack_sampler:(fun cfg rng_state -> - let _, (module Samplers) = make_default_samplers cfg.sampler in - let kbody = halt in - fun () -> - let ys = Samplers.Random_value.value (list unit) rng_state in - let cont = - KList_enter_body (kbody, [], ys, Some (list unit), ys.length, KNil) - in - Ex_stack_and_cont - {stack = ((), eos); stack_type = unit @$ bot; cont}) - () - - let () = - (* - KList_enter_body (empty list, bot accumulator case) -> - {List.rev singleton} -> next - KNil - *) - continuation_benchmark - ~amplification:100 - ~intercept:true - ~name:Interpreter_workload.N_KList_enter_body - ~salt:"_terminal" - ~cont_and_stack_sampler:(fun _cfg _rng_state -> - let kbody = halt in - fun () -> - let cont = - KList_enter_body - (kbody, [], Script_list.empty, Some (list unit), 1, KNil) - in - Ex_stack_and_cont - {stack = ((), eos); stack_type = unit @$ bot; cont}) - () - - let () = - (* - KList_exit_body (empty list) -> next - KList_enter_body -> - {List.rev 1 element} -> next - KNil - *) - continuation_benchmark - ~amplification:100 - ~intercept:true - ~name:Interpreter_workload.N_KList_exit_body - ~salt:"_terminal" - ~cont_and_stack_sampler:(fun _cfg _rng_state -> - let kbody = halt in - let cont = - KList_exit_body - (kbody, [], Script_list.empty, Some (list unit), 1, KNil) - in - fun () -> - Ex_stack_and_cont - {stack = ((), ((), eos)); stack_type = unit @$ unit @$ bot; cont}) - () - - let stack_type = cpair int unit @$ unit @$ bot - - let map_enter_body_code = - let kbody = ICdr (dummy_loc, halt) in - fun accu -> - KMap_enter_body - (kbody, accu, Script_map.empty int, Some (map int unit), KNil) - - let () = - (* - KMap_enter_body (empty case) -> next - KNil - *) - continuation_benchmark - ~amplification:100 - ~salt:"_empty" - ~name:Interpreter_workload.N_KMap_enter_body - ~cont_and_stack_sampler:(fun _cfg _rng_state () -> - Ex_stack_and_cont - { - stack = ((), eos); - stack_type = unit @$ bot; - cont = map_enter_body_code []; - }) - () - - let () = - (* - KMap_enter_body (singleton case) -> step - KCdr -> step - KHalt -> next - KMap_exit_body -> next - (map_update) - KMap_enter_body (empty case) -> next - KNil - *) - continuation_benchmark - ~amplification:100 - ~salt:"_singleton" - ~name:Interpreter_workload.N_KMap_enter_body - ~cont_and_stack_sampler:(fun _cfg _rng_state () -> - Ex_stack_and_cont - { - stack = ((), eos); - stack_type = unit @$ bot; - cont = map_enter_body_code [(Script_int.zero, ())]; - }) - () - - let () = - (* - KMap_exit_body -> - (map_update) -> next - KMap_enter_body (empty case) -> next - KNil - *) - continuation_benchmark - ~amplification:100 - ~name:Interpreter_workload.N_KMap_exit_body - ~cont_and_stack_sampler:(fun cfg rng_state -> - let kbody = ICdr (dummy_loc, halt) in - fun () -> - let ty = map int unit in - let key, map = Maps.generate_map_and_key_in_map cfg rng_state in - let cont = KMap_exit_body (kbody, [], map, key, Some ty, KNil) in - Ex_stack_and_cont - {stack = ((), ((), eos)); stack_type = unit @$ unit @$ bot; cont}) - () - - let () = - (* KMap_head -> KNil *) - continuation_benchmark - ~amplification:100 - ~name:Interpreter_workload.N_KMap_head - ~cont_and_stack_sampler:(fun _cfg _rng_state () -> - let cont = KMap_head (Option.some, KNil) in - Ex_stack_and_cont - {stack = ((), ((), eos)); stack_type = unit @$ unit @$ bot; cont}) - () - end - - let () = - simple_benchmark - ~name:Interpreter_workload.N_IEmit - ~stack_type:(unit_t @$ bot) - ~kinstr: - (IEmit - { - ty = unit_t; - k = halt; - loc = dummy_loc; - tag = Entrypoint_repr.default; - unparsed_ty = Script_repr.unit; - }) - () -end diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/interpreter_model.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/interpreter_model.ml deleted file mode 100644 index 20ebe6dac8f62bb4776b083b66d6d8c2c8e35b1a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/interpreter_model.ml +++ /dev/null @@ -1,559 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 ns = Namespace.make Registration_helpers.ns "interpreter" - -let fv s = Free_variable.of_namespace (ns s) - -(* ------------------------------------------------------------------------- *) - -let trace_error expected given = - let open Interpreter_workload in - let exp = string_of_instr_or_cont expected in - let given = string_of_instr_or_cont given in - let msg = - Format.asprintf - "Interpreter_model: trace error, expected %s, given %s" - exp - given - in - Stdlib.failwith msg - -let arity_error instr expected given = - let open Interpreter_workload in - let s = string_of_instr_or_cont instr in - let msg = - Format.asprintf - "Interpreter_model: arity error (%s), expected %d, given %a" - s - expected - Interpreter_workload.pp_args - given - in - Stdlib.failwith msg - -(* ------------------------------------------------------------------------- *) - -let arity_to_int : type a b c. (a, b, c) Model.arity -> int = - fun arity -> - let rec aux : type x y z. int -> (x, y, z) Model.arity -> int = - fun i -> function - | Model.Zero_arity -> i - | Succ_arity arity -> aux (i + 1) arity - in - aux 0 arity - -let model_with_conv : - type a. - Interpreter_workload.instr_or_cont_name -> - a Model.model -> - Interpreter_workload.ir_sized_step Model.t = - fun instr model -> - let open Interpreter_workload in - let module M = (val model) in - let module I = Model.Instantiate (Costlang.Void) (M) in - let arity_init = I.arity in - let rec make_args : - type x y z. arg list -> arg list -> (x, y, z) Model.arity -> z = - fun args_init args arity -> - match (args, arity) with - | [], Zero_arity -> () - | {arg; _} :: l, Succ_arity arity -> (arg, make_args args_init l arity) - | _ -> arity_error instr (arity_to_int arity_init) args_init - in - let conv {name; args} = - if name = instr then make_args args args arity_init - else trace_error instr name - in - Model.make ~conv model - -let sf = Format.asprintf - -let division_cost name = - let const = fv (sf "%s_const" name) in - let coeff = fv (sf "%s_coeff" name) in - let module M = struct - type arg_type = int * (int * unit) - - let takes_saturation_reprs = false - - module Def (X : Costlang.S) = struct - open X - - type model_type = size -> size -> size - - let arity = Model.arity_2 - - let model = - lam ~name:"size1" @@ fun size1 -> - lam ~name:"size2" @@ fun size2 -> - (* Note that [q] is guaranteed to be non-negative because we use - saturated subtraction. When [size1 < size2], the model evaluates to - [const] as expected. *) - let_ ~name:"q" (sat_sub size1 size2) @@ fun q -> - (free ~name:coeff * q * size2) + free ~name:const - end - - let name = ns name - end in - (module M : Model.Model_impl with type arg_type = int * (int * unit)) - -let addlogadd name = - let const = fv (sf "%s_const" name) in - let coeff = fv (sf "%s_coeff" name) in - let module M = struct - type arg_type = int * (int * unit) - - let name = ns name - - let takes_saturation_reprs = false - - module Def (X : Costlang.S) = struct - open X - - type model_type = size -> size -> size - - let arity = Model.arity_2 - - let model = - lam ~name:"size1" @@ fun size1 -> - lam ~name:"size2" @@ fun size2 -> - let_ ~name:"a" (size1 + size2) @@ fun a -> - (free ~name:coeff * (a * log2 (int 1 + a))) + free ~name:const - end - end in - (module M : Model.Model_impl with type arg_type = int * (int * unit)) - -let name_of_instr_or_cont instr_or_cont = - Interpreter_workload.string_of_instr_or_cont instr_or_cont - -module Models = struct - let const1_model name = - (* For constant-time instructions *) - Model.unknown_const1 ~name:(ns name) ~const:(fv (sf "%s_const" name)) - - let affine_model name = - (* For instructions with cost function - [\lambda size. const + coeff * size] *) - Model.affine - ~name:(ns name) - ~intercept:(fv (sf "%s_const" name)) - ~coeff:(fv (sf "%s_coeff" name)) - - let break_model name break = - Model.breakdown - ~name:(ns name) - ~coeff1:(fv (sf "%s_coeff1" name)) - ~coeff2:(fv (sf "%s_coeff2" name)) - ~break - - let break_model_2 name break1 break2 = - Model.breakdown2 - ~name:(ns name) - ~coeff1:(fv (sf "%s_coeff1" name)) - ~coeff2:(fv (sf "%s_coeff2" name)) - ~coeff3:(fv (sf "%s_coeff3" name)) - ~break1 - ~break2 - - let break_model_2_const name break1 break2 = - Model.breakdown2_const - ~name:(ns name) - ~coeff1:(fv (sf "%s_coeff1" name)) - ~coeff2:(fv (sf "%s_coeff2" name)) - ~coeff3:(fv (sf "%s_coeff3" name)) - ~const:(fv (sf "%s_const" name)) - ~break1 - ~break2 - - let nlogm_model name = - (* For instructions with cost function - [\lambda size1. \lambda size2. const + coeff * size1 log2(size2)] *) - Model.nlogm - ~name:(ns name) - ~intercept:(fv (sf "%s_const" name)) - ~coeff:(fv (sf "%s_coeff" name)) - - let concat_model name = - Model.bilinear_affine - ~name:(ns name) - ~intercept:(fv (sf "%s_const" name)) - ~coeff1:(fv (sf "%s_total_bytes" name)) - ~coeff2:(fv (sf "%s_list_length" name)) - - let concat_pair_model name = - Model.linear_sum - ~name:(ns name) - ~intercept:(fv (sf "%s_const" name)) - ~coeff:(fv (sf "%s_coeff" name)) - - let linear_max_model name = - (* For instructions with cost function - [\lambda size1. \lambda size2. const + coeff * max(size1,size2)] *) - Model.linear_max - ~name:(ns name) - ~intercept:(fv (sf "%s_const" name)) - ~coeff:(fv (sf "%s_coeff" name)) - - let linear_min_model name = - (* For instructions with cost function - [\lambda size1. \lambda size2. const + coeff * min(size1,size2)] *) - Model.linear_min - ~name:(ns name) - ~intercept:(fv (sf "%s_const" name)) - ~coeff:(fv (sf "%s_coeff" name)) - - let pack_model name = - Model.trilinear - ~name:(ns name) - ~coeff1:(fv (sf "%s_micheline_nodes" name)) - ~coeff2:(fv (sf "%s_micheline_int_bytes" name)) - ~coeff3:(fv (sf "%s_micheline_string_bytes" name)) - - let open_chest_model name = - let module M = struct - type arg_type = int * (int * unit) - - let takes_saturation_reprs = false - - module Def (X : Costlang.S) = struct - open X - - type model_type = size -> size -> size - - let arity = Model.arity_2 - - let model = - lam ~name:"size1" @@ fun size1 -> - lam ~name:"size2" @@ fun size2 -> - free ~name:(fv (sf "%s_const" name)) - + (free ~name:(fv (sf "%s_log_time_coeff" name)) * size1) - + (free ~name:(fv (sf "%s_plaintext_coeff" name)) * size2) - end - - let name = ns name - end in - (module M : Model.Model_impl with type arg_type = int * (int * unit)) - - let verify_update_model name = - Model.bilinear_affine - ~name:(ns name) - ~intercept:(fv (sf "%s_const" name)) - ~coeff1:(fv (sf "%s_inputs" name)) - ~coeff2:(fv (sf "%s_ouputs" name)) - - let list_enter_body_model name = - let module M = struct - type arg_type = int * (int * unit) - - let takes_saturation_reprs = false - - module Def (X : Costlang.S) = struct - open X - - type model_type = size -> size -> size - - let arity = Model.arity_2 - - let model = - lam ~name:"size_xs" @@ fun size_xs -> - lam ~name:"size_ys" @@ fun size_ys -> - if_ - (eq size_xs (int 0)) - (free ~name:(fv (sf "%s_const" name)) - + (free ~name:(fv (sf "%s_coeff" name)) * size_ys)) - (free ~name:(fv (sf "%s_iter" name))) - end - - let name = ns name - end in - (module M : Model.Model_impl with type arg_type = int * (int * unit)) - - let branching_model ~case_0 ~case_1 name = - let module M = struct - type arg_type = int * unit - - let takes_saturation_reprs = false - - module Def (X : Costlang.S) = struct - open X - - type model_type = size -> size - - let arity = Model.arity_1 - - let model = - lam ~name:"size" @@ fun size -> - if_ - (eq size (int 0)) - (free ~name:(fv (sf "%s_%s" name case_0))) - (free ~name:(fv (sf "%s_%s" name case_1))) - end - - let name = ns name - end in - (module M : Model.Model_impl with type arg_type = int * unit) - - let empty_branch_model name = - branching_model ~case_0:"empty" ~case_1:"nonempty" name - - let apply_model name = branching_model ~case_0:"lam" ~case_1:"lamrec" name - - let join_tickets_model name = - let module M = struct - type arg_type = int * (int * (int * (int * unit))) - - let takes_saturation_reprs = false - - module Def (X : Costlang.S) = struct - open X - - type model_type = size -> size -> size -> size -> size - - let arity = Model.Succ_arity Model.arity_3 - - let model = - lam ~name:"content_size_x" @@ fun content_size_x -> - lam ~name:"content_size_y" @@ fun content_size_y -> - lam ~name:"amount_size_x" @@ fun amount_size_x -> - lam ~name:"amount_size_y" @@ fun amount_size_y -> - free ~name:(fv (sf "%s_const" name)) - + free ~name:(fv (sf "%s_compare_coeff" name)) - * min content_size_x content_size_y - + free ~name:(fv (sf "%s_add_coeff" name)) - * max amount_size_x amount_size_y - end - - let name = ns name - end in - (module M : Model.Model_impl - with type arg_type = int * (int * (int * (int * unit)))) - - let lsl_bytes_model name = - Model.bilinear_affine - ~name:(ns name) - ~intercept:(fv (sf "%s_const" name)) - ~coeff1:(fv (sf "%s_bytes" name)) - ~coeff2:(fv (sf "%s_shift" name)) - - let lsr_bytes_model name = - let const = fv (sf "%s_const" name) in - let coeff = fv (sf "%s_coeff" name) in - let module M = struct - type arg_type = int * (int * unit) - - let takes_saturation_reprs = false - - module Def (X : Costlang.S) = struct - open X - - type model_type = size -> size -> size - - let arity = Model.arity_2 - - let model = - lam ~name:"size1" @@ fun size1 -> - lam ~name:"size2" @@ fun size2 -> - (* Note that [q] is guaranteed to be non-negative because we use - saturated subtraction. When [size1 < size2], the model evaluates to - [const] as expected. *) - let_ ~name:"q" (sat_sub size1 (size2 * float 0.125)) @@ fun q -> - free ~name:const + (free ~name:coeff * q) - end - - let name = ns name - end in - (module M : Model.Model_impl with type arg_type = int * (int * unit)) -end - -let ir_model instr_or_cont = - let open Interpreter_workload in - let open Models in - let name = name_of_instr_or_cont instr_or_cont in - let m s = Model.Model s in - match instr_or_cont with - | Instr_name instr -> ( - match instr with - | N_IDrop | N_IDup | N_ISwap | N_IPush | N_ICons_pair | N_ICar | N_ICdr - | N_ICons_some | N_ICons_none | N_IIf_none | N_IOpt_map | N_ILeft - | N_IRight | N_IIf_left | N_ICons_list | N_INil | N_IIf_cons - | N_IEmpty_set | N_IEmpty_map | N_IEmpty_big_map | N_IOr | N_IAnd | N_IXor - | N_INot | N_IIf | N_ILoop | N_ILoop_left | N_IDip | N_IExec | N_IView - | N_ILambda | N_IFailwith | N_IAddress | N_ICreate_contract - | N_ISet_delegate | N_INow | N_IMin_block_time | N_IBalance | N_IHash_key - | N_IUnpack | N_ISource | N_ISender | N_ISelf | N_IAmount | N_IChainId - | N_ILevel | N_ISelf_address | N_INever | N_IUnpair | N_IVoting_power - | N_ITotal_voting_power | N_IList_size | N_ISet_size | N_IMap_size - | N_ISapling_empty_state -> - const1_model name |> m - | N_ISet_mem | N_ISet_update | N_IMap_mem | N_IMap_get | N_IMap_update - | N_IBig_map_mem | N_IBig_map_get | N_IBig_map_update - | N_IMap_get_and_update | N_IBig_map_get_and_update -> - nlogm_model name |> m - | N_IConcat_string -> concat_model name |> m - | N_IConcat_string_pair -> concat_pair_model name |> m - | N_ISlice_string -> affine_model name |> m - | N_IString_size -> const1_model name |> m - | N_IConcat_bytes -> concat_model name |> m - | N_IConcat_bytes_pair -> concat_pair_model name |> m - | N_ISlice_bytes -> affine_model name |> m - | N_IBytes_size -> const1_model name |> m - | N_IOr_bytes -> linear_max_model name |> m - | N_IAnd_bytes -> linear_min_model name |> m - | N_IXor_bytes -> linear_max_model name |> m - | N_INot_bytes -> affine_model name |> m - | N_ILsl_bytes -> lsl_bytes_model name |> m - | N_ILsr_bytes -> lsr_bytes_model name |> m - | N_IBytes_nat -> affine_model name |> m - | N_INat_bytes -> affine_model name |> m - | N_IBytes_int -> affine_model name |> m - | N_IInt_bytes -> affine_model name |> m - | N_IAdd_seconds_to_timestamp | N_IAdd_timestamp_to_seconds - | N_ISub_timestamp_seconds | N_IDiff_timestamps -> - linear_max_model name |> m - | N_IAdd_tez | N_ISub_tez | N_ISub_tez_legacy | N_IEdiv_tez - | N_IMul_teznat | N_IMul_nattez | N_IEdiv_teznat -> - const1_model name |> m - | N_IIs_nat -> const1_model name |> m - | N_INeg -> affine_model name |> m - | N_IAbs_int -> affine_model name |> m - | N_IInt_nat -> const1_model name |> m - | N_IAdd_int -> linear_max_model name |> m - | N_IAdd_nat -> linear_max_model name |> m - | N_ISub_int -> linear_max_model name |> m - | N_IMul_int -> addlogadd name |> m - | N_IMul_nat -> addlogadd name |> m - | N_IEdiv_int -> division_cost name |> m - | N_IEdiv_nat -> division_cost name |> m - | N_ILsl_nat -> affine_model name |> m - | N_ILsr_nat -> affine_model name |> m - | N_IOr_nat -> linear_max_model name |> m - | N_IAnd_nat -> linear_min_model name |> m - | N_IAnd_int_nat -> linear_min_model name |> m - | N_IXor_nat -> linear_max_model name |> m - | N_INot_int -> affine_model name |> m - | N_ICompare -> linear_min_model name |> m - | N_IEq | N_INeq | N_ILt | N_IGt | N_ILe | N_IGe -> const1_model name |> m - | N_IPack -> pack_model name |> m - | N_IBlake2b | N_ISha256 | N_ISha512 | N_IKeccak | N_ISha3 -> - affine_model name |> m - | N_ICheck_signature_ed25519 | N_ICheck_signature_secp256k1 - | N_ICheck_signature_p256 | N_ICheck_signature_bls -> - affine_model name |> m - | N_IContract | N_ITransfer_tokens | N_IImplicit_account -> - const1_model name |> m - (* The following two instructions are expected to have an affine model. However, - we observe 3 affine parts, on [0;300], [300;400] and [400;\inf[. *) - | N_IDupN -> break_model_2 name 300 400 |> m - | N_IDropN -> break_model_2_const name 300 400 |> m - | N_IDig | N_IDug | N_IDipN -> affine_model name |> m - | N_IAdd_bls12_381_g1 | N_IAdd_bls12_381_g2 | N_IAdd_bls12_381_fr - | N_IMul_bls12_381_g1 | N_IMul_bls12_381_g2 | N_IMul_bls12_381_fr - | N_INeg_bls12_381_g1 | N_INeg_bls12_381_g2 | N_INeg_bls12_381_fr - | N_IInt_bls12_381_z_fr -> - const1_model name |> m - | N_IMul_bls12_381_fr_z | N_IMul_bls12_381_z_fr - | N_IPairing_check_bls12_381 -> - affine_model name |> m - | N_IComb_get | N_IComb | N_IComb_set | N_IUncomb -> - affine_model name |> m - | N_ITicket | N_IRead_ticket -> const1_model name |> m - | N_ISplit_ticket -> linear_max_model name |> m - | N_IJoin_tickets -> join_tickets_model name |> m - | N_ISapling_verify_update -> verify_update_model name |> m - | N_IList_map -> const1_model name |> m - | N_IList_iter -> const1_model name |> m - | N_IIter -> const1_model name |> m - | N_IMap_map -> affine_model name |> m - | N_IMap_iter -> affine_model name |> m - | N_ISet_iter -> affine_model name |> m - | N_IHalt -> const1_model name |> m - | N_IApply -> apply_model name |> m - | N_ILog -> const1_model name |> m - | N_IOpen_chest -> open_chest_model name |> m - | N_IEmit -> const1_model name |> m) - | Cont_name cont -> ( - match cont with - | N_KNil -> const1_model name |> m - | N_KCons -> const1_model name |> m - | N_KReturn -> const1_model name |> m - | N_KView_exit -> const1_model name |> m - | N_KMap_head -> const1_model name |> m - | N_KUndip -> const1_model name |> m - | N_KLoop_in -> const1_model name |> m - | N_KLoop_in_left -> const1_model name |> m - | N_KIter -> empty_branch_model name |> m - | N_KList_enter_body -> list_enter_body_model name |> m - | N_KList_exit_body -> const1_model name |> m - | N_KMap_enter_body -> empty_branch_model name |> m - | N_KMap_exit_body -> nlogm_model name |> m - | N_KLog -> const1_model name |> m) - -let amplification_loop_iteration = fv "amplification_loop_iteration" - -let amplification_loop_model = - Model.make - ~conv:(fun iterations -> (iterations, ())) - (Model.linear - ~name:(ns "amplification_loop_model") - ~coeff:amplification_loop_iteration) - -(* The following model stitches together the per-instruction models and - adds a term corresponding to the amplification (if needed). *) -let interpreter_model ?amplification sub_model = - Model.make_aggregated - ~model:(fun trace -> - let module Def (X : Costlang.S) = struct - type t = X.size X.repr - - let applied = - let initial = - match amplification with - | None -> X.int 0 - | Some amplification_factor -> - let (module Amplification_applied) = - Model.apply amplification_loop_model amplification_factor - in - let module Amplification_result = Amplification_applied (X) in - Amplification_result.applied - in - List.fold_left - (fun (acc : X.size X.repr) instr_trace -> - let name = instr_trace.Interpreter_workload.name in - let (Model.Model model) = ir_model name in - let (module Applied_instr) = - Model.apply (model_with_conv name model) instr_trace - in - let module R = Applied_instr (X) in - X.(acc + R.applied)) - initial - trace - end in - ((module Def) : Model.applied)) - ~sub_models:[sub_model] - -let make_model ?amplification instr_name = - let ir_model = ir_model instr_name in - [("interpreter", interpreter_model ?amplification ir_model)] diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/interpreter_workload.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/interpreter_workload.ml deleted file mode 100644 index 76da169ca2eb294fb1e38a8655f04663f3265665..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/interpreter_workload.ml +++ /dev/null @@ -1,1679 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021-2022 Nomadic Labs *) -(* Copyright (c) 2022 DaiLambda, 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 -module Size = Gas_input_size - -(* ------------------------------------------------------------------------- *) - -type id = string - -let pp_id = Format.pp_print_string - -let equal_id = String.equal - -(* ------------------------------------------------------------------------- *) -(* Names of IR instructions together with sizes of their operands as - encountered during evaluation. *) - -type instruction_name = - (* stack ops *) - | N_IDrop - | N_IDup - | N_ISwap - | N_IPush - (* pairs *) - | N_ICons_pair - | N_ICar - | N_ICdr - | N_IUnpair - (* options *) - | N_ICons_some - | N_ICons_none - | N_IIf_none - | N_IOpt_map - (* ors *) - | N_ILeft - | N_IRight - | N_IIf_left - (* lists *) - | N_ICons_list - | N_INil - | N_IIf_cons - | N_IList_map - | N_IList_iter - | N_IIter - | N_IList_size - (* sets *) - | N_IEmpty_set - | N_ISet_iter - | N_ISet_mem - | N_ISet_update - | N_ISet_size - (* maps *) - | N_IEmpty_map - | N_IMap_map - | N_IMap_iter - | N_IMap_mem - | N_IMap_get - | N_IMap_update - | N_IMap_get_and_update - | N_IMap_size - (* big maps *) - | N_IEmpty_big_map - | N_IBig_map_mem - | N_IBig_map_get - | N_IBig_map_update - | N_IBig_map_get_and_update - (* string operations *) - | N_IConcat_string - | N_IConcat_string_pair - | N_ISlice_string - | N_IString_size - (* bytes operations *) - | N_IConcat_bytes - | N_IConcat_bytes_pair - | N_ISlice_bytes - | N_IBytes_size - | N_IOr_bytes - | N_IAnd_bytes - | N_IXor_bytes - | N_INot_bytes - | N_ILsl_bytes - | N_ILsr_bytes - | N_IBytes_nat - | N_INat_bytes - | N_IBytes_int - | N_IInt_bytes - (* timestamp operations *) - | N_IAdd_seconds_to_timestamp - | N_IAdd_timestamp_to_seconds - | N_ISub_timestamp_seconds - | N_IDiff_timestamps - (* currency operations *) - | N_IAdd_tez - | N_ISub_tez - | N_ISub_tez_legacy - | N_IMul_teznat - | N_IMul_nattez - | N_IEdiv_teznat - | N_IEdiv_tez - (* boolean operations - assumed O(1) *) - | N_IOr - | N_IAnd - | N_IXor - | N_INot - (* integer operations *) - | N_IIs_nat - | N_INeg - | N_IAbs_int - | N_IInt_nat - | N_IAdd_int - | N_IAdd_nat - | N_ISub_int - | N_IMul_int - | N_IMul_nat - | N_IEdiv_int - | N_IEdiv_nat - | N_ILsl_nat - | N_ILsr_nat - | N_IOr_nat - | N_IAnd_nat - | N_IAnd_int_nat - | N_IXor_nat - | N_INot_int - (* control *) - | N_IIf - | N_ILoop - | N_ILoop_left - | N_IDip - | N_IExec - | N_IApply - | N_ILambda - | N_IFailwith - (* comparison, warning: ad-hoc polymorphic instruction *) - | N_ICompare - (* comparators *) - | N_IEq - | N_INeq - | N_ILt - | N_IGt - | N_ILe - | N_IGe - (* protocol *) - | N_IAddress - | N_IContract - | N_ITransfer_tokens - | N_IImplicit_account - | N_ICreate_contract - | N_ISet_delegate - (* time *) - | N_INow - | N_IMin_block_time - (* other *) - | N_IBalance - | N_ILevel - | N_IView - (* We specialize the check-signature instruction for each crypto scheme. *) - | N_ICheck_signature_ed25519 - | N_ICheck_signature_secp256k1 - | N_ICheck_signature_p256 - | N_ICheck_signature_bls - | N_IHash_key - | N_IPack - | N_IUnpack - | N_IBlake2b - | N_ISha256 - | N_ISha512 - | N_ISource - | N_ISender - | N_ISelf - | N_ISelf_address - | N_IAmount - | N_ISapling_empty_state - | N_ISapling_verify_update - | N_IDig - | N_IDug - | N_IDipN - | N_IDropN - | N_IChainId - | N_INever - | N_IVoting_power - | N_ITotal_voting_power - | N_IKeccak - | N_ISha3 - (* Elliptic curves *) - | N_IAdd_bls12_381_g1 - | N_IAdd_bls12_381_g2 - | N_IAdd_bls12_381_fr - | N_IMul_bls12_381_g1 - | N_IMul_bls12_381_g2 - | N_IMul_bls12_381_fr - | N_INeg_bls12_381_g1 - | N_INeg_bls12_381_g2 - | N_INeg_bls12_381_fr - | N_IMul_bls12_381_fr_z - | N_IMul_bls12_381_z_fr - | N_IInt_bls12_381_z_fr - | N_IPairing_check_bls12_381 - (* Combs *) - | N_IComb - | N_IUncomb - | N_IComb_get - | N_IComb_set - | N_IDupN - (* Tickets *) - | N_ITicket - | N_IRead_ticket - | N_ISplit_ticket - | N_IJoin_tickets - (* Misc *) - | N_IHalt - | N_ILog - (* Timelock*) - | N_IOpen_chest - (* Event *) - | N_IEmit - -type continuation_name = - | N_KNil - | N_KCons - | N_KReturn - | N_KView_exit - | N_KMap_head - | N_KUndip - | N_KLoop_in - | N_KLoop_in_left - | N_KIter - | N_KList_enter_body - | N_KList_exit_body - | N_KMap_enter_body - | N_KMap_exit_body - | N_KLog - -and instr_or_cont_name = - | Instr_name of instruction_name - | Cont_name of continuation_name - -(* ------------------------------------------------------------------------- *) -(* Code that ought to be auto-generated *) - -let string_of_instruction_name : instruction_name -> string = - fun ir -> - match ir with - | N_IDrop -> "N_IDrop" - | N_IDup -> "N_IDup" - | N_ISwap -> "N_ISwap" - | N_IPush -> "N_IPush" - | N_ICons_pair -> "N_ICons_pair" - | N_ICar -> "N_ICar" - | N_ICdr -> "N_ICdr" - | N_ICons_some -> "N_ICons_some" - | N_ICons_none -> "N_ICons_none" - | N_IIf_none -> "N_IIf_none" - | N_IOpt_map -> "N_IOpt_map" - | N_ILeft -> "N_ILeft" - | N_IRight -> "N_IRight" - | N_IIf_left -> "N_IIf_left" - | N_ICons_list -> "N_ICons_list" - | N_INil -> "N_INil" - | N_IIf_cons -> "N_IIf_cons" - | N_IList_map -> "N_IList_map" - | N_IList_iter -> "N_IList_iter" - | N_IIter -> "N_IIter" - | N_IList_size -> "N_IList_size" - | N_IEmpty_set -> "N_IEmpty_set" - | N_ISet_iter -> "N_ISet_iter" - | N_ISet_mem -> "N_ISet_mem" - | N_ISet_update -> "N_ISet_update" - | N_ISet_size -> "N_ISet_size" - | N_IEmpty_map -> "N_IEmpty_map" - | N_IMap_map -> "N_IMap_map" - | N_IMap_iter -> "N_IMap_iter" - | N_IMap_mem -> "N_IMap_mem" - | N_IMap_get -> "N_IMap_get" - | N_IMap_update -> "N_IMap_update" - | N_IMap_size -> "N_IMap_size" - | N_IEmpty_big_map -> "N_IEmpty_big_map" - | N_IBig_map_mem -> "N_IBig_map_mem" - | N_IBig_map_get -> "N_IBig_map_get" - | N_IBig_map_update -> "N_IBig_map_update" - | N_IConcat_string -> "N_IConcat_string" - | N_IConcat_string_pair -> "N_IConcat_string_pair" - | N_ISlice_string -> "N_ISlice_string" - | N_IString_size -> "N_IString_size" - | N_IConcat_bytes -> "N_IConcat_bytes" - | N_IConcat_bytes_pair -> "N_IConcat_bytes_pair" - | N_ISlice_bytes -> "N_ISlice_bytes" - | N_IBytes_size -> "N_IBytes_size" - | N_IOr_bytes -> "N_IOr_bytes" - | N_IAnd_bytes -> "N_IAnd_bytes" - | N_IXor_bytes -> "N_IXor_bytes" - | N_INot_bytes -> "N_INot_bytes" - | N_ILsl_bytes -> "N_ILsl_bytes" - | N_ILsr_bytes -> "N_ILsr_bytes" - | N_IBytes_nat -> "N_IBytes_nat" - | N_INat_bytes -> "N_INat_bytes" - | N_IBytes_int -> "N_IBytes_int" - | N_IInt_bytes -> "N_IInt_bytes" - | N_IAdd_seconds_to_timestamp -> "N_IAdd_seconds_to_timestamp" - | N_IAdd_timestamp_to_seconds -> "N_IAdd_timestamp_to_seconds" - | N_ISub_timestamp_seconds -> "N_ISub_timestamp_seconds" - | N_IDiff_timestamps -> "N_IDiff_timestamps" - | N_IAdd_tez -> "N_IAdd_tez" - | N_ISub_tez -> "N_ISub_tez" - | N_ISub_tez_legacy -> "N_ISub_tez_legacy" - | N_IMul_teznat -> "N_IMul_teznat" - | N_IMul_nattez -> "N_IMul_nattez" - | N_IEdiv_teznat -> "N_IEdiv_teznat" - | N_IEdiv_tez -> "N_IEdiv_tez" - | N_IOr -> "N_IOr" - | N_IAnd -> "N_IAnd" - | N_IXor -> "N_IXor" - | N_INot -> "N_INot" - | N_IIs_nat -> "N_IIs_nat" - | N_INeg -> "N_INeg" - | N_IAbs_int -> "N_IAbs_int" - | N_IInt_nat -> "N_IInt_nat" - | N_IAdd_int -> "N_IAdd_int" - | N_IAdd_nat -> "N_IAdd_nat" - | N_ISub_int -> "N_ISub_int" - | N_IMul_int -> "N_IMul_int" - | N_IMul_nat -> "N_IMul_nat" - | N_IEdiv_int -> "N_IEdiv_int" - | N_IEdiv_nat -> "N_IEdiv_nat" - | N_ILsl_nat -> "N_ILsl_nat" - | N_ILsr_nat -> "N_ILsr_nat" - | N_IOr_nat -> "N_IOr_nat" - | N_IAnd_nat -> "N_IAnd_nat" - | N_IAnd_int_nat -> "N_IAnd_int_nat" - | N_IXor_nat -> "N_IXor_nat" - | N_INot_int -> "N_INot_int" - | N_IIf -> "N_IIf" - | N_ILoop -> "N_ILoop" - | N_ILoop_left -> "N_ILoop_left" - | N_IDip -> "N_IDip" - | N_IExec -> "N_IExec" - | N_IApply -> "N_IApply" - | N_ILambda -> "N_ILambda" - | N_IFailwith -> "N_IFailwith" - | N_ICompare -> "N_ICompare" - | N_IEq -> "N_IEq" - | N_INeq -> "N_INeq" - | N_ILt -> "N_ILt" - | N_IGt -> "N_IGt" - | N_ILe -> "N_ILe" - | N_IGe -> "N_IGe" - | N_IAddress -> "N_IAddress" - | N_IContract -> "N_IContract" - | N_ITransfer_tokens -> "N_ITransfer_tokens" - | N_IImplicit_account -> "N_IImplicit_account" - | N_ICreate_contract -> "N_ICreate_contract" - | N_ISet_delegate -> "N_ISet_delegate" - | N_INow -> "N_INow" - | N_IMin_block_time -> "N_IMin_block_time" - | N_IBalance -> "N_IBalance" - | N_ICheck_signature_ed25519 -> "N_ICheck_signature_ed25519" - | N_ICheck_signature_secp256k1 -> "N_ICheck_signature_secp256k1" - | N_ICheck_signature_p256 -> "N_ICheck_signature_p256" - | N_ICheck_signature_bls -> "N_ICheck_signature_bls" - | N_IHash_key -> "N_IHash_key" - | N_IPack -> "N_IPack" - | N_IUnpack -> "N_IUnpack" - | N_IBlake2b -> "N_IBlake2b" - | N_ISha256 -> "N_ISha256" - | N_ISha512 -> "N_ISha512" - | N_ISource -> "N_ISource" - | N_ISender -> "N_ISender" - | N_ISelf -> "N_ISelf" - | N_IAmount -> "N_IAmount" - | N_IDig -> "N_IDig" - | N_IDug -> "N_IDug" - | N_IDipN -> "N_IDipN" - | N_IDropN -> "N_IDropN" - | N_IDupN -> "N_IDupN" - | N_IChainId -> "N_IChainId" - | N_ILevel -> "N_ILevel" - | N_IView -> "N_IView" - | N_ISelf_address -> "N_ISelf_address" - | N_INever -> "N_INever" - | N_IUnpair -> "N_IUnpair" - | N_IVoting_power -> "N_IVoting_power" - | N_ITotal_voting_power -> "N_ITotal_voting_power" - | N_IKeccak -> "N_IKeccak" - | N_ISha3 -> "N_ISha3" - | N_IAdd_bls12_381_g1 -> "N_IAdd_bls12_381_g1" - | N_IAdd_bls12_381_g2 -> "N_IAdd_bls12_381_g2" - | N_IAdd_bls12_381_fr -> "N_IAdd_bls12_381_fr" - | N_IMul_bls12_381_g1 -> "N_IMul_bls12_381_g1" - | N_IMul_bls12_381_g2 -> "N_IMul_bls12_381_g2" - | N_IMul_bls12_381_fr -> "N_IMul_bls12_381_fr" - | N_INeg_bls12_381_g1 -> "N_INeg_bls12_381_g1" - | N_INeg_bls12_381_g2 -> "N_INeg_bls12_381_g2" - | N_INeg_bls12_381_fr -> "N_INeg_bls12_381_fr" - | N_IPairing_check_bls12_381 -> "N_IPairing_check_bls12_381" - | N_IMul_bls12_381_fr_z -> "N_IMul_bls12_381_fr_z" - | N_IMul_bls12_381_z_fr -> "N_IMul_bls12_381_z_fr" - | N_IInt_bls12_381_z_fr -> "N_IInt_bls12_381_z_fr" - | N_IComb -> "N_IComb" - | N_IUncomb -> "N_IUncomb" - | N_IComb_get -> "N_IComb_get" - | N_IComb_set -> "N_IComb_set" - | N_ITicket -> "N_ITicket" - | N_IRead_ticket -> "N_IRead_ticket" - | N_ISplit_ticket -> "N_ISplit_ticket" - | N_IJoin_tickets -> "N_IJoin_tickets" - | N_ISapling_empty_state -> "N_ISapling_empty_state" - | N_ISapling_verify_update -> "N_ISapling_verify_update" - | N_IMap_get_and_update -> "N_IMap_get_and_update" - | N_IBig_map_get_and_update -> "N_IBig_map_get_and_update" - | N_IHalt -> "N_IHalt" - | N_ILog -> "N_ILog" - | N_IOpen_chest -> "N_IOpen_chest" - | N_IEmit -> "N_IEmit" - -let string_of_continuation_name : continuation_name -> string = - fun c -> - match c with - | N_KNil -> "N_KNil" - | N_KCons -> "N_KCons" - | N_KReturn -> "N_KReturn" - | N_KView_exit -> "N_KView_exit" - | N_KMap_head -> "N_KMap_head" - | N_KUndip -> "N_KUndip" - | N_KLoop_in -> "N_KLoop_in" - | N_KLoop_in_left -> "N_KLoop_in_left" - | N_KIter -> "N_KIter" - | N_KList_enter_body -> "N_KList_enter_body" - | N_KList_exit_body -> "N_KList_exit_body" - | N_KMap_enter_body -> "N_KMap_enter_body" - | N_KMap_exit_body -> "N_KMap_exit_body" - | N_KLog -> "N_KLog" - -let string_of_instr_or_cont name = - match name with - | Instr_name instr_name -> string_of_instruction_name instr_name - | Cont_name cont_name -> string_of_continuation_name cont_name - -(* ------------------------------------------------------------------------- *) - -type args = arg list - -and arg = {name : id; arg : Size.t} - -let nullary : args = [] - -let unary xn x : args = [{name = xn; arg = x}] - -let binary xn x yn y : args = {name = xn; arg = x} :: unary yn y - -let ternary xn x yn y zn z : args = {name = xn; arg = x} :: binary yn y zn z - -let quaternary wn w xn x yn y zn z : args = - {name = wn; arg = w} :: ternary xn x yn y zn z - -let pp_arg fmtr {name; arg} = Format.fprintf fmtr "%s = %a" name Size.pp arg - -let pp_args fmtr args = - Format.pp_print_list - ~pp_sep:(fun fmtr () -> Format.fprintf fmtr ";") - pp_arg - fmtr - args - -type ir_sized_step = {name : instr_or_cont_name; args : args} - -type t = ir_sized_step list - -let ir_sized_step instr_name args = {name = Instr_name instr_name; args} - -let cont_sized_step cont_name args = {name = Cont_name cont_name; args} - -(* ------------------------------------------------------------------------- *) - -let all_instructions = - [ - N_IDrop; - N_IDup; - N_ISwap; - N_IPush; - N_ICons_pair; - N_ICar; - N_ICdr; - N_ICons_some; - N_ICons_none; - N_IIf_none; - N_IOpt_map; - N_ILeft; - N_IRight; - N_IIf_left; - N_ICons_list; - N_INil; - N_IIf_cons; - N_IList_map; - N_IList_iter; - N_IIter; - N_IList_size; - N_IEmpty_set; - N_ISet_iter; - N_ISet_mem; - N_ISet_update; - N_ISet_size; - N_IEmpty_map; - N_IMap_map; - N_IMap_iter; - N_IMap_mem; - N_IMap_get; - N_IMap_update; - N_IMap_size; - N_IEmpty_big_map; - N_IBig_map_mem; - N_IBig_map_get; - N_IBig_map_update; - N_IConcat_string; - N_IConcat_string_pair; - N_ISlice_string; - N_IString_size; - N_IConcat_bytes; - N_IConcat_bytes_pair; - N_ISlice_bytes; - N_IBytes_size; - N_IBytes_nat; - N_INat_bytes; - N_IBytes_int; - N_IInt_bytes; - N_IAdd_seconds_to_timestamp; - N_IAdd_timestamp_to_seconds; - N_ISub_timestamp_seconds; - N_IDiff_timestamps; - N_IAdd_tez; - N_ISub_tez; - N_ISub_tez_legacy; - N_IMul_teznat; - N_IMul_nattez; - N_IEdiv_teznat; - N_IEdiv_tez; - N_IOr; - N_IAnd; - N_IXor; - N_INot; - N_IIs_nat; - N_INeg; - N_IAbs_int; - N_IInt_nat; - N_IAdd_int; - N_IAdd_nat; - N_ISub_int; - N_IMul_int; - N_IMul_nat; - N_IEdiv_int; - N_IEdiv_nat; - N_ILsl_nat; - N_ILsr_nat; - N_IOr_nat; - N_IAnd_nat; - N_IAnd_int_nat; - N_IXor_nat; - N_INot_int; - N_IIf; - N_ILoop; - N_ILoop_left; - N_IDip; - N_IExec; - N_IApply; - N_ILambda; - N_IFailwith; - N_ICompare; - N_IEq; - N_INeq; - N_ILt; - N_IGt; - N_ILe; - N_IGe; - N_IAddress; - N_IContract; - N_ITransfer_tokens; - N_IImplicit_account; - N_ICreate_contract; - N_ISet_delegate; - N_INow; - N_IMin_block_time; - N_IBalance; - N_ICheck_signature_ed25519; - N_ICheck_signature_secp256k1; - N_ICheck_signature_p256; - N_ICheck_signature_bls; - N_IHash_key; - N_IPack; - N_IUnpack; - N_IBlake2b; - N_ISha256; - N_ISha512; - N_ISource; - N_ISender; - N_ISelf; - N_IAmount; - N_IDig; - N_IDug; - N_IDipN; - N_IDropN; - N_IDupN; - N_IChainId; - N_ILevel; - N_IView; - N_ISelf_address; - N_INever; - N_IUnpair; - N_IVoting_power; - N_ITotal_voting_power; - N_IKeccak; - N_ISha3; - N_IAdd_bls12_381_g1; - N_IAdd_bls12_381_g2; - N_IAdd_bls12_381_fr; - N_IMul_bls12_381_g1; - N_IMul_bls12_381_g2; - N_IMul_bls12_381_fr; - N_INeg_bls12_381_g1; - N_INeg_bls12_381_g2; - N_INeg_bls12_381_fr; - N_IPairing_check_bls12_381; - N_IMul_bls12_381_fr_z; - N_IMul_bls12_381_z_fr; - N_IInt_bls12_381_z_fr; - N_IComb; - N_IUncomb; - N_IComb_get; - N_IComb_set; - N_ITicket; - N_IRead_ticket; - N_ISplit_ticket; - N_IJoin_tickets; - N_ISapling_empty_state; - N_ISapling_verify_update; - N_IMap_get_and_update; - N_IBig_map_get_and_update; - N_IHalt; - N_ILog; - N_IOpen_chest; - N_IEmit; - N_ILsl_bytes; - N_ILsr_bytes; - N_IOr_bytes; - N_IAnd_bytes; - N_IXor_bytes; - N_INot_bytes; - ] - -let all_continuations = - [ - N_KNil; - N_KCons; - N_KReturn; - N_KView_exit; - N_KMap_head; - N_KUndip; - N_KLoop_in; - N_KLoop_in_left; - N_KIter; - N_KList_enter_body; - N_KList_exit_body; - N_KMap_enter_body; - N_KMap_exit_body; - N_KLog; - ] - -let instruction_name_encoding = - let open Data_encoding in - def "instruction_name_encoding" - @@ string_enum - (List.map - (fun instr_name -> - (string_of_instruction_name instr_name, instr_name)) - all_instructions) - -let continuation_name_encoding = - let open Data_encoding in - def "continuation_name_encoding" - @@ string_enum - (List.map - (fun cont_name -> (string_of_continuation_name cont_name, cont_name)) - all_continuations) - -let args_encoding = - let open Data_encoding in - def "args_encoding" - @@ list - (conv - (fun {name; arg} -> (name, arg)) - (fun (name, arg) -> {name; arg}) - (tup2 string Size.encoding)) - -let instr_or_cont_name_encoding = - let open Data_encoding in - def "instr_or_cont_name" - @@ union - [ - case - ~title:"instr_name" - (Tag 0) - instruction_name_encoding - (function Instr_name name -> Some name | _ -> None) - (fun name -> Instr_name name); - case - ~title:"cont_name" - (Tag 1) - continuation_name_encoding - (function Cont_name name -> Some name | _ -> None) - (fun name -> Cont_name name); - ] - -let ir_sized_step_encoding = - let open Data_encoding in - def "ir_sized_step_encoding" - @@ conv - (fun {name; args} -> (name, args)) - (fun (name, args) -> {name; args}) - (tup2 instr_or_cont_name_encoding args_encoding) - -let encoding = - let open Data_encoding in - def "interpreter_trace_encoding" @@ list ir_sized_step_encoding - -(* ------------------------------------------------------------------------- *) - -module Instructions = struct - let drop = ir_sized_step N_IDrop nullary - - let dup = ir_sized_step N_IDup nullary - - let swap = ir_sized_step N_ISwap nullary - - let push = ir_sized_step N_IPush nullary - - let cons_pair = ir_sized_step N_ICons_pair nullary - - let car = ir_sized_step N_ICar nullary - - let cdr = ir_sized_step N_ICdr nullary - - let cons_some = ir_sized_step N_ICons_some nullary - - let cons_none = ir_sized_step N_ICons_none nullary - - let if_none = ir_sized_step N_IIf_none nullary - - let opt_map = ir_sized_step N_IOpt_map nullary - - let left = ir_sized_step N_ILeft nullary - - let right = ir_sized_step N_IRight nullary - - let if_left = ir_sized_step N_IIf_left nullary - - let cons_list = ir_sized_step N_ICons_list nullary - - let nil = ir_sized_step N_INil nullary - - let if_cons = ir_sized_step N_IIf_cons nullary - - let list_map = ir_sized_step N_IList_map nullary - - let list_iter = ir_sized_step N_IList_iter nullary - - let iter = ir_sized_step N_IIter nullary - - let list_size _list = ir_sized_step N_IList_size nullary - - let empty_set = ir_sized_step N_IEmpty_set nullary - - let set_iter set = ir_sized_step N_ISet_iter (unary "set" set) - - let set_mem elt set = ir_sized_step N_ISet_mem (binary "elt" elt "set" set) - - let set_update elt set = - ir_sized_step N_ISet_update (binary "elt" elt "set" set) - - let set_size _set = ir_sized_step N_ISet_size nullary - - let empty_map = ir_sized_step N_IEmpty_map nullary - - let map_map map = ir_sized_step N_IMap_map (unary "map" map) - - let map_iter map = ir_sized_step N_IMap_iter (unary "map" map) - - let map_mem key map = ir_sized_step N_IMap_mem (binary "key" key "map" map) - - let map_get key map = ir_sized_step N_IMap_get (binary "key" key "map" map) - - let map_update key map = - ir_sized_step N_IMap_update (binary "key" key "map" map) - - let map_size _map = ir_sized_step N_IMap_size nullary - - let empty_big_map = ir_sized_step N_IEmpty_big_map nullary - - let big_map_mem key big_map = - ir_sized_step N_IBig_map_mem (binary "key" key "big_map" big_map) - - let big_map_get key big_map = - ir_sized_step N_IBig_map_get (binary "key" key "big_map" big_map) - - let big_map_update key big_map = - ir_sized_step N_IBig_map_update (binary "key" key "big_map" big_map) - - let big_map_get_and_update key big_map = - ir_sized_step N_IBig_map_get_and_update (binary "key" key "big_map" big_map) - - let concat_string total_bytes list = - ir_sized_step - N_IConcat_string - (binary "total_bytes" total_bytes "list" list) - - let concat_string_pair str1 str2 = - ir_sized_step N_IConcat_string_pair (binary "str1" str1 "str2" str2) - - let slice_string string = - ir_sized_step N_ISlice_string (unary "string" string) - - let string_size _string = ir_sized_step N_IString_size nullary - - let concat_bytes total_bytes list = - ir_sized_step N_IConcat_bytes (binary "total_bytes" total_bytes "list" list) - - let concat_bytes_pair str1 str2 = - ir_sized_step N_IConcat_bytes_pair (binary "str1" str1 "str2" str2) - - let slice_bytes bytes = ir_sized_step N_ISlice_bytes (unary "bytes" bytes) - - let bytes_size = ir_sized_step N_IBytes_size nullary - - let lsl_bytes bytes shift = - ir_sized_step N_ILsl_bytes (binary "bytes" bytes "shift" shift) - - let lsr_bytes bytes shift = - ir_sized_step N_ILsr_bytes (binary "bytes" bytes "shift" shift) - - let or_bytes bytes1 bytes2 = - ir_sized_step N_IOr_bytes (binary "bytes1" bytes1 "bytes2" bytes2) - - let and_bytes bytes1 bytes2 = - ir_sized_step N_IAnd_bytes (binary "bytes1" bytes1 "bytes2" bytes2) - - let xor_bytes bytes1 bytes2 = - ir_sized_step N_IXor_bytes (binary "bytes1" bytes1 "bytes2" bytes2) - - let not_bytes bytes = ir_sized_step N_INot_bytes (unary "bytes" bytes) - - let bytes_nat nat = ir_sized_step N_IBytes_nat (unary "nat" nat) - - let nat_bytes bytes = ir_sized_step N_INat_bytes (unary "bytes" bytes) - - let bytes_int int = ir_sized_step N_IBytes_int (unary "int" int) - - let int_bytes bytes = ir_sized_step N_IInt_bytes (unary "bytes" bytes) - - let add_seconds_to_timestamp seconds tstamp = - ir_sized_step - N_IAdd_seconds_to_timestamp - (binary "seconds" seconds "tstamp" tstamp) - - let add_timestamp_to_seconds tstamp seconds = - ir_sized_step - N_IAdd_timestamp_to_seconds - (binary "tstamp" tstamp "seconds" seconds) - - let sub_timestamp_seconds tstamp seconds = - ir_sized_step - N_ISub_timestamp_seconds - (binary "tstamp" tstamp "seconds" seconds) - - let diff_timestamps tstamp1 tstamp2 = - ir_sized_step - N_IDiff_timestamps - (binary "tstamp1" tstamp1 "tstamp2" tstamp2) - - let add_tez _tez1 _tez2 = ir_sized_step N_IAdd_tez nullary - - let sub_tez _tez1 _tez2 = ir_sized_step N_ISub_tez nullary - - let sub_tez_legacy _tez1 _tez2 = ir_sized_step N_ISub_tez_legacy nullary - - let mul_teznat _tez _nat = ir_sized_step N_IMul_teznat nullary - - let mul_nattez _nat _tez = ir_sized_step N_IMul_nattez nullary - - let ediv_teznat _tez _nat = ir_sized_step N_IEdiv_teznat nullary - - let ediv_tez _tez1 _tez2 = ir_sized_step N_IEdiv_tez nullary - - let or_ = ir_sized_step N_IOr nullary - - let and_ = ir_sized_step N_IAnd nullary - - let xor_ = ir_sized_step N_IXor nullary - - let not_ = ir_sized_step N_INot nullary - - let is_nat _int = ir_sized_step N_IIs_nat nullary - - let neg int = ir_sized_step N_INeg (unary "int" int) - - let abs_int int = ir_sized_step N_IAbs_int (unary "int" int) - - let int_nat _nat = ir_sized_step N_IInt_nat nullary - - let add_int int1 int2 = - ir_sized_step N_IAdd_int (binary "int1" int1 "int2" int2) - - let add_nat nat1 nat2 = - ir_sized_step N_IAdd_nat (binary "nat1" nat1 "nat2" nat2) - - let sub_int int1 int2 = - ir_sized_step N_ISub_int (binary "int1" int1 "int2" int2) - - let mul_int int1 int2 = - ir_sized_step N_IMul_int (binary "int1" int1 "int2" int2) - - let mul_nat nat int = ir_sized_step N_IMul_nat (binary "nat" nat "int" int) - - let ediv_int int1 int2 = - ir_sized_step N_IEdiv_int (binary "int1" int1 "int2" int2) - - let ediv_nat nat int = ir_sized_step N_IEdiv_nat (binary "nat" nat "int" int) - - let lsl_nat nat1 _shift = ir_sized_step N_ILsl_nat (unary "nat" nat1) - - let lsr_nat nat1 _shift = ir_sized_step N_ILsr_nat (unary "nat" nat1) - - let or_nat nat1 nat2 = - ir_sized_step N_IOr_nat (binary "nat1" nat1 "nat2" nat2) - - let and_nat nat1 nat2 = - ir_sized_step N_IAnd_nat (binary "nat1" nat1 "nat2" nat2) - - let and_int_nat int nat = - ir_sized_step N_IAnd_int_nat (binary "int" int "nat" nat) - - let xor_nat nat1 nat2 = - ir_sized_step N_IXor_nat (binary "nat1" nat1 "nat2" nat2) - - let not_int int = ir_sized_step N_INot_int (unary "int" int) - - let if_ = ir_sized_step N_IIf nullary - - let loop = ir_sized_step N_ILoop nullary - - let loop_left = ir_sized_step N_ILoop_left nullary - - let dip = ir_sized_step N_IDip nullary - - let exec = ir_sized_step N_IExec nullary - - let apply ~(rec_flag : bool) = - ir_sized_step N_IApply (unary "rec" (if rec_flag then 1 else 0)) - - let lambda = ir_sized_step N_ILambda nullary - - let failwith_ = ir_sized_step N_IFailwith nullary - - let compare arg1 arg2 = - ir_sized_step N_ICompare (binary "arg1" arg1 "arg2" arg2) - - let eq = ir_sized_step N_IEq nullary - - let neq = ir_sized_step N_INeq nullary - - let lt = ir_sized_step N_ILt nullary - - let gt = ir_sized_step N_IGt nullary - - let le = ir_sized_step N_ILe nullary - - let ge = ir_sized_step N_IGe nullary - - let address = ir_sized_step N_IAddress nullary - - let contract = ir_sized_step N_IContract nullary - - let transfer_tokens = ir_sized_step N_ITransfer_tokens nullary - - let implicit_account = ir_sized_step N_IImplicit_account nullary - - let create_contract = ir_sized_step N_ICreate_contract nullary - - let set_delegate = ir_sized_step N_ISet_delegate nullary - - let now = ir_sized_step N_INow nullary - - let min_block_time = ir_sized_step N_IMin_block_time nullary - - let balance = ir_sized_step N_IBalance nullary - - let check_signature_ed25519 _pk _signature message = - ir_sized_step N_ICheck_signature_ed25519 (unary "message" message) - - let check_signature_secp256k1 _pk _signature message = - ir_sized_step N_ICheck_signature_secp256k1 (unary "message" message) - - let check_signature_p256 _pk _signature message = - ir_sized_step N_ICheck_signature_p256 (unary "message" message) - - let check_signature_bls _pk _signature message = - ir_sized_step N_ICheck_signature_bls (unary "message" message) - - let hash_key = ir_sized_step N_IHash_key nullary - - let pack (micheline_size : Size.micheline_size) = - ir_sized_step - N_IPack - (ternary - "micheline_nodes" - micheline_size.traversal - "micheline_int_bytes" - micheline_size.int_bytes - "micheline_string_bytes" - micheline_size.string_bytes) - - let unpack = ir_sized_step N_IUnpack nullary - - let blake2b bytes = ir_sized_step N_IBlake2b (unary "bytes" bytes) - - let sha256 bytes = ir_sized_step N_ISha256 (unary "bytes" bytes) - - let sha512 bytes = ir_sized_step N_ISha512 (unary "bytes" bytes) - - let source = ir_sized_step N_ISource nullary - - let sender = ir_sized_step N_ISender nullary - - let self = ir_sized_step N_ISelf nullary - - let amount = ir_sized_step N_IAmount nullary - - let dig depth = ir_sized_step N_IDig (unary "depth" depth) - - let dug depth = ir_sized_step N_IDug (unary "depth" depth) - - let dipn depth = ir_sized_step N_IDipN (unary "depth" depth) - - let dropn depth = ir_sized_step N_IDropN (unary "depth" depth) - - let dupn depth = ir_sized_step N_IDupN (unary "depth" depth) - - let chain_id = ir_sized_step N_IChainId nullary - - let level = ir_sized_step N_ILevel nullary - - let view = ir_sized_step N_IView nullary - - let self_address = ir_sized_step N_ISelf_address nullary - - let never = ir_sized_step N_INever nullary - - let unpair = ir_sized_step N_IUnpair nullary - - let voting_power = ir_sized_step N_IVoting_power nullary - - let total_voting_power = ir_sized_step N_ITotal_voting_power nullary - - let keccak bytes = ir_sized_step N_IKeccak (unary "bytes" bytes) - - let sha3 bytes = ir_sized_step N_ISha3 (unary "bytes" bytes) - - let add_bls12_381_g1 = ir_sized_step N_IAdd_bls12_381_g1 nullary - - let add_bls12_381_g2 = ir_sized_step N_IAdd_bls12_381_g2 nullary - - let add_bls12_381_fr = ir_sized_step N_IAdd_bls12_381_fr nullary - - let mul_bls12_381_g1 = ir_sized_step N_IMul_bls12_381_g1 nullary - - let mul_bls12_381_g2 = ir_sized_step N_IMul_bls12_381_g2 nullary - - let mul_bls12_381_fr = ir_sized_step N_IMul_bls12_381_fr nullary - - let neg_bls12_381_g1 = ir_sized_step N_INeg_bls12_381_g1 nullary - - let neg_bls12_381_g2 = ir_sized_step N_INeg_bls12_381_g2 nullary - - let neg_bls12_381_fr = ir_sized_step N_INeg_bls12_381_fr nullary - - let pairing_check_bls12_381 length = - ir_sized_step N_IPairing_check_bls12_381 (unary "length" length) - - let mul_bls12_381_fr_z nat = - ir_sized_step N_IMul_bls12_381_fr_z (unary "nat" nat) - - let mul_bls12_381_z_fr nat = - ir_sized_step N_IMul_bls12_381_z_fr (unary "nat" nat) - - let int_bls12_381_z_fr = ir_sized_step N_IInt_bls12_381_z_fr nullary - - let comb depth = ir_sized_step N_IComb (unary "depth" depth) - - let uncomb depth = ir_sized_step N_IUncomb (unary "depth" depth) - - let comb_get key = ir_sized_step N_IComb_get (unary "key" key) - - let comb_set key = ir_sized_step N_IComb_set (unary "key" key) - - let ticket = ir_sized_step N_ITicket nullary - - let read_ticket = ir_sized_step N_IRead_ticket nullary - - let split_ticket nat1 nat2 = - ir_sized_step N_ISplit_ticket (binary "nat1" nat1 "nat2" nat2) - - let join_tickets size1 size2 size3 size4 = - ir_sized_step - N_IJoin_tickets - (quaternary - "contents1" - size1 - "contents2" - size2 - "amount1" - size3 - "amount2" - size4) - - let sapling_empty_state = ir_sized_step N_ISapling_empty_state nullary - - let sapling_verify_update inputs outputs _bound_data _state = - ir_sized_step - N_ISapling_verify_update - (binary "inputs" inputs "outputs" outputs) - - let map_get_and_update key_size map_size = - ir_sized_step - N_IMap_get_and_update - (binary "key_size" key_size "map_size" map_size) - - let halt = ir_sized_step N_IHalt nullary - - let log = ir_sized_step N_ILog nullary - - let open_chest log_time size = - ir_sized_step N_IOpen_chest (binary "log_time" log_time "size" size) - - (** cost model for the EMIT instruction *) - let emit = ir_sized_step N_IEmit nullary -end - -module Control = struct - let nil = cont_sized_step N_KNil nullary - - let cons = cont_sized_step N_KCons nullary - - let return = cont_sized_step N_KReturn nullary - - let view_exit = cont_sized_step N_KView_exit nullary - - let map_head = cont_sized_step N_KMap_head nullary - - let undip = cont_sized_step N_KUndip nullary - - let loop_in = cont_sized_step N_KLoop_in nullary - - let loop_in_left = cont_sized_step N_KLoop_in_left nullary - - let iter size = cont_sized_step N_KIter (unary "size" size) - - let list_enter_body xs_size ys_size = - cont_sized_step - N_KList_enter_body - (binary "xs_size" xs_size "ys_size" ys_size) - - let list_exit_body = cont_sized_step N_KList_exit_body nullary - - let map_enter_body size = - cont_sized_step N_KMap_enter_body (unary "size" size) - - let map_exit_body key_size map_size = - cont_sized_step N_KMap_exit_body (binary "key" key_size "map" map_size) - - let log = cont_sized_step N_KLog nullary -end - -(* ------------------------------------------------------------------------- *) - -open Script_typed_ir - -let extract_compare_sized_step : - type a. a comparable_ty -> a -> a -> ir_sized_step = - fun comparable_ty x y -> - Instructions.compare - (Size.size_of_comparable_value comparable_ty x) - (Size.size_of_comparable_value comparable_ty y) - -let extract_ir_sized_step : - type bef_top bef res_top res. - Alpha_context.t -> - (bef_top, bef, res_top, res) Script_typed_ir.kinstr -> - bef_top * bef -> - ir_sized_step = - fun ctxt instr stack -> - let open Script_typed_ir in - match (instr, stack) with - | IDrop (_, _), _ -> Instructions.drop - | IDup (_, _), _ -> Instructions.dup - | ISwap (_, _), _ -> Instructions.swap - | IPush (_, _, _, _), _ -> Instructions.push - | ICons_pair (_, _), _ -> Instructions.cons_pair - | ICar (_, _), _ -> Instructions.car - | ICdr (_, _), _ -> Instructions.cdr - | IUnpair (_, _), _ -> Instructions.unpair - | ICons_some (_, _), _ -> Instructions.cons_some - | ICons_none (_, _, _), _ -> Instructions.cons_none - | IIf_none _, _ -> Instructions.if_none - | IOpt_map _, _ -> Instructions.opt_map - | ICons_left (_, _, _), _ -> Instructions.left - | ICons_right (_, _, _), _ -> Instructions.right - | IIf_left _, _ -> Instructions.if_left - | ICons_list (_, _), _ -> Instructions.cons_list - | INil (_, _, _), _ -> Instructions.nil - | IIf_cons _, _ -> Instructions.if_cons - | IList_iter (_, _, _, _), _ -> Instructions.list_iter - | IList_map (_, _, _, _), _ -> Instructions.list_map - | IList_size (_, _), (list, _) -> Instructions.list_size (Size.list list) - | IEmpty_set (_, _, _), _ -> Instructions.empty_set - | ISet_iter _, (set, _) -> Instructions.set_iter (Size.set set) - | ISet_mem (_, _), (v, (set, _)) -> - let (module S) = Script_set.get set in - let sz = S.OPS.elt_size v in - Instructions.set_mem sz (Size.set set) - | ISet_update (_, _), (v, (_flag, (set, _))) -> - let (module S) = Script_set.get set in - let sz = S.OPS.elt_size v in - Instructions.set_update sz (Size.set set) - | ISet_size (_, _), (set, _) -> Instructions.set_size (Size.set set) - | IEmpty_map (_, _, _, _), _ -> Instructions.empty_map - | IMap_map _, (map, _) -> Instructions.map_map (Size.map map) - | IMap_iter _, (map, _) -> Instructions.map_iter (Size.map map) - | IMap_mem (_, _), (v, (map, _)) -> - let (module Map) = Script_map.get_module map in - let key_size = Map.OPS.key_size v in - Instructions.map_mem key_size (Size.map map) - | IMap_get (_, _), (v, (map, _)) -> - let (module Map) = Script_map.get_module map in - let key_size = Map.OPS.key_size v in - Instructions.map_get key_size (Size.map map) - | IMap_update (_, _), (v, (_elt_opt, (map, _))) -> - let (module Map) = Script_map.get_module map in - let key_size = Map.OPS.key_size v in - Instructions.map_update key_size (Size.map map) - | IMap_get_and_update (_, _), (v, (_elt_opt, (map, _))) -> - let (module Map) = Script_map.get_module map in - let key_size = Map.OPS.key_size v in - Instructions.map_get_and_update key_size (Size.map map) - | IMap_size (_, _), (map, _) -> Instructions.map_size (Size.map map) - | IEmpty_big_map (_, _, _, _), _ -> Instructions.empty_big_map - | IBig_map_mem (_, _), (v, (Big_map {diff = {size; _}; key_type; _}, _)) -> - let key_size = Size.size_of_comparable_value key_type v in - Instructions.big_map_mem key_size (Size.of_int size) - | IBig_map_get (_, _), (v, (Big_map {diff = {size; _}; key_type; _}, _)) -> - let key_size = Size.size_of_comparable_value key_type v in - Instructions.big_map_get key_size (Size.of_int size) - | ( IBig_map_update (_, _), - (v, (_, (Big_map {diff = {size; _}; key_type; _}, _))) ) -> - let key_size = Size.size_of_comparable_value key_type v in - Instructions.big_map_update key_size (Size.of_int size) - | ( IBig_map_get_and_update (_, _), - (v, (_, (Big_map {diff = {size; _}; key_type; _}, _))) ) -> - let key_size = Size.size_of_comparable_value key_type v in - Instructions.big_map_get_and_update key_size (Size.of_int size) - | IConcat_string (_, _), (ss, _) -> - let list_size = Size.list ss in - let total_bytes = - List.fold_left - (fun x s -> Size.(add x (script_string s))) - Size.zero - ss.elements - in - Instructions.concat_string list_size total_bytes - | IConcat_string_pair (_, _), (s1, (s2, _)) -> - Instructions.concat_string_pair - (Size.script_string s1) - (Size.script_string s2) - | ISlice_string (_, _), (_off, (_len, (s, _))) -> - Instructions.slice_string (Size.script_string s) - | IString_size (_, _), (s, _) -> - Instructions.string_size (Size.script_string s) - | IConcat_bytes (_, _), (ss, _) -> - let list_size = Size.list ss in - let total_bytes = - List.fold_left (fun x s -> Size.(add x (bytes s))) Size.zero ss.elements - in - Instructions.concat_bytes list_size total_bytes - | IConcat_bytes_pair (_, _), (s1, (s2, _)) -> - Instructions.concat_bytes_pair (Size.bytes s1) (Size.bytes s2) - | ISlice_bytes (_, _), (_off, (_len, (s, _))) -> - Instructions.slice_bytes (Size.bytes s) - | IBytes_size (_, _), _ -> Instructions.bytes_size - | IBytes_nat (_, _), (n, _) -> Instructions.bytes_nat (Size.integer n) - | INat_bytes (_, _), (b, _) -> Instructions.nat_bytes (Size.bytes b) - | IBytes_int (_, _), (n, _) -> Instructions.bytes_int (Size.integer n) - | IInt_bytes (_, _), (b, _) -> Instructions.int_bytes (Size.bytes b) - | IAdd_seconds_to_timestamp (_, _), (s, (t, _)) -> - Instructions.add_seconds_to_timestamp (Size.timestamp t) (Size.integer s) - | IAdd_timestamp_to_seconds (_, _), (t, (s, _)) -> - Instructions.add_timestamp_to_seconds (Size.timestamp t) (Size.integer s) - | ISub_timestamp_seconds (_, _), (t, (s, _)) -> - Instructions.sub_timestamp_seconds (Size.timestamp t) (Size.integer s) - | IDiff_timestamps (_, _), (t1, (t2, _)) -> - Instructions.diff_timestamps (Size.timestamp t1) (Size.timestamp t2) - | IAdd_tez (_, _), (x, (y, _)) -> - Instructions.add_tez (Size.mutez x) (Size.mutez y) - | ISub_tez (_, _), (x, (y, _)) -> - Instructions.sub_tez (Size.mutez x) (Size.mutez y) - | ISub_tez_legacy (_, _), (x, (y, _)) -> - Instructions.sub_tez_legacy (Size.mutez x) (Size.mutez y) - | IMul_teznat (_, _), (x, (y, _)) -> - Instructions.mul_teznat (Size.mutez x) (Size.integer y) - | IMul_nattez (_, _), (x, (y, _)) -> - Instructions.mul_nattez (Size.integer x) (Size.mutez y) - | IEdiv_teznat (_, _), (x, (y, _)) -> - Instructions.ediv_teznat (Size.mutez x) (Size.integer y) - | IEdiv_tez (_, _), (x, (y, _)) -> - Instructions.ediv_tez (Size.mutez x) (Size.mutez y) - | IOr (_, _), _ -> Instructions.or_ - | IAnd (_, _), _ -> Instructions.and_ - | IXor (_, _), _ -> Instructions.xor_ - | INot (_, _), _ -> Instructions.not_ - | IIs_nat (_, _), (x, _) -> Instructions.is_nat (Size.integer x) - | INeg (_, _), (x, _) -> Instructions.neg (Size.integer x) - | IAbs_int (_, _), (x, _) -> Instructions.abs_int (Size.integer x) - | IInt_nat (_, _), (x, _) -> Instructions.int_nat (Size.integer x) - | IAdd_int (_, _), (x, (y, _)) -> - Instructions.add_int (Size.integer x) (Size.integer y) - | IAdd_nat (_, _), (x, (y, _)) -> - Instructions.add_nat (Size.integer x) (Size.integer y) - | ISub_int (_, _), (x, (y, _)) -> - Instructions.sub_int (Size.integer x) (Size.integer y) - | IMul_int (_, _), (x, (y, _)) -> - Instructions.mul_int (Size.integer x) (Size.integer y) - | IMul_nat (_, _), (x, (y, _)) -> - Instructions.mul_nat (Size.integer x) (Size.integer y) - | IEdiv_int (_, _), (x, (y, _)) -> - Instructions.ediv_int (Size.integer x) (Size.integer y) - | IEdiv_nat (_, _), (x, (y, _)) -> - Instructions.ediv_nat (Size.integer x) (Size.integer y) - | ILsl_nat (_, _), (x, (y, _)) -> - Instructions.lsl_nat (Size.integer x) (Size.integer y) - | ILsr_nat (_, _), (x, (y, _)) -> - Instructions.lsr_nat (Size.integer x) (Size.integer y) - | IOr_nat (_, _), (x, (y, _)) -> - Instructions.or_nat (Size.integer x) (Size.integer y) - | IAnd_nat (_, _), (x, (y, _)) -> - Instructions.and_nat (Size.integer x) (Size.integer y) - | IAnd_int_nat (_, _), (x, (y, _)) -> - Instructions.and_int_nat (Size.integer x) (Size.integer y) - | IXor_nat (_, _), (x, (y, _)) -> - Instructions.xor_nat (Size.integer x) (Size.integer y) - | INot_int (_, _), (x, _) -> Instructions.not_int (Size.integer x) - | IIf _, _ -> Instructions.if_ - | ILoop (_, _, _), _ -> Instructions.loop - | ILoop_left (_, _, _), _ -> Instructions.loop_left - | IDip (_, _, _, _), _ -> Instructions.dip - | IExec (_, _, _), _ -> Instructions.exec - | IApply (_, _, _), (_, (l, _)) -> ( - match l with - | Lam _ -> Instructions.apply ~rec_flag:false - | LamRec _ -> Instructions.apply ~rec_flag:true) - | ILambda (_, _, _), _ -> Instructions.lambda - | IFailwith (_, _), _ -> Instructions.failwith_ - | ICompare (_, cmp_ty, _), (a, (b, _)) -> - extract_compare_sized_step cmp_ty a b - | IEq (_, _), _ -> Instructions.eq - | INeq (_, _), _ -> Instructions.neq - | ILt (_, _), _ -> Instructions.lt - | IGt (_, _), _ -> Instructions.gt - | ILe (_, _), _ -> Instructions.le - | IGe (_, _), _ -> Instructions.ge - | IAddress (_, _), _ -> Instructions.address - | IContract (_, _, _, _), _ -> Instructions.contract - | ITransfer_tokens (_, _), _ -> Instructions.transfer_tokens - | IView (_, _, _, _), _ -> Instructions.view - | IImplicit_account (_, _), _ -> Instructions.implicit_account - | ICreate_contract _, _ -> Instructions.create_contract - | ISet_delegate (_, _), _ -> Instructions.set_delegate - | INow (_, _), _ -> Instructions.now - | IBalance (_, _), _ -> Instructions.balance - | ILevel (_, _), _ -> Instructions.level - | ICheck_signature (_, _), (public_key, (_signature, (message, _))) -> ( - match public_key with - | Signature.Ed25519 pk -> - let pk = Size.of_int (Signature.Ed25519.Public_key.size pk) in - let signature = Size.of_int Signature.Ed25519.size in - let message = Size.bytes message in - Instructions.check_signature_ed25519 pk signature message - | Signature.Secp256k1 pk -> - let pk = Size.of_int (Signature.Secp256k1.Public_key.size pk) in - let signature = Size.of_int Signature.Secp256k1.size in - let message = Size.bytes message in - Instructions.check_signature_secp256k1 pk signature message - | Signature.P256 pk -> - let pk = Size.of_int (Signature.P256.Public_key.size pk) in - let signature = Size.of_int Signature.P256.size in - let message = Size.bytes message in - Instructions.check_signature_p256 pk signature message - | Signature.Bls pk -> - let pk = Size.of_int (Signature.Bls.Public_key.size pk) in - let signature = Size.of_int Signature.Bls.size in - let message = Size.bytes message in - Instructions.check_signature_bls pk signature message) - | IHash_key (_, _), _ -> Instructions.hash_key - | IPack (_, ty, _), (v, _) -> ( - let script_res = - Lwt_main.run (Script_ir_translator.unparse_data ctxt Optimized ty v) - in - match script_res with - | Ok (node, _ctxt) -> - Instructions.pack (Size.of_micheline (Micheline.root node)) - | Error _ -> Stdlib.failwith "IPack workload: could not unparse") - | IUnpack (_, _, _), _ -> Instructions.unpack - | IBlake2b (_, _), (bytes, _) -> Instructions.blake2b (Size.bytes bytes) - | ISha256 (_, _), (bytes, _) -> Instructions.sha256 (Size.bytes bytes) - | ISha512 (_, _), (bytes, _) -> Instructions.sha512 (Size.bytes bytes) - | ISource (_, _), _ -> Instructions.source - | ISender (_, _), _ -> Instructions.sender - | ISelf (_, _, _, _), _ -> Instructions.self - | ISelf_address (_, _), _ -> Instructions.self_address - | IAmount (_, _), _ -> Instructions.amount - | ISapling_empty_state (_, _, _), _ -> Instructions.sapling_empty_state - | ISapling_verify_update (_, _), (transaction, (_state, _)) -> - let inputs = Size.sapling_transaction_inputs transaction in - let outputs = Size.sapling_transaction_outputs transaction in - let bound_data = Size.sapling_transaction_bound_data transaction in - let state = Size.zero in - Instructions.sapling_verify_update inputs outputs bound_data state - | ISapling_verify_update_deprecated (_, _), (transaction, (_state, _)) -> - let inputs = List.length transaction.inputs in - let outputs = List.length transaction.outputs in - let bound_data = Size.zero in - let state = Size.zero in - Instructions.sapling_verify_update inputs outputs bound_data state - | IDig (_, n, _, _), _ -> Instructions.dig (Size.of_int n) - | IDug (_, n, _, _), _ -> Instructions.dug (Size.of_int n) - | IDipn (_, n, _, _, _), _ -> Instructions.dipn (Size.of_int n) - | IDropn (_, n, _, _), _ -> Instructions.dropn (Size.of_int n) - | IChainId (_, _), _ -> Instructions.chain_id - | INever _, _ -> . - | IVoting_power (_, _), _ -> Instructions.voting_power - | ITotal_voting_power (_, _), _ -> Instructions.total_voting_power - | IKeccak (_, _), (bytes, _) -> Instructions.keccak (Size.bytes bytes) - | ISha3 (_, _), (bytes, _) -> Instructions.sha3 (Size.bytes bytes) - | IAdd_bls12_381_g1 (_, _), _ -> Instructions.add_bls12_381_g1 - | IAdd_bls12_381_g2 (_, _), _ -> Instructions.add_bls12_381_g2 - | IAdd_bls12_381_fr (_, _), _ -> Instructions.add_bls12_381_fr - | IMul_bls12_381_g1 (_, _), _ -> Instructions.mul_bls12_381_g1 - | IMul_bls12_381_g2 (_, _), _ -> Instructions.mul_bls12_381_g2 - | IMul_bls12_381_fr (_, _), _ -> Instructions.mul_bls12_381_fr - | IMul_bls12_381_z_fr (_, _), (_fr, (z, _)) -> - Instructions.mul_bls12_381_z_fr (Size.integer z) - | IMul_bls12_381_fr_z (_, _), (z, _) -> - Instructions.mul_bls12_381_fr_z (Size.integer z) - | IInt_bls12_381_fr (_, _), _ -> Instructions.int_bls12_381_z_fr - | INeg_bls12_381_g1 (_, _), _ -> Instructions.neg_bls12_381_g1 - | INeg_bls12_381_g2 (_, _), _ -> Instructions.neg_bls12_381_g2 - | INeg_bls12_381_fr (_, _), _ -> Instructions.neg_bls12_381_fr - | IPairing_check_bls12_381 (_, _), (list, _) -> - Instructions.pairing_check_bls12_381 (Size.list list) - | IComb (_, n, _, _), _ -> Instructions.comb (Size.of_int n) - | IUncomb (_, n, _, _), _ -> Instructions.uncomb (Size.of_int n) - | IComb_get (_, n, _, _), _ -> Instructions.comb_get (Size.of_int n) - | IComb_set (_, n, _, _), _ -> Instructions.comb_set (Size.of_int n) - | IDup_n (_, n, _, _), _ -> Instructions.dupn (Size.of_int n) - | ITicket (_, _, _), _ | ITicket_deprecated (_, _, _), _ -> - Instructions.ticket - | IRead_ticket (_, _, _), _ -> Instructions.read_ticket - | ISplit_ticket (_, _), (_ticket, ((amount_a, amount_b), _)) -> - Instructions.split_ticket (Size.integer amount_a) (Size.integer amount_b) - | IJoin_tickets (_, cmp_ty, _), ((ticket1, ticket2), _) -> - let size1 = Size.size_of_comparable_value cmp_ty ticket1.contents in - let size2 = Size.size_of_comparable_value cmp_ty ticket2.contents in - let tez1 = Size.integer (ticket1.amount :> Script_int.n Script_int.num) in - let tez2 = Size.integer (ticket2.amount :> Script_int.n Script_int.num) in - Instructions.join_tickets size1 size2 tez1 tez2 - | IHalt _, _ -> Instructions.halt - | ILog _, _ -> Instructions.log - | IOpen_chest (_, _), (_, (chest, (time, _))) -> - let plaintext_size = - Script_timelock.get_plaintext_size chest - 1 |> Size.of_int - in - let log_time = Z.log2 Z.(one + Script_int.to_zint time) |> Size.of_int in - Instructions.open_chest log_time plaintext_size - | IMin_block_time _, _ -> Instructions.min_block_time - | IEmit _, _ -> Instructions.emit - | ILsl_bytes (_, _), (x, (y, _)) -> - let y = - match Script_int.to_int y with - | Some y -> y - | None -> (* overflow *) assert false - in - Instructions.lsl_bytes (Size.bytes x) y - | ILsr_bytes (_, _), (x, (y, _)) -> - let y = - match Script_int.to_int y with - | Some y -> y - | None -> (* overflow *) assert false - in - Instructions.lsr_bytes (Size.bytes x) y - | IOr_bytes (_, _), (x, (y, _)) -> - Instructions.or_bytes (Size.bytes x) (Size.bytes y) - | IAnd_bytes (_, _), (x, (y, _)) -> - Instructions.and_bytes (Size.bytes x) (Size.bytes y) - | IXor_bytes (_, _), (x, (y, _)) -> - Instructions.xor_bytes (Size.bytes x) (Size.bytes y) - | INot_bytes (_, _), (x, _) -> Instructions.not_bytes (Size.bytes x) - -let extract_control_trace (type bef_top bef aft_top aft) - (cont : (bef_top, bef, aft_top, aft) Script_typed_ir.continuation) = - match cont with - | KNil -> Control.nil - | KCons _ -> Control.cons - | KReturn _ -> Control.return - | KMap_head (_, _) -> Control.map_head - | KUndip _ -> Control.undip - | KLoop_in _ -> Control.loop_in - | KLoop_in_left _ -> Control.loop_in_left - | KIter (_, _, xs, _) -> Control.iter (Size.of_int (List.length xs)) - | KList_enter_body (_, xs, ys, _, _, _) -> - Control.list_enter_body - (Size.of_int (List.length xs)) - (Size.of_int (Script_list.length ys)) - | KList_exit_body (_, _, _, _, _, _) -> Control.list_exit_body - | KMap_enter_body (_, xs, _, _, _) -> - Control.map_enter_body (Size.of_int (List.length xs)) - | KMap_exit_body (_, _, map, k, _, _) -> - let (module Map) = Script_map.get_module map in - let key_size = Map.OPS.key_size k in - Control.map_exit_body key_size (Size.map map) - | KView_exit _ -> Control.view_exit - | KLog _ -> Control.log - -(** [Stop_bench] gets raised when a [IFailwith] would be the next instruction. - This allows us to recover the full execution trace, including the trace of - the [IFailwith]. - - The actual benchmark will follow the same execution branch, but instead will - raise an [error] which will be ignored. Thus it is safe to end a benchmark - with [IFailwith], but timings are expected to be different from ending with - [IHalt]. This means that, if we choose to include this behavior in any - benchmark, [IFailwith] must be benched. *) -exception Stop_bench - -let extract_deps (type bef_top bef aft_top aft) ctxt step_constants - (sty : (bef_top, bef) Script_typed_ir.stack_ty) - (kinstr : (bef_top, bef, aft_top, aft) Script_typed_ir.kinstr) - (stack : bef_top * bef) = - let trace = ref [] in - (* Logger definition *) - let logger = - Script_interpreter_logging.make - (module struct - let log_interp _instr _ctxt _log _stack_ty _stack = () - - let log_entry : - type a s b f. (a, s, b, f, a, s) Script_typed_ir.logging_function = - fun kinstr ctxt _loc _stack_ty stack -> - trace := extract_ir_sized_step ctxt kinstr stack :: !trace ; - match kinstr with IFailwith _ -> raise Stop_bench | _ -> () - - let log_control kont = trace := extract_control_trace kont :: !trace - - let log_exit _instr _ctxt _log _stack_ty _stack = () - - let get_log () = Environment.Error_monad.return_none - end) - in - try - let res = - Lwt_main.run - (Script_interpreter.Internals.kstep - (Some logger) - ctxt - step_constants - sty - kinstr - (fst stack) - (snd stack)) - in - match Environment.wrap_tzresult res with - | Error errs -> - Format.eprintf "%a@." Error_monad.pp_print_trace errs ; - raise (Failure "Interpreter_workload.extract_deps: error in step") - | Ok (_aft_top, _aft, _ctxt) -> - (* ((aft_top, aft), List.rev !trace, ctxt) *) - List.rev !trace - with Stop_bench -> List.rev !trace - -let extract_deps_continuation (type bef_top bef aft_top aft) ctxt step_constants - (stack_type : (bef_top, bef) stack_ty) - (cont : (bef_top, bef, aft_top, aft) Script_typed_ir.continuation) - (stack : bef_top * bef) = - let trace = ref [] in - (* Logger definition *) - let logger = - Script_interpreter_logging.make - (module struct - let log_interp _instr _ctxt _log _stack_ty _stack = () - - let log_entry : - type a s b f. (a, s, b, f, a, s) Script_typed_ir.logging_function = - fun kinstr ctxt _loc _stack_ty stack -> - trace := extract_ir_sized_step ctxt kinstr stack :: !trace ; - match kinstr with IFailwith _ -> raise Stop_bench | _ -> () - - let log_control kont = trace := extract_control_trace kont :: !trace - - let log_exit _instr _ctxt _log _stack_ty _stack = () - - let get_log () = Environment.Error_monad.return_none - end) - in - try - let res = - let _gas_counter, outdated_ctxt = - Local_gas_counter.local_gas_counter_and_outdated_context ctxt - in - Lwt_main.run - (Script_interpreter.Internals.next - (Some logger) - (outdated_ctxt, step_constants) - (Local_gas_counter 0xFF_FF_FF_FF) - stack_type - cont - (fst stack) - (snd stack)) - in - match Environment.wrap_tzresult res with - | Error errs -> - Format.eprintf "%a@." Error_monad.pp_print_trace errs ; - raise (Failure "Interpreter_workload.extract_deps: error in step") - | Ok (_aft_top, _aft, _outdated_ctxt, _gas) -> - (* ((aft_top, aft), List.rev !trace, outdated_ctxt, gas) *) - List.rev !trace - with Stop_bench -> List.rev !trace - -let sized_step_to_sparse_vec {name; args} = - let s = string_of_instr_or_cont name in - match args with - | [] -> Sparse_vec.String.of_list [(s, float_of_int 1)] - | _ -> - List.fold_left - (fun acc {name; arg} -> - Sparse_vec.String.( - add acc (of_list [(s ^ "_" ^ name, float_of_int (Size.to_int arg))]))) - Sparse_vec.String.zero - args - -let trace_to_sparse_vec trace = - List.fold_left - (fun acc step -> Sparse_vec.String.add acc (sized_step_to_sparse_vec step)) - Sparse_vec.String.zero - trace diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/michelson_commands.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/michelson_commands.ml deleted file mode 100644 index 2c8f3c34acd4555dbb8c3bf0b0f4eaae6b49a42b..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/michelson_commands.ml +++ /dev/null @@ -1,207 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 Michelson_generation - -let group = - { - Tezos_clic.name = "Michelson generation"; - title = "Command for generating random Michelson code and data"; - } - -module Michelson_concat_cmd = struct - let handler () file1 file2 file3 () = - let trace1 = Michelson_mcmc_samplers.load ~filename:file1 in - let trace2 = Michelson_mcmc_samplers.load ~filename:file2 in - let terms = trace1 @ trace2 in - let l1 = List.length trace1 in - let l2 = List.length trace2 in - Format.eprintf - "Loaded %d terms from %s, %d terms from %s, total %d@." - l1 - file1 - l2 - file2 - (l1 + l2) ; - Michelson_mcmc_samplers.save ~filename:file3 ~terms ; - return_unit - - let params = - Tezos_clic.( - prefixes [Protocol.name; "michelson"; "concat"; "files"] - @@ string ~name:"FILENAME" ~desc:"First file" - @@ prefixes ["and"] - @@ string ~name:"FILENAME" ~desc:"Second file" - @@ prefixes ["into"] - @@ string ~name:"FILENAME" ~desc:"Target file" - @@ stop) - - let command = - Tezos_clic.command - ~group - ~desc:"Michelson generation" - Tezos_clic.no_options - params - handler -end - -let () = Registration.add_command Michelson_concat_cmd.command - -module Michelson_gen_cmd = struct - let lift_opt f opt_arg state = - match opt_arg with None -> state | Some arg -> f arg state - - let handler (min_size, max_size, burn_in, seed) terms_count terms_kind - filename () = - let default = Michelson_generation.default_generator_config in - let min = Option.value ~default:default.target_size.min min_size in - let max = Option.value ~default:default.target_size.max max_size in - let burn_in_multiplier = - Option.value ~default:default.burn_in_multiplier burn_in - in - let rng_state = - match seed with - | None -> - Format.eprintf "Self-initialization of PRNG@." ; - let state = Random.State.make_self_init () in - Format.(eprintf "PRNG state hash: %d@." (Hashtbl.hash state)) ; - state - | Some seed -> - Format.eprintf "PRNG initialized with seed %d@." seed ; - Random.State.make [|seed|] - in - let cfg = - {Michelson_generation.target_size = {min; max}; burn_in_multiplier} - in - let terms_count = - match int_of_string terms_count with - | exception Failure _ -> - Format.eprintf "TERMS-COUNT must be an integer, exiting@." ; - exit 1 - | terms_count -> - if terms_count <= 0 then ( - Format.eprintf "TERMS-COUNT must be strictly positive, exiting@." ; - exit 1) - else terms_count - in - let progress = - Benchmark_helpers.make_progress_printer - Format.err_formatter - terms_count - "Generating term" - in - let terms = - match terms_kind with - | "data" -> - Stdlib.List.init terms_count (fun _i -> - progress () ; - Michelson_mcmc_samplers.Data - (Michelson_generation.make_data_sampler rng_state cfg)) - | "code" -> - Stdlib.List.init terms_count (fun _i -> - progress () ; - Michelson_mcmc_samplers.Code - (Michelson_generation.make_code_sampler rng_state cfg)) - | _ -> - Format.eprintf "Term kind must be either \"data\" or \"code\"@." ; - exit 1 - in - Michelson_mcmc_samplers.save ~filename ~terms ; - return_unit - - let min_size_arg = - let min_size = - Tezos_clic.parameter (fun (_ : unit) parsed -> - try return (int_of_string parsed) - with _ -> - Format.eprintf "Error while parsing --min-size argument.@." ; - exit 1) - in - Tezos_clic.arg - ~doc:"Lower bound for target size of terms" - ~long:"min-size" - ~placeholder:"int" - min_size - - let max_size_arg = - let max_size = - Tezos_clic.parameter (fun (_ : unit) parsed -> - try return (int_of_string parsed) - with _ -> - Format.eprintf "Error while parsing --max-size argument.@." ; - exit 1) - in - Tezos_clic.arg - ~doc:"Lower bound for target size of terms" - ~long:"max-size" - ~placeholder:"int" - max_size - - let burn_in_arg = - let target_size = - Tezos_clic.parameter (fun (_ : unit) parsed -> - try return (int_of_string parsed) - with _ -> - Format.eprintf "Error while parsing --burn-in argument.@." ; - exit 1) - in - Tezos_clic.arg - ~doc:"Burn-in multiplier" - ~long:"burn-in" - ~placeholder:"int" - target_size - - let seed_arg = - let seed = - Tezos_clic.parameter (fun (_ : unit) parsed -> - try return (int_of_string parsed) - with _ -> - Format.eprintf "Error while parsing --seed argument.@." ; - exit 1) - in - Tezos_clic.arg ~doc:"RNG seed" ~long:"seed" ~placeholder:"int" seed - - let options = Tezos_clic.args4 min_size_arg max_size_arg burn_in_arg seed_arg - - let params = - Tezos_clic.( - prefixes [Protocol.name; "michelson"; "generate"] - @@ string ~name:"TERMS-COUNT" ~desc:"Number of terms to generate" - @@ prefixes ["terms"; "of"; "kind"] - @@ string ~name:"{data|code}" ~desc:"Kind of term to generate" - @@ prefixes ["in"] - @@ string ~name:"FILENAME" ~desc:"File where to save Michelson terms" - @@ stop) - - let command = - Tezos_clic.command - ~group - ~desc:"Michelson generation" - options - params - handler -end - -let () = Registration.add_command Michelson_gen_cmd.command diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/michelson_generation.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/michelson_generation.ml deleted file mode 100644 index d1422930010aa84e1f20e06e14f4763745f68599..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/michelson_generation.ml +++ /dev/null @@ -1,113 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 generator_config = { - target_size : Base_samplers.range; - burn_in_multiplier : int; -} - -let default_generator_config = - {target_size = {Base_samplers.min = 100; max = 1000}; burn_in_multiplier = 5} - -let generator_config_encoding = - let open Data_encoding in - conv - (fun {target_size; burn_in_multiplier} -> (target_size, burn_in_multiplier)) - (fun (target_size, burn_in_multiplier) -> {target_size; burn_in_multiplier}) - (obj2 - (req "target_size" Base_samplers.range_encoding) - (req "burn_in_multiplier" int31)) - -(* ----------------------------------------------------------------------- *) - -(* ----------------------------------------------------------------------- *) - -module Crypto_samplers = Crypto_samplers.Make_finite_key_pool (struct - let size = 16 - - let algo = `Default -end) - -module Samplers = - Michelson_samplers.Make - (struct - let parameters = - { - Michelson_samplers.base_parameters = - { - int_size = {min = 8; max = 32}; - string_size = {min = 8; max = 128}; - bytes_size = {min = 8; max = 128}; - }; - list_size = {min = 0; max = 1000}; - set_size = {min = 0; max = 1000}; - map_size = {min = 0; max = 1000}; - } - end) - (Crypto_samplers) - -module Michelson_base_samplers = Samplers.Michelson_base - -(* ----------------------------------------------------------------------- *) - -let make_data_sampler rng_state config = - let target_size = - Base_samplers.sample_in_interval rng_state ~range:config.target_size - in - let module Data = - Michelson_mcmc_samplers.Make_data_sampler - (Michelson_base_samplers) - (Crypto_samplers) - (struct - let rng_state = rng_state - - let target_size = target_size - - let verbosity = `Silent - end) - in - let burn_in = target_size * config.burn_in_multiplier in - let generator = Data.generator ~burn_in rng_state in - generator rng_state - -let make_code_sampler rng_state config = - let target_size = - Base_samplers.sample_in_interval rng_state ~range:config.target_size - in - let module Code = - Michelson_mcmc_samplers.Make_code_sampler - (Michelson_base_samplers) - (Crypto_samplers) - (struct - let rng_state = rng_state - - let target_size = target_size - - let verbosity = `Silent - end) - in - let burn_in = target_size * config.burn_in_multiplier in - let generator = Code.generator ~burn_in rng_state in - generator rng_state diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/michelson_generation.mli b/src/proto_017_PtNairob/lib_benchmarks_proto/michelson_generation.mli deleted file mode 100644 index 89868e6f58b1eee6164ea500e3e8ceeba4c70876..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/michelson_generation.mli +++ /dev/null @@ -1,61 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 Wrappers around some Michelson generators and related helpers} *) - -(** [generator_config] specifies some parameters to the - {!Tezos_benchmark_alpha.Michelson_mcmc_samplers} Michelson code and data generators. *) -type generator_config = { - target_size : Base_samplers.range; - (** The target size of the terms, in number of nodes, is sampled uniformly - in [target_size]. *) - burn_in_multiplier : int; - (** The generators are based on a Markov chain, which must be - "heated-up" until it reaches its stationary state. A prefix of samples - are therefore thrown away: this is called the {e burn-in} phase. - The number of thrown away terms is proportional to [burn_in_multiplier] - and [target_size]. *) -} - -(** Default configuration for the generators. *) -val default_generator_config : generator_config - -val generator_config_encoding : generator_config Data_encoding.t - -(** Samplers *) - -(** [make_data_sampler] constructs a Michelson data sampler based on the - infrastructure available in {!Tezos_benchmark_alpha.Michelson_mcmc_samplers}. *) -val make_data_sampler : - Random.State.t -> generator_config -> Michelson_mcmc_samplers.michelson_data - -(** [make_code_sampler] constructs a Michelson code sampler based on the - infrastructure available in {!Tezos_benchmark_alpha.Michelson_mcmc_samplers}. *) -val make_code_sampler : - Random.State.t -> generator_config -> Michelson_mcmc_samplers.michelson_code - -(** [Samplers] is an instance of the direct-style (non-MCMC based) samplers - implemented in {!Tezos_benchmark_alpha.Michelson_samplers}. *) -module Samplers : Michelson_samplers.S diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/michelson_types.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/michelson_types.ml deleted file mode 100644 index 74a49958dbfe5ff81ce75218a3826df43926bda6..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/michelson_types.ml +++ /dev/null @@ -1,130 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021-2022 Nomadic Labs, *) -(* *) -(* 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 -open Script_typed_ir - -[@@@ocaml.warning "-32"] - -let ( @$ ) x y = Item_t (x, y) - -let bot = Bot_t - -let unit = unit_t - -(* the type of integers *) -let int = int_t - -(* the type of naturals *) -let nat = nat_t - -(* the type of strings *) -let string = string_t - -(* the type of bytes *) -let bytes = bytes_t - -(* the type of booleans *) -let bool = bool_t - -(* the type of mutez *) -let mutez = mutez_t - -(* the type of public key *) -let public_key = key_t - -(* the type of key hashes *) -let key_hash = key_hash_t - -(* the type of signatures *) -let signature = signature_t - -(* the type of addresses *) -let address = address_t - -(* the type of chain ids *) -let chain_id = chain_id_t - -(* the type of timestamps *) -let timestamp = timestamp_t - -(* list type constructor *) -let list x = match list_t (-1) x with Error _ -> assert false | Ok t -> t - -(* option type constructor *) -let option x = match option_t (-1) x with Error _ -> assert false | Ok t -> t - -(* map type constructor*) -let map k v = match map_t (-1) k v with Error _ -> assert false | Ok t -> t - -(* map type constructor*) -let big_map k v = - match big_map_t (-1) k v with Error _ -> assert false | Ok t -> t - -(* set type constructor*) -let set k = match set_t (-1) k with Error _ -> assert false | Ok t -> t - -(* pair type constructor*) -let pair k1 k2 = - match pair_t (-1) k1 k2 with Error _ -> assert false | Ok t -> t - -(* comparable pair type constructor *) -let cpair k1 k2 = - match comparable_pair_t (-1) k1 k2 with Error _ -> assert false | Ok t -> t - -(* or type constructor*) -let or_ k1 k2 = match or_t (-1) k1 k2 with Error _ -> assert false | Ok t -> t - -(* comparable or type constructor *) -let cor k1 k2 = - match comparable_or_t (-1) k1 k2 with Error _ -> assert false | Ok t -> t - -let lambda x y = - match lambda_t (-1) x y with Error _ -> assert false | Ok t -> t - -let contract arg_ty = - match contract_t (-1) arg_ty with Error _ -> assert false | Ok t -> t - -let operation = operation_t - -let sapling_state memo_size = sapling_state_t ~memo_size - -let sapling_transaction memo_size = sapling_transaction_t ~memo_size - -let sapling_transaction_deprecated memo_size = - sapling_transaction_deprecated_t ~memo_size - -let bls12_381_g1 = bls12_381_g1_t - -let bls12_381_g2 = bls12_381_g2_t - -let bls12_381_fr = bls12_381_fr_t - -let ticket ty = - match ticket_t (-1) ty with Error _ -> assert false | Ok t -> t - -let chest_key = chest_key_t - -let chest = chest_t diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/registration_helpers.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/registration_helpers.ml deleted file mode 100644 index fab95d0781c3c83c371088b59e003d4a4282a8e9..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/registration_helpers.ml +++ /dev/null @@ -1,53 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* Copyright (c) 2023 Marigold *) -(* *) -(* 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 ns = Namespace.root - -let adjust_tags tags = Tags.common :: tags - -let register ((module Bench) : Benchmark.t) = - let module B : Benchmark.S = struct - include Bench - - let tags = adjust_tags tags - end in - Registration.register (module B) - -let register_simple (module Bench : Benchmark.Simple) = - let module B = struct - include Bench - - let tags = adjust_tags tags - end in - Registration.register_simple (module B) - -let register_simple_with_num (module Bench : Benchmark.Simple_with_num) = - let module B = struct - include Bench - - let tags = adjust_tags tags - end in - Registration.register_simple_with_num (module B) diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/sapling_benchmarks.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/sapling_benchmarks.ml deleted file mode 100644 index 9a90578bae098bdcd556edbcd559ec11f2de6f9f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/sapling_benchmarks.ml +++ /dev/null @@ -1,165 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 -module Size = Gas_input_size - -let ns = Namespace.make Registration_helpers.ns "sapling" - -let fv s = Free_variable.of_namespace (ns s) - -module Apply_diff_bench : Benchmark.S = struct - include Interpreter_benchmarks.Default_config - include Interpreter_benchmarks.Default_boilerplate - - let name = ns "SAPLING_APPLY_DIFF" - - let info = "Benchmarking SAPLING_APPLY_DIFF" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let tags = ["sapling"] - - let diff_from_tx (tx : Alpha_context.Sapling.transaction) = - let open Environment.Sapling.UTXO in - let commitments_and_ciphertexts = - List.map (fun x -> (x.cm, x.ciphertext)) tx.outputs - in - { - Protocol.Sapling_repr.commitments_and_ciphertexts; - nullifiers = List.map (fun (x : input) -> x.nf) tx.inputs; - } - - type workload = {nb_input : int; nb_output : int; nb_cm : int; nb_nf : int} - - let workload_encoding : workload Data_encoding.t = - let open Data_encoding in - def "diff_arg_encoding" - @@ conv - (fun {nb_input; nb_output; nb_cm; nb_nf} -> - (nb_input, nb_output, nb_cm, nb_nf)) - (fun (nb_input, nb_output, nb_cm, nb_nf) -> - {nb_input; nb_output; nb_cm; nb_nf}) - (tup4 Size.encoding Size.encoding Size.encoding Size.encoding) - - let workload_to_vector {nb_input; nb_output; nb_cm = _; nb_nf = _} = - let l = - [ - ("nb_input", float_of_int nb_input); - ("nb_output", float_of_int nb_output); - ] - in - Sparse_vec.String.of_list l - - let model = - Model.make - ~conv:(fun {nb_input; nb_output; _} -> (nb_input, (nb_output, ()))) - (Model.bilinear_affine - ~name - ~intercept:(fv "apply_diff_const") - ~coeff1:(fv "apply_diff_inputs") - ~coeff2:(fv "apply_diff_outputs")) - - let models = [("apply_diff", model)] - - let benchmark_apply_diff seed sapling_transition () = - let sapling_forge_rng_state = - Random.State.make - @@ Option.fold - ~none:Sapling_generation.shared_seed - ~some:(fun seed -> [|seed|]) - seed - in - Lwt_main.run - ( Execution_context.make ~rng_state:sapling_forge_rng_state - >>=? fun (ctxt, step_constants) -> - Sapling_generation.prepare_seeded_state sapling_transition ctxt - >>=? fun (_, _, _, _, ctxt, state_id) -> - let external_state_id = Alpha_context.Sapling.Id.parse_z state_id in - let internal_state_id = - Lazy_storage_kind.Sapling_state.Id.parse_z state_id - in - Alpha_context.Sapling.(state_from_id ctxt external_state_id) - >|= Environment.wrap_tzresult - >>=? fun (state, ctxt) -> - Format.eprintf "state hash: %d@." (Hashtbl.hash state.diff) ; - Format.eprintf - "tx hash: %d@." - (Hashtbl.hash sapling_transition.sapling_tx) ; - let address = Contract_hash.to_b58check step_constants.self in - let chain_id = - Environment.Chain_id.to_b58check step_constants.chain_id - in - let anti_replay = address ^ chain_id in - Format.eprintf "anti-replay: %s@." anti_replay ; - let diff = diff_from_tx sapling_transition.sapling_tx in - let closure () = - ignore - (Lwt_main.run - (Sapling_generation.apply_diff ctxt internal_state_id diff)) - in - let workload = - { - nb_input = List.length sapling_transition.sapling_tx.inputs; - nb_output = List.length sapling_transition.sapling_tx.outputs; - nb_cm = Int64.to_int sapling_transition.commitment_count; - nb_nf = Int64.to_int sapling_transition.nullifier_count; - } - in - return (Generator.Plain {workload; closure}) ) - |> function - | Ok closure -> closure - | Error errs -> - Format.eprintf - "Runner.benchmarkable_from_instr_str:\n%a@." - (Format.pp_print_list Error_monad.pp) - errs ; - exit 1 - - let create_benchmarks ~rng_state ~bench_num config = - ignore rng_state ; - match config.sapling with - | {sapling_txs_file; seed} -> - let transitions = - Sapling_generation.load - ~filename:sapling_txs_file - Sapling_generation.Full_transaction - in - let length = List.length transitions in - if length < bench_num then - Format.eprintf - "KSapling_verify_update: warning, only %d available transactions \ - (requested %d)@." - length - bench_num ; - let transitions = List.take_n (min bench_num length) transitions in - List.map - (fun (_filename, tx) -> benchmark_apply_diff seed tx) - transitions -end - -let () = Registration_helpers.register (module Apply_diff_bench) diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/sapling_commands.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/sapling_commands.ml deleted file mode 100644 index 6be04868415a66bf03f181ed550e68ac5d06c659..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/sapling_commands.ml +++ /dev/null @@ -1,134 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 Sapling_gen_cmd = struct - let lift_opt f opt_arg state = - match opt_arg with None -> state | Some arg -> f arg state - - (* ----------------------------------------------------------------------- *) - (* Handling options for the "generate sapling transactions" command *) - - (* Generic max-%s argument *) - let max name = - Tezos_clic.arg - ~doc:(Printf.sprintf "Maximum number of %s" name) - ~long:(Printf.sprintf "max-%s" name) - ~placeholder:"integer" - (Tezos_clic.parameter (fun (_ : unit) parsed -> - match int_of_string parsed with - | exception Failure _ -> - Format.eprintf - "Ill-formatted --max-%s option (expected integer), exiting@." - name ; - exit 1 - | res when res < 0 -> - Format.eprintf - "--max-%s should be a positive integer, exiting@." - name ; - exit 1 - | res -> return res)) - - (* Integer argument --seed *) - let seed_arg = - let seed = - Tezos_clic.parameter (fun (_ : unit) parsed -> - try return (int_of_string parsed) - with _ -> - Format.eprintf "Error while parsing --seed argument.@." ; - exit 1) - in - Tezos_clic.arg ~doc:"RNG seed" ~long:"seed" ~placeholder:"int" seed - - let positive_param = - Tezos_clic.parameter (fun _ s -> - match int_of_string_opt s with - | Some i when i > 0 -> return i - | _ -> failwith "Parameter should be a positive integer literal") - - open Sapling_generation - - let set_max_inputs max_inputs options = {options with max_inputs} - - let set_max_outputs max_outputs options = {options with max_outputs} - - let set_max_nullifiers max_nullifiers options = {options with max_nullifiers} - - let set_max_additional_commitments max_additional_commitments options = - {options with max_additional_commitments} - - let set_seed seed (options : sapling_gen_options) = - {options with seed = Some seed} - - let sapling_handler - (max_inputs, max_outputs, max_nullifiers, max_additional_commitments, seed) - tx_count save_to () = - let sapling_gen_options = - default_sapling_gen_options - |> lift_opt set_max_inputs max_inputs - |> lift_opt set_max_outputs max_outputs - |> lift_opt set_max_nullifiers max_nullifiers - |> lift_opt set_max_additional_commitments max_additional_commitments - |> lift_opt set_seed seed - in - generate save_to tx_count sapling_gen_options ; - return () - - let options = - Tezos_clic.args5 - (max "inputs") - (max "outputs") - (max "nullifiers") - (max "additional-commitments") - seed_arg - - let params = - Tezos_clic.( - prefixes [Protocol.name; "sapling"; "generate"] - @@ param - ~name:"SAPLING-TX-COUNT" - ~desc:"Number of sapling transactions to generate" - positive_param - @@ prefixes ["transactions"; "in"] - @@ string - ~name:"SAPLING-TX-FILE" - ~desc:"File containing sapling transactions" - @@ stop) - - let group = - { - Tezos_clic.name = "Sapling tx generation"; - title = "Command for generating random sapling transactions"; - } - - let command = - Tezos_clic.command - ~group - ~desc:"Sapling transaction generation" - options - params - sapling_handler -end - -let () = Registration.add_command Sapling_gen_cmd.command diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/sapling_generation.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/sapling_generation.ml deleted file mode 100644 index 5560cd7d214145ad8039ed24b5d7472c54a34c5b..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/sapling_generation.ml +++ /dev/null @@ -1,588 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 - -(* ------------------------------------------------------------------------- *) -type sapling_gen_options = { - max_inputs : int; - max_outputs : int; - max_nullifiers : int; - max_additional_commitments : int; - seed : int option; -} - -let default_sapling_gen_options = - { - max_inputs = 100; - max_outputs = 100; - max_nullifiers = 100; - max_additional_commitments = 50; - seed = None; - } - -(* ------------------------------------------------------------------------- *) -(* Evil incantations *) - -(* We have to break the protocol abstraction boundary quite often in this - module. Props to whoever finds a way to avoid these calls. *) - -let alpha_to_raw (x : Alpha_context.t) : Raw_context.t = Obj.magic x - -let raw_to_alpha (x : Raw_context.t) : Alpha_context.t = Obj.magic x - -(* ------------------------------------------------------------------------- *) -(* Helpers *) - -(* sample a random permutation of [0 ; ... ; n-1] *) -let fisher_yates n state = - let a = Array.init n (fun i -> i) in - for i = 0 to Array.length a - 1 do - let j = Random.State.int state (i + 1) in - let tmp = a.(j) in - a.(j) <- a.(i) ; - a.(i) <- tmp - done ; - a - -(* sample a random injection of [0 ; ... ; m-1 ] in [0 ; ... ; n - 1] *) -let random_injection m n state = - if m > n then invalid_arg "random_injection" - else - let a = fisher_yates n state in - Array.sub a 0 m - -(* ------------------------------------------------------------------------- *) -(* Sapling generation *) - -(* Sapling state spec + sapling transaction valid for that state. *) -type sapling_transition = { - state_seed : int64; - nullifier_count : int64; - commitment_count : int64; - sapling_tx : Alpha_context.Sapling.transaction; -} - -type forge_info = { - rcm : Tezos_sapling.Core.Client.Rcm.t; - position : int64; - amount : int64; - address : Tezos_sapling.Core.Client.Viewing_key.address; - nf : Tezos_sapling.Core.Client.Nullifier.t; -} - -let random_amount state sum = - Random.State.int64 - state - (Int64.sub Tezos_sapling.Core.Validator.UTXO.max_amount sum) - -let reverse diff = - Protocol.Sapling_repr. - { - diff with - commitments_and_ciphertexts = List.rev diff.commitments_and_ciphertexts; - } - -let pp_rpc_diff fmtr (diff : Protocol.Sapling_repr.diff) = - let json = - Data_encoding.Json.construct Protocol.Sapling_repr.diff_encoding diff - in - Format.fprintf fmtr "%a" Data_encoding.Json.pp json - -let random_bytes state size = - Bytes.init size (fun _ -> Char.chr (Random.State.int state 256)) - -let rec gen_rcm state = - let rcm = - Data_encoding.Binary.of_bytes_exn - Tezos_sapling.Core.Client.Rcm.encoding - (random_bytes state 32) - in - try - Tezos_sapling.Core.Client.Rcm.assert_valid rcm ; - rcm - with _ -> gen_rcm state - -(* Adds a commitment, ciphertext, cv to an rpc_diff *) -let add_input diff vk index position sum state = - let rcm = gen_rcm state in - let amount = random_amount state sum in - let new_idx, address = - Tezos_sapling.Core.Client.Viewing_key.new_address vk index - in - let cv = - Tezos_sapling.Core.Client.CV.of_bytes (random_bytes state 32) - |> WithExceptions.Option.get ~loc:__LOC__ - in - let ciphertext, cm = - Tezos_sapling.Core.Client.Forge.Output.to_ciphertext - Tezos_sapling.Core.Client.Forge.Output. - {address; amount; memo = Bytes.empty} - cv - vk - rcm - (Tezos_sapling.Core.Client.DH.esk_random ()) - in - let nf = - Tezos_sapling.Core.Client.Nullifier.compute address vk ~amount rcm ~position - in - let diff = - Protocol.Sapling_repr. - { - diff with - commitments_and_ciphertexts = - (cm, ciphertext) :: diff.commitments_and_ciphertexts; - } - in - return (diff, {rcm; position; amount; address; nf}, new_idx) - -let generate_commitments ~vk ~nb_input ~nb_cm ~nb_nf ~diff ~index state = - let inj = random_injection nb_input nb_cm state in - let use_for_input i = Array.exists (fun k -> k = i) inj in - let rec loop i cm_index nb_nf diff to_forge sum = - if i = nb_cm then return (reverse diff, to_forge) - else if use_for_input i then - (* create commitment for input *) - add_input diff vk cm_index (Int64.of_int i) sum state - >>=? fun (diff, forge_info, next_index) -> - let sum = Int64.add sum forge_info.amount in - loop (i + 1) next_index nb_nf diff (forge_info :: to_forge) sum - else - (* create commitment (not for input) *) - add_input diff vk cm_index (Int64.of_int i) sum state - >>=? fun (diff, {nf; _}, next_index) -> - (* can we use a nullifier? *) - if nb_nf = 0 then (* No. *) - loop (i + 1) next_index nb_nf diff to_forge sum - else - (* Yes! Grab it. *) - let diff = - Protocol.Sapling_repr.{diff with nullifiers = nf :: diff.nullifiers} - in - loop (i + 1) next_index (nb_nf - 1) diff to_forge sum - in - loop 0 index nb_nf diff [] 0L - -(* Add roots to the storage. One cm has to be added for every root. *) -let rec add_root nb_root ctxt id vk index size diff state = - if nb_root > 0 then - add_input Protocol.Sapling_storage.empty_diff vk index size 0L state - >>=? fun (diff_to_add, {position = size; _}, new_idx) -> - Protocol.Sapling_storage.apply_diff ctxt id diff_to_add - >|= Environment.wrap_tzresult - >>=? fun (ctxt, _) -> - (* We call it nb_root -1 because one root is already present*) - add_root - (nb_root - 1) - ctxt - id - vk - new_idx - (Int64.succ size) - Protocol.Sapling_repr. - { - diff with - commitments_and_ciphertexts = - diff.commitments_and_ciphertexts - @ diff_to_add.commitments_and_ciphertexts; - } - state - else return (ctxt, diff) - -(* Compute a state as an OCaml object to compute the witness *) -let state_from_rpc_diff rpc_diff = - Tezos_sapling.Storage.add - (Tezos_sapling.Storage.empty ~memo_size:0) - rpc_diff.Protocol.Sapling_repr.commitments_and_ciphertexts - -(* Create an (unspendable) output from a proving context and a vk *) -let output proving_ctx vk sum state = - let address = Tezos_sapling.Core.Client.Viewing_key.dummy_address () in - let amount = random_amount state sum in - let rcm = Tezos_sapling.Core.Client.Rcm.random () in - let esk = Tezos_sapling.Core.Client.DH.esk_random () in - let cv_o, proof_o = - Tezos_sapling.Core.Client.Proving.output_proof - proving_ctx - esk - address - rcm - ~amount - in - let ciphertext, cm = - Tezos_sapling.Core.Client.Forge.Output.to_ciphertext - Tezos_sapling.Core.Client.Forge.Output. - {address; amount; memo = Bytes.empty} - cv_o - vk - rcm - esk - in - (Tezos_sapling.Core.Validator.UTXO.{cm; proof_o; ciphertext}, amount) - -(* Returns a list of outputs and the sum of their amount *) -let outputs nb_output proving_ctx vk state = - let rec aux output_amount list_outputs nb_output sum = - match nb_output with - | 0 -> (output_amount, list_outputs) - | nb_output -> - let output, amount = output proving_ctx vk sum state in - assert ( - Int64.compare - amount - (Int64.sub - Int64.max_int - Tezos_sapling.Core.Validator.UTXO.max_amount) - < 0) ; - aux - (Int64.add output_amount amount) - (output :: list_outputs) - (nb_output - 1) - (Int64.add sum amount) - in - aux 0L [] nb_output 0L - -(* Create the list of inputs. To use once the merkle tree is completed. *) -let make_inputs to_forge local_state proving_ctx sk vk root anti_replay = - List.map_ep - (fun {rcm; position; amount; address; nf} -> - let witness = Tezos_sapling.Storage.get_witness local_state position in - let ar = Tezos_sapling.Core.Client.Proving.ar_random () in - let cv, rk, proof = - Tezos_sapling.Core.Client.Proving.spend_proof - proving_ctx - vk - sk - address - rcm - ar - ~amount - ~root - ~witness - in - let signature = - Tezos_sapling.Core.Client.Proving.spend_sig - sk - ar - cv - nf - rk - proof - anti_replay - in - return - Tezos_sapling.Core.Validator.UTXO. - {cv; nf; rk; proof_i = proof; signature}) - to_forge - -let init_fresh_sapling_state ctxt = - let open Environment.Error_monad in - Protocol.Lazy_storage_diff.fresh - Protocol.Lazy_storage_kind.Sapling_state - ~temporary:false - ctxt - >>=? fun (ctxt, id) -> - Protocol.Sapling_storage.init ctxt id ~memo_size:0 - (* TODO CHECK *) - >>=? fun ctxt -> return (ctxt, id) - -let generate_spending_and_viewing_keys state = - let sk = - Tezos_sapling.Core.Client.Spending_key.of_seed (random_bytes state 32) - in - let vk = Tezos_sapling.Core.Client.Viewing_key.of_sk sk in - (sk, vk) - -let prepare_seeded_state_internal ~(nb_input : int) ~(nb_nf : int) - ~(nb_cm : int) (ctxt : Raw_context.t) (state : Random.State.t) : - (Sapling_repr.diff - * forge_info list - * Tezos_sapling.Core.Client.Spending_key.t - * Tezos_sapling.Core.Client.Viewing_key.t - * Raw_context.t - * Protocol.Lazy_storage_kind.Sapling_state.Id.t) - tzresult - Lwt.t = - init_fresh_sapling_state ctxt >|= Environment.wrap_tzresult - >>=? fun (ctxt, id) -> - let index_start = Tezos_sapling.Core.Client.Viewing_key.default_index in - let sk, vk = generate_spending_and_viewing_keys state in - generate_commitments - ~vk - ~nb_input - ~nb_cm - ~nb_nf - ~diff:Protocol.Sapling_storage.empty_diff - ~index:index_start - state - >>=? fun (diff, to_forge) -> - Protocol.Sapling_storage.apply_diff ctxt id (reverse diff) - >|= Environment.wrap_tzresult - >>=? fun (ctxt, _size) -> return (diff, to_forge, sk, vk, ctxt, id) - -let prepare_seeded_state - {state_seed; nullifier_count; commitment_count; sapling_tx} ctxt = - let rng_state = Random.State.make [|Int64.to_int state_seed|] in - prepare_seeded_state_internal - ~nb_input:(List.length sapling_tx.inputs) - ~nb_nf:(Int64.to_int nullifier_count) - ~nb_cm:(Int64.to_int commitment_count) - (alpha_to_raw ctxt) - rng_state - >>=? fun (diff, forge_info, spending_key, viewing_key, raw_ctxt, raw_id) -> - let id = Protocol.Lazy_storage_kind.Sapling_state.Id.unparse_to_z raw_id in - return (diff, forge_info, spending_key, viewing_key, raw_to_alpha raw_ctxt, id) - -let generate ~(nb_input : int) ~(nb_output : int) ~(nb_nf : int) ~(nb_cm : int) - ~(anti_replay : string) ~ctxt state = - assert (nb_input <= nb_cm) ; - assert (nb_nf <= nb_cm - nb_input) ; - prepare_seeded_state_internal ~nb_input ~nb_nf ~nb_cm ctxt state - >>=? fun (diff, to_forge, sk, vk, ctxt, id) -> - let local_state = state_from_rpc_diff diff in - let root = Tezos_sapling.Storage.get_root local_state in - Tezos_sapling.Core.Client.Proving.with_proving_ctx (fun proving_ctx -> - make_inputs to_forge local_state proving_ctx sk vk root anti_replay - >>=? fun inputs -> - let output_amount, outputs = outputs nb_output proving_ctx vk state in - let input_amount = - List.fold_left - (fun sum {amount; _} -> - assert ( - Int64.compare - sum - (Int64.sub - Int64.max_int - Tezos_sapling.Core.Validator.UTXO.max_amount) - < 0) ; - Int64.add sum amount) - 0L - to_forge - in - let balance = Int64.sub input_amount output_amount in - let bound_data = - (* The bound data are benched separately so we add - empty bound data*) - "" - in - let binding_sig = - Tezos_sapling.Core.Client.Proving.make_binding_sig - proving_ctx - inputs - outputs - ~balance - ~bound_data - anti_replay - in - let transaction = - Tezos_sapling.Core.Validator.UTXO. - {inputs; outputs; binding_sig; balance; root; bound_data} - in - return transaction) - >>=? fun transaction -> - assert (Compare.List_length_with.(transaction.inputs = nb_input)) ; - assert (Compare.List_length_with.(transaction.outputs = nb_output)) ; - return (transaction, (ctxt, id)) - -(* ------------------------------------------------------------------------- *) -(* Nicely packaging sapling generation for snoop *) - -let sapling_transition_encoding = - let open Data_encoding in - conv - (fun {state_seed; nullifier_count; commitment_count; sapling_tx} -> - (state_seed, nullifier_count, commitment_count, sapling_tx)) - (fun (state_seed, nullifier_count, commitment_count, sapling_tx) -> - {state_seed; nullifier_count; commitment_count; sapling_tx}) - (obj4 - (req "state_seed" int64) - (req "nullifier_count" int64) - (req "commitment_count" int64) - (req "sapling_tx" Alpha_context.Sapling.transaction_encoding)) - -let sapling_dataset_encoding = Data_encoding.list sapling_transition_encoding - -let save ~filename ~txs = - let str = - match Data_encoding.Binary.to_string sapling_dataset_encoding txs with - | Error err -> - Format.eprintf - "Sapling_generation.save: encoding failed (%a); exiting@." - Data_encoding.Binary.pp_write_error - err ; - exit 1 - | Ok res -> res - in - ignore (* TODO handle error *) - (Lwt_main.run @@ Tezos_stdlib_unix.Lwt_utils_unix.create_file filename str) - -let load_file filename = - Lwt_main.run - @@ ( Tezos_stdlib_unix.Lwt_utils_unix.read_file filename >>= fun str -> - Format.eprintf "Sapling_generation.load: loaded %s@." filename ; - match Data_encoding.Binary.of_string sapling_dataset_encoding str with - | Ok result -> - let result = List.map (fun tx -> (filename, tx)) result in - Lwt.return result - | Error err -> - Format.eprintf - "Sapling_generation.load: can't load file (%a); exiting@." - Data_encoding.Binary.pp_read_error - err ; - exit 1 ) - -let get_all_sapling_data_files directory = - let is_sapling_data file = - let regexp = Str.regexp ".*\\.sapling" in - Str.string_match regexp file 0 - in - let lift file = directory ^ "/" ^ file in - let handle = Unix.opendir directory in - let rec loop acc = - match Unix.readdir handle with - | file -> if is_sapling_data file then loop (lift file :: acc) else loop acc - | exception End_of_file -> - Unix.closedir handle ; - acc - in - loop [] - -type type_transaction = Empty | No_inputs | No_outputs | Full_transaction - -let load ~filename type_transaction = - if not (Sys.file_exists filename) then ( - Format.eprintf "Sapling_generation.load: file does not exist@." ; - Stdlib.failwith "Sapling_generation.load") - else if Sys.is_directory filename then - let () = - Format.eprintf - "Sapling_generation.load: loading all .sapling files from directory \ - %s@." - filename - in - let files = get_all_sapling_data_files filename in - List.concat_map load_file files - |> List.filter (fun (_str, transac) -> - match type_transaction with - | Empty -> - List.is_empty transac.sapling_tx.outputs - && List.is_empty transac.sapling_tx.inputs - | No_inputs -> - (not (List.is_empty transac.sapling_tx.outputs)) - && List.is_empty transac.sapling_tx.inputs - | No_outputs -> - List.is_empty transac.sapling_tx.outputs - && not (List.is_empty transac.sapling_tx.inputs) - | Full_transaction -> - (not (List.is_empty transac.sapling_tx.outputs)) - && not (List.is_empty transac.sapling_tx.inputs)) - else load_file filename - -let shared_seed = [|9798798; 217861209; 876786|] - -let generate (save_to : string) (tx_count : int) - (sapling_gen_options : sapling_gen_options) = - let result = - Lwt_main.run - (let { - max_inputs; - max_outputs; - max_nullifiers; - max_additional_commitments; - seed; - } = - sapling_gen_options - in - let rng_state = - (* /!\ This must match the seed used at benchmark time, - defined in Runner.benchmark_sapling. /!\ *) - Random.State.make - @@ Option.fold ~none:shared_seed ~some:(fun seed -> [|seed|]) seed - in - Execution_context.make ~rng_state >>=? fun (ctxt, step_constants) -> - let address = Contract_hash.to_b58check step_constants.self in - let chain_id = - Environment.Chain_id.to_b58check step_constants.chain_id - in - let anti_replay = address ^ chain_id in - let ctxt = alpha_to_raw ctxt in - (match sapling_gen_options.seed with - | None -> Random.self_init () - | Some seed -> Random.init seed) ; - let seeds = - Stdlib.List.init tx_count (fun i -> (i, Random.int 0x3FFFFFFF)) - in - let rec loop seeds acc = - match seeds with - | [] -> return acc - | (i, seed) :: tl -> - let nb_input = - if max_inputs = 0 then 0 else 1 + Random.int max_inputs - in - let nb_output = - if max_outputs = 0 then 0 else 1 + Random.int max_outputs - in - let nb_nf = 1 + Random.int max_nullifiers in - let nb_cm = - nb_input + nb_nf + Random.int max_additional_commitments - in - let () = - Format.eprintf "@." ; - Format.eprintf "generating sapling tx %i/%d@." (i + 1) tx_count ; - Format.eprintf "saving to file %s@." save_to ; - Format.eprintf "nb_input = %d@." nb_input ; - Format.eprintf "nb_output = %d@." nb_output ; - Format.eprintf "nb_nf = %d@." nb_nf ; - Format.eprintf "nb_cm = %d@." nb_cm ; - Format.eprintf "anti_replay = %s@." anti_replay - in - let state = Random.State.make [|seed|] in - generate - ~nb_input - ~nb_output - ~nb_nf - ~nb_cm - ~anti_replay - ~ctxt - state - >>=? fun (tx, (_ctxt, _state_id)) -> - let result = - { - state_seed = Int64.of_int seed; - nullifier_count = Int64.of_int nb_nf; - commitment_count = Int64.of_int nb_cm; - sapling_tx = Obj.magic tx; - } - in - loop tl (result :: acc) - in - loop seeds []) - in - match result with Ok txs -> save ~filename:save_to ~txs | Error _ -> () - -let apply_diff ctxt id diff = - let open Environment.Error_monad in - Sapling_storage.apply_diff (alpha_to_raw ctxt) id diff - >>=? fun (ctxt, size) -> return (raw_to_alpha ctxt, size) diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/sc_rollup_benchmarks.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/sc_rollup_benchmarks.ml deleted file mode 100644 index 4c21b767c1bae9489858f398cfc34e297a70505d..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/sc_rollup_benchmarks.ml +++ /dev/null @@ -1,655 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -let ns = Namespace.make Registration_helpers.ns "sc_rollup" - -let fv s = Free_variable.of_namespace (ns s) - -let ( -- ) min max : Base_samplers.range = {min; max} - -(** This section contains preliminary definitions for building a pvm state from - scratch. *) -module Pvm_state_generator = struct - module Context = Tezos_context_memory.Context_binary - - module Wasm_context = struct - type Tezos_tree_encoding.tree_instance += Tree of Context.tree - - module Tree = struct - include Context.Tree - - type tree = Context.tree - - type t = Context.t - - type key = string list - - type value = bytes - - let select = function - | Tree t -> t - | _ -> raise Tezos_tree_encoding.Incorrect_tree_type - - let wrap t = Tree t - end - - type tree = Context.tree - - type proof = Context.Proof.tree Context.Proof.t - - let verify_proof p f = - Lwt.map Result.to_option (Context.verify_tree_proof p f) - - let produce_proof context tree step = - let open Lwt_syntax in - let* context = Context.add_tree context [] tree in - let* _hash = Context.commit ~time:Time.Protocol.epoch context in - let index = Context.index context in - match Context.Tree.kinded_key tree with - | Some k -> - let* p = Context.produce_tree_proof index k step in - return (Some p) - | None -> return None - - let kinded_hash_to_state_hash = function - | `Value hash | `Node hash -> - Sc_rollup_repr.State_hash.context_hash_to_state_hash hash - - let proof_before proof = - kinded_hash_to_state_hash proof.Context.Proof.before - - let proof_after proof = kinded_hash_to_state_hash proof.Context.Proof.after - - let proof_encoding = - let module Proof_encoding = - Tezos_context_merkle_proof_encoding.Merkle_proof_encoding - in - Proof_encoding.V2.Tree2.tree_proof_encoding - end - - let make_transaction value text contract = - let entrypoint = Entrypoint_repr.default in - let destination : Contract_hash.t = - Contract_hash.of_bytes_exn @@ Bytes.of_string contract - in - let open Tezos_micheline.Micheline in - let open Michelson_v1_primitives in - let unparsed_parameters = - strip_locations - @@ Prim - ( 0, - I_TICKET, - [ - Prim - (0, I_PAIR, [Int (0, Z.of_int32 value); String (1, text)], []); - ], - [] ) - in - Sc_rollup_outbox_message_repr.{unparsed_parameters; entrypoint; destination} - - let make_transactions ~rng_state ~max = - let open Base_samplers in - let n = sample_in_interval ~range:(0 -- max) rng_state in - Stdlib.List.init n (fun _ -> - let contract = uniform_string ~nbytes:20 rng_state in - let value = - Int32.of_int @@ sample_in_interval ~range:(-1000 -- 1000) rng_state - in - let text = string ~size:(0 -- 40) rng_state in - make_transaction value text contract) - - let make_outbox_message ~nb_transactions ~rng_state = - let transactions = make_transactions ~rng_state ~max:nb_transactions in - Sc_rollup_outbox_message_repr.Atomic_transaction_batch {transactions} - - let dummy_context = - let dummy = Context.init "/tmp" in - Context.empty @@ Lwt_main.run dummy - - let empty_tree = Context.Tree.empty dummy_context - - (* Build a pvm state from scratch. *) - let build_pvm_state rng_state ~nb_inbox_messages ~input_payload_size - ~nb_output_buffer_levels ~output_buffer_size ~nb_transactions ~tree_depth - ~tree_branching_factor = - let open Lwt_result_syntax in - let random_key () = - Base_samplers.readable_ascii_string ~size:(5 -- 5) rng_state - in - (* [gen_tree] Generates a tree for the given depth and branching factor. - This function is witten in CPS to avoid [stack-overflow] errors when - branching factor is 1 and tree depth is big. *) - let gen_tree () = - let bottom_tree = - let tree = empty_tree in - let key = [random_key ()] in - let value = Bytes.empty in - Context.Tree.add tree key value - in - let rec gen_tree tree_depth kont = - if tree_depth = 0 then kont bottom_tree - else - gen_tree - (tree_depth - 1) - (let rec kont' nb_subtrees acc_subtrees subtree = - let*! subtree in - let acc_subtrees = subtree :: acc_subtrees in - let nb_subtrees = nb_subtrees + 1 in - if nb_subtrees = tree_branching_factor then - let tree = empty_tree in - kont - @@ List.fold_left_s - (fun tree subtree -> - let key = [random_key ()] in - Context.Tree.add_tree tree key subtree) - tree - acc_subtrees - else gen_tree (tree_depth - 1) (kont' nb_subtrees acc_subtrees) - in - kont' 0 []) - in - gen_tree tree_depth Fun.id - in - (* Add trees of junk data in the [durable] and [wasm] parts - of the storage. *) - let*! durable_junk_tree = gen_tree () in - let*! wasm_junk_tree = gen_tree () in - let tree = empty_tree in - let*! tree = Context.Tree.add_tree tree ["durable"] durable_junk_tree in - let*! tree = Context.Tree.add_tree tree ["wasm"] wasm_junk_tree in - (* Create an output buffers and fill it with random batches of - transactions. *) - let open Tezos_webassembly_interpreter in - let open Tezos_scoru_wasm in - let module Index_Vector = Lazy_vector.Mutable.ZVector in - let module Level_Map = Lazy_map.Mutable.LwtInt32Map in - let output = - Level_Map.create - ~produce_value:(fun _ -> - Lwt.return @@ Index_Vector.create (Z.of_int output_buffer_size)) - () - in - let*! () = - let open Sc_rollup_outbox_message_repr in - List.iter_s - (fun l -> - let*! outbox = Level_Map.get (Int32.of_int l) output in - Lwt.return - @@ List.iter - (fun i -> - let out = make_outbox_message ~nb_transactions ~rng_state in - let outbox_message = - Data_encoding.Binary.to_bytes_exn encoding out - in - Index_Vector.set (Z.of_int i) outbox_message outbox) - Misc.(0 --> (output_buffer_size - 1))) - Misc.(0 --> (nb_output_buffer_levels - 1)) - in - let output = Output_buffer.Internal_for_tests.make output in - (* Create the input buffer. *) - let input = Index_Vector.create (Z.of_int nb_inbox_messages) in - let make_input_message (message_counter : int) : Input_buffer.message = - let open Base_samplers in - let random_payload () = - uniform_bytes ~nbytes:input_payload_size rng_state - in - { - raw_level = Int32.of_int message_counter; - message_counter = Z.of_int message_counter; - payload = random_payload (); - } - in - let () = - List.iter - (fun counter -> - Index_Vector.set (Z.of_int counter) (make_input_message counter) input) - Misc.(0 --> (nb_inbox_messages - 1)) - in - (* Encode the buffers and update the state of the pvm. *) - let buffers = Eval.{input; output} in - let buffers_encoding = Wasm_pvm.durable_buffers_encoding in - let module Tree_encoding_runner = - Tezos_tree_encoding.Runner.Make (Wasm_context.Tree) in - let*! tree = - Tree_encoding_runner.encode - (Tezos_tree_encoding.option buffers_encoding) - (Some buffers) - tree - in - Lwt.return (dummy_context, output, tree) - - let select_output ~output_buffer ~nb_output_buffer_levels ~output_buffer_size - rng_state = - let open Lwt_result_syntax in - let open Base_samplers in - (* Pick a level. *) - let outbox_level = - Int32.of_int - @@ sample_in_interval - ~range:(0 -- (nb_output_buffer_levels - 1)) - rng_state - in - (* Pick a message. *) - let message_index = - Z.of_int - @@ sample_in_interval ~range:(0 -- (output_buffer_size - 1)) rng_state - in - let*! bytes_output_message = - Tezos_webassembly_interpreter.Output_buffer.get_message - output_buffer - {outbox_level; message_index} - in - let message = - Data_encoding.Binary.of_bytes_exn - Sc_rollup_outbox_message_repr.encoding - bytes_output_message - in - let*? outbox_level = - Environment.wrap_tzresult @@ Raw_level_repr.of_int32 outbox_level - in - (* Produce an output proof for the picked message, and return the proof - and its length. *) - return Sc_rollup_PVM_sig.{outbox_level; message_index; message} -end - -(** This benchmark estimates the cost of verifying an output proof for the - Wasm PVM. - The inferred cost model is [c1 + c2 * proof_length]. *) -module Sc_rollup_verify_output_proof_benchmark = struct - open Pvm_state_generator - module Full_Wasm = - Sc_rollup_wasm.V2_0_0.Make (Environment.Wasm_2_0_0.Make) (Wasm_context) - - (* Benchmark starts here. *) - - let name = ns "Sc_rollup_verify_output_proof_benchmark" - - let info = "Estimating the cost of verifying an output proof" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let tags = ["sc_rollup"] - - type config = { - nb_inbox_messages : int; - input_payload_size : int; - nb_output_buffer_levels : int; - output_buffer_size : int; - nb_transactions : int; - tree_depth : int; - tree_branching_factor : int; - } - - let config_encoding = - let open Data_encoding in - conv - (fun { - nb_inbox_messages; - input_payload_size; - nb_output_buffer_levels; - output_buffer_size; - nb_transactions; - tree_depth; - tree_branching_factor; - } -> - ( nb_inbox_messages, - input_payload_size, - nb_output_buffer_levels, - output_buffer_size, - nb_transactions, - tree_depth, - tree_branching_factor )) - (fun ( nb_inbox_messages, - input_payload_size, - nb_output_buffer_levels, - output_buffer_size, - nb_transactions, - tree_depth, - tree_branching_factor ) -> - { - nb_inbox_messages : int; - input_payload_size : int; - nb_output_buffer_levels; - output_buffer_size; - nb_transactions; - tree_depth; - tree_branching_factor; - }) - (obj7 - (req "nb_inbox_messages" int31) - (req "input_payload_size" int31) - (req "nb_output_buffer_levels" int31) - (req "output_buffer_size" int31) - (req "nb_transactions" int31) - (req "tree_depth" int31) - (req "tree_branching_factor" int31)) - - (** The actual config used to generate the more accurate model in - [sc_rollup_costs.ml] is : - [{ - nb_inbox_messages = 1000; - input_payload_size = 4096; - nb_output_buffer_levels = 10_000; - output_buffer_size = 100; - nb_transactions = 50; - tree_depth = 10; - tree_branching_factor = 4; - }] - With the config above, the benchmark takes more than an hour. The default - config is lighter and takes a few minutes. - - The table below shows benchmarking results for different tree depths and - number of outbox levels of the pvm state. The branching factor of the - generated "junk" trees in this benchmark is 4 (i.e for a depth of 10 the - generated tree contains more than 1_000_000 nodes). A tree depth of more - than 10 or a number of outbox levels of more than 10000 reaches the - memory limit of a laptop with 16Gb of memory. All proofs generated by - these benchmarks are below 10kb. - - +-----------+---------------+-------------------------+-----------------+ - | Junk tree | Number of | Inferred model | Gas cost for a | - | depth | outbox levels | | proof 10kb long | - +-----------+---------------+-------------------------+-----------------+ - | 5 | 1000 | 7.907*size + 99291.292 | 178361 | - +-----------+---------------+-------------------------+-----------------+ - | 6 | 2000 | 9.510*size + 99516.012 | 194616 | - +-----------+---------------+-------------------------+-----------------+ - | 7 | 4000 | 11.383*size + 95445.175 | 209275 | - +-----------+---------------+-------------------------+-----------------+ - | 8 | 6000 | 11.316*size + 100760.29 | 213920 | - +-----------+---------------+-------------------------+-----------------+ - | 9 | 8000 | 11.227*size + 98748.490 | 211018 | - +-----------+---------------+-------------------------+-----------------+ - | 10 | 10000 | 11.680*size + 98707.082 | 215507 | - +-----------+---------------+-------------------------+-----------------+ - - The [nb_transactions] parameter is the max number of transactions in an - outbox message, it is set at 50 because a message with 50 transactions - approches the max size of an outbox message. Hence, this allows to - benchmark for various proof lengths. The [nb_inbox_messages] parameter is - set to correspond to the max number of messages in an inbox. And the - [input_payload_size] parameter is set to the biggest possible size of an - input message. These two parameters impact the number of nodes in the pvm - state and are stored in the "input" part of the state. We add data in this - "input" part because of its proximity with the "output" part in the pvm - state. *) - let default_config = - { - nb_inbox_messages = 1000; - input_payload_size = 4096; - nb_output_buffer_levels = 10_000; - output_buffer_size = 100; - nb_transactions = 50; - tree_depth = 10; - tree_branching_factor = 4; - } - - type workload = {proof_length : int} - - let workload_encoding = - let open Data_encoding in - conv - (fun {proof_length} -> proof_length) - (fun proof_length -> {proof_length}) - (obj1 (req "proof_length" int31)) - - let workload_to_vector {proof_length} = - Sparse_vec.String.of_list [("proof_length", float_of_int proof_length)] - - let verify_output_proof_model = - Model.make - ~conv:(fun {proof_length} -> (proof_length, ())) - (Model.affine - ~name - ~intercept:(fv "verify_const") - ~coeff:(fv "verify_proof_length")) - - let models = [("verify_output_proof", verify_output_proof_model)] - - let pvm_state = ref None - - let benchmark rng_state conf () = - let nb_output_buffer_levels = conf.nb_output_buffer_levels in - let output_buffer_size = conf.output_buffer_size in - let prepare_benchmark_scenario () = - let open Lwt_result_syntax in - (* Build [pvm_state] and save it to be used for all benchmarks. The state - is large enough for each benchmark to be relatively random. *) - let*! context, output_buffer, initial_tree = - match !pvm_state with - | None -> - let res = - build_pvm_state - rng_state - ~nb_inbox_messages:conf.nb_inbox_messages - ~input_payload_size:conf.input_payload_size - ~nb_output_buffer_levels:conf.nb_output_buffer_levels - ~output_buffer_size:conf.output_buffer_size - ~nb_transactions:conf.nb_transactions - ~tree_depth:conf.tree_depth - ~tree_branching_factor:conf.tree_branching_factor - in - pvm_state := Some res ; - res - | Some pvm_state -> pvm_state - in - (* Select an output. *) - let* output = - select_output - ~output_buffer - ~nb_output_buffer_levels - ~output_buffer_size - rng_state - in - (* produce an output proof, and also return the length of its encoding.*) - let*! pf = Full_Wasm.produce_output_proof context initial_tree output in - match pf with - | Ok proof -> - let proof_length = - Data_encoding.Binary.length Full_Wasm.output_proof_encoding proof - in - return (proof, proof_length) - | Error _ -> assert false - in - - let output_proof, proof_length = - match Lwt_main.run @@ prepare_benchmark_scenario () with - | Ok (proof, len) -> (proof, len) - | Error _ -> assert false - in - let workload = {proof_length} in - - let closure () = - ignore (Lwt_main.run @@ Full_Wasm.verify_output_proof output_proof) - in - Generator.Plain {workload; closure} - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (benchmark rng_state config) -end - -(** This benchmark estimates the cost of verifying an output proof for the - Wasm PVM. - The inferred cost model is [c1 + c2 * proof_length]. *) -module Sc_rollup_deserialize_output_proof_benchmark = struct - open Pvm_state_generator - module Full_Wasm = - Sc_rollup_wasm.V2_0_0.Make (Environment.Wasm_2_0_0.Make) (Wasm_context) - - (* Benchmark starts here. *) - - let name = ns "Sc_rollup_deserialize_output_proof_benchmark" - - let info = "Estimating the cost of deserializing an output proof" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let tags = ["sc_rollup"] - - type config = { - nb_output_buffer_levels : int; - output_buffer_size : int; - nb_transactions : int; - tree_depth : int; - } - - let config_encoding = - let open Data_encoding in - conv - (fun { - nb_output_buffer_levels; - output_buffer_size; - nb_transactions; - tree_depth; - } -> - ( nb_output_buffer_levels, - output_buffer_size, - nb_transactions, - tree_depth )) - (fun ( nb_output_buffer_levels, - output_buffer_size, - nb_transactions, - tree_depth ) -> - { - nb_output_buffer_levels; - output_buffer_size; - nb_transactions; - tree_depth; - }) - (obj4 - (req "nb_output_buffer_levels" int31) - (req "output_buffer_size" int31) - (req "nb_transactions" int31) - (req "tree_depth" int31)) - - let default_config = - { - nb_output_buffer_levels = 10_000; - output_buffer_size = 100; - nb_transactions = 50; - tree_depth = 10; - } - - type workload = {proof_length : int} - - let workload_encoding = - let open Data_encoding in - conv - (fun {proof_length} -> proof_length) - (fun proof_length -> {proof_length}) - (obj1 (req "proof_length" int31)) - - let workload_to_vector {proof_length} = - Sparse_vec.String.of_list [("proof_length", float_of_int proof_length)] - - let verify_output_proof_model = - Model.make - ~conv:(fun {proof_length} -> (proof_length, ())) - (Model.affine - ~name - ~intercept:(fv "deserialize_const") - ~coeff:(fv "deserialize_proof_length")) - - let models = [("deserialize_output_proof", verify_output_proof_model)] - - let pvm_state = ref None - - let benchmark rng_state conf () = - let prepared_benchmark_scenario = - let nb_output_buffer_levels = conf.nb_output_buffer_levels in - let output_buffer_size = conf.output_buffer_size in - let tree_depth = conf.tree_depth in - let open Lwt_result_syntax in - (* Build [pvm_state] and save it to be used for all benchmarks. The state - is large enough for each benchmark to be relatively random. *) - let*! context, output_buffer, initial_tree = - match !pvm_state with - | Some pvm_state -> pvm_state - | None -> - let res = - build_pvm_state - rng_state - ~nb_inbox_messages:0 - ~input_payload_size:0 - ~nb_output_buffer_levels - ~output_buffer_size - ~nb_transactions:conf.nb_transactions - ~tree_depth - ~tree_branching_factor:2 - in - pvm_state := Some res ; - res - in - (* Select an output. *) - let* output = - select_output - ~output_buffer - ~nb_output_buffer_levels - ~output_buffer_size - rng_state - in - (* Produce an output proof, and return its encoding and the length of the - encoding. *) - let*! pf = Full_Wasm.produce_output_proof context initial_tree output in - match pf with - | Ok proof -> - let encoded_proof = - Data_encoding.Binary.to_bytes_exn - Full_Wasm.output_proof_encoding - proof - in - let proof_length = Bytes.length encoded_proof in - return (encoded_proof, proof_length) - | Error _ -> assert false - in - - let encoded_proof, proof_length = - prepared_benchmark_scenario |> Lwt_main.run - |> WithExceptions.Result.get_ok ~loc:__LOC__ - in - let workload = {proof_length} in - - let closure () = - ignore - (Data_encoding.Binary.of_bytes_exn - Full_Wasm.output_proof_encoding - encoded_proof) - in - Generator.Plain {workload; closure} - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (benchmark rng_state config) -end - -let () = - Registration_helpers.register (module Sc_rollup_verify_output_proof_benchmark) - -let () = - Registration_helpers.register - (module Sc_rollup_deserialize_output_proof_benchmark) diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/script_repr_benchmarks.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/script_repr_benchmarks.ml deleted file mode 100644 index b5629ff0c0e011c61261a2a09c781ede706506ef..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/script_repr_benchmarks.ml +++ /dev/null @@ -1,144 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 ns = Namespace.make Registration_helpers.ns "script_repr" - -let fv s = Free_variable.of_namespace (ns s) - -(** {2 [Script_repr] benchmarks} *) - -module Script_repr_shared_config = struct - type config = unit - - let config_encoding = Data_encoding.unit - - let default_config = () - - type workload = {micheline_nodes : int} - - let workload_encoding = - let open Data_encoding in - conv - (fun {micheline_nodes} -> micheline_nodes) - (fun micheline_nodes -> {micheline_nodes}) - (obj1 (req "micheline_nodes" int31)) - - let tags = [Tags.translator] - - let workload_to_vector {micheline_nodes} = - Sparse_vec.String.of_list [("nodes", float_of_int micheline_nodes)] -end - -module Sampler = Micheline_sampler.Make (struct - type prim = Michelson_v1_primitives.prim - - (* The runtime of the functions in [Script_repr] do not depend on the primitives. *) - let sample_prim : Michelson_v1_primitives.prim Base_samplers.sampler = - fun _rng_state -> I_ADD - - let sample_annots : string list Base_samplers.sampler = fun _rng_state -> [] - - let sample_string = Base_samplers.uniform_string ~nbytes:4 - - let sample_bytes = Base_samplers.uniform_bytes ~nbytes:4 - - let sample_z = Base_samplers.int ~size:{min = 1; max = 8} - - let width_function = Micheline_sampler.reasonable_width_function -end) - -module Micheline_nodes_benchmark : Benchmark.S = struct - include Script_repr_shared_config - - let name = ns "MICHELINE_NODES" - - let info = - "Benchmarking the time it takes to compute the number of nodes of a \ - Micheline term" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let size_based_model = - Model.make - ~conv:(function {micheline_nodes} -> (micheline_nodes, ())) - (Model.affine - ~name - ~intercept:(fv (Format.asprintf "%s_const" (Namespace.basename name))) - ~coeff: - (fv - (Format.asprintf "%s_ns_per_node_coeff" (Namespace.basename name)))) - - let models = [("size_translator_model", size_based_model)] - - let micheline_nodes_benchmark node = - let nodes = Script_repr.micheline_nodes node in - let workload = {micheline_nodes = nodes} in - let closure () = ignore (Script_repr.micheline_nodes node) in - Generator.Plain {workload; closure} - - let make_bench rng_state _cfg () = - let term = Sampler.sample rng_state in - micheline_nodes_benchmark term - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (make_bench rng_state config) -end - -let () = Registration_helpers.register (module Micheline_nodes_benchmark) - -module Script_repr_strip_annotations : Benchmark.S = struct - include Script_repr_shared_config - - let name = ns "strip_annotations" - - let info = "Benchmarking Script_repr.strip_annotations" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let strip_annotations_model = - Model.( - make - ~conv:(fun {micheline_nodes} -> (micheline_nodes, ())) - (linear ~name ~coeff:(fv "nodes"))) - - let models = [("strip_annotations_model", strip_annotations_model)] - - let create_benchmark rng_state () = - let node = Sampler.sample rng_state in - let closure () = ignore @@ Script_repr.strip_annotations node in - let micheline_nodes = Script_repr.micheline_nodes node in - Generator.Plain {workload = {micheline_nodes}; closure} - - let create_benchmarks ~rng_state ~bench_num _cfg = - List.repeat bench_num (create_benchmark rng_state) -end - -let () = Registration_helpers.register (module Script_repr_strip_annotations) diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml deleted file mode 100644 index ac45fd47f5728ae0199d85343c6ab6e0abf5bc3b..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml +++ /dev/null @@ -1,312 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 ns = Namespace.make Registration_helpers.ns "script_typed_ir_size" - -let fv s = Free_variable.of_namespace (ns s) - -(** {2 [Script_typed_ir_size]-related benchmarks} *) - -(** Benchmarking {!Script_typed_ir_size.value_size}. *) - -let model_name = "ir_size_model" - -let strict = Script_ir_translator_config.make ~legacy:false () - -module Size_benchmarks_shared_config = struct - include Translator_benchmarks.Config - - type workload = {size : int} - - let workload_encoding : workload Data_encoding.t = - let open Data_encoding in - def "size_encoding" - @@ conv (fun {size} -> size) (fun size -> {size}) (obj1 (req "size" int31)) - - let workload_to_vector {size} = - Sparse_vec.String.of_list [("size", float_of_int size)] - - let tags = [Tags.translator] - - let size_based_model name = - let intercept_variable = fv (Format.asprintf "%s_const" name) in - let coeff_variable = fv (Format.asprintf "%s_size_coeff" name) in - Model.make - ~conv:(function {size} -> (size, ())) - (Model.affine - ~name:(ns "size_based_model") - ~intercept:intercept_variable - ~coeff:coeff_variable) -end - -module Value_size_benchmark : sig - include Tezos_benchmark.Benchmark.S - - val size_based_model : string -> workload Model.t -end = struct - include Size_benchmarks_shared_config - - let name = ns "VALUE_SIZE" - - let models = [(model_name, size_based_model (Namespace.basename name))] - - let info = "Benchmarking Script_typed_ir_size.value_size" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let value_size_benchmark rng_state (node : Protocol.Script_repr.expr) - (michelson_type : Script_repr.expr) = - (* FIXME: cleanup and factorize this code between translator benches and these ones. *) - let open Translator_benchmarks in - Lwt_main.run - ( Execution_context.make ~rng_state >>=? fun (ctxt, _) -> - let ex_ty = Type_helpers.michelson_type_to_ex_ty michelson_type ctxt in - match ex_ty with - | Script_typed_ir.Ex_ty ty -> ( - match - Lwt_main.run - (Script_ir_translator.parse_data - ctxt - ~elab_conf:strict - ~allow_forged:false - ty - (Micheline.root node)) - with - | Error _ | (exception _) -> - bad_data name node michelson_type In_protocol - | Ok (value, _) -> - let open Script_typed_ir_size in - let open Cache_memory_helpers in - let size = Nodes.(to_int (fst (value_size ty value))) in - let workload = {size} in - let closure () = ignore (value_size ty value) in - return (Generator.Plain {workload; closure})) ) - |> function - | Ok closure -> closure - | Error errs -> global_error name errs - - let make_bench rng_state cfg () = - let Michelson_mcmc_samplers.{term; typ} = - Michelson_generation.make_data_sampler rng_state cfg.generator_config - in - value_size_benchmark rng_state term typ - - let create_benchmarks ~rng_state ~bench_num config = - match config.michelson_terms_file with - | Some file -> - Format.eprintf "Loading terms from %s@." file ; - let terms = Michelson_mcmc_samplers.load ~filename:file in - List.filter_map - (function - | Michelson_mcmc_samplers.Data {term; typ} -> - Some (fun () -> value_size_benchmark rng_state term typ) - | _ -> None) - terms - | None -> - Format.eprintf "No michelson_terms_file given, generating on-the-fly@." ; - List.repeat bench_num (make_bench rng_state config) -end - -let () = Registration_helpers.register (module Value_size_benchmark) - -(** Benchmarking {!Script_typed_ir_size.ty_size}. *) - -module Type_size_benchmark : Tezos_benchmark.Benchmark.S = struct - include Size_benchmarks_shared_config - - type config = unit - - let config_encoding = Data_encoding.unit - - let default_config = () - - let name = ns "TYPE_SIZE" - - let info = - "Benchmarking the time it takes to compute Script_typed_ir_size.ty_size" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let models = [(model_name, size_based_model (Namespace.basename name))] - - let type_size_benchmark (Script_typed_ir.Ex_ty ty) = - let open Script_typed_ir_size.Internal_for_tests in - let open Cache_memory_helpers in - let size = Nodes.(to_int (fst (ty_size ty))) in - let workload = {size} in - let closure () = ignore (ty_size ty) in - Generator.Plain {workload; closure} - - let make_bench rng_state _cfg () = - (* The [size] here is a parameter to the random sampler and does not - match the [size] returned by [type_size]. *) - let size = - Base_samplers.sample_in_interval ~range:{min = 1; max = 1000} rng_state - in - let ex_ty = - Michelson_generation.Samplers.Random_type.m_type ~size rng_state - in - type_size_benchmark ex_ty - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (make_bench rng_state config) -end - -let () = Registration_helpers.register (module Type_size_benchmark) - -(** Benchmarking {!Script_typed_ir_size.kinstr_size}. *) - -module Kinstr_size_benchmark : sig - include Tezos_benchmark.Benchmark.S - - val size_based_model : string -> workload Model.t -end = struct - include Size_benchmarks_shared_config - - let name = ns "KINSTR_SIZE" - - let models = [(model_name, size_based_model (Namespace.basename name))] - - let info = "Benchmarking Script_typed_ir_size.kinstr_size" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let kinstr_size_benchmark rng_state (expr : Protocol.Script_repr.expr) - (stack : Script_repr.expr list) = - (* FIXME: cleanup and factorize this code between translator benches and these ones. *) - let open Translator_benchmarks in - Lwt_main.run - ( Execution_context.make ~rng_state >>=? fun (ctxt, _) -> - let ex_stack_ty = - Type_helpers.michelson_type_list_to_ex_stack_ty stack ctxt - in - let (Script_ir_translator.Ex_stack_ty bef) = ex_stack_ty in - let node = Micheline.root expr in - match - Lwt_main.run - (Script_ir_translator.parse_instr - Script_tc_context.data - ctxt - ~elab_conf:strict - node - bef) - with - | Error _ | (exception _) -> bad_code name expr stack In_protocol - | Ok (Failed {descr}, _) -> - let kdescr = Script_ir_translator.close_descr (descr Bot_t) in - let kinstr = kdescr.kinstr in - let open Script_typed_ir_size.Internal_for_tests in - let workload = - let open Cache_memory_helpers in - {size = Nodes.to_int @@ fst @@ kinstr_size kinstr} - in - let closure () = ignore (kinstr_size kinstr) in - return (Generator.Plain {workload; closure}) - | Ok (Typed descr, _) -> - let kdescr = Script_ir_translator.close_descr descr in - let kinstr = kdescr.kinstr in - let open Script_typed_ir_size.Internal_for_tests in - let workload = - let open Cache_memory_helpers in - {size = Nodes.to_int @@ fst @@ kinstr_size kinstr} - in - let closure () = ignore (kinstr_size kinstr) in - return (Generator.Plain {workload; closure}) ) - |> function - | Ok closure -> closure - | Error errs -> global_error name errs - - let make_bench rng_state cfg () = - let Michelson_mcmc_samplers.{term; bef; aft = _} = - Michelson_generation.make_code_sampler rng_state cfg.generator_config - in - kinstr_size_benchmark rng_state term bef - - let create_benchmarks ~rng_state ~bench_num config = - match config.michelson_terms_file with - | Some file -> - Format.eprintf "Loading terms from %s@." file ; - let terms = Michelson_mcmc_samplers.load ~filename:file in - List.filter_map - (function - | Michelson_mcmc_samplers.Code {term; bef; aft = _} -> - Some (fun () -> kinstr_size_benchmark rng_state term bef) - | _ -> None) - terms - | None -> - Format.eprintf "No michelson_terms_file given, generating on-the-fly@." ; - List.repeat bench_num (make_bench rng_state config) -end - -let () = Registration_helpers.register (module Kinstr_size_benchmark) - -module Node_size_benchmark : Benchmark.S = struct - include Script_repr_benchmarks.Script_repr_shared_config - - let name = ns "NODE_SIZE" - - let info = - "Benchmarking the time it takes to compute Script_typed_ir_size.node_size" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let size_based_model = - Model.make - ~conv:(function {micheline_nodes} -> (micheline_nodes, ())) - (Model.affine - ~name - ~intercept:(fv (Format.asprintf "%s_const" (Namespace.basename name))) - ~coeff: - (fv - (Format.asprintf "%s_ns_per_node_coeff" (Namespace.basename name)))) - - let models = [(model_name, size_based_model)] - - let micheline_nodes_benchmark node = - let open Cache_memory_helpers in - let nodes = Nodes.to_int @@ fst @@ node_size node in - let workload = {micheline_nodes = nodes} in - let closure () = ignore (Script_typed_ir_size.node_size node) in - Generator.Plain {workload; closure} - - let make_bench rng_state _cfg () = - let term = Script_repr_benchmarks.Sampler.sample rng_state in - micheline_nodes_benchmark term - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (make_bench rng_state config) -end - -let () = Registration_helpers.register (module Node_size_benchmark) diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/skip_list_benchmarks.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/skip_list_benchmarks.ml deleted file mode 100644 index 0fa417a123f8128415fff876b184ee692fcc121e..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/skip_list_benchmarks.ml +++ /dev/null @@ -1,181 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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 module provides benchmarks for skip list operations for basis = 4. *) - -open Protocol -open Benchmarks_proto - -module Skip_list = Skip_list_repr.Make (struct - (** The benchmarks must be run again if [basis] is changed. *) - let basis = 4 -end) - -let ns = Namespace.make Registration.ns "skip_list" - -let fv s = Free_variable.of_namespace (ns s) - -(** Benchmark for the [Skip_list_repr.next] function. It is used for estimating - the parameters for [Skip_list_cost_model.model_next]. *) -module Next : Benchmark.S = struct - let generated_code_destination = Some "skip_list" - - include Skip_list - - let name = ns "next" - - let info = "Benchmark for Skip_list_repr.next" - - let tags = ["skip_list"] - - type config = {max_items : int} - - let default_config = {max_items = 10000} - - let module_filename = __FILE__ - - let config_encoding = - let open Data_encoding in - conv (fun {max_items} -> max_items) (fun max_items -> {max_items}) int31 - - type workload = int - - let workload_encoding = Data_encoding.int31 - - let workload_to_vector len = - Sparse_vec.String.of_list [("len", float_of_int @@ len)] - - let model = Model.make ~conv:(fun x -> (x, ())) Model.logn - - let create_skip_list_of_len len = - let rec go n cell = - if n = 0 then cell - else go (pred n) @@ next ~prev_cell:cell ~prev_cell_ptr:() () - in - go len (genesis ()) - - let create_benchmark ~rng_state ({max_items} : config) = - let workload = - (* Since the model we want to infer is logarithmic in - the length, we sample the logarithm of the length - (and not the length itself) uniformly in an interval. *) - let logmax = log (float_of_int max_items) in - let loglen = - Base_samplers.sample_float_in_interval ~min:0. ~max:logmax rng_state - in - int_of_float (exp loglen) - in - let prev_cell = create_skip_list_of_len workload in - let prev_cell_ptr = () in - let closure () = ignore (next ~prev_cell ~prev_cell_ptr ()) in - Generator.Plain {workload; closure} -end - -(** Benchmark for the [Sc_rollup_inbox_repr.hash_skip_list_cell] - function. It is used for estimating the parameters for - [Skip_list_cost_model.model_hash_cell]. The model estimates hashing - a skip_list cell content and all its back pointers. *) -module Hash_cell : Benchmark.S = struct - let generated_code_destination = Some "skip_list" - - let name = ns "hash_cell" - - let info = "Estimating the costs of hashing a skip list cell" - - let tags = ["skip_list"] - - let module_filename = __FILE__ - - include Skip_list - module Hash = Sc_rollup_inbox_repr.Hash - - let hash merkelized = - let payload_hash = Skip_list.content merkelized in - let back_pointers_hashes = Skip_list.back_pointers merkelized in - Hash.to_bytes payload_hash :: List.map Hash.to_bytes back_pointers_hashes - |> Hash.hash_bytes - - type config = {max_index : int} - - let config_encoding = - let open Data_encoding in - conv - (fun {max_index} -> max_index) - (fun max_index -> {max_index}) - (obj1 (req "max_index" int31)) - - let default_config = {max_index = 65536} - - type workload = {nb_backpointers : int} - - let workload_encoding = - let open Data_encoding in - conv - (fun {nb_backpointers} -> nb_backpointers) - (fun nb_backpointers -> {nb_backpointers}) - (obj1 (req "max_nb_backpointers" int31)) - - let workload_to_vector {nb_backpointers} = - Sparse_vec.String.of_list - [("nb_backpointers", float_of_int nb_backpointers)] - - let model = - Model.make - ~conv:(fun {nb_backpointers} -> (nb_backpointers, ())) - Model.affine - - let create_benchmark ~rng_state conf = - (* Since the model we want to infer is logarithmic in - the length, we sample the logarithm of the length - (and not the length itself) uniformly in an interval. *) - let skip_list_loglen = - let logmax = log (float_of_int conf.max_index) in - Base_samplers.sample_float_in_interval ~min:0. ~max:logmax rng_state - in - let skip_list_len = int_of_float (exp skip_list_loglen) in - let random_hash () = - Hash.hash_string - [Base_samplers.string ~size:{min = 32; max = 32} rng_state] - in - let cell = - let rec repeat n cell = - if n = 0 then cell - else - let prev_cell = cell and prev_cell_ptr = hash cell in - repeat - (n - 1) - (Skip_list.next ~prev_cell ~prev_cell_ptr (random_hash ())) - in - repeat skip_list_len (Skip_list.genesis (random_hash ())) - in - let nb_backpointers = List.length (Skip_list.back_pointers cell) in - let workload = {nb_backpointers} in - let closure () = ignore (hash cell) in - Generator.Plain {workload; closure} -end - -let () = Registration.register (module Next) - -let () = Registration.register (module Hash_cell) diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/storage_benchmarks.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/storage_benchmarks.ml deleted file mode 100644 index bfb68c3249c8adc3c4785d1067a73b2ba3a51ded..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/storage_benchmarks.ml +++ /dev/null @@ -1,251 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** {2 [Storage_functors] benchmarks} - - This module registers a benchmark [List_key_values_benchmark]. Its result - is used to fill in the corresponding value, [list_key_values_step] - defined in [Storage_costs]. - *) - -open Tezos_benchmark -open Storage_functors -open Protocol - -let ns = Namespace.make Registration_helpers.ns "storage" - -let fv s = Free_variable.of_namespace (ns s) - -(** Creates a dummy raw-context value. *) -let default_raw_context () = - let open Lwt_result_syntax in - let initial_account = Account.new_account () in - let bootstrap_account = - Account.make_bootstrap_account - ~balance:(Alpha_context.Tez.of_mutez_exn 100_000_000_000L) - initial_account - in - Block.prepare_initial_context_params () >>=? fun (constants, _, _) -> - let parameters = - Default_parameters.parameters_of_constants - ~bootstrap_accounts:[bootstrap_account] - ~commitments:[] - constants - in - let json = Default_parameters.json_of_parameters parameters in - let proto_params = - Data_encoding.Binary.to_bytes_exn Data_encoding.json json - in - let protocol_param_key = ["protocol_parameters"] in - let*! context = - Tezos_protocol_environment.Context.( - let empty = Tezos_protocol_environment.Memory_context.empty in - let*! ctxt = add empty ["version"] (Bytes.of_string "genesis") in - add ctxt protocol_param_key proto_params) - in - let typecheck ctxt script_repr = return ((script_repr, None), ctxt) in - let*! e = - Init_storage.prepare_first_block - Chain_id.zero - context - ~level:0l - ~timestamp:(Time.Protocol.of_seconds 1643125688L) - ~predecessor:Block_hash.zero - ~typecheck - in - Lwt.return @@ Environment.wrap_tzresult e - -module String = struct - type t = string - - let encoding = Data_encoding.string -end - -module Int32 = struct - type t = int32 - - let encoding = Data_encoding.int32 - - module 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 = Environment.RPC_arg.int; - encoding = Data_encoding.int31; - compare = Compare.Int.compare; - } - end -end - -module Root_raw_context = - Make_subcontext (Registered) (Raw_context) - (struct - let name = ["benchmark_storage_functors"] - end) - -module Indexed_context = - Make_indexed_subcontext - (Make_subcontext (Registered) (Root_raw_context) - (struct - let name = ["index"] - end)) - (Int32.Index) - -module Table = - Make_indexed_carbonated_data_storage - (Make_subcontext (Registered) (Raw_context) - (struct - let name = ["table_for_list_key_values"] - end)) - (Int32.Index) - (struct - type t = string - - let encoding = Data_encoding.string - end) - -module List_key_values_benchmark_boilerplate = struct - type config = {max_size : int} - - let name = ns "List_key_values" - - let info = "List key values" - - let config_encoding = - let open Data_encoding in - conv - (fun {max_size} -> max_size) - (fun max_size -> {max_size}) - (obj1 (req "max_size" int31)) - - let default_config = {max_size = 100_000} - - type workload = {size : int} - - let tags = ["big_map"] - - let workload_encoding = - let open Data_encoding in - conv (fun {size} -> size) (fun size -> {size}) (obj1 (req "size" int31)) - - let workload_to_vector {size} = - Sparse_vec.String.of_list [("size", float_of_int size)] - - let models = - [ - ( "list_key_values", - Model.make - ~conv:(fun {size} -> (size, ())) - (Model.affine - ~name - ~intercept:(fv "list_key_values_intercept") - ~coeff:(fv "list_key_values_step")) ); - ] -end - -module List_key_values_benchmark = struct - include List_key_values_benchmark_boilerplate - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let benchmark rng_state {max_size} () = - let wrap m = m >|= Environment.wrap_tzresult in - let size = - Base_samplers.sample_in_interval - ~range:{min = 1; max = max_size} - rng_state - in - let ctxt = - let fill_table = - let open Lwt_result_syntax in - let* ctxt = default_raw_context () in - List.fold_left_es - (fun ctxt (key, value) -> - let* ctxt, _, _ = wrap @@ Table.add ctxt key value in - return ctxt) - ctxt - (Stdlib.List.init size (fun key -> (key, string_of_int key))) - in - match Lwt_main.run fill_table with Ok ctxt -> ctxt | _ -> assert false - in - let workload = {size} in - let closure () = - (* We pass length [0] so that none of the steps of the fold over the - key-value pairs load any values. That is isolate the cost of iterating - over the tree without loading values. *) - Table.list_key_values ~length:0 ctxt |> Lwt_main.run |> ignore - in - Generator.Plain {workload; closure} - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (benchmark rng_state config) -end - -module List_key_values_benchmark_intercept = struct - include List_key_values_benchmark_boilerplate - - let name = Namespace.make ns (Namespace.basename name) "intercept" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let benchmark _rng_state _config () = - let ctxt = - match Lwt_main.run (default_raw_context ()) with - | Ok ctxt -> ctxt - | _ -> assert false - in - let workload = {size = 0} in - let closure () = - (* We pass length [0] so that none of the steps of the fold over the - key-value pairs load any values. That is isolate the cost of iterating - over the tree without loading values. *) - Table.list_key_values ~length:0 ctxt |> Lwt_main.run |> ignore - in - Generator.Plain {workload; closure} - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (benchmark rng_state config) -end - -let () = Registration_helpers.register (module List_key_values_benchmark) - -let () = - Registration_helpers.register (module List_key_values_benchmark_intercept) diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/tags.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/tags.ml deleted file mode 100644 index e5aca30e639aceed637044a370b145e8f180011e..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/tags.ml +++ /dev/null @@ -1,35 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* Copyright (c) 2023 Marigold *) -(* *) -(* 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 interpreter = "interpreter" - -let translator = "translator" - -let encoding = "encoding" - -let cache = "cache" - -let common = Protocol.name diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/ticket_benchmarks.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/ticket_benchmarks.ml deleted file mode 100644 index 4b616ec76bb82529fac3cf94eb1c66a1478bd3f0..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/ticket_benchmarks.ml +++ /dev/null @@ -1,311 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Protocol -open Alpha_context - -let ns = Namespace.make Registration_helpers.ns "tickets" - -let fv s = Free_variable.of_namespace (ns s) - -module Ticket_type_shared = struct - type config = {max_size : int} - - let default_config = {max_size = Constants_repr.michelson_maximum_type_size} - - let config_encoding = - let open Data_encoding in - conv - (fun {max_size} -> max_size) - (fun max_size -> {max_size}) - (obj1 (req "max_size" int31)) - - type workload = {nodes : int} - - let workload_encoding = - let open Data_encoding in - conv - (function {nodes} -> nodes) - (fun nodes -> {nodes}) - (obj1 (req "nodes" int31)) - - let workload_to_vector {nodes} = - Sparse_vec.String.of_list [("nodes", float_of_int nodes)] - - let tags = ["tickets"] -end - -exception - Ticket_benchmark_error of { - benchmark_name : Namespace.t; - trace : Tezos_base.TzPervasives.tztrace; - } - -(** A benchmark for {!Ticket_costs.Constants.cost_compare_ticket_hash}. *) -module Compare_ticket_hash_benchmark : Benchmark.S = struct - type config = unit - - let config_encoding = Data_encoding.unit - - let default_config = () - - type workload = unit - - let tags = ["tickets"] - - let workload_encoding = Data_encoding.unit - - let workload_to_vector () = Sparse_vec.String.of_list [] - - let name = ns "COMPARE_TICKET_HASH" - - let info = "Compare cost for Ticket_hash" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let compare_model = - Model.make - ~conv:(fun () -> ()) - (Model.unknown_const1 ~name ~const:(fv "compare_ticket_hash")) - - let models = [("compare_tickets", compare_model)] - - let benchmark rng_state _conf () = - let bytes = Base_samplers.bytes rng_state ~size:{min = 1; max = 64} in - let hash = - Ticket_hash.of_script_expr_hash @@ Script_expr_hash.hash_bytes [bytes] - in - let hash2 = - Ticket_hash.of_script_expr_hash @@ Script_expr_hash.hash_bytes [bytes] - in - let workload = () in - let closure () = ignore (Ticket_hash.compare hash hash2) in - Generator.Plain {workload; closure} - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (benchmark rng_state config) -end - -let () = Registration_helpers.register (module Compare_ticket_hash_benchmark) - -(** A benchmark for {!Ticket_costs.Constants.cost_compare_key_contract}. - - In this benchmark we only compare originated contracts; we never use - implicit contracts. This is justified partly by the fact that - currently the carbonated maps only use originated contracts as keys. - In addition, while developing this benchmark the implicit contracts were - also tested and gave almost identical timings. *) -module Compare_key_contract_benchmark : Benchmark.S = struct - type config = unit - - let config_encoding = Data_encoding.unit - - let default_config = () - - type workload = unit - - let workload_encoding = Data_encoding.unit - - let workload_to_vector () = Sparse_vec.String.of_list [] - - let tags = ["tickets"] - - let name = ns "COMPARE_CONTRACT" - - let info = "Compare cost for Contracts" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let compare_model = - Model.make - ~conv:(fun () -> ()) - (Model.unknown_const1 ~name ~const:(fv "compare_contract")) - - let models = [("compare_tickets", compare_model)] - - let benchmark rng_state _conf () = - let bytes = Base_samplers.bytes rng_state ~size:{min = 32; max = 64} in - let branch = Block_hash.hash_bytes [bytes] in - let op_hash = Operation.hash_raw {shell = {branch}; proto = bytes} in - let nonce = Origination_nonce.Internal_for_tests.initial op_hash in - let contract = Contract.Internal_for_tests.originated_contract nonce in - let contract2 = Contract.Internal_for_tests.originated_contract nonce in - let workload = () in - let closure () = ignore (Contract.compare contract contract2) in - Generator.Plain {workload; closure} - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (benchmark rng_state config) -end - -let () = Registration_helpers.register (module Compare_key_contract_benchmark) - -(* A simple ticket type for use in the benchmarks. *) -let ticket_ty = - let open Script_typed_ir in - WithExceptions.Result.get_ok ~loc:__LOC__ (ticket_t (-1) int_t) - -(* A dummy type generator, sampling linear terms of a given size. - The generator always returns types of the shape: - - [pair int_or_ticket (pair int_or_ticket (pair int_or_ticket ...))] - - This is a worst case type for [type_has_tickets], though nested - ors, nested maps or nested lists would be just as bad. *) -let rec dummy_type_generator ~rng_state size = - let open Script_typed_ir in - let ticket_or_int = - if Base_samplers.uniform_bool rng_state then Ex_ty ticket_ty - else Ex_ty int_t - in - if size <= 1 then ticket_or_int - else - match (ticket_or_int, dummy_type_generator ~rng_state (size - 3)) with - | Ex_ty l, Ex_ty r -> ( - match pair_t (-1) l r with - | Error _ -> assert false - | Ok (Ty_ex_c t) -> Ex_ty t) - -(** A benchmark for {!Ticket_costs.Constants.cost_has_tickets_of_ty}. *) -module Has_tickets_type_benchmark : Benchmark.S = struct - include Ticket_type_shared - - let name = ns "TYPE_HAS_TICKETS" - - let info = "Benchmarking type_has_tickets" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let make_bench_helper rng_state config () = - let open Result_syntax in - let* ctxt, _ = Lwt_main.run (Execution_context.make ~rng_state) in - let ctxt = Gas_helpers.set_limit ctxt in - let size = Random.State.int rng_state config.max_size in - let (Ex_ty ty) = dummy_type_generator ~rng_state size in - let nodes = - let size = Script_typed_ir.ty_size ty in - Saturation_repr.to_int @@ Script_typed_ir.Type_size.to_int size - in - let workload = {nodes} in - let closure () = ignore (Ticket_scanner.type_has_tickets ctxt ty) in - ok (Generator.Plain {workload; closure}) - - let make_bench rng_state config () = - match make_bench_helper rng_state config () with - | Ok closure -> closure - | Error trace -> - raise (Ticket_benchmark_error {benchmark_name = name; trace}) - - let size_model = - Model.make - ~conv:(function {nodes} -> (nodes, ())) - (Model.affine - ~name - ~intercept:(fv (Format.asprintf "%s_const" (Namespace.basename name))) - ~coeff:(fv (Format.asprintf "%s_coeff" (Namespace.basename name)))) - - let models = [("size_has_tickets_model", size_model)] - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (make_bench rng_state config) -end - -let () = Registration_helpers.register (module Has_tickets_type_benchmark) - -let ticket_sampler rng_state = - let seed = Base_samplers.uniform_bytes ~nbytes:32 rng_state in - let pkh, _, _ = Signature.generate_key ~algo:Signature.Ed25519 ~seed () in - let ticketer = Alpha_context.Contract.Implicit pkh in - Script_typed_ir. - {ticketer; contents = Script_int.zero; amount = Ticket_amount.one} - -(** A benchmark for {!Ticket_costs.Constants.cost_collect_tickets_step}. *) -module Collect_tickets_benchmark : Benchmark.S = struct - include Ticket_type_shared - - let name = ns "COLLECT_TICKETS_STEP" - - let info = "Benchmarking tickets_of_value" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let make_bench_helper rng_state config () = - let open Script_typed_ir in - let open Result_syntax in - let* ctxt, _ = Lwt_main.run (Execution_context.make ~rng_state) in - let ctxt = Gas_helpers.set_limit ctxt in - let ty = - match list_t (-1) ticket_ty with Error _ -> assert false | Ok t -> t - in - let _, elements = - Structure_samplers.list - ~range:{min = 0; max = config.max_size} - ~sampler:ticket_sampler - rng_state - in - let boxed_ticket_list = Script_list.of_list elements in - Environment.wrap_tzresult - @@ let* has_tickets, ctxt = Ticket_scanner.type_has_tickets ctxt ty in - let workload = {nodes = Script_list.length boxed_ticket_list} in - let closure () = - ignore - (Lwt_main.run - (Ticket_scanner.tickets_of_value - ctxt - ~include_lazy:true - has_tickets - boxed_ticket_list)) - in - ok (Generator.Plain {workload; closure}) - - let make_bench rng_state config () = - match make_bench_helper rng_state config () with - | Ok closure -> closure - | Error trace -> - raise (Ticket_benchmark_error {benchmark_name = name; trace}) - - let size_model = - Model.make - ~conv:(function {nodes} -> (nodes, ())) - (Model.affine - ~name - ~intercept:(fv (Format.asprintf "%s_const" (Namespace.basename name))) - ~coeff:(fv (Format.asprintf "%s_coeff" (Namespace.basename name)))) - - let models = [("size_collect_tickets_step_model", size_model)] - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (make_bench rng_state config) -end - -let () = Registration_helpers.register (module Collect_tickets_benchmark) diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/translator_benchmarks.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/translator_benchmarks.ml deleted file mode 100644 index d58d5470139a4e1773f07ecc62103a544663247c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/translator_benchmarks.ml +++ /dev/null @@ -1,831 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021-2022 Nomadic Labs, *) -(* *) -(* 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 - -module Encodings = -Tezos_shell_benchmarks.Encoding_benchmarks_helpers.Make (struct - let file = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" -end) - -module Size = Gas_input_size - -let ns = Translator_model.ns - -let fv = Translator_model.fv - -(** {2 [Script_ir_translator] benchmarks} *) - -module Config = struct - type config = { - generator_config : Michelson_generation.generator_config; - michelson_terms_file : string option; - } - - let default_config = - { - generator_config = Michelson_generation.default_generator_config; - michelson_terms_file = None; - } - - let config_encoding = - let open Data_encoding in - conv - (fun {generator_config; michelson_terms_file} -> - (generator_config, michelson_terms_file)) - (fun (generator_config, michelson_terms_file) -> - {generator_config; michelson_terms_file}) - (obj2 - (req "generator_config" Michelson_generation.generator_config_encoding) - (req "michelson_terms_file" (option string))) -end - -module Default_boilerplate = struct - type workload = Translator_workload.t - - let workload_encoding = Translator_workload.encoding - - let workload_to_vector = Translator_workload.workload_to_sparse_vec - - let tags = [Tags.translator] - - let make_models t_kind code_or_data = - [ - ( "gas_translator_model", - Translator_model.gas_based_model t_kind code_or_data ); - ( "size_translator_model", - Translator_model.size_based_model t_kind code_or_data ); - ] -end - -(* ----------------------------------------------------------------------- *) -(* Error handling *) - -type phase = Workload_production | In_protocol | Global - -type error_kind = - | Global_error of { - benchmark_name : Namespace.t; - workload : Tezos_base.TzPervasives.tztrace; - } - | Bad_data of { - benchmark_name : Namespace.t; - micheline : Alpha_context.Script.expr; - expected_type : Alpha_context.Script.expr; - phase : phase; - } - | Bad_code of { - benchmark_name : Namespace.t; - micheline : Alpha_context.Script.expr; - expected_stack_type : Alpha_context.Script.expr list; - phase : phase; - } - -let pp_phase fmtr (phase : phase) = - match phase with - | Workload_production -> Format.fprintf fmtr "workload production" - | In_protocol -> Format.fprintf fmtr "in protocol" - | Global -> Format.fprintf fmtr "global" - -let report_michelson_errors fmtr errs = - Michelson_v1_error_reporter.report_errors - ~details:true - ~show_source:true - fmtr - errs - -let make_printable node = - Micheline_printer.printable Michelson_v1_primitives.string_of_prim node - -let pp_error_kind fmtr (error_kind : error_kind) = - match error_kind with - | Global_error {benchmark_name; workload} -> - Format.open_vbox 1 ; - Format.fprintf fmtr "Global error:@," ; - Format.fprintf fmtr "benchmark = %a@," Namespace.pp benchmark_name ; - Format.fprintf fmtr "workload:@," ; - report_michelson_errors fmtr workload ; - Format.close_box () - | Bad_data {benchmark_name; micheline; expected_type; phase} -> - Format.open_vbox 1 ; - Format.fprintf fmtr "Bad data:@," ; - Format.fprintf fmtr "benchmark = %a@," Namespace.pp benchmark_name ; - Format.fprintf - fmtr - "expression = @[%a@]@," - Micheline_printer.print_expr - (make_printable micheline) ; - Format.fprintf - fmtr - "expected type = @[%a@]@," - Micheline_printer.print_expr - (make_printable expected_type) ; - Format.fprintf fmtr "phase = %a@," pp_phase phase ; - Format.close_box () - | Bad_code {benchmark_name; micheline; expected_stack_type; phase} -> - Format.open_vbox 1 ; - Format.fprintf fmtr "Bad code:@," ; - Format.fprintf fmtr "benchmark = %a@," Namespace.pp benchmark_name ; - Format.fprintf - fmtr - "expression = @[%a@]@," - Micheline_printer.print_expr - (make_printable micheline) ; - Format.fprintf - fmtr - "expected stack = @[%a@]@," - (Format.pp_print_list - ~pp_sep:(fun fmtr () -> Format.fprintf fmtr "::") - (fun fmtr node -> - let printable = make_printable node in - Format.fprintf fmtr "%a" Micheline_printer.print_expr printable)) - expected_stack_type ; - Format.fprintf fmtr "phase = %a@," pp_phase phase ; - Format.close_box () - -exception Translator_benchmark_error of error_kind - -let () = - Printexc.register_printer (function - | Translator_benchmark_error err -> - Some (Format.asprintf "%a" pp_error_kind err) - | _ -> None) - -let global_error benchmark_name workload = - raise (Translator_benchmark_error (Global_error {benchmark_name; workload})) - -let bad_data benchmark_name micheline expected_type phase = - raise - (Translator_benchmark_error - (Bad_data {benchmark_name; micheline; expected_type; phase})) - -let bad_code benchmark_name micheline expected_stack_type phase = - raise - (Translator_benchmark_error - (Bad_code {benchmark_name; micheline; expected_stack_type; phase})) - -(* ----------------------------------------------------------------------- *) -(* Typechecking data (Micheline data -> typed data) *) - -let strict = Script_ir_translator_config.make ~legacy:false () - -module Typechecking_data : Benchmark.S = struct - include Config - include Default_boilerplate - - let models = make_models Translator_workload.Parsing Translator_workload.Data - - let name = ns "TYPECHECKING_DATA" - - let info = "Benchmarking typechecking of data" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let typechecking_data_benchmark rng_state (node : Protocol.Script_repr.expr) - (michelson_type : Script_repr.expr) = - Lwt_main.run - ( Execution_context.make ~rng_state >>=? fun (ctxt, _) -> - let ex_ty = Type_helpers.michelson_type_to_ex_ty michelson_type ctxt in - let workload = - match - Translator_workload.data_typechecker_workload - ctxt - Translator_workload.Parsing - (Micheline.root node) - ex_ty - with - | None -> bad_data name node michelson_type Workload_production - | Some workload -> workload - in - match ex_ty with - | Script_typed_ir.Ex_ty ty -> - let closure () = - match - Lwt_main.run - (Script_ir_translator.parse_data - ctxt - ~elab_conf:strict - ~allow_forged:false - ty - (Micheline.root node)) - with - | Error _ | (exception _) -> - bad_data name node michelson_type In_protocol - | Ok _ -> () - in - return (Generator.Plain {workload; closure}) ) - |> function - | Ok closure -> closure - | Error errs -> global_error name errs - - let make_bench rng_state cfg () = - let Michelson_mcmc_samplers.{term; typ} = - Michelson_generation.make_data_sampler rng_state cfg.generator_config - in - typechecking_data_benchmark rng_state term typ - - let create_benchmarks ~rng_state ~bench_num config = - match config.michelson_terms_file with - | Some file -> - Format.eprintf "Loading terms from %s@." file ; - let terms = Michelson_mcmc_samplers.load ~filename:file in - List.filter_map - (function - | Michelson_mcmc_samplers.Data {term; typ} -> - Some (fun () -> typechecking_data_benchmark rng_state term typ) - | _ -> None) - terms - | None -> - Format.eprintf "No michelson_terms_file given, generating on-the-fly@." ; - List.repeat bench_num (make_bench rng_state config) -end - -let () = - Benchmarks_proto.Registration.register_as_simple_with_num - (module Typechecking_data) - -module Unparsing_data : Benchmark.S = struct - include Config - include Default_boilerplate - - let models = - make_models Translator_workload.Unparsing Translator_workload.Data - - let name = ns "UNPARSING_DATA" - - let info = "Benchmarking unparsing of data" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let unparsing_data_benchmark rng_state (node : Protocol.Script_repr.expr) - (michelson_type : Protocol.Script_repr.expr) = - Lwt_main.run - ( Execution_context.make ~rng_state >>=? fun (ctxt, _) -> - let ex_ty = Type_helpers.michelson_type_to_ex_ty michelson_type ctxt in - let workload = - match - Translator_workload.data_typechecker_workload - ctxt - Translator_workload.Unparsing - (Micheline.root node) - ex_ty - with - | None -> bad_data name node michelson_type Workload_production - | Some workload -> workload - in - match ex_ty with - | Script_typed_ir.Ex_ty ty -> - Script_ir_translator.parse_data - ctxt - ~elab_conf:strict - ~allow_forged:false - ty - (Micheline.root node) - >|= Environment.wrap_tzresult - >>=? fun (typed, ctxt) -> - let closure () = - match - Lwt_main.run - (Script_ir_translator.Internal_for_benchmarking.unparse_data - ~stack_depth:0 - ctxt - Script_ir_unparser.Optimized - ty - typed) - with - | Error _ | (exception _) -> - bad_data name node michelson_type In_protocol - | Ok _ -> () - in - return (Generator.Plain {workload; closure}) ) - |> function - | Ok closure -> closure - | Error errs -> global_error name errs - - let make_bench rng_state cfg () = - let Michelson_mcmc_samplers.{term; typ} = - Michelson_generation.make_data_sampler rng_state cfg.generator_config - in - unparsing_data_benchmark rng_state term typ - - let create_benchmarks ~rng_state ~bench_num config = - match config.michelson_terms_file with - | Some file -> - Format.eprintf "Loading terms from %s@." file ; - let terms = Michelson_mcmc_samplers.load ~filename:file in - List.filter_map - (function - | Michelson_mcmc_samplers.Data {term; typ} -> - Some (fun () -> unparsing_data_benchmark rng_state term typ) - | _ -> None) - terms - | None -> - Format.eprintf "No michelson_terms_file given, generating on-the-fly@." ; - List.repeat bench_num (make_bench rng_state config) -end - -let () = - Benchmarks_proto.Registration.register_as_simple_with_num - (module Unparsing_data) - -module Typechecking_code : Benchmark.S = struct - include Config - include Default_boilerplate - - let models = make_models Translator_workload.Parsing Translator_workload.Code - - let name = ns "TYPECHECKING_CODE" - - let info = "Benchmarking typechecking of code" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let typechecking_code_benchmark rng_state (node : Protocol.Script_repr.expr) - (stack : Script_repr.expr list) = - Lwt_main.run - ( Execution_context.make ~rng_state >>=? fun (ctxt, _) -> - let ex_stack_ty = - Type_helpers.michelson_type_list_to_ex_stack_ty stack ctxt - in - let workload = - match - Translator_workload.code_typechecker_workload - ctxt - Translator_workload.Parsing - (Micheline.root node) - ex_stack_ty - with - | None -> bad_code name node stack Workload_production - | Some workload -> workload - in - let (Script_ir_translator.Ex_stack_ty bef) = ex_stack_ty in - let closure () = - let result = - Lwt_main.run - (Script_ir_translator.parse_instr - Script_tc_context.data - ctxt - ~elab_conf:strict - (Micheline.root node) - bef) - in - match Environment.wrap_tzresult result with - | Error errs -> - Format.eprintf "%a@." Error_monad.pp_print_trace errs ; - bad_code name node stack In_protocol - | Ok _ -> () - in - return (Generator.Plain {workload; closure}) ) - |> function - | Ok closure -> closure - | Error errs -> global_error name errs - - let make_bench rng_state (cfg : Config.config) () = - let open Michelson_generation in - let Michelson_mcmc_samplers.{term; bef; aft = _} = - make_code_sampler rng_state cfg.generator_config - in - typechecking_code_benchmark rng_state term bef - - let create_benchmarks ~rng_state ~bench_num config = - match config.michelson_terms_file with - | Some file -> - Format.eprintf "Loading terms from %s@." file ; - let terms = Michelson_mcmc_samplers.load ~filename:file in - List.filter_map - (function - | Michelson_mcmc_samplers.Code {term; bef; aft = _} -> - Some (fun () -> typechecking_code_benchmark rng_state term bef) - | _ -> None) - terms - | None -> - Format.eprintf "No michelson_terms_file given, generating on-the-fly@." ; - List.repeat bench_num (make_bench rng_state config) -end - -let () = - Benchmarks_proto.Registration.register_as_simple_with_num - (module Typechecking_code) - -module Unparsing_code : Benchmark.S = struct - include Config - include Default_boilerplate - - let models = - make_models Translator_workload.Unparsing Translator_workload.Code - - let name = ns "UNPARSING_CODE" - - let info = "Benchmarking unparsing of code" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let unparsing_code_benchmark rng_state (node : Protocol.Script_repr.expr) - (stack : Script_repr.expr list) = - Lwt_main.run - ( Execution_context.make ~rng_state >>=? fun (ctxt, _) -> - let ex_stack_ty = - Type_helpers.michelson_type_list_to_ex_stack_ty stack ctxt - in - let workload = - match - Translator_workload.code_typechecker_workload - ctxt - Translator_workload.Unparsing - (Micheline.root node) - ex_stack_ty - with - | None -> bad_code name node stack Workload_production - | Some workload -> workload - in - let (Script_ir_translator.Ex_stack_ty bef) = ex_stack_ty in - (* We parse the code just to check it is well-typed. *) - Script_ir_translator.parse_instr - Script_tc_context.data - ctxt - ~elab_conf:strict - (Micheline.root node) - bef - >|= Environment.wrap_tzresult - >>=? fun (_typed, ctxt) -> - let closure () = - let result = - Lwt_main.run - (Script_ir_translator.Internal_for_benchmarking.unparse_code - ~stack_depth:0 - ctxt - Optimized - (Micheline.root node)) - in - match Environment.wrap_tzresult result with - | Error errs -> - Format.eprintf "%a@." Error_monad.pp_print_trace errs ; - bad_code name node stack In_protocol - | Ok _ -> () - in - return (Generator.Plain {workload; closure}) ) - |> function - | Ok closure -> closure - | Error errs -> global_error name errs - - let make_bench rng_state (cfg : Config.config) () = - let open Michelson_generation in - let Michelson_mcmc_samplers.{term; bef; aft = _} = - make_code_sampler rng_state cfg.generator_config - in - unparsing_code_benchmark rng_state term bef - - let create_benchmarks ~rng_state ~bench_num config = - match config.michelson_terms_file with - | Some file -> - Format.eprintf "Loading terms from %s@." file ; - let terms = Michelson_mcmc_samplers.load ~filename:file in - List.filter_map - (function - | Michelson_mcmc_samplers.Code {term; bef; aft = _} -> - Some (fun () -> unparsing_code_benchmark rng_state term bef) - | _ -> None) - terms - | None -> List.repeat bench_num (make_bench rng_state config) -end - -let () = - Benchmarks_proto.Registration.register_as_simple_with_num - (module Unparsing_code) - -let rec check_printable_ascii v i = - if Compare.Int.(i < 0) then true - else - match v.[i] with - | '\n' | '\x20' .. '\x7E' -> check_printable_ascii v (i - 1) - | _ -> false - -let check_printable_benchmark = - let open Tezos_shell_benchmarks.Encoding_benchmarks_helpers in - let open Encodings in - linear_shared - ~name:"CHECK_PRINTABLE" - ~generator:(fun rng_state -> - let open Base_samplers in - let string = - readable_ascii_string rng_state ~size:{min = 1; max = 1024} - in - (string, {Shared_linear.bytes = String.length string})) - ~make_bench:(fun generator () -> - let generated, workload = generator () in - let closure () = - ignore (check_printable_ascii generated (String.length generated - 1)) - in - Generator.Plain {workload; closure}) - () - -let () = Registration_helpers.register_simple_with_num check_printable_benchmark - -module Ty_eq : Benchmark.S = struct - type config = {max_size : int} - - let config_encoding = - let open Data_encoding in - conv - (fun {max_size} -> max_size) - (fun max_size -> {max_size}) - (obj1 (req "max_size" int31)) - - let default_config = {max_size = 64} - - type workload = Ty_eq_workload of {nodes : int; consumed : Size.t} - - let workload_encoding = - let open Data_encoding in - conv - (function Ty_eq_workload {nodes; consumed} -> (nodes, consumed)) - (fun (nodes, consumed) -> Ty_eq_workload {nodes; consumed}) - (obj2 (req "nodes" int31) (req "consumed" int31)) - - let workload_to_vector = function - | Ty_eq_workload {nodes; consumed} -> - Sparse_vec.String.of_list - [("nodes", float_of_int nodes); ("consumed", float_of_int consumed)] - - let name = ns "TY_EQ" - - let info = "Benchmarking equating types" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let tags = [Tags.translator] - - let intercept_var = fv (Format.asprintf "%s_const" (Namespace.basename name)) - - let coeff_var = fv (Format.asprintf "%s_coeff" (Namespace.basename name)) - - let size_model = - Model.make - ~conv:(function Ty_eq_workload {nodes; _} -> (nodes, ())) - (Model.affine ~name ~intercept:intercept_var ~coeff:coeff_var) - - let models = [("size_translator_model", size_model)] - - let ty_eq_benchmark rng_state nodes (ty : Script_typed_ir.ex_ty) = - Lwt_main.run - ( Execution_context.make ~rng_state >>=? fun (ctxt, _) -> - let ctxt = Gas_helpers.set_limit ctxt in - match ty with - | Ex_ty ty -> - let dummy_loc = 0 in - Lwt.return - (Gas_monad.run ctxt - @@ Script_ir_translator.ty_eq - ~error_details:(Informative dummy_loc) - ty - ty) - >|= Environment.wrap_tzresult - >>=? fun (_, ctxt') -> - let consumed = - Alpha_context.Gas.consumed ~since:ctxt ~until:ctxt' - in - let workload = - Ty_eq_workload - {nodes; consumed = Z.to_int (Gas_helpers.fp_to_z consumed)} - in - let closure () = - ignore - (Gas_monad.run ctxt - @@ Script_ir_translator.ty_eq - ~error_details:(Informative dummy_loc) - ty - ty) - in - return (Generator.Plain {workload; closure}) ) - |> function - | Ok closure -> closure - | Error errs -> global_error name errs - - let make_bench rng_state (cfg : config) () = - let nodes = - Base_samplers.( - sample_in_interval ~range:{min = 1; max = cfg.max_size} rng_state) - in - let ty = - Michelson_generation.Samplers.Random_type.m_type ~size:nodes rng_state - in - ty_eq_benchmark rng_state nodes ty - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (make_bench rng_state config) -end - -let () = Registration_helpers.register (module Ty_eq) - -(* A dummy type generator, sampling linear terms of a given size. - The generator always returns types of the shape: - - [pair unit (pair unit (pair unit ...))] - - This structure is the worse-case of the unparsing function for types because - an extra test is performed to determine if the comb type needs to be folded. -*) -let rec dummy_type_generator size = - let open Script_typed_ir in - if size <= 1 then Ex_ty unit_t - else - match dummy_type_generator (size - 2) with - | Ex_ty r -> ( - let l = unit_t in - match pair_t (-1) l r with - | Error _ -> assert false - | Ok (Ty_ex_c t) -> Ex_ty t) - -(* A dummy comparable type generator, sampling linear terms of a given size. *) -let rec dummy_comparable_type_generator size = - let open Script_ir_translator in - let open Script_typed_ir in - if size <= 0 then Ex_comparable_ty unit_t - else - match dummy_comparable_type_generator (size - 2) with - | Ex_comparable_ty r -> - let l = unit_t in - Ex_comparable_ty - (match comparable_pair_t (-1) l r with - | Error _ -> assert false - | Ok t -> t) - -module Parse_type_shared = struct - type config = {max_size : int} - - let default_config = {max_size = Constants_repr.michelson_maximum_type_size} - - let config_encoding = - let open Data_encoding in - conv - (fun {max_size} -> max_size) - (fun max_size -> {max_size}) - (obj1 (req "max_size" int31)) - - type workload = Type_workload of {nodes : int; consumed : Size.t} - - let workload_encoding = - let open Data_encoding in - conv - (function Type_workload {nodes; consumed} -> (nodes, consumed)) - (fun (nodes, consumed) -> Type_workload {nodes; consumed}) - (obj2 (req "nodes" int31) (req "consumed" int31)) - - let workload_to_vector = function - | Type_workload {nodes; consumed} -> - Sparse_vec.String.of_list - [("nodes", float_of_int nodes); ("consumed", float_of_int consumed)] - - let tags = [Tags.translator] -end - -let parse_ty ctxt node = - Script_ir_translator.parse_ty - ctxt - ~legacy:true - ~allow_lazy_storage:true - ~allow_operation:true - ~allow_contract:true - ~allow_ticket:true - node - -let unparse_ty ctxt ty = Script_ir_unparser.unparse_ty ~loc:(-1) ctxt ty - -module Parse_type_benchmark : Benchmark.S = struct - include Parse_type_shared - - let name = ns "PARSE_TYPE" - - let info = "Benchmarking parse_ty" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let make_bench rng_state config () = - ( Lwt_main.run (Execution_context.make ~rng_state) >>? fun (ctxt, _) -> - let ctxt = Gas_helpers.set_limit ctxt in - let size = Random.State.int rng_state config.max_size in - let ty = dummy_type_generator size in - match ty with - | Ex_ty ty -> - Environment.wrap_tzresult @@ unparse_ty ctxt ty - >>? fun (unparsed, _) -> - Environment.wrap_tzresult @@ parse_ty ctxt unparsed - >>? fun (_, ctxt') -> - let consumed = - Z.to_int - (Gas_helpers.fp_to_z - (Alpha_context.Gas.consumed ~since:ctxt ~until:ctxt')) - in - let nodes = - let x = Script_typed_ir.ty_size ty in - Saturation_repr.to_int @@ Script_typed_ir.Type_size.to_int x - in - let workload = Type_workload {nodes; consumed} in - let closure () = ignore (parse_ty ctxt unparsed) in - ok (Generator.Plain {workload; closure}) ) - |> function - | Ok closure -> closure - | Error errs -> global_error name errs - - let size_model = - Model.make - ~conv:(function Type_workload {nodes; consumed = _} -> (nodes, ())) - (Model.affine - ~name - ~intercept:(fv (Format.asprintf "%s_const" (Namespace.basename name))) - ~coeff:(fv (Format.asprintf "%s_coeff" (Namespace.basename name)))) - - let models = [("size_translator_model", size_model)] - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (make_bench rng_state config) -end - -let () = Registration_helpers.register (module Parse_type_benchmark) - -module Unparse_type_benchmark : Benchmark.S = struct - include Parse_type_shared - - let name = ns "UNPARSE_TYPE" - - let info = "Benchmarking unparse_ty" - - let module_filename = __FILE__ - - let purpose = Benchmark.Other_purpose "No longer used to generate code" - - let make_bench rng_state config () = - ( Lwt_main.run (Execution_context.make ~rng_state) >>? fun (ctxt, _) -> - let ctxt = Gas_helpers.set_limit ctxt in - let size = Random.State.int rng_state config.max_size in - let ty = dummy_type_generator size in - match ty with - | Ex_ty ty -> - Environment.wrap_tzresult @@ unparse_ty ctxt ty >>? fun (_, ctxt') -> - let consumed = - Z.to_int - (Gas_helpers.fp_to_z - (Alpha_context.Gas.consumed ~since:ctxt ~until:ctxt')) - in - let nodes = - let x = Script_typed_ir.ty_size ty in - Saturation_repr.to_int @@ Script_typed_ir.Type_size.to_int x - in - let workload = Type_workload {nodes; consumed} in - let closure () = ignore (unparse_ty ctxt ty) in - ok (Generator.Plain {workload; closure}) ) - |> function - | Ok closure -> closure - | Error errs -> global_error name errs - - let size_model = - Model.make - ~conv:(function Type_workload {nodes; consumed = _} -> (nodes, ())) - (Model.affine - ~name - ~intercept:(fv (Format.asprintf "%s_const" (Namespace.basename name))) - ~coeff:(fv (Format.asprintf "%s_coeff" (Namespace.basename name)))) - - let models = [("size_translator_model", size_model)] - - let create_benchmarks ~rng_state ~bench_num config = - List.repeat bench_num (make_bench rng_state config) -end - -let () = Registration_helpers.register (module Unparse_type_benchmark) diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/translator_model.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/translator_model.ml deleted file mode 100644 index f1d2f2dc15d1815ea221b1d8146dccb4b8111240..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/translator_model.ml +++ /dev/null @@ -1,70 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 ns = Namespace.make Registration_helpers.ns "translator" - -let fv s = Free_variable.of_namespace (ns s) - -let gas_full t_kind code_or_data = - let name = - Format.asprintf - "%a_%a" - Translator_workload.pp_kind - t_kind - Translator_workload.pp_code_or_data - code_or_data - in - let intercept = fv (Format.asprintf "%s_const" name) in - let coeff = fv (Format.asprintf "%s_coeff" name) in - Model.affine ~name:(ns name) ~intercept ~coeff - -let size_full t_kind code_or_data = - let name = - Format.asprintf - "%a_%a" - Translator_workload.pp_kind - t_kind - Translator_workload.pp_code_or_data - code_or_data - in - let coeff1 = fv (Format.asprintf "%s_traversal" name) in - let coeff2 = fv (Format.asprintf "%s_int_bytes" name) in - let coeff3 = fv (Format.asprintf "%s_string_bytes" name) in - Model.trilinear ~name:(ns name) ~coeff1 ~coeff2 ~coeff3 - -let gas_based_model t_kind code_or_data = - Model.make - ~conv:(function - | Translator_workload.Typechecker_workload {consumed; _} -> (consumed, ())) - (gas_full t_kind code_or_data) - -let size_based_model t_kind code_or_data = - Model.make - ~conv:(function - | Translator_workload.Typechecker_workload {micheline_size; _} -> ( - match micheline_size with - | {traversal; int_bytes; string_bytes} -> - (traversal, (int_bytes, (string_bytes, ()))))) - (size_full t_kind code_or_data) diff --git a/src/proto_017_PtNairob/lib_benchmarks_proto/translator_workload.ml b/src/proto_017_PtNairob/lib_benchmarks_proto/translator_workload.ml deleted file mode 100644 index 52207e6265062a77d3e820b2c9216352c9ca4e83..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_benchmarks_proto/translator_workload.ml +++ /dev/null @@ -1,188 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 Size = Protocol.Gas_input_size - -type kind = Parsing | Unparsing - -type code_or_data = Code | Data - -type t = - | Typechecker_workload of { - t_kind : kind; - code_or_data : code_or_data; - micheline_size : Size.micheline_size; - consumed : Size.t; - } - -let kind_encoding : kind Data_encoding.t = - let open Data_encoding in - def "kind_encoding" - @@ string_enum [("parsing", Parsing); ("unparsing", Unparsing)] - -let code_or_data_encoding : code_or_data Data_encoding.t = - let open Data_encoding in - def "code_or_data_encoding" @@ string_enum [("code", Code); ("data", Data)] - -let encoding : t Data_encoding.t = - let open Data_encoding in - def "translator_trace_encoding" - @@ conv - (function - | Typechecker_workload {t_kind; code_or_data; micheline_size; consumed} - -> - (t_kind, code_or_data, micheline_size, consumed)) - (fun (t_kind, code_or_data, micheline_size, consumed) -> - Typechecker_workload {t_kind; code_or_data; micheline_size; consumed}) - (tup4 - kind_encoding - code_or_data_encoding - Size.micheline_size_encoding - Size.encoding) - -let pp_kind fmtr (kind : kind) = - match kind with - | Parsing -> Format.pp_print_string fmtr "Parsing" - | Unparsing -> Format.pp_print_string fmtr "Unparsing" - -let pp_code_or_data fmtr (x : code_or_data) = - match x with - | Code -> Format.pp_print_string fmtr "Code" - | Data -> Format.pp_print_string fmtr "Data" - -let pp fmtr (trace : t) = - match trace with - | Typechecker_workload {t_kind; code_or_data; micheline_size; consumed} -> - Format.fprintf - fmtr - "typechecker_trace { %a; %a; %a; %a }" - pp_kind - t_kind - pp_code_or_data - code_or_data - Size.pp_micheline_size - micheline_size - Size.pp - consumed - -let workload_to_sparse_vec (trace : t) = - let name, {Size.traversal; int_bytes; string_bytes}, consumed = - match trace with - | Typechecker_workload {t_kind; code_or_data; micheline_size; consumed} -> - let name = - Format.asprintf "%a_%a" pp_kind t_kind pp_code_or_data code_or_data - in - (name, micheline_size, consumed) - in - let n s = name ^ "_" ^ s in - let vars = - [ - (n "traversal", float_of_int (Size.to_int traversal)); - (n "int_bytes", float_of_int (Size.to_int int_bytes)); - (n "string_bytes", float_of_int (Size.to_int string_bytes)); - (n "gas", float_of_int (Size.to_int consumed)); - ] - in - Sparse_vec.String.of_list vars - -let data_typechecker_workload ctxt t_kind micheline_node ex_ty = - let open Protocol in - match ex_ty with - | Script_typed_ir.Ex_ty ty -> - let ctxt = Gas_helpers.set_limit ctxt in - Lwt_main.run - ( Script_ir_translator.parse_data - ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:false ()) - ~allow_forged:false - ty - micheline_node - |> Lwt.map Environment.wrap_tzresult - >>= fun res -> - match res with - | Ok (_res, ctxt_after) -> - let micheline_size = Size.of_micheline micheline_node in - let consumed = - Alpha_context.Gas.consumed ~since:ctxt ~until:ctxt_after - in - let trace = - Typechecker_workload - { - t_kind; - code_or_data = Data; - micheline_size; - consumed = - Size.of_int (Z.to_int (Gas_helpers.fp_to_z consumed)); - } - in - Lwt.return (Some trace) - | Error errors -> - Michelson_v1_error_reporter.report_errors - ~details:true - ~show_source:true - Format.err_formatter - errors ; - Format.eprintf "@." ; - Lwt.return None ) - -let code_typechecker_workload (ctxt : Protocol.Alpha_context.context) - (t_kind : kind) (code : Protocol.Alpha_context.Script.node) - (bef : Protocol.Script_ir_translator.ex_stack_ty) = - let open Protocol in - let ctxt = Gas_helpers.set_limit ctxt in - let (Script_ir_translator.Ex_stack_ty stack_ty) = bef in - Lwt_main.run - ( Script_ir_translator.parse_instr - Script_tc_context.data - ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:false ()) - code - stack_ty - |> Lwt.map Environment.wrap_tzresult - >>= fun res -> - match res with - | Ok (_res, ctxt_after) -> - let micheline_size = Size.of_micheline code in - let consumed = - Alpha_context.Gas.consumed ~since:ctxt ~until:ctxt_after - in - let trace = - Typechecker_workload - { - t_kind; - code_or_data = Code; - micheline_size; - consumed = Size.of_int (Z.to_int (Gas_helpers.fp_to_z consumed)); - } - in - Lwt.return (Some trace) - | Error errs -> - Michelson_v1_error_reporter.report_errors - ~details:true - ~show_source:true - Format.err_formatter - errs ; - Format.eprintf "@." ; - Lwt.return None ) diff --git a/src/proto_017_PtNairob/lib_client/test/dune b/src/proto_017_PtNairob/lib_client/test/dune deleted file mode 100644 index 710ac2f9ca36b8e8ecc17c2bc91dd60d038b428d..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_client/test/dune +++ /dev/null @@ -1,55 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name src_proto_017_PtNairob_lib_client_test_tezt_lib) - (instrumentation (backend bisect_ppx)) - (libraries - tezt.core - octez-libs.base - octez-libs.micheline - octez-protocol-017-PtNairob-libs.client - tezos-protocol-017-PtNairob.protocol - octez-libs.base-test-helpers - octez-libs.test-helpers - octez-alcotezt - qcheck-alcotest) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezt_core - -open Tezt_core.Base - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_micheline - -open Tezos_client_017_PtNairob - -open Tezos_protocol_017_PtNairob - -open Tezos_base_test_helpers - -open Tezos_test_helpers - -open Octez_alcotezt) - (modules - test_michelson_v1_macros - test_client_proto_contracts - test_client_proto_context - test_proxy)) - -(executable - (name main) - (instrumentation (backend bisect_ppx --bisect-sigterm)) - (libraries - src_proto_017_PtNairob_lib_client_test_tezt_lib - tezt) - (link_flags - (:standard) - (:include %{workspace_root}/macos-link-flags.sexp)) - (modules main)) - -(rule - (alias runtest) - (package octez-protocol-017-PtNairob-libs) - (enabled_if (<> false %{env:RUNTEZTALIAS=true})) - (action (run %{dep:./main.exe}))) - -(rule - (targets main.ml) - (action (with-stdout-to %{targets} (echo "let () = Tezt.Test.run ()")))) diff --git a/src/proto_017_PtNairob/lib_client/test/test_client_proto_context.ml b/src/proto_017_PtNairob/lib_client/test/test_client_proto_context.ml deleted file mode 100644 index a2187640bc1df213103614d9ac1dafacab15e47b..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_client/test/test_client_proto_context.ml +++ /dev/null @@ -1,69 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(* Testing - ------- - Component: Client - Invocation: dune exec src/proto_017_PtNairob/lib_client/test/main.exe \ - -- --file test_client_proto_context.ml - Subject: Tests roundtrips of batch_transfer_operation_encoding -*) - -open Protocol -open Alpha_context -open Qcheck2_helpers - -let binary_roundtrip ?pp encoding t = - let b = Data_encoding.Binary.to_bytes_exn encoding t in - let actual = Data_encoding.Binary.of_bytes_exn encoding b in - qcheck_eq' ?pp ~expected:t ~actual () - -let gen_batch_transfer_operation_encoding = - let open QCheck2.Gen in - let gen_z = sized @@ fun n -> map Z.of_bits (string_size (return n)) in - let gen_gas_arith_integral = - map Gas.Arith.integral_of_int_exn (int_range 0 (Int.div Int.max_int 1000)) - in - let* destination = string in - let* fee = opt string in - let* gas_limit = opt gen_gas_arith_integral in - let* storage_limit = opt gen_z in - let* amount = string in - let* arg = opt string in - let* entrypoint = opt (string_size (1 -- 31)) in - let entrypoint = Option.map Entrypoint.of_string_strict_exn entrypoint in - return - Client_proto_context. - {destination; fee; gas_limit; storage_limit; amount; arg; entrypoint} - -let tests = - [ - QCheck2.Test.make - ~name:"test_batch_transfer_operation_encoding_roundtrip" - gen_batch_transfer_operation_encoding - (binary_roundtrip Client_proto_context.batch_transfer_operation_encoding); - ] - -let () = Alcotest.run ~__FILE__ Protocol.name [("Encodings", qcheck_wrap tests)] diff --git a/src/proto_017_PtNairob/lib_client/test/test_client_proto_contracts.ml b/src/proto_017_PtNairob/lib_client/test/test_client_proto_contracts.ml deleted file mode 100644 index 622eff603172b78342e029346ce3ba0eab231eec..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_client/test/test_client_proto_contracts.ml +++ /dev/null @@ -1,99 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Client - Invocation: dune exec src/proto_017_PtNairob/lib_client/test/main.exe \ - -- --file test_client_proto_contracts.ml - Subject: Unit tests for Client_proto_contracts -*) - -(** [mock_wallet entities] is a mock of the - [Tezos_client_base.Client_context.wallet] class that only - implements the [load] method. This methods returns a key-value - association as given by the json string [entities] that should have - the form: ["[{"name": "alias", "value": "key" }, <...>]"]. *) -class mock_wallet (entities : string) : Tezos_client_base.Client_context.wallet - = - object - method load_passwords = None - - method read_file _path = failwith "mock_wallet:read_file" - - method get_base_dir = "" - - method with_lock : type a. (unit -> a Lwt.t) -> a Lwt.t = fun _f -> _f () - - method load : type a. - string -> default:a -> a Data_encoding.encoding -> a tzresult Lwt.t = - fun _alias_name ~default:_default _encoding -> - let json = (Ezjsonm.from_string entities :> Data_encoding.json) in - return @@ Data_encoding.Json.destruct _encoding json - - method write : type a. - string -> a -> a Data_encoding.encoding -> unit tzresult Lwt.t = - fun _alias_name _list _encoding -> failwith "mock_wallet:write" - - method last_modification_time : string -> float option tzresult Lwt.t = - fun _ -> Lwt_result_syntax.return_none - end - -(** - Test. - Tests different lookups of - [Client_proto_contracts.Contract_alias.find_destination]. -*) -let test_find_destination _ = - let bootstrap1 = "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" in - let wallet_json = - Format.asprintf {| [{"name": "test_alias", "value": "%s" }] |} bootstrap1 - in - let w = new mock_wallet wallet_json in - let test msg key exp_source = - Client_proto_contracts.Contract_alias.find_destination w key - >>=? fun contract -> - Client_proto_contracts.Raw_contract_alias.to_source contract - >>=? fun source -> - (* Alcotest equality assertion *) - Alcotest.(check string msg source exp_source) ; - return_unit - in - test "Expected alias:test_alias = bootstrap1" "alias:test_alias" bootstrap1 - >>=? fun () -> - test "Expected key:test_alias = bootstrap1" "key:test_alias" bootstrap1 - >>=? fun () -> - test "Expected bootstrap1 = bootstrap1" bootstrap1 bootstrap1 >>=? fun () -> - test "Expected test_alias bootstrap1" "test_alias" bootstrap1 - -let () = - Alcotest_lwt.run - ~__FILE__ - Protocol.name - [ - ( "client_proto_contracts", - [Tztest.tztest "test_find_destination" `Quick test_find_destination] ); - ] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_client/test/test_michelson_v1_macros.ml b/src/proto_017_PtNairob/lib_client/test/test_michelson_v1_macros.ml deleted file mode 100644 index 675def85fec96856b504a4d4b16ad64e2c08ce27..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_client/test/test_michelson_v1_macros.ml +++ /dev/null @@ -1,1348 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2019 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Client - Invocation: dune exec src/proto_017_PtNairob/lib_client/test/main.exe \ - -- --file test_michelson_v1_macros.ml - Dependencies: src/proto_alpha/lib_client/test/assert.ml - Subject: Expansion and unexpansion of Micheline terms. -*) - -open Protocol -module Assert = Assert - -let pp ppf expr = - expr - |> Micheline_printer.printable (fun s -> s) - |> Format.fprintf ppf "%a" Micheline_printer.print_expr - -let to_string e = Format.asprintf "%a" pp e -(* expands : expression with macros fully expanded *) - -let assert_expands - (original : (Micheline_parser.location, string) Micheline.node) - (expanded : (Micheline_parser.location, string) Micheline.node) = - let {Michelson_v1_parser.expanded = expansion; _}, errors = - let source = to_string (Micheline.strip_locations original) in - Michelson_v1_parser.expand_all ~source ~original - in - match errors with - | [] -> - Assert.equal - ~pp - (Michelson_v1_primitives.strings_of_prims expansion) - (Micheline.strip_locations expanded) ; - ok () - | errors -> Error errors - -(****************************************************************************) - -open Micheline - -let zero_loc = Micheline_parser.location_zero - -let left_branch = Seq (zero_loc, [Prim (zero_loc, "SWAP", [], [])]) - -let right_branch = Seq (zero_loc, []) - -(***************************************************************************) -(* Test expands *) -(***************************************************************************) - -(** [prim_name] is the syntactic sugar to be expanded, while [compare_name] - is syntactic atom. *) -let assert_compare_macro prim_name compare_name = - assert_expands - (Prim (zero_loc, prim_name, [], [])) - (Seq - ( zero_loc, - [ - Prim (zero_loc, "COMPARE", [], []); - Prim (zero_loc, compare_name, [], []); - ] )) - -(** Expand "COMP{EQ|NEQ|LT|GT|LE|GE}" - into "COMPARE ; {EQ|NEQ|LT|GT|LE|GE}". -*) -let test_compare_marco_expansion () = - assert_compare_macro "CMPEQ" "EQ" >>? fun () -> - assert_compare_macro "CMPNEQ" "NEQ" >>? fun () -> - assert_compare_macro "CMPLT" "LT" >>? fun () -> - assert_compare_macro "CMPGT" "GT" >>? fun () -> - assert_compare_macro "CMPLE" "LE" >>? fun () -> - assert_compare_macro "CMPGE" "GE" - -let assert_if_macro prim_name compare_name = - assert_expands - (Prim (zero_loc, prim_name, [left_branch; right_branch], [])) - (Seq - ( zero_loc, - [ - Prim (zero_loc, compare_name, [], []); - Prim (zero_loc, "IF", [left_branch; right_branch], []); - ] )) - -(** Expand "IF{EQ|NEQ|LT|GT|LE|GE}" - into "{EQ|NEQ|LT|GT|LE|GE} ; IF" -*) -let test_if_compare_macros_expansion () = - assert_if_macro "IFEQ" "EQ" >>? fun () -> - assert_if_macro "IFNEQ" "NEQ" >>? fun () -> - assert_if_macro "IFLT" "LT" >>? fun () -> - assert_if_macro "IFGT" "GT" >>? fun () -> - assert_if_macro "IFLE" "LE" >>? fun () -> assert_if_macro "IFGE" "GE" - -let assert_if_cmp_macros prim_name compare_name = - assert_expands - (Prim (zero_loc, prim_name, [left_branch; right_branch], [])) - (Seq - ( zero_loc, - [ - Prim (zero_loc, "COMPARE", [], []); - Prim (zero_loc, compare_name, [], []); - Prim (zero_loc, "IF", [left_branch; right_branch], []); - ] )) - -(** Expand "IF{EQ|NEQ|LT|GT|LE|GE}" - into "{EQ|NEQ|LT|GT|LE|GE} ; IF" -*) -let test_if_cmp_macros_expansion () = - assert_if_cmp_macros "IFCMPEQ" "EQ" >>? fun () -> - assert_if_cmp_macros "IFCMPNEQ" "NEQ" >>? fun () -> - assert_if_cmp_macros "IFCMPLT" "LT" >>? fun () -> - assert_if_cmp_macros "IFCMPGT" "GT" >>? fun () -> - assert_if_cmp_macros "IFCMPLE" "LE" >>? fun () -> - assert_if_cmp_macros "IFCMPGE" "GE" - -(****************************************************************************) -(* Fail *) - -(** Expand "FAIL" - into "UNIT ; FAILWITH" -*) -let test_fail_expansion () = - assert_expands - (Prim (zero_loc, "FAIL", [], [])) - (Seq - ( zero_loc, - [Prim (zero_loc, "UNIT", [], []); Prim (zero_loc, "FAILWITH", [], [])] - )) - -(**********************************************************************) -(* assertion *) - -let seq_unit_failwith = - Seq - ( zero_loc, - [Prim (zero_loc, "UNIT", [], []); Prim (zero_loc, "FAILWITH", [], [])] ) - -(* {} {FAIL} *) -let fail_false = [Seq (zero_loc, []); Seq (zero_loc, [seq_unit_failwith])] - -(* {FAIL} {} *) -let fail_true = [Seq (zero_loc, [seq_unit_failwith]); Seq (zero_loc, [])] - -(** Expand "ASSERT" - into "IF {} {FAIL}" -*) -let test_assert_expansion () = - assert_expands - (Prim (zero_loc, "ASSERT", [], [])) - (Seq (zero_loc, [Prim (zero_loc, "IF", fail_false, [])])) - -let assert_assert_if_compare prim_name compare_name = - assert_expands - (Prim (zero_loc, prim_name, [], [])) - (Seq - ( zero_loc, - [ - Prim (zero_loc, compare_name, [], []); - Prim (zero_loc, "IF", fail_false, []); - ] )) - -(** Expand "ASSERT_{EQ|NEQ|LT|GT|LE|GE}" - into "{EQ|NEQ|LT|GT|LE|GE} ; IF {} {FAIL}" -*) -let test_assert_if () = - assert_assert_if_compare "ASSERT_EQ" "EQ" >>? fun () -> - assert_assert_if_compare "ASSERT_NEQ" "NEQ" >>? fun () -> - assert_assert_if_compare "ASSERT_LT" "LT" >>? fun () -> - assert_assert_if_compare "ASSERT_LE" "LE" >>? fun () -> - assert_assert_if_compare "ASSERT_GT" "GT" >>? fun () -> - assert_assert_if_compare "ASSERT_GE" "GE" - -let assert_cmp_if prim_name compare_name = - assert_expands - (Prim (zero_loc, prim_name, [], [])) - (Seq - ( zero_loc, - [ - Seq - ( zero_loc, - [ - Prim (zero_loc, "COMPARE", [], []); - Prim (zero_loc, compare_name, [], []); - ] ); - Prim (zero_loc, "IF", fail_false, []); - ] )) - -(** Expand "ASSERT_CMP{EQ|NEQ|LT|GT|LE|GE}" - into "COMPARE ; {EQ|NEQ|LT|GT|LE|GE} ; IF {} {FAIL}" -*) -let test_assert_cmp_if () = - assert_cmp_if "ASSERT_CMPEQ" "EQ" >>? fun () -> - assert_cmp_if "ASSERT_CMPNEQ" "NEQ" >>? fun () -> - assert_cmp_if "ASSERT_CMPLT" "LT" >>? fun () -> - assert_cmp_if "ASSERT_CMPLE" "LE" >>? fun () -> - assert_cmp_if "ASSERT_CMPGT" "GT" >>? fun () -> - assert_cmp_if "ASSERT_CMPGE" "GE" - -(* The work of merge request !628 - > ASSERT_LEFT @x => IF_LEFT {RENAME @x} {FAIL} - > ASSERT_RIGHT @x => IF_LEFT {FAIL} {RENAME @x} - > ASSERT_SOME @x => IF_NONE {FAIL} {RENAME @x} -*) - -let may_rename annot = Seq (zero_loc, [Prim (zero_loc, "RENAME", [], annot)]) - -let fail_false_may_rename = - [ - may_rename ["@annot"]; - Seq - ( zero_loc, - [ - Seq - ( zero_loc, - [ - Prim (zero_loc, "UNIT", [], []); - Prim (zero_loc, "FAILWITH", [], []); - ] ); - ] ); - ] - -let fail_true_may_rename = - [ - Seq - ( zero_loc, - [ - Seq - ( zero_loc, - [ - Prim (zero_loc, "UNIT", [], []); - Prim (zero_loc, "FAILWITH", [], []); - ] ); - ] ); - may_rename ["@annot"]; - ] - -(** Expand "ASSERT_SOME @annot" - into "IF_NONE { } {UNIT;FAILWITH}" - using variable annotation "@annot" -*) -let test_assert_some_annot () = - assert_expands - (Prim (zero_loc, "ASSERT_SOME", [], ["@annot"])) - (Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_true_may_rename, [])])) - -(** Expand "ASSERT_SOME" - into "IF_NONE { UNIT;FAILWITH } { }" -*) -let test_assert_some () = - assert_expands - (Prim (zero_loc, "ASSERT_SOME", [], [])) - (Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_true, [])])) - -(** Expand "ASSERT_LEFT @annot" - into "IF_LEFT { } {UNIT;FAILWITH}" - using variable annotation "@annot" -*) -let test_assert_left_annot () = - assert_expands - (Prim (zero_loc, "ASSERT_LEFT", [], ["@annot"])) - (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_false_may_rename, [])])) - -(** Expand "ASSERT_LEFT" - into "IF_LEFT { } {UNIT;FAILWITH}" -*) -let test_assert_left () = - assert_expands - (Prim (zero_loc, "ASSERT_LEFT", [], [])) - (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_false, [])])) - -(** Expand "ASSERT_RIGHT @annot" - into "IF_LEFT {UNIT;FAILWITH} { }" - using variable annotation "@annot" -*) -let test_assert_right_annot () = - assert_expands - (Prim (zero_loc, "ASSERT_RIGHT", [], ["@annot"])) - (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_true_may_rename, [])])) - -(** Expand "ASSERT_RIGHT" - into "IF_LEFT {UNIT;FAILWITH} { }" -*) -let test_assert_right () = - assert_expands - (Prim (zero_loc, "ASSERT_RIGHT", [], [])) - (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_true, [])])) - -(** Expand "ASSERT_NONE" - into "IF_NONE { } { UNIT;FAILWITH }" -*) -let test_assert_none () = - assert_expands - (Prim (zero_loc, "ASSERT_NONE", [], [])) - (Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_false, [])])) - -(***********************************************************************) -(*Syntactic Conveniences*) - -(* diip *) - -(** Expand "DIP" into "DIP". - Expand "DIIIIIIIIP" into "DIP 8". - Expand "DIIP" into "DIP 2". -*) -let test_diip () = - let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in - assert_expands - (Prim (zero_loc, "DIP", [code], [])) - (Prim (zero_loc, "DIP", [code], [])) - >>? fun () -> - assert_expands - (Prim (zero_loc, "DIIIIIIIIP", [code], [])) - (Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 8); code], [])) - >>? fun () -> - assert_expands - (Prim (zero_loc, "DIIP", [code], [])) - (Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 2); code], [])) - -(* pair *) - -(** Expand "PAIR" - into "PAIR" -*) -let test_pair () = - assert_expands - (Prim (zero_loc, "PAIR", [], [])) - (Prim (zero_loc, "PAIR", [], [])) - -(** Expand "PAPPAIIR" - into "DIP {PAIR}; DIP {PAIR}; PAIR" -*) -let test_pappaiir () = - let pair = Prim (zero_loc, "PAIR", [], []) in - assert_expands - (Prim (zero_loc, "PAPPAIIR", [], [])) - (Seq - ( zero_loc, - [ - Prim (zero_loc, "DIP", [Seq (zero_loc, [pair])], []); - Prim (zero_loc, "DIP", [Seq (zero_loc, [pair])], []); - pair; - ] )) - -(* unpair *) - -(** Expand "UNPAIR" - into "DUP ; CAR ; DIP {CDR}" -*) -let test_unpair () = - assert_expands - (Prim (zero_loc, "UNPAIR", [], [])) - (Prim (zero_loc, "UNPAIR", [], [])) - -(* duup *) - -(** Expand "DUUP" - into "DIP {DUP} ; SWAP" -*) -let test_duup () = - assert_expands - (Prim (zero_loc, "DUUP", [], [])) - (Prim (zero_loc, "DUP", [Int (zero_loc, Z.of_int 2)], [])) - -(* car/cdr *) - -(** Expand "CAR" into "CAR" - Expand "CDR" into "CDR" - Expand "CADR" into "CAR ; CDR" - Expand "CDAR" into "CDR ; CAR" -*) -let test_caddadr_expansion () = - let car = Prim (zero_loc, "CAR", [], []) in - assert_expands (Prim (zero_loc, "CAR", [], [])) car >>? fun () -> - let cdr = Prim (zero_loc, "CDR", [], []) in - assert_expands (Prim (zero_loc, "CDR", [], [])) cdr >>? fun () -> - assert_expands (Prim (zero_loc, "CADR", [], [])) (Seq (zero_loc, [car; cdr])) - >>? fun () -> - assert_expands (Prim (zero_loc, "CDAR", [], [])) (Seq (zero_loc, [cdr; car])) - -let test_carn_cdrn_expansion () = - let car n = Prim (zero_loc, "CAR", [Int (zero_loc, Z.of_int n)], []) in - let cdr n = Prim (zero_loc, "CDR", [Int (zero_loc, Z.of_int n)], []) in - let get n = - Seq (zero_loc, [Prim (zero_loc, "GET", [Int (zero_loc, Z.of_int n)], [])]) - in - assert_expands (cdr 0) (get 0) >>? fun () -> - assert_expands (car 0) (get 1) >>? fun () -> - assert_expands (cdr 1) (get 2) >>? fun () -> - assert_expands (car 1) (get 3) >>? fun () -> assert_expands (cdr 2) (get 4) - -(* if_some *) - -(** Expand "IF_SOME { 1 } { 2 }" - into "IF_NONE { 2 } { 1 }" -*) -let test_if_some () = - assert_expands - (Prim (zero_loc, "IF_SOME", [right_branch; left_branch], [])) - (Seq - (zero_loc, [Prim (zero_loc, "IF_NONE", [left_branch; right_branch], [])])) - -(*set_caddadr*) - -(** Expand "SET_CAR" - into "CDR; SWAP; PAIR" -*) -let test_set_car_expansion () = - assert_expands - (Prim (zero_loc, "SET_CAR", [], [])) - (Seq - ( zero_loc, - [ - Prim (zero_loc, "CDR", [], ["@%%"]); - Prim (zero_loc, "SWAP", [], []); - Prim (zero_loc, "PAIR", [], ["%"; "%@"]); - ] )) - -(** Expand "SET_CDR" - into "CAR; PAIR" -*) -let test_set_cdr_expansion () = - assert_expands - (Prim (zero_loc, "SET_CDR", [], [])) - (Seq - ( zero_loc, - [ - Prim (zero_loc, "CAR", [], ["@%%"]); - Prim (zero_loc, "PAIR", [], ["%@"; "%"]); - ] )) - -(** Expand "SET_CADR" - into "DUP; DIP {CAR; { CAR; PAIR }}; CDR; SWAP; PAIR" -*) -let test_set_cadr_expansion () = - let set_car = - Seq - ( zero_loc, - [ - Prim (zero_loc, "CAR", [], ["@%%"]); - Prim (zero_loc, "PAIR", [], ["%@"; "%"]); - ] ) - in - assert_expands - (Prim (zero_loc, "SET_CADR", [], [])) - (Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim - ( zero_loc, - "DIP", - [Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); set_car])], - [] ); - Prim (zero_loc, "CDR", [], ["@%%"]); - Prim (zero_loc, "SWAP", [], []); - Prim (zero_loc, "PAIR", [], ["%@"; "%@"]); - ] )) - -(** Expand "SET_CDAR" - into "DUP; DIP {CDR; { CDR; SWAP; PAIR }}; CAR; PAIR" -*) -let test_set_cdar_expansion () = - let set_cdr = - Seq - ( zero_loc, - [ - Prim (zero_loc, "CDR", [], ["@%%"]); - Prim (zero_loc, "SWAP", [], []); - Prim (zero_loc, "PAIR", [], ["%"; "%@"]); - ] ) - in - assert_expands - (Prim (zero_loc, "SET_CDAR", [], [])) - (Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim - ( zero_loc, - "DIP", - [Seq (zero_loc, [Prim (zero_loc, "CDR", [], ["@%%"]); set_cdr])], - [] ); - Prim (zero_loc, "CAR", [], ["@%%"]); - Prim (zero_loc, "PAIR", [], ["%@"; "%@"]); - ] )) - -(* TO BE CHANGE IN THE DOCUMENTATION: @MR!791 - FROM: - > MAP_CAR code => DUP ; CDR ; DIP { CAR ; code } ; SWAP ; PAIR - TO: - > MAP_CAR code => DUP ; CDR ; DIP { CAR ; {code} } ; SWAP ; PAIR -*) - -(** Expand "MAP_CAR {CAR}" - into "DUP; CDR; DIP {CAR; CAR}; SWAP; PAIR" -*) -let test_map_car () = - (* code is a sequence *) - let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in - assert_expands - (Prim (zero_loc, "MAP_CAR", [code], [])) - (Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim (zero_loc, "CDR", [], ["@%%"]); - Prim - ( zero_loc, - "DIP", - [Seq (zero_loc, [Prim (zero_loc, "CAR", [], []); code])], - [] ); - Prim (zero_loc, "SWAP", [], []); - Prim (zero_loc, "PAIR", [], ["%"; "%@"]); - ] )) - -(** Expand "MAP_CDR {CAR}" - into "DUP; CDR; CAR; SWAP; CAR; PAIR" -*) -let test_map_cdr () = - let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in - assert_expands - (Prim (zero_loc, "MAP_CDR", [code], [])) - (Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim (zero_loc, "CDR", [], []); - code; - Prim (zero_loc, "SWAP", [], []); - Prim (zero_loc, "CAR", [], ["@%%"]); - Prim (zero_loc, "PAIR", [], ["%@"; "%"]); - ] )) - -(** Expand "MAP_CAADR {CAR}" - into "DUP; - DIP { CAR; - DUP; - DIP { CAR; - DUP; - CDR; - CAR; - SWAP; - CAR; - PAIR - } - CDR; - SWAP; - PAIR - }; - CDR; - SWAP; - PAIR" -*) -let test_map_caadr () = - let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in - let map_cdr = - Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim (zero_loc, "CDR", [], []); - code; - Prim (zero_loc, "SWAP", [], []); - Prim (zero_loc, "CAR", [], ["@%%"]); - Prim (zero_loc, "PAIR", [], ["%@"; "%"]); - ] ) - in - let map_cadr = - Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim - ( zero_loc, - "DIP", - [Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); map_cdr])], - [] ); - Prim (zero_loc, "CDR", [], ["@%%"]); - Prim (zero_loc, "SWAP", [], []); - Prim (zero_loc, "PAIR", [], ["%@"; "%@"]); - ] ) - in - assert_expands - (Prim (zero_loc, "MAP_CAADR", [code], [])) - (Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim - ( zero_loc, - "DIP", - [Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); map_cadr])], - [] ); - Prim (zero_loc, "CDR", [], ["@%%"]); - Prim (zero_loc, "SWAP", [], []); - Prim (zero_loc, "PAIR", [], ["%@"; "%@"]); - ] )) - -(** Expand "MAP_CDADR" - into "DUP; - DIP { CDR; - DUP; - DIP { CAR; - DUP; - CDR; - CAR; - SWAP; - CAR; - PAIR - }; - CDR; - CAR; - PAIR - }; - CAR; - PAIR" -*) -let test_map_cdadr () = - let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in - let map_cdr = - Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim (zero_loc, "CDR", [], []); - code; - Prim (zero_loc, "SWAP", [], []); - Prim (zero_loc, "CAR", [], ["@%%"]); - Prim (zero_loc, "PAIR", [], ["%@"; "%"]); - ] ) - in - let map_cadr = - Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim - ( zero_loc, - "DIP", - [Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); map_cdr])], - [] ); - Prim (zero_loc, "CDR", [], ["@%%"]); - Prim (zero_loc, "SWAP", [], []); - Prim (zero_loc, "PAIR", [], ["%@"; "%@"]); - ] ) - in - assert_expands - (Prim (zero_loc, "MAP_CDADR", [code], [])) - (Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim - ( zero_loc, - "DIP", - [Seq (zero_loc, [Prim (zero_loc, "CDR", [], ["@%%"]); map_cadr])], - [] ); - Prim (zero_loc, "CAR", [], ["@%%"]); - Prim (zero_loc, "PAIR", [], ["%@"; "%@"]); - ] )) - -(****************************************************************************) -(* Unexpand tests *) -(****************************************************************************) - -(** Asserts that unexpanding the expression [original] conforms with - the canonical form of [ex]. - [unparse.Michelson_v1_parser.unexpanded] contains the original - expression with macros *) -let assert_unexpansion original ex = - let {Michelson_v1_parser.expanded; _}, errors = - let source = to_string (Micheline.strip_locations original) in - Michelson_v1_parser.expand_all ~source ~original - in - let unparse = Michelson_v1_printer.unparse_expression expanded in - match errors with - | [] -> - Assert.equal - ~pp - unparse.Michelson_v1_parser.unexpanded - (Micheline.strip_locations ex) ; - ok () - | _ :: _ -> Error errors - -(** Unexpanding "UNIT; FAILWITH" - yields "FAIL" -*) -let test_unexpand_fail () = - assert_unexpansion - (Seq - ( zero_loc, - [Prim (zero_loc, "UNIT", [], []); Prim (zero_loc, "FAILWITH", [], [])] - )) - (Prim (zero_loc, "FAIL", [], [])) - -(** Unexpanding "IF_LEFT { 1 } { 2 }" - yields "IF_RIGHT { 2 } { 1 }" -*) -let test_unexpand_if_right () = - assert_unexpansion - (Seq - (zero_loc, [Prim (zero_loc, "IF_LEFT", [left_branch; right_branch], [])])) - (Prim (zero_loc, "IF_RIGHT", [right_branch; left_branch], [])) - -(** IF_NONE - Unexpanding "IF_NONE { 1 } { 2 }" - yields "IF_SOME { 2 } { 1 }" -*) -let test_unexpand_if_some () = - assert_unexpansion - (Seq - (zero_loc, [Prim (zero_loc, "IF_NONE", [left_branch; right_branch], [])])) - (Prim (zero_loc, "IF_SOME", [right_branch; left_branch], [])) - -(** Unexpanding "IF {} { UNIT; FAILWITH }" - yields "ASSERT" -*) -let test_unexpand_assert () = - assert_unexpansion - (Seq (zero_loc, [Prim (zero_loc, "IF", fail_false, [])])) - (Prim (zero_loc, "ASSERT", [], [])) - -let assert_unexpansion_assert_if_compare compare_name prim_name = - assert_unexpansion - (Seq - ( zero_loc, - [ - Prim (zero_loc, compare_name, [], []); - Prim (zero_loc, "IF", fail_false, []); - ] )) - (Prim (zero_loc, prim_name, [], [])) - -(** Unexpanding "{EQ|NEQ|LT|LE|GT|GE} ; IF {} {FAIL}" - yields "ASSERT_{EQ|NEQ|LT|LE|GT|GE}" -*) -let test_unexpand_assert_if () = - assert_unexpansion_assert_if_compare "EQ" "ASSERT_EQ" >>? fun () -> - assert_unexpansion_assert_if_compare "NEQ" "ASSERT_NEQ" >>? fun () -> - assert_unexpansion_assert_if_compare "LT" "ASSERT_LT" >>? fun () -> - assert_unexpansion_assert_if_compare "LE" "ASSERT_LE" >>? fun () -> - assert_unexpansion_assert_if_compare "GT" "ASSERT_GT" >>? fun () -> - assert_unexpansion_assert_if_compare "GE" "ASSERT_GE" - -let assert_unexpansion_assert_cmp_if_compare compare_name prim_name = - assert_unexpansion - (Seq - ( zero_loc, - [ - Seq - ( zero_loc, - [ - Prim (zero_loc, "COMPARE", [], []); - Prim (zero_loc, compare_name, [], []); - ] ); - Prim (zero_loc, "IF", fail_false, []); - ] )) - (Prim (zero_loc, prim_name, [], [])) - -(** Unexpanding "COMPARE; {EQ|NEQ|LT|LE|GT|GE}; IF {} {FAIL}" - yields "ASSERT_CMP{EQ|NEQ|LT|LE|GT|GE}" -*) -let test_unexpansion_assert_cmp_if () = - assert_unexpansion_assert_cmp_if_compare "EQ" "ASSERT_CMPEQ" >>? fun () -> - assert_unexpansion_assert_cmp_if_compare "NEQ" "ASSERT_CMPNEQ" >>? fun () -> - assert_unexpansion_assert_cmp_if_compare "LT" "ASSERT_CMPLT" >>? fun () -> - assert_unexpansion_assert_cmp_if_compare "LE" "ASSERT_CMPLE" >>? fun () -> - assert_unexpansion_assert_cmp_if_compare "GT" "ASSERT_CMPGT" >>? fun () -> - assert_unexpansion_assert_cmp_if_compare "GE" "ASSERT_CMPGE" - -(** Unexpanding "IF_NONE { FAIL } { RENAME @annot }" - yields "ASSERT_SOME @annot" -*) -let test_unexpand_assert_some_annot () = - assert_unexpansion - (Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_true_may_rename, [])])) - (Prim (zero_loc, "ASSERT_SOME", [], ["@annot"])) - -(** Unexpanding "IF_LEFT { RENAME @annot } { FAIL }" - yields "ASSERT_LEFT @annot" -*) -let test_unexpand_assert_left_annot () = - assert_unexpansion - (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_false_may_rename, [])])) - (Prim (zero_loc, "ASSERT_LEFT", [], ["@annot"])) - -(** Unexpanding "IF_LEFT { FAIL } { RENAME @annot }" - yields "ASSERT_RIGHT @annot" -*) -let test_unexpand_assert_right_annot () = - assert_unexpansion - (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_true_may_rename, [])])) - (Prim (zero_loc, "ASSERT_RIGHT", [], ["@annot"])) - -(** Unexpanding "IF_NONE {} { FAIL }" - yields "ASSERT_NONE" -*) -let test_unexpand_assert_none () = - assert_unexpansion - (Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_false, [])])) - (Prim (zero_loc, "ASSERT_NONE", [], [])) - -(** Unexpanding "IF_NONE { FAIL } {}" - yields "ASSERT_SOME" -*) -let test_unexpand_assert_some () = - assert_unexpansion - (Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_true, [])])) - (Prim (zero_loc, "ASSERT_SOME", [], [])) - -(** Unexpanding "IF_LEFT {} { FAIL }" - yields "ASSERT_LEFT" -*) -let test_unexpand_assert_left () = - assert_unexpansion - (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_false, [])])) - (Prim (zero_loc, "ASSERT_LEFT", [], [])) - -(** Unexpanding "IF_LEFT { FAIL } {}" - yields "ASSERT_RIGHT" -*) -let test_unexpand_assert_right () = - assert_unexpansion - (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_true, [])])) - (Prim (zero_loc, "ASSERT_RIGHT", [], [])) - -(** Unexpanding "DUP; CAR; DIP { CDR }" - yields "UNPAIR" -*) -let test_unexpand_unpair () = - assert_unexpansion - (Prim (zero_loc, "UNPAIR", [], [])) - (Prim (zero_loc, "UNPAIR", [], [])) - -(** Unexpanding "PAIR" - yields "PAIR" -*) -let test_unexpand_pair () = - assert_unexpansion - (Prim (zero_loc, "PAIR", [], [])) - (Prim (zero_loc, "PAIR", [], [])) - -(** Unexpanding "DIP { PAIR }; DIP { PAIR }; PAIR" - yields "PAPPAIIR" -*) -let test_unexpand_pappaiir () = - assert_unexpansion - (Seq - ( zero_loc, - [ - Prim - ( zero_loc, - "DIP", - [Seq (zero_loc, [Prim (zero_loc, "PAIR", [], [])])], - [] ); - Prim - ( zero_loc, - "DIP", - [Seq (zero_loc, [Prim (zero_loc, "PAIR", [], [])])], - [] ); - Prim (zero_loc, "PAIR", [], []); - ] )) - (Prim (zero_loc, "PAPPAIIR", [], [])) - -(** Unexpanding "DIP { DUP }; SWAP" - yields "DUP 2" -*) -let test_unexpand_duup () = - assert_unexpansion - (Seq - ( zero_loc, - [ - Prim - ( zero_loc, - "DIP", - [Seq (zero_loc, [Prim (zero_loc, "DUP", [], [])])], - [] ); - Prim (zero_loc, "SWAP", [], []); - ] )) - (Prim (zero_loc, "DUP", [Int (zero_loc, Z.of_int 2)], [])) - -(** Unexpanding "CAR" yields "CAR" - Unexpanding "CDR" yields "CDR" - Unexpanding "CAR; CDR" yields "CADR" - Unexpanding "CDR; CAR" yields "CDAR" -*) -let test_unexpand_caddadr () = - let car = Prim (zero_loc, "CAR", [], []) in - let cdr = Prim (zero_loc, "CDR", [], []) in - assert_unexpansion (Seq (zero_loc, [car])) car >>? fun () -> - assert_unexpansion (Seq (zero_loc, [cdr])) cdr >>? fun () -> - assert_unexpansion - (Seq (zero_loc, [car; cdr])) - (Prim (zero_loc, "CADR", [], [])) - >>? fun () -> - assert_unexpansion - (Seq (zero_loc, [cdr; car])) - (Prim (zero_loc, "CDAR", [], [])) - -let test_unexpand_carn_cdrn () = - let car n = Prim (zero_loc, "CAR", [Int (zero_loc, Z.of_int n)], []) in - let cdr n = Prim (zero_loc, "CDR", [Int (zero_loc, Z.of_int n)], []) in - let get n = - Seq (zero_loc, [Prim (zero_loc, "GET", [Int (zero_loc, Z.of_int n)], [])]) - in - assert_unexpansion (get 0) (cdr 0) >>? fun () -> - assert_unexpansion (get 1) (car 0) >>? fun () -> - assert_unexpansion (get 2) (cdr 1) >>? fun () -> - assert_unexpansion (get 3) (car 1) >>? fun () -> - assert_unexpansion (get 4) (cdr 2) - -(** Unexpanding "CDR; SWAP; PAIR" - yields "SET_CAR" -*) -let test_unexpand_set_car () = - assert_unexpansion - (Seq - ( zero_loc, - [ - Prim (zero_loc, "CDR", [], ["@%%"]); - Prim (zero_loc, "SWAP", [], []); - Prim (zero_loc, "PAIR", [], ["%"; "%@"]); - ] )) - (Prim (zero_loc, "SET_CAR", [], [])) - -(** Unexpanding "CAR; PAIR" - yields "SET_CDR" -*) -let test_unexpand_set_cdr () = - assert_unexpansion - (Seq - ( zero_loc, - [ - Prim (zero_loc, "CAR", [], ["@%%"]); - Prim (zero_loc, "PAIR", [], ["%@"; "%"]); - ] )) - (Prim (zero_loc, "SET_CDR", [], [])) - -(** Unexpanding "DUP; CAR; DROP; CDR; SWAP; PAIR" - yields "SET_CAR" -*) -let test_unexpand_set_car_annot () = - assert_unexpansion - (Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim (zero_loc, "CAR", [], ["%@"]); - Prim (zero_loc, "DROP", [], []); - Prim (zero_loc, "CDR", [], []); - Prim (zero_loc, "SWAP", [], []); - Prim (zero_loc, "PAIR", [], []); - ] )) - (Prim (zero_loc, "SET_CAR", [], ["%@"])) - -(** Unexpanding "DUP; CDR; DROP; CAR; PAIR" - yields "SET_CDR" -*) -let test_unexpand_set_cdr_annot () = - assert_unexpansion - (Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim (zero_loc, "CDR", [], ["%@"]); - Prim (zero_loc, "DROP", [], []); - Prim (zero_loc, "CAR", [], []); - Prim (zero_loc, "PAIR", [], []); - ] )) - (Prim (zero_loc, "SET_CDR", [], ["%@"])) - -(** Unexpanding "DUP; DIP { CAR; CAR; PAIR }; CDR; SWAP; PAIR" - yields "SET_CADR" -*) -let test_unexpand_set_cadr () = - let set_car = - Seq - ( zero_loc, - [ - Prim (zero_loc, "CAR", [], ["@%%"]); - Prim (zero_loc, "PAIR", [], ["%@"; "%"]); - ] ) - in - assert_unexpansion - (Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim - ( zero_loc, - "DIP", - [Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); set_car])], - [] ); - Prim (zero_loc, "CDR", [], ["@%%"]); - Prim (zero_loc, "SWAP", [], []); - Prim (zero_loc, "PAIR", [], ["%@"; "%@"]); - ] )) - (Prim (zero_loc, "SET_CADR", [], [])) - -let test_unexpand_set_cdar () = - let set_cdr = - Seq - ( zero_loc, - [ - Prim (zero_loc, "CDR", [], ["@%%"]); - Prim (zero_loc, "SWAP", [], []); - Prim (zero_loc, "PAIR", [], ["%"; "%@"]); - ] ) - in - assert_unexpansion - (Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim - ( zero_loc, - "DIP", - [Seq (zero_loc, [Prim (zero_loc, "CDR", [], ["@%%"]); set_cdr])], - [] ); - Prim (zero_loc, "CAR", [], ["@%%"]); - Prim (zero_loc, "PAIR", [], ["%@"; "%@"]); - ] )) - (Prim (zero_loc, "SET_CDAR", [], [])) - -(* FIXME: Seq()(Prim): does not parse, raise an error unparse *) -let test_unexpand_map_car () = - let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in - assert_unexpansion - (Prim (zero_loc, "MAP_CAR", [code], [])) - (Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim (zero_loc, "CDR", [], ["@%%"]); - Prim - ( zero_loc, - "DIP", - [ - Seq - ( zero_loc, - [ - Prim (zero_loc, "CAR", [], []); - Prim (zero_loc, "CAR", [], []); - ] ); - ], - [] ); - Prim (zero_loc, "SWAP", [], []); - Prim (zero_loc, "PAIR", [], ["%"; "%@"]); - ] )) - -(***********************************************************************) -(*BUG: the test with MAP_CDR or any map with "D" inside fail *) - -let _test_unexpand_map_cdr () = - let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in - assert_unexpansion - (Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim (zero_loc, "CDR", [], []); - code; - Prim (zero_loc, "SWAP", [], []); - Prim (zero_loc, "CAR", [], []); - Prim (zero_loc, "PAIR", [], []); - ] )) - (Prim (zero_loc, "MAP_CDR", [code], [])) - -let _test_unexpand_map_caadr () = - let code = [Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])])] in - let map_cdr = - Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim - ( zero_loc, - "DIP", - [ - Seq - ( zero_loc, - [ - Prim (zero_loc, "CAR", [], ["@%%"]); - Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim (zero_loc, "CDR", [], []); - Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]); - Prim (zero_loc, "SWAP", [], []); - Prim (zero_loc, "CAR", [], ["@%%"]); - Prim (zero_loc, "PAIR", [], ["%@"; "%"]); - ] ); - ] ); - ], - [] ); - Prim (zero_loc, "CDR", [], ["@%%"]); - Prim (zero_loc, "SWAP", [], []); - Prim (zero_loc, "PAIR", [], ["%@"; "%@"]); - ] ) - in - assert_unexpansion - (Prim (zero_loc, "MAP_CAAR", code, [])) - (Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim - ( zero_loc, - "DIP", - [Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); map_cdr])], - [] ); - Prim (zero_loc, "CDR", [], ["@%%"]); - Prim (zero_loc, "SWAP", [], []); - Prim (zero_loc, "PAIR", [], ["%@"; "%@"]); - ] )) - -let _test_unexpand_map_cdadr () = - let code = [Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])])] in - let map_cdr = - Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim - ( zero_loc, - "DIP", - [ - Seq - ( zero_loc, - [ - Prim (zero_loc, "CAR", [], ["@%%"]); - Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim (zero_loc, "CDR", [], []); - Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]); - Prim (zero_loc, "SWAP", [], []); - Prim (zero_loc, "CAR", [], ["@%%"]); - Prim (zero_loc, "PAIR", [], ["%@"; "%"]); - ] ); - ] ); - ], - [] ); - Prim (zero_loc, "CDR", [], ["@%%"]); - Prim (zero_loc, "SWAP", [], []); - Prim (zero_loc, "PAIR", [], ["%@"; "%@"]); - ] ) - in - assert_unexpansion - (Seq - ( zero_loc, - [ - Prim (zero_loc, "DUP", [], []); - Prim - ( zero_loc, - "DIP", - [Seq (zero_loc, [Prim (zero_loc, "CDR", [], ["@%%"]); map_cdr])], - [] ); - Prim (zero_loc, "CAR", [], ["@%%"]); - Prim (zero_loc, "PAIR", [], ["%@"; "%@"]); - ] )) - (Prim (zero_loc, "MAP_CDADR", code, [])) - -let test_unexpand_diip () = - let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in - assert_unexpansion - (Prim (zero_loc, "DIIP", [code], [])) - (Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 2); code], [])) - -(** Unexpanding "DIP { DIP { DIP { DUP }; SWAP" - yields "DIIP { DIP { DUP }; SWAP }" -*) -let test_unexpand_diip_duup1 () = - let single code = Seq (zero_loc, [code]) in - let cst str = Prim (zero_loc, str, [], []) in - let app str code = Prim (zero_loc, str, [code], []) in - let dip = app "DIP" in - let diip code = - Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 2); code], []) - in - let dup = cst "DUP" in - let swap = cst "SWAP" in - let dip_dup_swap = Seq (zero_loc, [dip (single dup); swap]) in - assert_unexpansion - (* { DIP { DIP { DIP { DUP }; SWAP }}} *) - (single (dip (single (dip dip_dup_swap)))) - (* DIIP { DIP { DUP }; SWAP } *) - (diip dip_dup_swap) - -(** Unexpanding "DIP { DIP {{ DIP { DUP }; SWAP" - yields "DIIP { DUUP }" -*) -let test_unexpand_diip_duup2 () = - let single code = Seq (zero_loc, [code]) in - let cst str = Prim (zero_loc, str, [], []) in - let app str code = Prim (zero_loc, str, [code], []) in - let dip = app "DIP" in - let diip code = - Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 2); code], []) - in - let dup = cst "DUP" in - let duup = Prim (zero_loc, "DUP", [Int (zero_loc, Z.of_int 2)], []) in - let swap = cst "SWAP" in - let dip_dup_swap = Seq (zero_loc, [dip (single dup); swap]) in - assert_unexpansion - (* { DIP { DIP {{ DIP { DUP }; SWAP }}}} *) - (single (dip (single (dip (single dip_dup_swap))))) - (* DIIP { DUUP } *) - (diip (single duup)) - -(*****************************************************************************) -(* Test *) -(*****************************************************************************) - -let tests = - [ - (*compare*) - ("compare expansion", fun _ -> Lwt.return (test_compare_marco_expansion ())); - ( "if compare expansion", - fun _ -> Lwt.return (test_if_compare_macros_expansion ()) ); - ( "if compare expansion: IFCMP", - fun _ -> Lwt.return (test_if_cmp_macros_expansion ()) ); - (*fail*) - ("fail expansion", fun _ -> Lwt.return (test_fail_expansion ())); - (*assertion*) - ("assert expansion", fun _ -> Lwt.return (test_assert_expansion ())); - ("assert if expansion", fun _ -> Lwt.return (test_assert_if ())); - ("assert cmpif expansion", fun _ -> Lwt.return (test_assert_cmp_if ())); - ("assert none expansion", fun _ -> Lwt.return (test_assert_none ())); - ("assert some expansion", fun _ -> Lwt.return (test_assert_some ())); - ("assert left expansion", fun _ -> Lwt.return (test_assert_left ())); - ("assert right expansion", fun _ -> Lwt.return (test_assert_right ())); - ( "assert some annot expansion", - fun _ -> Lwt.return (test_assert_some_annot ()) ); - ( "assert left annot expansion", - fun _ -> Lwt.return (test_assert_left_annot ()) ); - ( "assert right annot expansion", - fun _ -> Lwt.return (test_assert_right_annot ()) ); - (*syntactic conveniences*) - ("diip expansion", fun _ -> Lwt.return (test_diip ())); - ("duup expansion", fun _ -> Lwt.return (test_duup ())); - ("pair expansion", fun _ -> Lwt.return (test_pair ())); - ("pappaiir expansion", fun _ -> Lwt.return (test_pappaiir ())); - ("unpair expansion", fun _ -> Lwt.return (test_unpair ())); - ("caddadr expansion", fun _ -> Lwt.return (test_caddadr_expansion ())); - ( "carn and cdrn expansion", - fun _ -> Lwt.return (test_carn_cdrn_expansion ()) ); - ("if_some expansion", fun _ -> Lwt.return (test_if_some ())); - ("set_car expansion", fun _ -> Lwt.return (test_set_car_expansion ())); - ("set_cdr expansion", fun _ -> Lwt.return (test_set_cdr_expansion ())); - ("set_cadr expansion", fun _ -> Lwt.return (test_set_cadr_expansion ())); - ("set_cdar expansion", fun _ -> Lwt.return (test_set_cdar_expansion ())); - ("map_car expansion", fun _ -> Lwt.return (test_map_car ())); - ("map_cdr expansion", fun _ -> Lwt.return (test_map_cdr ())); - ("map_caadr expansion", fun _ -> Lwt.return (test_map_caadr ())); - ("map_cdadr expansion", fun _ -> Lwt.return (test_map_cdadr ())); - (*Unexpand*) - ("fail unexpansion", fun _ -> Lwt.return (test_unexpand_fail ())); - ("if_right unexpansion", fun _ -> Lwt.return (test_unexpand_if_right ())); - ("if_some unexpansion", fun _ -> Lwt.return (test_unexpand_if_some ())); - ("assert unexpansion", fun _ -> Lwt.return (test_unexpand_assert ())); - ("assert_if unexpansion", fun _ -> Lwt.return (test_unexpand_assert_if ())); - ( "assert_cmp_if unexpansion", - fun _ -> Lwt.return (test_unexpansion_assert_cmp_if ()) ); - ( "assert_none unexpansion", - fun _ -> Lwt.return (test_unexpand_assert_none ()) ); - ( "assert_some unexpansion", - fun _ -> Lwt.return (test_unexpand_assert_some ()) ); - ( "assert_left unexpansion", - fun _ -> Lwt.return (test_unexpand_assert_left ()) ); - ( "assert_right unexpansion", - fun _ -> Lwt.return (test_unexpand_assert_right ()) ); - ( "assert_some annot unexpansion", - fun _ -> Lwt.return (test_unexpand_assert_some_annot ()) ); - ( "assert_left annot unexpansion", - fun _ -> Lwt.return (test_unexpand_assert_left_annot ()) ); - ( "assert_right annot unexpansion", - fun _ -> Lwt.return (test_unexpand_assert_right_annot ()) ); - ("unpair unexpansion", fun _ -> Lwt.return (test_unexpand_unpair ())); - ("pair unexpansion", fun _ -> Lwt.return (test_unexpand_pair ())); - ("pappaiir unexpansion", fun _ -> Lwt.return (test_unexpand_pappaiir ())); - ("duup unexpansion", fun _ -> Lwt.return (test_unexpand_duup ())); - ("caddadr unexpansion", fun _ -> Lwt.return (test_unexpand_caddadr ())); - ( "carn and cdrn unexpansion", - fun _ -> Lwt.return (test_unexpand_carn_cdrn ()) ); - ("set_car unexpansion", fun _ -> Lwt.return (test_unexpand_set_car ())); - ("set_cdr unexpansion", fun _ -> Lwt.return (test_unexpand_set_cdr ())); - ("set_cdar unexpansion", fun _ -> Lwt.return (test_unexpand_set_cdar ())); - ("set_cadr unexpansion", fun _ -> Lwt.return (test_unexpand_set_cadr ())); - ( "set_car annot unexpansion", - fun _ -> Lwt.return (test_unexpand_set_car_annot ()) ); - ( "set_cdr annot unexpansion", - fun _ -> Lwt.return (test_unexpand_set_cdr_annot ()) ); - ("map_car unexpansion", fun _ -> Lwt.return (test_unexpand_map_car ())); - ("diip unexpansion", fun _ -> Lwt.return (test_unexpand_diip ())); - ("diip_duup1 unexpansion", fun _ -> Lwt.return (test_unexpand_diip_duup1 ())); - ("diip_duup2 unexpansion", fun _ -> Lwt.return (test_unexpand_diip_duup2 ())) - (***********************************************************************) - (*BUG - the function in Michelson_v1_macros.unexpand_map_caddadr - failed to test the case with the character "D". - It returns an empty {} for the expand *) - (*"diip unexpansion", (fun _ -> Lwt.return (test_unexpand_diip ())) ;*) - (*"map_cdr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_cdr ())) ;*) - (*"map_caadr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_caadr ())) ;*) - (*"map_cdadr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_cdadr ())) ;*); - ] - -let wrap (n, f) = - Alcotest_lwt.test_case n `Quick (fun _ () -> - f () >>= function - | Ok () -> Lwt.return_unit - | Error error -> - Format.kasprintf Stdlib.failwith "%a" pp_print_trace error) - -let () = - Alcotest_lwt.run - ~__FILE__ - Protocol.name - [("micheline v1 macros", List.map wrap tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_client/test/test_proxy.ml b/src/proto_017_PtNairob/lib_client/test/test_proxy.ml deleted file mode 100644 index 99dc1e584eb8200db1d7bfd00abc3ca4aefd41be..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_client/test/test_proxy.ml +++ /dev/null @@ -1,90 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Client - Invocation: dune exec src/proto_017_PtNairob/lib_client/test/main.exe \ - -- --file test_proxy.ml - Subject: Test of --mode proxy and tezos-proxy-server heuristic -*) - -let proxy_mode_gen = QCheck2.Gen.oneofl Tezos_proxy.Proxy.[Client; Server] - -let key_gen = - (* Segments taken from the implementation of split_key in src/proto_alpha/lib_client/proxy.ml *) - let keys = - QCheck2.Gen.oneofl - [ - "big_maps"; - "index"; - "contents"; - "contracts"; - "cycle"; - "cycle"; - "rolls"; - "owner"; - "snapshot"; - "v1"; - ] - |> QCheck2.Gen.list - in - QCheck2.Gen.frequency QCheck2.Gen.[(9, keys); (1, list string)] - -(** Whether [t1] is a prefix of [t2] *) -let rec is_prefix t1 t2 = - match (t1, t2) with - | [], _ -> true - | _, [] -> false - | x1 :: rest1, x2 :: rest2 when x1 = x2 -> is_prefix rest1 rest2 - | _ -> false - -let test_split_key = - let fmt = - let pp_sep fmt () = Format.fprintf fmt "/" in - Format.pp_print_list ~pp_sep Format.pp_print_string - in - QCheck2.Test.make - ~name:"[fst (split_key s)] is a prefix of [s]" - QCheck2.Gen.(pair proxy_mode_gen key_gen) - @@ fun (mode, key) -> - match Proxy.ProtoRpc.split_key mode key with - | None -> true - | Some (shorter, _) -> - if is_prefix shorter key then true - else - QCheck2.Test.fail_reportf - "Expected result of split_key to be a prefix of the input key. But \ - %a is not a prefix of %a." - fmt - shorter - fmt - key - -let () = - Alcotest.run - ~__FILE__ - Protocol.name - [("proxy", Qcheck2_helpers.qcheck_wrap [test_split_key])] diff --git a/src/proto_017_PtNairob/lib_dac_plugin/dac_plugin_registration.ml b/src/proto_017_PtNairob/lib_dac_plugin/dac_plugin_registration.ml deleted file mode 100644 index e7a6f4860ca6987d75e1036a7ff4cb16b38b9170..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_dac_plugin/dac_plugin_registration.ml +++ /dev/null @@ -1,105 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* Copyright (c) 2023 TriliTech, *) -(* *) -(* 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 Make (Mapper : sig - val of_bytes : bytes -> Dac_plugin.hash -end) : Dac_plugin.T = struct - let to_bytes = Dac_plugin.hash_to_bytes - - let to_reveal_hash dac_hash = - dac_hash |> to_bytes - |> Data_encoding.Binary.of_bytes_exn Protocol.Sc_rollup_reveal_hash.encoding - - let of_reveal_hash reveal_hash = - reveal_hash - |> Data_encoding.Binary.to_bytes_exn Protocol.Sc_rollup_reveal_hash.encoding - |> Mapper.of_bytes - - let of_hex hex = - Protocol.Sc_rollup_reveal_hash.of_hex hex |> Option.map of_reveal_hash - - let to_hex hash = to_reveal_hash hash |> Protocol.Sc_rollup_reveal_hash.to_hex - - let encoding = - let binary = - Data_encoding.conv - to_reveal_hash - of_reveal_hash - Protocol.Sc_rollup_reveal_hash.encoding - in - Data_encoding.( - (* Hexifies the hash when encoding in json. *) - splitted - ~binary - ~json: - (conv_with_guard - to_hex - (fun str -> - Result.of_option ~error:"Not a valid hash" (of_hex str)) - (string' Plain))) - - let equal h1 h2 = - Protocol.Sc_rollup_reveal_hash.equal (to_reveal_hash h1) (to_reveal_hash h2) - - let dac_hash_to_proto_supported_hashes = function - | Dac_plugin.Blake2B -> Protocol.Sc_rollup_reveal_hash.Blake2B - - let proto_to_dac_hash_supported_hashes = function - | Protocol.Sc_rollup_reveal_hash.Blake2B -> Dac_plugin.Blake2B - - let hash_string ~(scheme : Dac_plugin.supported_hashes) ?key strings = - Protocol.Sc_rollup_reveal_hash.hash_string - ~scheme:(dac_hash_to_proto_supported_hashes scheme) - ?key - strings - |> of_reveal_hash - - let hash_bytes ~(scheme : Dac_plugin.supported_hashes) ?key bytes = - Protocol.Sc_rollup_reveal_hash.hash_bytes - ~scheme:(dac_hash_to_proto_supported_hashes scheme) - ?key - bytes - |> of_reveal_hash - - let scheme_of_hash hash = - to_reveal_hash hash |> Protocol.Sc_rollup_reveal_hash.scheme_of_hash - |> proto_to_dac_hash_supported_hashes - - let size ~scheme = - Protocol.Sc_rollup_reveal_hash.size - ~scheme:(dac_hash_to_proto_supported_hashes scheme) - - module Proto = Registerer.Registered -end - -let make_plugin : (bytes -> Dac_plugin.hash) -> (module Dac_plugin.T) = - fun of_bytes -> - let module Plugin = Make (struct - let of_bytes = of_bytes - end) in - (module Plugin) - -let () = Dac_plugin.register make_plugin diff --git a/src/proto_017_PtNairob/lib_dac_plugin/dune b/src/proto_017_PtNairob/lib_dac_plugin/dune deleted file mode 100644 index ab548602e292d5a38d7811cc976b46a03130ddef..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_dac_plugin/dune +++ /dev/null @@ -1,30 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name tezos_dac_017_PtNairob) - (public_name octez-protocol-017-PtNairob-libs.dac) - (instrumentation (backend bisect_ppx)) - (libraries - octez-libs.base - octez-protocol-compiler.registerer - octez-libs.stdlib-unix - tezos-dac-lib - tezos-dac-client-lib - octez-protocol-017-PtNairob-libs.client - tezos-protocol-017-PtNairob.embedded-protocol - tezos-protocol-017-PtNairob.protocol) - (inline_tests (flags -verbose) (modes native)) - (preprocess (pps ppx_expect)) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_protocol_registerer - -open Tezos_stdlib_unix - -open Tezos_dac_lib - -open Tezos_dac_client_lib - -open Tezos_client_017_PtNairob - -open Tezos_embedded_protocol_017_PtNairob - -open Tezos_protocol_017_PtNairob)) diff --git a/src/proto_017_PtNairob/lib_dac_plugin/test/dune b/src/proto_017_PtNairob/lib_dac_plugin/test/dune deleted file mode 100644 index cd3da527cff4890bcde0bdd1d77dd2978886cfa7..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_dac_plugin/test/dune +++ /dev/null @@ -1,52 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name src_proto_017_PtNairob_lib_dac_plugin_test_tezt_lib) - (instrumentation (backend bisect_ppx)) - (libraries - tezt.core - octez-libs.base - octez-protocol-017-PtNairob-libs.dac - tezos-protocol-017-PtNairob.protocol - octez-libs.base-test-helpers - octez-protocol-017-PtNairob-libs.test-helpers - tezos-dac-lib - tezos_dac_node_lib - octez-alcotezt) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezt_core - -open Tezt_core.Base - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_dac_017_PtNairob - -open Tezos_protocol_017_PtNairob - -open Tezos_base_test_helpers - -open Tezos_017_PtNairob_test_helpers - -open Tezos_dac_lib - -open Tezos_dac_node_lib - -open Octez_alcotezt) - (modules test_dac_pages_encoding test_dac_plugin_registration test_helpers)) - -(executable - (name main) - (instrumentation (backend bisect_ppx --bisect-sigterm)) - (libraries - src_proto_017_PtNairob_lib_dac_plugin_test_tezt_lib - tezt) - (link_flags - (:standard) - (:include %{workspace_root}/macos-link-flags.sexp)) - (modules main)) - -(rule - (alias runtest) - (package octez-protocol-017-PtNairob-libs) - (enabled_if (<> false %{env:RUNTEZTALIAS=true})) - (action (run %{dep:./main.exe}))) - -(rule - (targets main.ml) - (action (with-stdout-to %{targets} (echo "let () = Tezt.Test.run ()")))) diff --git a/src/proto_017_PtNairob/lib_dac_plugin/test/test_dac_pages_encoding.ml b/src/proto_017_PtNairob/lib_dac_plugin/test/test_dac_pages_encoding.ml deleted file mode 100644 index 814efbb706bb8e12a874c8cc74cfd717a7da243d..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_dac_plugin/test/test_dac_pages_encoding.ml +++ /dev/null @@ -1,593 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022-2023 Trili Tech *) -(* Copyright (c) 2023 Marigold, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Dal_node Slot_frame_encoding - Invocation: dune exec src/proto_017_PtNairob/lib_dac_plugin/test/main.exe \ - -- --file test_dac_pages_encoding.ml - Subject: Tests for the SCORU storage module -*) - -(** DAC/FIXME: https://gitlab.com/tezos/tezos/-/issues/4021 - Add tests to check actual (sequences of) bytes in serialized pages. *) - -(* Tests are run against a mock storage backend where a Hash-indexed/Bytes-valued Map - is used to simulate adding and retrieving files to a directory. -*) - -(** TODO: https://gitlab.com/tezos/tezos/-/issues/4855 - Move tests to libdac_node/test -*) -let dac_plugin = Stdlib.Option.get (Dac_plugin.get Protocol.hash) - -module Hashes_map = Map.Make (struct - type t = Dac_plugin.hash - - let compare h1 h2 = Dac_plugin.raw_compare h1 h2 -end) - -type hashes_map = bytes Hashes_map.t - -let long_payload = - (* Inferno, Canto I (Dante Alighieri). Size in bytes: 5226. *) - {|Nel mezzo del cammin di nostra vita -mi ritrovai per una selva oscura -ché la diritta via era smarrita. -Ahi quanto a dir qual era è cosa dura -esta selva selvaggia e aspra e forte -che nel pensier rinova la paura! -Tant’è amara che poco è più morte; -ma per trattar del ben ch’i’ vi trovai, -dirò de l’altre cose ch’i’ v’ho scorte. -Io non so ben ridir com’i’ v’intrai, -tant’era pien di sonno a quel punto -che la verace via abbandonai. -Ma poi ch’i’ fui al piè d’un colle giunto, -là dove terminava quella valle -che m’avea di paura il cor compunto, -guardai in alto, e vidi le sue spalle -vestite già de’ raggi del pianeta -che mena dritto altrui per ogne calle. -Allor fu la paura un poco queta -che nel lago del cor m’era durata -la notte ch’i’ passai con tanta pieta. -E come quei che con lena affannata -uscito fuor del pelago a la riva -si volge a l’acqua perigliosa e guata, -così l’animo mio, ch’ancor fuggiva, -si volse a retro a rimirar lo passo -che non lasciò già mai persona viva. -Poi ch’èi posato un poco il corpo lasso, -ripresi via per la piaggia diserta, -sì che ’l piè fermo sempre era ’l più basso. -Ed ecco, quasi al cominciar de l’erta, -una lonza leggera e presta molto, -che di pel macolato era coverta; -e non mi si partia dinanzi al volto, -anzi ’mpediva tanto il mio cammino, -ch’i’ fui per ritornar più volte vòlto. -Temp’era dal principio del mattino, -e ’l sol montava ’n sù con quelle stelle -ch’eran con lui quando l’amor divino -mosse di prima quelle cose belle; -sì ch’a bene sperar m’era cagione -di quella fiera a la gaetta pelle -l’ora del tempo e la dolce stagione; -ma non sì che paura non mi desse -la vista che m’apparve d’un leone. -Questi parea che contra me venisse -con la test’alta e con rabbiosa fame, -sì che parea che l’aere ne tremesse. -Ed una lupa, che di tutte brame -sembiava carca ne la sua magrezza, -e molte genti fé già viver grame, -questa mi porse tanto di gravezza -con la paura ch’uscia di sua vista, -ch’io perdei la speranza de l’altezza. -E qual è quei che volontieri acquista, -e giugne ’l tempo che perder lo face, -che ’n tutt’i suoi pensier piange e s’attrista; -tal mi fece la bestia sanza pace, -che, venendomi ’ncontro, a poco a poco -mi ripigneva là dove ’l sol tace. -Mentre ch’i’ rovinava in basso loco, -dinanzi a li occhi mi si fu offerto -chi per lungo silenzio parea fioco. -Quando vidi costui nel gran diserto, -«Miserere di me», gridai a lui, -«qual che tu sii, od ombra od omo certo!». -Rispuosemi: «Non omo, omo già fui, -e li parenti miei furon lombardi, -mantoani per patria ambedui. -Nacqui sub Iulio, ancor che fosse tardi, -e vissi a Roma sotto ’l buono Augusto -nel tempo de li dèi falsi e bugiardi. -Poeta fui, e cantai di quel giusto -figliuol d’Anchise che venne di Troia, -poi che ’l superbo Ilión fu combusto. -Ma tu perché ritorni a tanta noia? -perché non sali il dilettoso monte -ch’è principio e cagion di tutta gioia?». -«Or se’ tu quel Virgilio e quella fonte -che spandi di parlar sì largo fiume?», -rispuos’io lui con vergognosa fronte. -«O de li altri poeti onore e lume -vagliami ’l lungo studio e ’l grande amore -che m’ha fatto cercar lo tuo volume. -Tu se’ lo mio maestro e ’l mio autore; -tu se’ solo colui da cu’ io tolsi -lo bello stilo che m’ha fatto onore. -Vedi la bestia per cu’ io mi volsi: -aiutami da lei, famoso saggio, -ch’ella mi fa tremar le vene e i polsi». -«A te convien tenere altro viaggio», -rispuose poi che lagrimar mi vide, -«se vuo’ campar d’esto loco selvaggio: -ché questa bestia, per la qual tu gride, -non lascia altrui passar per la sua via, -ma tanto lo ’mpedisce che l’uccide; -e ha natura sì malvagia e ria, -che mai non empie la bramosa voglia, -e dopo ’l pasto ha più fame che pria. -Molti son li animali a cui s’ammoglia, -e più saranno ancora, infin che ’l veltro -verrà, che la farà morir con doglia. -Questi non ciberà terra né peltro, -ma sapienza, amore e virtute, -e sua nazion sarà tra feltro e feltro. -Di quella umile Italia fia salute -per cui morì la vergine Cammilla, -Eurialo e Turno e Niso di ferute. -Questi la caccerà per ogne villa, -fin che l’avrà rimessa ne lo ’nferno, -là onde ’nvidia prima dipartilla. -Ond’io per lo tuo me’ penso e discerno -che tu mi segui, e io sarò tua guida, -e trarrotti di qui per loco etterno, -ove udirai le disperate strida, -vedrai li antichi spiriti dolenti, -ch’a la seconda morte ciascun grida; -e vederai color che son contenti -nel foco, perché speran di venire -quando che sia a le beate genti. -A le quai poi se tu vorrai salire, -anima fia a ciò più di me degna: -con lei ti lascerò nel mio partire; -ché quello imperador che là sù regna, -perch’i’ fu’ ribellante a la sua legge, -non vuol che ’n sua città per me si vegna. -In tutte parti impera e quivi regge; -quivi è la sua città e l’alto seggio: -oh felice colui cu’ ivi elegge!». -E io a lui: «Poeta, io ti richeggio -per quello Dio che tu non conoscesti, -acciò ch’io fugga questo male e peggio, -che tu mi meni là dov’or dicesti, -sì ch’io veggia la porta di san Pietro -e color cui tu fai cotanto mesti». -Allor si mosse, e io li tenni dietro.|} - -module Hashes_map_backend = struct - type t = bytes Hashes_map.t ref - - type configuration = unit - - type hash = Dac_plugin.hash - - let init () = ref Hashes_map.empty - - type error += Page_is_missing of Dac_plugin.raw_hash - - let save (_plugin : Dac_plugin.t) t ~(hash : Dac_plugin.hash) ~content = - let open Lwt_result_syntax in - let () = t := Hashes_map.add hash content !t in - return () - - let mem (_plugin : Dac_plugin.t) t (hash : Dac_plugin.hash) = - Lwt_result_syntax.return @@ Hashes_map.mem hash !t - - let load (_plugin : Dac_plugin.t) t hash = - let open Lwt_result_syntax in - let bytes = Hashes_map.find hash !t in - match bytes with - | None -> tzfail @@ Page_is_missing (Dac_plugin.hash_to_raw hash) - | Some bytes -> return bytes - - let number_of_pages t = List.length @@ Hashes_map.bindings !t -end - -(* Page store implementation that uses two in-memory stores (p1, p2). - Data is loaded from (p2) if present in such a store, otherwise it - is fetched from (p1) and, if the contents of the page are valid - with respect to the hash provided, then it is saved to p2. - Otherwise, an error is returned. -*) - -module With_hash_check : - Page_store.S with type configuration = unit and type t = Hashes_map_backend.t = - Page_store.Internal_for_tests.With_data_integrity_check (Hashes_map_backend) - -module Double_hash_map_backend : - Page_store.S - with type configuration = Hashes_map_backend.t * Hashes_map_backend.t = - Page_store.Internal_for_tests.With_remote_fetch - (struct - type remote_context = Hashes_map_backend.t - - let fetch = Hashes_map_backend.load - end) - (With_hash_check) - -let assert_equal_bytes ~loc msg a b = - Assert.equal ~loc Bytes.equal msg String.pp_bytes_hex a b - -let assert_fails_with ~loc k expected_err = - let open Lwt_result_syntax in - let*! res = k in - Assert.error ~loc res (( = ) expected_err) - -module Merkle_tree = struct - open Pages_encoding.Merkle_tree - - module Make_V0_for_test (C : Pages_encoding.CONFIG) (S : Page_store.S) = - struct - module Buffered = - Internal_for_tests.Make_buffered - (S) - (struct - let content_version = 0 - - let hashes_version = 0 - end) - (C) - - include Internal_for_tests.Make (Buffered) - end - - module V0 = struct - let test_serialization_fails_with ~loc ~max_page_size ~payload ~error = - let open - Make_V0_for_test - (struct - let max_page_size = max_page_size - end) - (Hashes_map_backend) in - let page_store = Hashes_map_backend.init () in - let serialize_payload = - serialize_payload dac_plugin ~page_store payload - in - assert_fails_with ~loc serialize_payload error - - let test_serialization_roundtrip ?expect_num_of_pages ~loc ~max_page_size - payload = - let open - Make_V0_for_test - (struct - let max_page_size = max_page_size - end) - (Hashes_map_backend) in - let page_store = Hashes_map_backend.init () in - let open Lwt_result_syntax in - let* hash = serialize_payload dac_plugin ~page_store payload in - let* retrieved_payload = - deserialize_payload dac_plugin ~page_store hash - in - let* () = - match expect_num_of_pages with - | Some expected -> - let actual = Hashes_map_backend.number_of_pages page_store in - Assert.equal_int ~loc actual expected - | None -> return_unit - in - assert_equal_bytes - ~loc - "Deserialized payload do not match with original" - payload - retrieved_payload - - (* We use 50 bytes as the size of a page. Of these, 5 bytes are used for - the preamble, which leaves 45 bytes of space for storing hashes in a - page. The overall size of a hash is 33 bytes (32 bytes for the inner hash - plus 1 byte for the tag identifying the hashing scheme of the hash), - therefore only floor(45/33) = 1 hashes can be stored for each page. - Because the serialization process requires a page size that can contain - at least two hashes, the serialization of any content will fail in this case. - *) - let serialize_one_hash_per_page_fails () = - let payload = - List.repeat 195 (Bytes.of_string "a") |> Bytes.concat Bytes.empty - in - test_serialization_fails_with - ~loc:__LOC__ - ~max_page_size:50 - ~payload - ~error:(Pages_encoding.Merkle_tree_branching_factor_not_high_enough 1) - - let serialize_empty_payload_fails () = - (* Limit the number of hashes stored per page to 2. Because hashes - have a fixed size of 33 bytes (32 bytes for inner hash and 1 byte for - hashing sheme tag of the hash), and 5 bytes are used for the preamble, - we need 33 * 2 + 5 = 71 bytes to store two hashes in a page. We round - this value to 80. *) - test_serialization_fails_with - ~loc:__LOC__ - ~max_page_size:80 - ~payload:Bytes.empty - ~error:Pages_encoding.Payload_cannot_be_empty - - let one_page_roundtrip () = - (* Limit the number of hashes stored per page to 2. Because hashes - have a fixed size of 33 bytes (32 bytes for inner hash and 1 byte for - hashing sheme tag of the hash), and 5 bytes are used for the preamble, - we need 33 * 2 + 5 = 71 bytes to store two hashes in a page. We round - this value to 80. *) - let max_page_size = 80 in - let payload = Bytes.of_string "Hello payload" in - test_serialization_roundtrip - ~expect_num_of_pages:1 - ~loc:__LOC__ - ~max_page_size - payload - - let multiple_pages_roundtrip_heterogeneous_payload () = - (* Each page in tests contains at most 80 bytes, of which 5 are reserved - for the page prefix. This leaves 75 bytes to store the payload to be - serialized in a page. It also means that a `Hashes` page can contain - at most 2 hashes of size 33 bytes each (32 bytes for inner hash and 1 - byte for hashing sheme tag of the hash). If we try to serialize a - payload between 151 and 225 bytes (included), then the serialized - payload should be spread among a total of 6 pages. Of these, - 225/75 = 3 pages are used to store the payload, ceil(3/2) = 2 pages - are used for storing the 3 hashes of the 3 payload pages, and - ceil(2/2) = 1 page is used for storing the 2 hashes of the previous - pages. *) - let max_page_size = 80 in - let payload = - Bytes.of_string - "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do \ - eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim \ - ad minim veniam, quis nostrud exercitation ullamco" - in - test_serialization_roundtrip - ~expect_num_of_pages:6 - ~loc:__LOC__ - ~max_page_size - payload - - let deserialization_of_corrupt_data_with_hash_integrity_check_fails () = - let open Lwt_result_syntax in - let module Page_size = struct - let max_page_size = 80 - end in - let module Mock_remote_codec = - Make_V0_for_test (Page_size) (Hashes_map_backend) - in - let module Mock_synch_codec = - Make_V0_for_test - (struct - let max_page_size = 80 - end) - (Double_hash_map_backend) - in - let mock_remote_store = Hashes_map_backend.init () in - let mock_local_store = Hashes_map_backend.init () in - let page_store = - Double_hash_map_backend.init (mock_remote_store, mock_local_store) - in - let payload = - Bytes.of_string "This is a payload that will be tampered later on" - in - let corrupt_payload = - Bytes.of_string "This is the payload that has been tampered with" - in - let* root_hash = - Mock_remote_codec.serialize_payload - dac_plugin - ~page_store:mock_remote_store - payload - in - (* We save the corrupt payload in the store and then retrieve it again, - to be sure that the content corresponds to a valid page. Then we - update the content of the original (non corrupt) payload in the store - to the (serialized) corrupt payload. *) - let* root_hash_of_corrupt_payload = - Mock_remote_codec.serialize_payload - dac_plugin - ~page_store:mock_remote_store - corrupt_payload - in - let* serialised_corrupt_payload = - Hashes_map_backend.load - dac_plugin - mock_remote_store - root_hash_of_corrupt_payload - in - let* () = - Hashes_map_backend.save - dac_plugin - mock_remote_store - ~hash:root_hash - ~content:serialised_corrupt_payload - in - let* () = - assert_fails_with - ~loc:__LOC__ - (Mock_synch_codec.deserialize_payload - dac_plugin - ~page_store - root_hash) - (Page_store.Incorrect_page_hash - { - expected = Dac_plugin.hash_to_raw root_hash; - actual = Dac_plugin.hash_to_raw root_hash_of_corrupt_payload; - }) - in - (* Check that pages have not been copied from the remote mock store - to the local one. *) - Assert.equal_int - ~loc:__LOC__ - (Hashes_map_backend.number_of_pages mock_local_store) - 0 - - let multiple_pages_roundtrip_homogeneous_payload () = - (* Each page in tests contains at most 80 bytes, of which 5 are reserved - for the page prefix. This leaves 75 bytes to store the content to be - serialized in a page. It also means that a `Hashes` page can contain - at most 2 hashes of size 33 bytes each (32 bytes for inner hash and 1 - byte for hashing sheme tag of the hash). If we try to serialize a - payload of 225 repetitions of the same character, then only one - payload page will be produced. However, the hash of this page will be - repeated three times across two pages represent nodes of the Merkle - tree. Finally, another page will be used for storing the Merkle tree - root page, which contains the two hashes of the Merkle tree nodes - above. In total, the serialization should be spread among 4 pages. *) - let max_page_size = 80 in - let payload = - List.repeat 225 (Bytes.of_string "a") |> Bytes.concat Bytes.empty - in - test_serialization_roundtrip - ~expect_num_of_pages:4 - ~loc:__LOC__ - ~max_page_size - payload - - let multiple_pages_roundtrip_do_not_exceed_page_size () = - (* Check that a bug related to the size of hashes has been fixed. - Before the bug was fixed: the `Sc_rollup.Reveal_hash` module borrowed - the size function from the underlying hash module, meaning that it - would return `31` for the size, rather than the actual hash size - which is `32`. For a page that is exactly `98` bytes long, this would - mean that the serialization algorithm will compute the number of - hashes per page to be `(98-5)/31 = 3`, but the actual hash pages will - have size `32 * 3 + 5 = 101` bytes. This will cause the check on a page - size to fail, when serializing a page. With 98 bytes per page, 93 - bytes will be reserved for the payload in content pages. - Before the patch was applied, trying to - serialize a payload of `93 * 3 = 279` bytes with a page size of - 98 bytes would have caused to try to serialize a page containing - 3 hashes of 32 bytes each, resulting in a page of `101 bytes` and - causing the serialization to fail. - *) - let max_page_size = 98 in - (* 279 bytes of payload *) - let payload = - Bytes.of_string - "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do \ - eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim \ - ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut \ - aliquip ex ea commodo consequat. Duis aute irure dolor in \ - reprehenderit in volup" - in - test_serialization_roundtrip ~loc:__LOC__ ~max_page_size payload - - let long_content_roundtrip () = - (* To ensure that the serialization and deserialization process work as - expected, we test a roundtrip for a reasonably long text. We also - increase the page size to allow for more than two hashes in a page. *) - (* The page size is set to 150. Of these, 5 bytes are used for the page - preamble, and the reset will contain hashes which are 32 bytes long - each. The number of hashes that can fit into a page is - floor((150 - 5)/32) = 4. *) - let max_page_size = 150 in - let payload = Bytes.of_string long_payload in - test_serialization_roundtrip ~loc:__LOC__ ~max_page_size payload - - (* TODO: https://gitlab.com/tezos/tezos/-/issues/4608 - Define helper function that calculates expected number of pages given the - payload and use it for PBT expected number of pages given payload *) - module PBT = struct - open QCheck2.Gen - - (* Serialization requires [~max_page_size] that guarantees at least two - hashes per page. In orher words, we need at least 71 bytes in total since - 5 bytes is used as a preamble and each hash is 32 bytes long and uses - aditional 1 byte for the tag used to identify the version scheme: - 5 + 2 (32 + 1) = 71 *) - let gen_max_page_size = int_range 71 10_000 - - let gen_non_empty_payload = bytes_size (int_range 1 10_000) - - let serialization_roundtrip_pbt = - let test_serialization_roundtrip (max_page_size, payload) = - test_serialization_roundtrip ~loc:__LOC__ ~max_page_size payload - in - Tztest.tztest_qcheck2 - ~name:"PBT for merkle_tree_V0 serialization/deserialization roundtrip" - (pair gen_max_page_size gen_non_empty_payload) - test_serialization_roundtrip - end - end -end - -let tests = - [ - Tztest.tztest - "Storing only one hash per page causes serialization to fail (Merkle \ - tree, v0)" - `Quick - Merkle_tree.V0.serialize_one_hash_per_page_fails; - Tztest.tztest - "Serializing empty payload returns an error (Merkle tree, v0)" - `Quick - Merkle_tree.V0.serialize_empty_payload_fails; - Tztest.tztest - "Contents fitting in one page can be retrieved after being saved (Merkle \ - tree, v0)" - `Quick - Merkle_tree.V0.one_page_roundtrip; - Tztest.tztest - "Contents fitting in more pages can be retrieved after being saved - no \ - repeated pages (Merkle tree, V0)" - `Quick - Merkle_tree.V0.multiple_pages_roundtrip_heterogeneous_payload; - Tztest.tztest - "Contents fitting in more pages can be retrieved after being saved - \ - repeated pages (Merkle tree, V0)" - `Quick - Merkle_tree.V0.multiple_pages_roundtrip_homogeneous_payload; - Tztest.tztest - "Serialization and deserialization of very long content is correct." - `Quick - Merkle_tree.V0.long_content_roundtrip; - Tztest.tztest - "Hashes pages are not larger than expected" - `Quick - Merkle_tree.V0.multiple_pages_roundtrip_do_not_exceed_page_size; - Tztest.tztest - "Deserialization with integrity check fails if page contents are corrupt" - `Quick - Merkle_tree.V0 - .deserialization_of_corrupt_data_with_hash_integrity_check_fails; - Merkle_tree.V0.PBT.serialization_roundtrip_pbt; - ] - -let () = - Alcotest_lwt.run - ~__FILE__ - Protocol.name - [Test_helpers.Unit_test.spec "Dac_pages_encoding.ml" tests] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_dac_plugin/test/test_dac_plugin_registration.ml b/src/proto_017_PtNairob/lib_dac_plugin/test/test_dac_plugin_registration.ml deleted file mode 100644 index 2bf59c94fbd3f31a9c52991bf26c1ca93543b2dd..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_dac_plugin/test/test_dac_plugin_registration.ml +++ /dev/null @@ -1,159 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Lib_dac_node Dac_hash - Invocation: dune exec src/proto_017_PtNairob/lib_dac_plugin/test/main.exe \ - -- --file test_dac_plugin_registration.ml - Subject: Tests for the interoperability between Dac hash - and given protocol hash -*) - -module Protocol_reveal_hash = Protocol.Sc_rollup_reveal_hash - -let dac_plugin = Stdlib.Option.get (Dac_plugin.get Protocol.hash) - -module P = (val dac_plugin) - -(* Hash copied from - https://gitlab.com/tezos/tezos/-/blob/master/tezt/tests/dac.ml#L331 *) -let reveal_hash = - Stdlib.Option.get - @@ Protocol_reveal_hash.of_hex - "00a3703854279d2f377d689163d1ec911a840d84b56c4c6f6cafdf0610394df7c6" - -let assert_equal_bytes ~loc msg = - Assert.equal ~loc Bytes.equal msg String.pp_bytes_hex - -let test_dac_hash_bin_encoding_roundtrip_with_reveal_hash () = - let open Lwt_result_syntax in - let to_bytes e a = - Stdlib.Result.get_ok @@ Data_encoding.Binary.to_bytes e a - in - let from_bytes e a = - Stdlib.Result.get_ok @@ Data_encoding.Binary.of_bytes e a - in - let reveal_hash_bytes = to_bytes Protocol_reveal_hash.encoding reveal_hash in - let dac_hash = from_bytes P.encoding reveal_hash_bytes in - let dac_hash_bytes = to_bytes P.encoding dac_hash in - let reveal_hash_decoded = - from_bytes Protocol_reveal_hash.encoding dac_hash_bytes - in - let* () = - assert_equal_bytes - ~loc:__LOC__ - "Encoded bytes are not equal" - reveal_hash_bytes - dac_hash_bytes - in - Assert.equal - ~loc:__LOC__ - Protocol_reveal_hash.equal - "Roundtrip hash is not equal" - Protocol_reveal_hash.pp - reveal_hash - reveal_hash_decoded - -let test_dac_hash_hex_roundtrip_with_reveal_hash () = - let reveal_hash_hex = Protocol_reveal_hash.to_hex reveal_hash in - let dac_hash = Stdlib.Option.get @@ P.of_hex reveal_hash_hex in - let dac_hash_hex = P.to_hex dac_hash in - Assert.equal_string ~loc:__LOC__ reveal_hash_hex dac_hash_hex - -let test_dac_hash_hash_bytes_with_reveal_hash () = - let payload = Bytes.of_string "Hello world" in - let dac_hash = P.hash_bytes ~scheme:Blake2B [payload] in - let dac_hash = - Stdlib.Result.get_ok @@ Data_encoding.Binary.to_bytes P.encoding dac_hash - in - let reveal_hash = Protocol_reveal_hash.hash_bytes ~scheme:Blake2B [payload] in - let reveal_hash = - Stdlib.Result.get_ok - @@ Data_encoding.Binary.to_bytes Protocol_reveal_hash.encoding reveal_hash - in - assert_equal_bytes - ~loc:__LOC__ - "Encoded bytes are not equal" - reveal_hash - dac_hash - -let test_dac_hash_hash_string_with_reveal_hash () = - let payload = "Hello world" in - let dac_hash = P.hash_string ~scheme:Blake2B [payload] in - let dac_hash = - Stdlib.Result.get_ok @@ Data_encoding.Binary.to_bytes P.encoding dac_hash - in - let reveal_hash = - Protocol_reveal_hash.hash_string ~scheme:Blake2B [payload] - in - let reveal_hash = - Stdlib.Result.get_ok - @@ Data_encoding.Binary.to_bytes Protocol_reveal_hash.encoding reveal_hash - in - assert_equal_bytes - ~loc:__LOC__ - "Encoded bytes are not equal" - reveal_hash - dac_hash - -let test_json_encoding_is_hexified () = - let payload = Bytes.of_string "Hello world" in - let dac_hash = P.hash_bytes ~scheme:Blake2B [payload] in - let dac_hash_json = Data_encoding.Json.construct P.encoding dac_hash in - let dac_hash_json_string = Data_encoding.Json.to_string dac_hash_json in - let dac_hash_hex_string = P.to_hex dac_hash in - Assert.equal_string ~loc:__LOC__ dac_hash_hex_string dac_hash_json_string - -let tests = - [ - Tztest.tztest - "Binary encoding roundtrip test between Dac hash and reveal hash" - `Quick - test_dac_hash_bin_encoding_roundtrip_with_reveal_hash; - Tztest.tztest - "Hex encoding roundtrip test between Dac hash and reveal hash" - `Quick - test_dac_hash_hex_roundtrip_with_reveal_hash; - Tztest.tztest - "Hash bytes should be equal between Dac hash and reveal hash" - `Quick - test_dac_hash_hash_bytes_with_reveal_hash; - Tztest.tztest - "Hash string should be equal between Dac hash and reveal hash" - `Quick - test_dac_hash_hash_string_with_reveal_hash; - Tztest.tztest - "Json encoded hash string should be a hex string" - `Quick - test_dac_hash_hash_string_with_reveal_hash; - ] - -let () = - Alcotest_lwt.run - ~__FILE__ - Protocol.name - [Test_helpers.Unit_test.spec "Dac_plugin_registration.ml" tests] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_dac_plugin/test/test_helpers.ml b/src/proto_017_PtNairob/lib_dac_plugin/test/test_helpers.ml deleted file mode 100644 index 832d0dd725a9180fba8175132321c789378ce500..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_dac_plugin/test/test_helpers.ml +++ /dev/null @@ -1,45 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -module Unit_test : sig - (** - * Example: [spec "Dac_pages_encoding.ml" Test_dac_pages_encoding.tests] - * Unit tests needs tag in log (like "[UNIT] some test description here...") - * This function handles such meta data *) - val spec : - string -> - unit Alcotest_lwt.test_case list -> - string * unit Alcotest_lwt.test_case list - - (** Tests with description string without [Unit] are skipped *) - val _skip : - string -> - unit Alcotest_lwt.test_case list -> - string * unit Alcotest_lwt.test_case list -end = struct - let spec unit_name test_cases = ("[Unit] " ^ unit_name, test_cases) - - let _skip unit_name test_cases = ("[SKIPPED] " ^ unit_name, test_cases) -end diff --git a/src/proto_017_PtNairob/lib_dal/dal_plugin_registration.ml b/src/proto_017_PtNairob/lib_dal/dal_plugin_registration.ml deleted file mode 100644 index 1b02684140359b41053543c4c8cb49db7d52dbf4..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_dal/dal_plugin_registration.ml +++ /dev/null @@ -1,139 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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 -open Alpha_context - -module Plugin = struct - module Proto = Registerer.Registered - - type block_info = Protocol_client_context.Alpha_block_services.block_info - - let parametric_constants chain block ctxt = - let cpctxt = new Protocol_client_context.wrap_rpc_context ctxt in - Protocol.Constants_services.parametric cpctxt (chain, block) - - let get_constants chain block ctxt = - let open Lwt_result_syntax in - let* parametric = parametric_constants chain block ctxt in - let { - Constants.Parametric.feature_enable; - number_of_slots; - attestation_lag; - attestation_threshold; - cryptobox_parameters; - blocks_per_epoch = _; - } = - parametric.dal - in - return - { - Dal_plugin.feature_enable; - incentives_enable = false; - number_of_slots; - attestation_lag; - attestation_threshold; - cryptobox_parameters; - } - - let block_info ?chain ?block ~metadata ctxt = - let cpctxt = new Protocol_client_context.wrap_rpc_context ctxt in - Protocol_client_context.Alpha_block_services.info - cpctxt - ?chain - ?block - ~metadata - () - - let block_shell_header (block_info : block_info) = block_info.header.shell - - let get_round fitness = - let open Result_syntax in - let* round = Fitness.round_from_raw fitness |> Environment.wrap_tzresult in - return @@ Round.to_int32 round - - (* Turn the given value of type {!Protocol.Apply_operation_result.operation_result} - into a value of type {!Dal_plugin.operation_application_result}. *) - let status_of_result = function - | Protocol.Apply_operation_result.Applied _ -> Dal_plugin.Succeeded - | _ -> Dal_plugin.Failed - - let get_published_slot_headers (block : block_info) = - let open Lwt_result_syntax in - let open Protocol.Alpha_context in - let apply_internal acc ~source:_ _op _res = acc in - let apply (type kind) acc ~source:_ (op : kind manager_operation) - (result : (kind, _, _) Protocol.Apply_operation_result.operation_result) - = - match op with - | Dal_publish_slot_header operation -> - ( operation.published_level, - operation.slot_index, - operation.commitment, - status_of_result result ) - :: acc - | _ -> acc - in - Layer1_services.( - process_manager_operations [] block.operations {apply; apply_internal}) - |> List.map_es (fun (published_level, slot_index, commitment, status) -> - let published_level = Raw_level.to_int32 published_level in - let slot_index = Dal.Slot_index.to_int slot_index in - return Dal_plugin.({published_level; slot_index; commitment}, status)) - - let get_committee ctxt ~level = - let open Lwt_result_syntax in - let cpctxt = new Protocol_client_context.wrap_rpc_context ctxt in - let*? level = Raw_level.of_int32 level |> Environment.wrap_tzresult in - let+ pkh_to_shards = - Plugin.RPC.Dal.dal_shards cpctxt (`Main, `Head 0) ~level () - in - List.fold_left - (fun acc (pkh, s) -> Signature.Public_key_hash.Map.add pkh s acc) - Signature.Public_key_hash.Map.empty - pkh_to_shards - - let attested_slot_headers (block : block_info) ~number_of_slots = - let open Result_syntax in - let* metadata = - Option.to_result - block.metadata - ~none: - (TzTrace.make @@ Layer1_services.Cannot_read_block_metadata block.hash) - in - let confirmed_slots = - Option.value - ~default:Dal.Attestation.empty - metadata.protocol_data.dal_attestation - in - let* all_slots = - Dal.Slot_index.slots_range ~lower:0 ~upper:(number_of_slots - 1) - |> Environment.wrap_tzresult - in - List.filter (Dal.Attestation.is_attested confirmed_slots) all_slots - |> Dal.Slot_index.to_int_list |> return -end - -let () = Dal_plugin.register (module Plugin) diff --git a/src/proto_017_PtNairob/lib_dal/dal_slot_frame_encoding.ml b/src/proto_017_PtNairob/lib_dal/dal_slot_frame_encoding.ml deleted file mode 100644 index f89360351623062b4fdb4075f09d1a987da14a75..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_dal/dal_slot_frame_encoding.ml +++ /dev/null @@ -1,257 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Trili Tech *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Protocol -open Alpha_context -open Protocol_client_context - -type error += - | Slot_size_is_too_big of {actual_size : int; max_size : int} - | Wrong_slot_frame_version of {expected : int; provided : int} - | Could_not_deserialize_slot - -let () = - register_error_kind - `Permanent - ~id:"slot_size_is_too_big" - ~title:"Slot size is too big" - ~description:"Slot cannot fit in maximum size" - ~pp:(fun ppf (actual_size, max_size) -> - Format.fprintf - ppf - "Actual size: %d, Maximum size: %d" - actual_size - max_size) - Data_encoding.(obj2 (req "actual_size" int31) (req "maximum_size" int31)) - (function - | Slot_size_is_too_big {actual_size; max_size} -> - Some (actual_size, max_size) - | _ -> None) - (fun (actual_size, max_size) -> - Slot_size_is_too_big {actual_size; max_size}) ; - register_error_kind - `Permanent - ~id:"wrong_slot_frame_version" - ~title:"Wrong slot frame version" - ~description:"Wrong slot frame version" - ~pp:(fun ppf (expected, provided) -> - Format.fprintf - ppf - "Version expected: %d, Version provided: %d" - expected - provided) - Data_encoding.( - obj2 (req "version_expected" uint8) (req "version_provided" uint8)) - (function - | Wrong_slot_frame_version {expected; provided} -> - Some (expected, provided) - | _ -> None) - (fun (expected, provided) -> Wrong_slot_frame_version {expected; provided}) ; - register_error_kind - `Permanent - ~id:"could_not_deserialize_slot" - ~title:"Slot could not be deserialized" - ~description:"Error when recovering slot contents from binary" - ~pp:(fun ppf () -> - Format.fprintf ppf "Error when recovering slot contents from binary") - Data_encoding.(unit) - (function Could_not_deserialize_slot -> Some () | _ -> None) - (fun () -> Could_not_deserialize_slot) - -type version = int - -type message = string - -module Rollups_map = Map.Make (Sc_rollup.Address) - -type t = message list Rollups_map.t - -module type Slot_version = sig - val version_prefix : version - - val expected_slot_size : t -> int - - val serialize : max_size:int -> t -> string tzresult Lwt.t - - val deserialize : max_size:int -> string -> t tzresult Lwt.t -end - -let version_encoding = Data_encoding.uint8 - -module V0 = struct - let version_prefix = 0 - - (* Binary representation of string uses 4 bytes as a header, - containing the string length. This conforms to the specification - given for messages. *) - let message_encoding = Data_encoding.string - - (* Binary representation of lists uses 4 bytes as a header, containing - the length of the list in bytes. This conforms to the - specification given for messages frames. *) - let messages_frame_encoding = Data_encoding.(list message_encoding) - - (* Binary representation of lists uses 4 bytes as a header, containing - the size of the encoded list contents in bytes. - `all_messages_frame_encoding` encodes not only the encoded messages - frames, but also the 4 bytes containing the length of all messages - frames that separate the rollups frame from the messages frame. - *) - let all_messages_frames_encoding = - Data_encoding.(list messages_frame_encoding) - - (* Binary representation of a [Sc_rollup.Address.t] uses 20 bytes, - while the encoding of a [int32] uses 4 bytes. These are - concatenated together by `rollup_offset_entry_encoding`. *) - let rollup_offset_entry_encoding = - Data_encoding.(tup2 Sc_rollup.Address.encoding int32) - - (* Binary representation of lists uses 4 bytes as a header, containing - the size of the encoded list contents in bytes. - the size in bytes of the rollups frame. containing - the length of the list in bytes. Thus the rollups_frame_encoding - conforms to the specification given*) - let rollups_frame_encoding = Data_encoding.(list rollup_offset_entry_encoding) - - let slot_encoding ~max_size = - Data_encoding.( - check_size max_size - @@ tup3 - version_encoding - rollups_frame_encoding - all_messages_frames_encoding) - - module Internal = struct - let size_of_opt size = match size with None -> assert false | Some n -> n - - let message_size = Data_encoding.Binary.length message_encoding - - let messages_frame_size = - Data_encoding.Binary.length messages_frame_encoding - - let all_messages_frames_size = - Data_encoding.Binary.length all_messages_frames_encoding - - let frame_prefix_size = - size_of_opt Data_encoding.(Binary.fixed_length int32) - - let frame_version_size = - size_of_opt Data_encoding.(Binary.fixed_length uint8) - - let rollup_entry_size = - size_of_opt - @@ Data_encoding.Binary.fixed_length rollup_offset_entry_encoding - - let rollups_frame_size number_of_rollups = - (rollup_entry_size * number_of_rollups) + frame_prefix_size - end - - let expected_slot_size all_rollups_messages = - let bindings = Rollups_map.bindings all_rollups_messages in - let number_of_rollups = bindings |> List.length in - let messages = List.map snd bindings in - Internal.( - frame_version_size - + rollups_frame_size number_of_rollups - + all_messages_frames_size messages) - - let serialize ~max_size all_rollups_messages = - let open Lwt_result_syntax in - let first_messages_frame_offset = - Internal.( - frame_version_size - + rollups_frame_size - (Rollups_map.bindings all_rollups_messages |> List.length) - + frame_prefix_size) - in - let rev_rollups_frame, rev_messages_frames, expected_slot_size = - Rollups_map.fold - (fun rollup messages (rollups_frame, messages_frames, next_offset) -> - let rollups_frame = - (rollup, Int32.of_int next_offset) :: rollups_frame - in - let messages_frames = messages :: messages_frames in - let next_offset = - next_offset + Internal.messages_frame_size messages - in - (rollups_frame, messages_frames, next_offset)) - all_rollups_messages - ([], [], first_messages_frame_offset) - in - let* () = - fail_unless - (expected_slot_size <= max_size) - (Slot_size_is_too_big {actual_size = expected_slot_size; max_size}) - in - let rollups_frame = List.rev rev_rollups_frame in - let messages_frames = List.rev rev_messages_frames in - let*? result = - Data_encoding.Binary.to_string - (slot_encoding ~max_size) - (version_prefix, rollups_frame, messages_frames) - |> Result.map_error (fun _ -> assert false) - in - return result - - (* Deserialization of slot contents will be done by WASM PVM kernels, as - per #3374. However, we should still provide a function to - deserialize the contents of a slot, as other components other than the - PVM kernel may need to inspect it. *) - let deserialize ~max_size serialized = - let open Lwt_result_syntax in - let actual_size = String.length serialized in - let* () = - fail_unless - (actual_size <= max_size) - (Slot_size_is_too_big {actual_size; max_size}) - in - let version_prefix, rollups_frame, messages_frames = - Data_encoding.Binary.of_string_exn (slot_encoding ~max_size) serialized - in - let* () = - fail_when - (version_prefix <> 0) - (Wrong_slot_frame_version {expected = 0; provided = version_prefix}) - in - let* () = - fail_when - (List.compare_length_with messages_frames @@ List.length rollups_frame - <> 0) - Could_not_deserialize_slot - in - let*? deserialized = - List.map2 - ~when_different_lengths:[] - (fun (rollup, _offset) messages -> (rollup, messages)) - rollups_frame - messages_frames - |> Result.map_error (fun _ -> [Could_not_deserialize_slot]) - |> Result.map (fun rollups_with_messages -> - Rollups_map.add_seq - (List.to_seq rollups_with_messages) - Rollups_map.empty) - in - return deserialized -end diff --git a/src/proto_017_PtNairob/lib_dal/dal_slot_frame_encoding.mli b/src/proto_017_PtNairob/lib_dal/dal_slot_frame_encoding.mli deleted file mode 100644 index 2b6134c2b089c9dfb7978e6f8f97929f57b367bf..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_dal/dal_slot_frame_encoding.mli +++ /dev/null @@ -1,182 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Trili Tech *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(* Library for encoding messages from distinct rollups into a slot. This - library contains encoding and decoding functions for different versions of - the slot-frame encoding. Currently, only one version, V0, exists. As the - structure of slot-frame progresses, new versions will be added. *) - -open Protocol -open Alpha_context - -type error += - | Slot_size_is_too_big of {actual_size : int; max_size : int} - | Wrong_slot_frame_version of {expected : int; provided : int} - | Could_not_deserialize_slot - -type version = int - -module Rollups_map : Map.S with type key = Sc_rollup.Address.t - -type message = string - -(* The type that will be used to serialize and deserialize a slot into a - slot-frame. It consists of a map from rollup addresses to list of - messages. *) -type t = message list Rollups_map.t - -(* Common interface for all slot versions. *) -module type Slot_version = sig - (* [version_prefix] denotes the version of the slot-frame encoding. - It must be a value between 0 and 255, and two different slot-frame - econdings cannot have the same version prefix. *) - val version_prefix : version - - (* [expected_slot_size rollups_messages] returns the value of the - size (in bytes) of a slot-frame that includes all the messages - in [rollups_messages]. It must satisfy the following property: - `expected_slot_size rollups_messages = - String.length @@ serialize rollups_messages`. - *) - val expected_slot_size : t -> int - - (* [serialize ~max_size rollups_messages] returns the encoding - of [rollups_messages] as a string, provided that the result - does not occupy more then [~max_size] byted. - When it succeeds, it must satisfy the following property: - `deserialize ~max_size @@ serialize ~max_size rollups_messages = - rollups_messages` - - May fail with: - {ul - {li [Slot_size_is_too_big {actual_size; max_size}] if the encoding of the - slot would take [actual_size] bytes, where `actual_size > max_size`} - } - *) - val serialize : max_size:int -> t -> string tzresult Lwt.t - - (* [deserialize ~max_size slot_frame] returns the rollup-address indexed map - of messages whose encoding corresponds to [slot_frame], as long as the - [slot_frame] does not occupy more then [~max_size] bytes, and [slot_frame] - contains the correct version_prefix, i.e. the first byte [slot_frame] - is set to `\000`. When it succeeds, it must satisfy the following property: - `serialize ~max_size @@ deserialize ~max_size slot_frame = - slot_frame` - - May fail with: - {ul - {li [Slot_size_is_too_big {actual_size; max_size}] if - [String.length slot_frame = actual_size], where - `actual_size > max_size`. - } - {li [Wrong_slot_frame_version of {expected; provided = 0}] if the first - byte of [slot_frame] is set to the binary encoding of [expected]. - } - {li [Could_not_deserialize_slot] if [slot_frame] does not correspond to - the serialization of a valid rollup-address indexed map of messages. - } - } - *) - val deserialize : max_size:int -> string -> t tzresult Lwt.t -end - -(*'V0' version of the slot-frame encoding. - Suppose that we want to include messages from rollups `r_1, ..., r_n`. - Specifically, for `i=1, ..., n`, suppose that rollup `r_i` wants to include - an arbitrary number j of messages `[m_{i,1}; ... m_{i, j} ]` into the slot. - The number of messages j to be included in a slot may be different for each - rollup. The encoded slot will consist of a string where: - {ul - {li The first byte contains the slot-frame version, currently set to `0x00`,} - {li The next `n * 24 + 4` bytes contain the `rollups-frame`, which contains - the information about where the messages for the rollups - `r_1, .., r_n` are stored. Specifically, the first 4 bytes denote the - length (in bytes) of the remaining part of the rollups-frame, which is - `n * 24`. This is followed by `n` entries of `24` bytes each. For each - entry, the first `20` bytes contain the encoded address of the rollup - node, while the other `4` contain the offset - from the start of the - slot - to the start of the rollup's messages-frame (described next). - } - {li The `4` bytes following the rollups frame contain the length of the - rest of the encoded slot, } - {li Next, there are n messages-frames, one for each rollup. For - `i = 1, ..., n`, the size of the i-th messages-frame is - `4 * n_i + (\sum_{j=1}^{n_i} |m_{i, j}|) + 4` bytes. The first four - bytes denote the length of the messages-frame. Then we have the - sequence of the encoded messages `m_{i,1}, ..., m_{i, j}`. The encoded - message `m_{i,j}` consists of 4 bytes representing `|m_{i,j}|`, - followed by `m_{i,j}` itself. - } - } - - As an example, suppose that we have two rollups `r1` and `r2`. For - simplicity, let's assume that the binary represenation of `r1` and `r2` are - `ROLLUP_ADDRESS_1XXXX` and `ROLLUP_ADDRESS_2YYYY`. Suppose that we want to - include in the slot messages [["hello"; "world"]] from `r1`, and messages - [["CAFEBABE"; "CAFEDEAD"]] from `r2` (in this order). The overall encoded - frame will be - "\000 - \000\000\000\048 - ROLLUP_ADDRESS_1XXXX\000\000\000\057 - ROLLUP_ADDRESS_2YYYY\000\000\000\079 - \000\000\000\050 - \000\000\000\018\000\000\000\005hello\000\000\000\005world - \000\000\000\024\000\000\000\008CAFEBABE\000\000\000\008CAFEDEAD". -*) -module V0 : sig - include Slot_version - - (* Functions used internally by the V0 version of the slot. These functions - are exposed so that they can be used in tests. This is necessary as we - will have implementations of the deserialization for the slot functions in - different programming languages. Checking the values returned by these - functions in tests will serve as documentation for developers wanting to - implement their own version of the V0 slot-frame deserialization. *) - module Internal : sig - (* [messages_size message] returns the size in bytes that [message] - would take in a slot-frame. *) - val message_size : message -> int - - (* [messages_frame_size messages] returns the size in bytes that the - encoding of messages as a messages frame would take in a slot-frame. *) - val messages_frame_size : message list -> int - - (* [all_messages_frame all_messages] returns the size in bytes - that the encoding of [all_messages] would take in a slot-frame. - This value includes the 4 bytes that separate the rollups-frame - from the rest of the slot frame in the encoding. *) - val all_messages_frames_size : message list list -> int - - (* [rollup_entry_size] returns the size in bytes - that one rollup would take in the rollups-frame. - *) - val rollup_entry_size : int - - (* [rollups_frame_size number_of_rollups] returns the size - in bytes that the rollups-frame would take in a slot-frame, - if the latter contains messages for [number_of_rollups] rollups. *) - val rollups_frame_size : int -> int - end -end diff --git a/src/proto_017_PtNairob/lib_dal/dune b/src/proto_017_PtNairob/lib_dal/dune deleted file mode 100644 index 6bbb739b91a31137d1936d4f2fa466880eca6420..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_dal/dune +++ /dev/null @@ -1,32 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name tezos_dal_017_PtNairob) - (public_name octez-protocol-017-PtNairob-libs.dal) - (instrumentation (backend bisect_ppx)) - (libraries - octez-libs.base - octez-protocol-compiler.registerer - octez-libs.stdlib-unix - tezos-dal-node-lib - octez-protocol-017-PtNairob-libs.client - octez-protocol-017-PtNairob-libs.plugin - tezos-protocol-017-PtNairob.embedded-protocol - octez-protocol-017-PtNairob-libs.layer2-utils - tezos-protocol-017-PtNairob.protocol) - (inline_tests (flags -verbose) (modes native)) - (preprocess (pps ppx_expect)) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_protocol_registerer - -open Tezos_stdlib_unix - -open Tezos_dal_node_lib - -open Tezos_client_017_PtNairob - -open Tezos_protocol_plugin_017_PtNairob - -open Tezos_embedded_protocol_017_PtNairob - -open Tezos_layer2_utils_017_PtNairob - -open Tezos_protocol_017_PtNairob)) diff --git a/src/proto_017_PtNairob/lib_dal/test/dune b/src/proto_017_PtNairob/lib_dal/test/dune deleted file mode 100644 index a11e9eb55907ae24a6d9a41df1c0814127eb72c0..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_dal/test/dune +++ /dev/null @@ -1,48 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name src_proto_017_PtNairob_lib_dal_test_tezt_lib) - (instrumentation (backend bisect_ppx)) - (libraries - tezt.core - octez-libs.base - octez-protocol-017-PtNairob-libs.dal - tezos-protocol-017-PtNairob.protocol - octez-libs.base-test-helpers - octez-protocol-017-PtNairob-libs.test-helpers - octez-alcotezt) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezt_core - -open Tezt_core.Base - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_dal_017_PtNairob - -open Tezos_protocol_017_PtNairob - -open Tezos_base_test_helpers - -open Tezos_017_PtNairob_test_helpers - -open Octez_alcotezt) - (modules test_dal_slot_frame_encoding test_helpers)) - -(executable - (name main) - (instrumentation (backend bisect_ppx --bisect-sigterm)) - (libraries - src_proto_017_PtNairob_lib_dal_test_tezt_lib - tezt) - (link_flags - (:standard) - (:include %{workspace_root}/macos-link-flags.sexp)) - (modules main)) - -(rule - (alias runtest) - (package octez-protocol-017-PtNairob-libs) - (enabled_if (<> false %{env:RUNTEZTALIAS=true})) - (action (run %{dep:./main.exe}))) - -(rule - (targets main.ml) - (action (with-stdout-to %{targets} (echo "let () = Tezt.Test.run ()")))) diff --git a/src/proto_017_PtNairob/lib_dal/test/test_dal_slot_frame_encoding.ml b/src/proto_017_PtNairob/lib_dal/test/test_dal_slot_frame_encoding.ml deleted file mode 100644 index 7a5592492e0b14128cd24a02e68319a706cb8454..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_dal/test/test_dal_slot_frame_encoding.ml +++ /dev/null @@ -1,420 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Trili Tech *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Dal_node Slot_frame_encoding - Invocation: dune exec src/proto_017_PtNairob/lib_dal/test/main.exe \ - -- --file test_dal_slot_frame_encoding.ml - Subject: Tests for the SCORU storage module -*) - -(* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3421 - Property based tests to check basic invariants of slot-frame encoding V0. *) - -open Protocol -open Alpha_context -module Rollup_messages_map = Dal_slot_frame_encoding.Rollups_map -module V0 = Dal_slot_frame_encoding.V0 - -(* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3339 - Fetch this value from protocol default constants *) -let max_size = 1_048_576 - -let assert_fails_with ~loc k expected_err = - let open Lwt_result_syntax in - let*! res = k in - Assert.error ~loc res (( = ) expected_err) - -module Compare_list_string = Compare.List (String) -module Compare_list_list_string = Compare.List (Compare_list_string) -module Compare_list_rollup = Compare.List (Sc_rollup.Address) - -let assert_equal_bytes ~loc msg = - Assert.equal ~loc Bytes.equal msg String.pp_bytes_hex - -let assert_equal_list_string ~loc msg = - Assert.equal - ~loc - Compare_list_string.equal - msg - (Format.pp_print_list Format.pp_print_string) - -let assert_equal_list_list_string ~loc msg = - Assert.equal - ~loc - Compare_list_list_string.equal - msg - (Format.pp_print_list (Format.pp_print_list Format.pp_print_string)) - -let assert_equal_list_rollups ~loc msg = - Assert.equal - ~loc - Compare_list_rollup.equal - msg - (Format.pp_print_list Sc_rollup.Address.pp) - -let sc_rollup_1 = - Sc_rollup.Address.of_b58check_exn "sr1BAwv191dVYeZg44ZxVy8dFwfRQKW6bSqc" - -let sc_rollup_2 = - Sc_rollup.Address.of_b58check_exn "sr1Fq8fPi2NjhWUXtcXBggbL6zFjZctGkmso" - -let slot_frame_encoding_size_correct_single_v0 () = - let open Lwt_result_syntax in - let messages_rollup_1 = - ["hello"; "is"; "it"; "me"; "you"; "are"; "looking"; "for"] - in - (* One rollup with offset should take 24 bytes *) - let entry_size = V0.Internal.rollup_entry_size in - let* () = Assert.equal_int ~loc:__LOC__ entry_size 24 in - (* 1 byte for version *) - let expected_version_size = 1 in - (* 20 bytes for one rollup address + 4 bytes of offset + 4 bytes for frame length = 28 bytes *) - let computed_rollups_frame_size = V0.Internal.rollups_frame_size 1 in - let expected_rollups_frame_size = 28 in - let* () = - Assert.equal_int - ~loc:__LOC__ - computed_rollups_frame_size - expected_rollups_frame_size - in - (*27 bytes total messages + - 4 * 8 = 32 bytes message length prefixes + - 4 bytes list length prefix + - 63 bytes for messages frame *) - let computed_messages_frame_size = - V0.Internal.messages_frame_size messages_rollup_1 - in - let expected_messages_frame_size = 63 in - let* () = - Assert.equal_int - ~loc:__LOC__ - computed_messages_frame_size - expected_messages_frame_size - in - (* 4 bytes of list length prefix + - 63 bytes of messages_frame_size = 67 bytes for all messages frames *) - let computed_all_messages_frames_size = - V0.Internal.all_messages_frames_size [messages_rollup_1] - in - let expected_all_messages_frames_size = 4 + expected_messages_frame_size in - let* () = - Assert.equal_int - ~loc:__LOC__ - computed_all_messages_frames_size - expected_all_messages_frames_size - in - let expected_size = - expected_version_size + expected_rollups_frame_size - + expected_all_messages_frames_size - in - let map = - Rollup_messages_map.empty - |> Rollup_messages_map.add sc_rollup_1 messages_rollup_1 - in - let computed_size = V0.expected_slot_size map in - Assert.equal_int ~loc:__LOC__ expected_size computed_size - -let slot_frame_encoding_size_correct_multiple_v0 () = - let open Lwt_result_syntax in - let messages_rollup_1 = ["Summer"; "loving"; "had"; "me"; "a"; "blast"] in - let messages_rollup_2 = ["Summer"; "loving"; "happened"; "so"; "fast"] in - (* 1 byte for version *) - let expected_version_size = 1 in - (* 24 * 2 = 48 bytes for two rollup entries + - 4 bytes for frame length prefix = 52 bytes - *) - let computed_rollups_frame_size = V0.Internal.rollups_frame_size 2 in - let expected_rollups_frame_size = 52 in - let* () = - Assert.equal_int - ~loc:__LOC__ - computed_rollups_frame_size - expected_rollups_frame_size - in - (* Frame 1: - 6 + 6 + 3 + 2 + 1 + 5 = 23 bytes for messages + - 4 * 6 = 24 bytes for message length prefix for 6 messages - + 4 bytes for message frame prefix = - 51 bytes for the messages frame for rollup1. - Frame 2: - 6 + 6 + 8 + 2 + 4 = 26 bytes for messages + - 4 * 5 = 20 bytes for message length prefix for 6 messages - + 4 bytes for message frame prefix = - 50 bytes for the messages frame for rollup2. - Messages frame length: - 51 bytes for rollup1 messages frame + - 50 bytes for rollup2 messages frame + - 4 bytes prefix length for all messages frames = - 105 bytes - *) - let computed_all_messages_frames_size = - V0.Internal.all_messages_frames_size [messages_rollup_1; messages_rollup_2] - in - let expected_all_messages_frames_size = 105 in - let* () = - Assert.equal_int - ~loc:__LOC__ - computed_all_messages_frames_size - expected_all_messages_frames_size - in - let expected_size = - expected_version_size + expected_rollups_frame_size - + expected_all_messages_frames_size - in - let map = - Rollup_messages_map.empty - |> Rollup_messages_map.add sc_rollup_1 messages_rollup_1 - |> Rollup_messages_map.add sc_rollup_2 messages_rollup_2 - in - let computed_size = V0.expected_slot_size map in - Assert.equal_int ~loc:__LOC__ expected_size computed_size - -let slot_frame_encoding_decoding_correct_single_v0 () = - let open Lwt_result_syntax in - let messages_rollup_1 = - ["hello"; "is"; "it"; "me"; "you"; "are"; "looking"; "for"] - in - let messages_map = - Rollup_messages_map.empty - |> Rollup_messages_map.add sc_rollup_1 messages_rollup_1 - in - let* serialized = V0.serialize ~max_size messages_map in - let* () = - Assert.equal_int - ~loc:__LOC__ - (String.length serialized) - (V0.expected_slot_size messages_map) - in - let* deserialized = V0.deserialize ~max_size serialized in - let rollups_with_messages = Rollup_messages_map.bindings deserialized in - let* () = - assert_equal_list_rollups - ~loc:__LOC__ - "Deserialized rollups are different from originals" - [sc_rollup_1] - (List.map fst rollups_with_messages) - in - assert_equal_list_list_string - ~loc:__LOC__ - "Messages frames are different from originals" - [messages_rollup_1] - (List.map snd rollups_with_messages) - -let slot_frame_encoding_decoding_correct_multiple_v0 () = - let open Lwt_result_syntax in - let messages_rollup_1 = ["Summer"; "loving"; "had"; "me"; "a"; "blast"] in - let messages_rollup_2 = ["Summer"; "loving"; "happened"; "so"; "fast"] in - let messages_map = - Rollup_messages_map.empty - |> Rollup_messages_map.add sc_rollup_1 messages_rollup_1 - |> Rollup_messages_map.add sc_rollup_2 messages_rollup_2 - in - let* serialized = V0.serialize ~max_size messages_map in - let* () = - Assert.equal_int - ~loc:__LOC__ - (String.length serialized) - (V0.expected_slot_size messages_map) - in - let* deserialized = V0.deserialize ~max_size serialized in - let rollups_with_messages = Rollup_messages_map.bindings deserialized in - let* () = - assert_equal_list_rollups - ~loc:__LOC__ - "Deserialized rollups are different from originals" - [sc_rollup_1; sc_rollup_2] - (List.map fst rollups_with_messages) - in - assert_equal_list_list_string - ~loc:__LOC__ - "Messages frames are different from originals" - [messages_rollup_1; messages_rollup_2] - (List.map snd rollups_with_messages) - -let slot_frame_encoding_fails_if_too_big () = - let messages_rollup_1 = ["Summer"; "loving"; "had"; "me"; "a"; "blast"] in - let messages_rollup_2 = ["Summer"; "loving"; "happened"; "so"; "fast"] in - let messages_map = - Rollup_messages_map.empty - |> Rollup_messages_map.add sc_rollup_1 messages_rollup_1 - |> Rollup_messages_map.add sc_rollup_2 messages_rollup_2 - in - let actual_size = V0.expected_slot_size messages_map in - let max_size = actual_size - 1 in - assert_fails_with - ~loc:__LOC__ - (V0.serialize ~max_size messages_map) - (Dal_slot_frame_encoding.Slot_size_is_too_big {actual_size; max_size}) - -let slot_frame_decoding_fails_if_too_big () = - let open Lwt_result_syntax in - let messages_rollup_1 = ["Summer"; "loving"; "had"; "me"; "a"; "blast"] in - let messages_rollup_2 = ["Summer"; "loving"; "happened"; "so"; "fast"] in - let messages_map = - Rollup_messages_map.empty - |> Rollup_messages_map.add sc_rollup_1 messages_rollup_1 - |> Rollup_messages_map.add sc_rollup_2 messages_rollup_2 - in - let actual_size = V0.expected_slot_size messages_map in - let* serialized = V0.serialize ~max_size:actual_size messages_map in - let max_size = actual_size - 1 in - assert_fails_with - ~loc:__LOC__ - (V0.deserialize ~max_size serialized) - (Dal_slot_frame_encoding.Slot_size_is_too_big {actual_size; max_size}) - -let slot_frame_decoding_fails_if_wrong_version () = - let open Lwt_result_syntax in - let messages_rollup_1 = ["Summer"; "loving"; "had"; "me"; "a"; "blast"] in - let messages_rollup_2 = ["Summer"; "loving"; "happened"; "so"; "fast"] in - let messages_map = - Rollup_messages_map.empty - |> Rollup_messages_map.add sc_rollup_1 messages_rollup_1 - |> Rollup_messages_map.add sc_rollup_2 messages_rollup_2 - in - let* serialized = - Dal_slot_frame_encoding.V0.serialize ~max_size messages_map - in - let serialized_wrong_version = - "\001" ^ String.sub serialized 1 (String.length serialized - 1) - in - assert_fails_with - ~loc:__LOC__ - (V0.deserialize ~max_size serialized_wrong_version) - (Dal_slot_frame_encoding.Wrong_slot_frame_version - {expected = 0; provided = 1}) - -let slot_frame_encoding_correct_offsets () = - let open Lwt_result_syntax in - let messages_rollup_1 = ["hello"; "world"] in - let messages_rollup_2 = ["CAFEBABE"; "CAFEDEAD"] in - let messages_map = - Rollup_messages_map.empty - |> Rollup_messages_map.add sc_rollup_1 messages_rollup_1 - |> Rollup_messages_map.add sc_rollup_2 messages_rollup_2 - in - let* serialized = V0.serialize ~max_size messages_map in - (* the value of the offset that denotes where the messages frame for - sc_rollup_1 starts can be found at offset 25 until 29 (excluded): - 1 byte for version + - 4 bytes for rollups frame prefix + - 20 bytes for rollup address = 25. - *) - let first_offset = - String.sub serialized 25 4 |> Data_encoding.(Binary.of_string_exn int32) - in - (* the value of the offset should be 57l: - 1 byte for version number + 4 bytes for rollups frame prefix + - 2 * 24 bytes for rollups frame + - 4 bytes for messages frames prefix = 57. *) - let* () = Assert.equal_int32 ~loc:__LOC__ first_offset 57l in - (* The length of the first messages frame should be 22 bytes: - 4 bytes for the messages frame prefix + - 4 + 5 bytes for the encoding of the message "hello" + - 4 + 5 bytes for the encoding of the message "world" = 22. - *) - let first_messages_frame = - Data_encoding.(Binary.of_string_exn @@ list string) - @@ String.sub serialized 57 22 - in - let* () = - assert_equal_list_string - ~loc:__LOC__ - "Messages frame for sc_rollup_1 is not as expected" - first_messages_frame - ["hello"; "world"] - in - (* The value of the offset that denotes where the messages frame for - sc_rollup_2 STARTS can be found at bytes 49 until 53 (excluded): - 29 offset where the entry for sc_rollup_2 starts + - 20 bytes for the encoding of sc_rollup_2 = 49. - *) - let second_offset = - String.sub serialized 49 4 |> Data_encoding.(Binary.of_string_exn int32) - in - (* the value of the second offset should be 79 - 57 offset where the messages frame for sc_rollup_1 starts + - 22 bytes length of the first messages frame = 79 - *) - let* () = Assert.equal_int32 ~loc:__LOC__ second_offset 79l in - (* The length of the first messages frame should be 28: - 4 bytes for the messages frame prefix + - 4 + 8 bytes for the encoding of the message "CAFEBABE" + - 4 + 8 bytes for the encoding of the message "CAFEDEAD" = 28 - *) - let second_messages_frame = - Data_encoding.(Binary.of_string_exn @@ list string) - @@ String.sub serialized 79 28 - in - assert_equal_list_string - ~loc:__LOC__ - "Messages frame for sc_rollup_1 is not as expected" - second_messages_frame - ["CAFEBABE"; "CAFEDEAD"] - -let tests = - [ - Tztest.tztest - "Encoded slot has expected size (V0, 1 rollup)" - `Quick - slot_frame_encoding_size_correct_single_v0; - Tztest.tztest - "Encoded slot has expected size (V0, 2 rollups)" - `Quick - slot_frame_encoding_size_correct_multiple_v0; - Tztest.tztest - "Encoded slot can be decoded (V0, 1 rollup)" - `Quick - slot_frame_encoding_decoding_correct_single_v0; - Tztest.tztest - "Encoded slot can be decoded (V0, 2 rollups)" - `Quick - slot_frame_encoding_decoding_correct_multiple_v0; - Tztest.tztest - "Encoding of a slot over maximum size fails (V0)" - `Quick - slot_frame_encoding_fails_if_too_big; - Tztest.tztest - "Offsets of messages frames are correct (V0)" - `Quick - slot_frame_encoding_correct_offsets; - Tztest.tztest - "Slot decoding fails when slot size is too big (V0)" - `Quick - slot_frame_decoding_fails_if_too_big; - Tztest.tztest - "Slot decoding fails when first byte has wrong version (V0)" - `Quick - slot_frame_decoding_fails_if_wrong_version; - ] - -let () = - Alcotest_lwt.run - ~__FILE__ - Protocol.name - [Test_helpers.Unit_test.spec "Slot_framing_protocol.ml" tests] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_dal/test/test_helpers.ml b/src/proto_017_PtNairob/lib_dal/test/test_helpers.ml deleted file mode 100644 index 4c0437a54c220835d434fd4ed4277293873f7154..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_dal/test/test_helpers.ml +++ /dev/null @@ -1,45 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -module Unit_test : sig - (** - * Example: [spec "Slot_framing_protocol.ml" Test_dal_slot_frame_encoding.test_cases] - * Unit tests needs tag in log (like "[UNIT] some test description here...") - * This function handles such meta data *) - val spec : - string -> - unit Alcotest_lwt.test_case list -> - string * unit Alcotest_lwt.test_case list - - (** Tests with description string without [Unit] are skipped *) - val _skip : - string -> - unit Alcotest_lwt.test_case list -> - string * unit Alcotest_lwt.test_case list -end = struct - let spec unit_name test_cases = ("[Unit] " ^ unit_name, test_cases) - - let _skip unit_name test_cases = ("[SKIPPED] " ^ unit_name, test_cases) -end diff --git a/src/proto_017_PtNairob/lib_delegate/abstract_context_index.ml b/src/proto_017_PtNairob/lib_delegate/abstract_context_index.ml deleted file mode 100644 index 2e54f32fdc1398787ea5bb20ca04aefeee2427b3..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/abstract_context_index.ml +++ /dev/null @@ -1,38 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 = { - sync_fun : unit -> unit Lwt.t; - checkout_fun : - Context_hash.t -> Tezos_protocol_environment.Context.t option Lwt.t; - finalize_fun : unit -> unit Lwt.t; -} - -let abstract index = - { - sync_fun = (fun () -> Context.sync index); - checkout_fun = Shell_context.checkout index; - finalize_fun = (fun () -> Context.close index); - } diff --git a/src/proto_017_PtNairob/lib_delegate/abstract_context_index.mli b/src/proto_017_PtNairob/lib_delegate/abstract_context_index.mli deleted file mode 100644 index 5a280d04ac579a0d7f27272693335772133ed201..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/abstract_context_index.mli +++ /dev/null @@ -1,33 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 = { - sync_fun : unit -> unit Lwt.t; - checkout_fun : - Context_hash.t -> Tezos_protocol_environment.Context.t option Lwt.t; - finalize_fun : unit -> unit Lwt.t; -} - -val abstract : Context.index -> t diff --git a/src/proto_017_PtNairob/lib_delegate/baking_actions.ml b/src/proto_017_PtNairob/lib_delegate/baking_actions.ml deleted file mode 100644 index 1eeef3905a099c091c422540aa1c29970053cf2a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_actions.ml +++ /dev/null @@ -1,854 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context -open Baking_state -module Events = Baking_events.Actions - -module Operations_source = struct - type error += - | Failed_operations_fetch of { - path : string; - reason : string; - details : Data_encoding.json option; - } - - let operations_encoding = - Data_encoding.(list (dynamic_size Operation.encoding)) - - let retrieve = function - | None -> Lwt.return_none - | Some operations -> ( - let fail reason details = - let path = - match operations with - | Baking_configuration.Operations_source.Local {filename} -> - filename - | Baking_configuration.Operations_source.Remote {uri; _} -> - Uri.to_string uri - in - fail (Failed_operations_fetch {path; reason; details}) - in - let decode_operations json = - protect - ~on_error:(fun _ -> - fail "cannot decode the received JSON into operations" (Some json)) - (fun () -> - return (Data_encoding.Json.destruct operations_encoding json)) - in - match operations with - | Baking_configuration.Operations_source.Local {filename} -> - if Sys.file_exists filename then - Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file filename - >>= function - | Error _ -> - Events.(emit invalid_json_file filename) >>= fun () -> - Lwt.return_none - | Ok json -> ( - decode_operations json >>= function - | Ok operations -> Lwt.return_some operations - | Error errs -> - Events.(emit cannot_fetch_operations errs) >>= fun () -> - Lwt.return_none) - else - Events.(emit no_operations_found_in_file filename) >>= fun () -> - Lwt.return_none - | Baking_configuration.Operations_source.Remote {uri; http_headers} -> ( - ( ((with_timeout - (Systime_os.sleep (Time.System.Span.of_seconds_exn 5.)) - (fun _ -> - Tezos_rpc_http_client_unix.RPC_client_unix - .generic_media_type_call - ~accept:[Media_type.json] - ?headers:http_headers - `GET - uri) - >>=? function - | `Json json -> return json - | _ -> fail "json not returned" None) - >>=? function - | `Ok json -> return json - | `Unauthorized json -> fail "unauthorized request" json - | `Gone json -> fail "gone" json - | `Error json -> fail "error" json - | `Not_found json -> fail "not found" json - | `Forbidden json -> fail "forbidden" json - | `Conflict json -> fail "conflict" json) - >>=? fun json -> decode_operations json ) - >>= function - | Ok operations -> Lwt.return_some operations - | Error errs -> - Events.(emit cannot_fetch_operations errs) >>= fun () -> - Lwt.return_none)) -end - -type block_kind = - | Fresh of Operation_pool.pool - | Reproposal of { - consensus_operations : packed_operation list; - payload_hash : Block_payload_hash.t; - payload_round : Round.t; - payload : Operation_pool.payload; - } - -type block_to_bake = { - predecessor : block_info; - round : Round.t; - delegate : Baking_state.consensus_key_and_delegate; - kind : block_kind; - force_apply : bool; -} - -type inject_block_kind = - | Forge_and_inject of block_to_bake - | Inject_only of signed_block - -type action = - | Do_nothing - | Inject_block of {kind : inject_block_kind; updated_state : state} - | Forge_block of {block_to_bake : block_to_bake; updated_state : state} - | Inject_preendorsements of { - preendorsements : (consensus_key_and_delegate * consensus_content) list; - } - | Inject_endorsements of { - endorsements : (consensus_key_and_delegate * consensus_content) list; - } - | Update_to_level of level_update - | Synchronize_round of round_update - | Watch_proposal - -and level_update = { - new_level_proposal : proposal; - compute_new_state : - current_round:Round.t -> - delegate_slots:delegate_slots -> - next_level_delegate_slots:delegate_slots -> - (state * action) Lwt.t; -} - -and round_update = { - new_round_proposal : proposal; - handle_proposal : state -> (state * action) Lwt.t; -} - -type t = action - -let pp_action fmt = function - | Do_nothing -> Format.fprintf fmt "do nothing" - | Inject_block {kind; _} -> ( - match kind with - | Forge_and_inject _ -> Format.fprintf fmt "forge and inject block" - | Inject_only _ -> Format.fprintf fmt "inject forged block") - | Forge_block _ -> Format.fprintf fmt "forge_block" - | Inject_preendorsements _ -> Format.fprintf fmt "inject preendorsements" - | Inject_endorsements _ -> Format.fprintf fmt "inject endorsements" - | Update_to_level _ -> Format.fprintf fmt "update to level" - | Synchronize_round _ -> Format.fprintf fmt "synchronize round" - | Watch_proposal -> Format.fprintf fmt "watch proposal" - -let generate_seed_nonce_hash config delegate level = - if level.Level.expected_commitment then - Baking_nonces.generate_seed_nonce config delegate level.level - >>=? fun seed_nonce -> return_some seed_nonce - else return_none - -let sign_block_header state proposer unsigned_block_header = - let cctxt = state.global_state.cctxt in - let chain_id = state.global_state.chain_id in - let force = state.global_state.config.force in - let {Block_header.shell; protocol_data = {contents; _}} = - unsigned_block_header - in - let unsigned_header = - Data_encoding.Binary.to_bytes_exn - Alpha_context.Block_header.unsigned_encoding - (shell, contents) - in - let level = shell.level in - Baking_state.round_of_shell_header shell >>?= fun round -> - let open Baking_highwatermarks in - cctxt#with_lock (fun () -> - let block_location = - Baking_files.resolve_location ~chain_id `Highwatermarks - in - may_sign_block - cctxt - block_location - ~delegate:proposer.public_key_hash - ~level - ~round - >>=? function - | true -> - record_block - cctxt - block_location - ~delegate:proposer.public_key_hash - ~level - ~round - >>=? fun () -> return_true - | false -> - Events.(emit potential_double_baking (level, round)) >>= fun () -> - return force) - >>=? function - | false -> fail (Block_previously_baked {level; round}) - | true -> - Client_keys.sign - cctxt - proposer.secret_key_uri - ~watermark:Block_header.(to_watermark (Block_header chain_id)) - unsigned_header - >>=? fun signature -> - return {Block_header.shell; protocol_data = {contents; signature}} - -let forge_signed_block ~state_recorder ~updated_state state block_to_bake = - let open Lwt_result_syntax in - let { - predecessor; - round; - delegate = (consensus_key, _) as delegate; - kind; - force_apply; - } = - block_to_bake - in - Events.( - emit - prepare_forging_block - (Int32.succ predecessor.shell.level, round, delegate)) - >>= fun () -> - let cctxt = state.global_state.cctxt in - let chain_id = state.global_state.chain_id in - let simulation_mode = state.global_state.validation_mode in - let round_durations = state.global_state.round_durations in - Environment.wrap_tzresult - (Round.timestamp_of_round - round_durations - ~predecessor_timestamp:predecessor.shell.timestamp - ~predecessor_round:predecessor.round - ~round) - >>?= fun timestamp -> - let external_operation_source = state.global_state.config.extra_operations in - Operations_source.retrieve external_operation_source >>= fun extern_ops -> - let simulation_kind, payload_round = - match kind with - | Fresh pool -> - let pool = - let node_pool = Operation_pool.Prioritized.of_pool pool in - match extern_ops with - | None -> node_pool - | Some ops -> - Operation_pool.Prioritized.merge_external_operations node_pool ops - in - (Block_forge.Filter pool, round) - | Reproposal {consensus_operations; payload_hash; payload_round; payload} -> - ( Block_forge.Apply - { - ordered_pool = - Operation_pool.ordered_pool_of_payload - ~consensus_operations - payload; - payload_hash; - }, - payload_round ) - in - Events.( - emit forging_block (Int32.succ predecessor.shell.level, round, delegate)) - >>= fun () -> - Plugin.RPC.current_level - cctxt - ~offset:1l - (`Hash state.global_state.chain_id, `Hash (predecessor.hash, 0)) - >>=? fun injection_level -> - generate_seed_nonce_hash - state.global_state.config.Baking_configuration.nonce - consensus_key - injection_level - >>=? fun seed_nonce_opt -> - let seed_nonce_hash = Option.map fst seed_nonce_opt in - let user_activated_upgrades = - state.global_state.config.user_activated_upgrades - in - (* Set liquidity_baking_toggle_vote for this block *) - let {Baking_configuration.vote_file; liquidity_baking_vote} = - state.global_state.config.liquidity_baking - in - (* Prioritize reading from the [vote_file] if it exists. *) - (match vote_file with - | Some per_block_vote_file -> - Liquidity_baking_vote.read_liquidity_baking_toggle_vote_no_fail - ~default_liquidity_baking_vote:liquidity_baking_vote - ~per_block_vote_file - | None -> Lwt.return liquidity_baking_vote) - >>= fun liquidity_baking_toggle_vote -> - (* Cache last toggle vote to use in case of vote file errors *) - let updated_state = - { - updated_state with - global_state = - { - updated_state.global_state with - config = - { - updated_state.global_state.config with - liquidity_baking = - { - updated_state.global_state.config.liquidity_baking with - liquidity_baking_vote = liquidity_baking_toggle_vote; - }; - }; - }; - } - in - Events.(emit vote_for_liquidity_baking_toggle) liquidity_baking_toggle_vote - >>= fun () -> - let chain = `Hash state.global_state.chain_id in - let pred_block = `Hash (predecessor.hash, 0) in - let* pred_resulting_context_hash = - Shell_services.Blocks.resulting_context_hash - cctxt - ~chain - ~block:pred_block - () - in - let* pred_live_blocks = - Chain_services.Blocks.live_blocks cctxt ~chain ~block:pred_block () - in - Block_forge.forge - cctxt - ~chain_id - ~pred_info:predecessor - ~pred_live_blocks - ~pred_resulting_context_hash - ~timestamp - ~round - ~seed_nonce_hash - ~payload_round - ~liquidity_baking_toggle_vote - ~user_activated_upgrades - ~force_apply - state.global_state.config.fees - simulation_mode - simulation_kind - state.global_state.constants.parametric - >>=? fun {unsigned_block_header; operations} -> - sign_block_header state consensus_key unsigned_block_header - >>=? fun signed_block_header -> - (match seed_nonce_opt with - | None -> - (* Nothing to do *) - return_unit - | Some (_, nonce) -> - let block_hash = Block_header.hash signed_block_header in - Baking_nonces.register_nonce cctxt ~chain_id block_hash nonce) - >>=? fun () -> - state_recorder ~new_state:updated_state >>=? fun () -> - let signed_block = - {round; delegate; operations; block_header = signed_block_header} - in - return (signed_block, updated_state) - -let inject_block ~updated_state state signed_block = - let {round; delegate; block_header; operations} = signed_block in - Events.(emit injecting_block (block_header.shell.level, round, delegate)) - >>= fun () -> - let cctxt = state.global_state.cctxt in - Node_rpc.inject_block - cctxt - ~force:state.global_state.config.force - ~chain:(`Hash state.global_state.chain_id) - block_header - operations - >>=? fun bh -> - Events.(emit block_injected (bh, block_header.shell.level, round, delegate)) - >>= fun () -> return updated_state - -let sign_consensus_votes state operations kind = - let open Lwt_result_syntax in - let cctxt = state.global_state.cctxt in - let chain_id = state.global_state.chain_id in - (* N.b. signing a lot of operations may take some time *) - (* Don't parallelize signatures: the signer might not be able to - handle concurrent requests *) - let block_location = - Baking_files.resolve_location ~chain_id `Highwatermarks - in - (* Hypothesis: all consensus votes have the same round and level *) - match operations with - | [] -> return_nil - | (_, (consensus_content : consensus_content)) :: _ -> - let level = Raw_level.to_int32 consensus_content.level in - let round = consensus_content.round in - (* Filter all operations that don't satisfy the highwatermark *) - let* authorized_consensus_votes = - cctxt#with_lock @@ fun () -> - let* highwatermarks = Baking_highwatermarks.load cctxt block_location in - let may_sign_consensus_vote = - match kind with - | `Preendorsement -> Baking_highwatermarks.may_sign_preendorsement - | `Endorsement -> Baking_highwatermarks.may_sign_endorsement - in - let*! authorized_operations = - List.filter_s - (fun (((consensus_key, _delegate_pkh) as delegate), _) -> - let may_sign = - may_sign_consensus_vote - highwatermarks - ~delegate:consensus_key.public_key_hash - ~level - ~round - in - if may_sign || state.global_state.config.force then - Lwt.return_true - else - let*! () = - match kind with - | `Preendorsement -> - Events.( - emit - skipping_preendorsement - ( delegate, - level, - round, - [ - Baking_highwatermarks.Block_previously_preendorsed - {round; level}; - ] )) - | `Endorsement -> - Events.( - emit - skipping_endorsement - ( delegate, - level, - round, - [ - Baking_highwatermarks.Block_previously_endorsed - {round; level}; - ] )) - in - Lwt.return_false) - operations - in - (* Record all consensus votes new highwatermarks as one batch *) - let* () = - let delegates = - List.map - (fun ((ck, _), _) -> ck.public_key_hash) - authorized_operations - in - let record_all_consensus_vote = - match kind with - | `Preendorsement -> - Baking_highwatermarks.record_all_preendorsements - | `Endorsement -> Baking_highwatermarks.record_all_endorsements - in - record_all_consensus_vote - highwatermarks - cctxt - block_location - ~delegates - ~level - ~round - in - return authorized_operations - in - let forge_and_sign_consensus_vote : type a. _ -> a contents_list -> _ = - fun ((consensus_key, _) as delegate) contents -> - let shell = - (* The branch is the latest finalized block. *) - { - Tezos_base.Operation.branch = - state.level_state.latest_proposal.predecessor.shell.predecessor; - } - in - let watermark = - match kind with - | `Preendorsement -> - Operation.(to_watermark (Preendorsement chain_id)) - | `Endorsement -> Operation.(to_watermark (Endorsement chain_id)) - in - let unsigned_operation = (shell, Contents_list contents) in - let unsigned_operation_bytes = - Data_encoding.Binary.to_bytes_exn - Operation.unsigned_encoding - unsigned_operation - in - let level = Raw_level.to_int32 consensus_content.level in - let round = consensus_content.round in - let sk_uri = consensus_key.secret_key_uri in - Client_keys.sign cctxt ~watermark sk_uri unsigned_operation_bytes - >>= function - | Error err -> - (match kind with - | `Preendorsement -> - Events.( - emit skipping_preendorsement (delegate, level, round, err)) - | `Endorsement -> - Events.(emit skipping_endorsement (delegate, level, round, err))) - >>= fun () -> return_none - | Ok signature -> - let protocol_data = - Operation_data {contents; signature = Some signature} - in - let operation : Operation.packed = {shell; protocol_data} in - return_some (delegate, operation, level, round) - in - List.filter_map_es - (fun (delegate, consensus_content) -> - let event = - match kind with - | `Preendorsement -> Events.signing_preendorsement - | `Endorsement -> Events.signing_endorsement - in - Events.(emit event delegate) >>= fun () -> - match kind with - | `Endorsement -> - forge_and_sign_consensus_vote - delegate - (Single (Endorsement consensus_content)) - | `Preendorsement -> - forge_and_sign_consensus_vote - delegate - (Single (Preendorsement consensus_content))) - authorized_consensus_votes - -let inject_consensus_vote state preendorsements kind = - let cctxt = state.global_state.cctxt in - let chain_id = state.global_state.chain_id in - sign_consensus_votes state preendorsements kind >>=? fun signed_operations -> - (* TODO: add a RPC to inject multiple operations *) - let fail_inject_event, injected_event = - match kind with - | `Preendorsement -> - (Events.failed_to_inject_preendorsement, Events.preendorsement_injected) - | `Endorsement -> - (Events.failed_to_inject_endorsement, Events.endorsement_injected) - in - List.iter_ep - (fun (delegate, operation, level, round) -> - protect - ~on_error:(fun err -> - Events.(emit fail_inject_event (delegate, err)) >>= fun () -> - return_unit) - (fun () -> - Node_rpc.inject_operation cctxt ~chain:(`Hash chain_id) operation - >>=? fun oph -> - Events.(emit injected_event (oph, delegate, level, round)) - >>= fun () -> return_unit)) - signed_operations - -let sign_dal_attestations state attestations = - let cctxt = state.global_state.cctxt in - let chain_id = state.global_state.chain_id in - (* N.b. signing a lot of operations may take some time *) - (* Don't parallelize signatures: the signer might not be able to - handle concurrent requests *) - let shell = - { - Tezos_base.Operation.branch = - state.level_state.latest_proposal.predecessor.hash; - } - in - List.filter_map_es - (fun (((consensus_key, _) as delegate), consensus_content) -> - let watermark = Operation.(to_watermark (Dal_attestation chain_id)) in - let contents = - Single (Dal_attestation (consensus_content : Dal.Attestation.operation)) - in - let unsigned_operation = (shell, Contents_list contents) in - let unsigned_operation_bytes = - Data_encoding.Binary.to_bytes_exn - Operation.unsigned_encoding - unsigned_operation - in - Client_keys.sign - cctxt - ~watermark - consensus_key.secret_key_uri - unsigned_operation_bytes - >>= function - | Error err -> - let level = Raw_level.to_int32 consensus_content.level in - let round = state.round_state.current_round in - Events.(emit skipping_attestation (delegate, level, round, err)) - >>= fun () -> return_none - | Ok signature -> - let protocol_data = - Operation_data {contents; signature = Some signature} - in - let operation : Operation.packed = {shell; protocol_data} in - return_some - (delegate, operation, consensus_content.Dal.Attestation.attestation)) - attestations - -let inject_dal_attestations state attestations = - let cctxt = state.global_state.cctxt in - let chain_id = state.global_state.chain_id in - sign_dal_attestations state attestations >>=? fun signed_operations -> - List.iter_ep - (fun (delegate, signed_operation, (attestation : Dal.Attestation.t)) -> - let encoded_op = - Data_encoding.Binary.to_bytes_exn Operation.encoding signed_operation - in - Shell_services.Injection.operation - cctxt - ~chain:(`Hash chain_id) - encoded_op - >>=? fun oph -> - let bitset_int = Bitset.to_z (attestation :> Bitset.t) in - Events.(emit attestation_injected (oph, delegate, bitset_int)) - >>= fun () -> return_unit) - signed_operations - -let no_dal_node_warning_counter = ref 0 - -let only_if_dal_feature_enabled state ~default_value f = - let open Constants in - let Parametric.{dal = {feature_enable; _}; _} = - state.global_state.constants.parametric - in - if feature_enable then - match state.global_state.dal_node_rpc_ctxt with - | None -> - incr no_dal_node_warning_counter ; - (if !no_dal_node_warning_counter mod 10 = 1 then - Events.(emit no_dal_node ()) - else Lwt.return_unit) - >>= fun () -> return default_value - | Some ctxt -> f ctxt - else return default_value - -let get_dal_attestations state ~level = - only_if_dal_feature_enabled state ~default_value:[] (fun dal_node_rpc_ctxt -> - let delegates = - SlotMap.bindings state.level_state.delegate_slots.own_delegate_slots - |> List.map (fun (_slot, (consensus_key_and_delegate, _slots)) -> - consensus_key_and_delegate) - |> List.sort_uniq compare - (* TODO: https://gitlab.com/tezos/tezos/-/issues/4666 - This sorting can be avoided. *) - in - let signing_key delegate = (fst delegate).public_key_hash in - List.fold_left_es - (fun acc delegate -> - Node_rpc.get_attestable_slots - dal_node_rpc_ctxt - (signing_key delegate) - ~level - >>=? fun res -> - match res with - | Tezos_dal_node_services.Types.Not_in_committee -> return acc - | Attestable_slots {slots = attestation; published_level = _} -> - return ((delegate, attestation) :: acc)) - [] - delegates - >>=? fun attestations -> - List.map - (fun (delegate, attestation_flags) -> - let attestation = - List.fold_left_i - (fun i acc flag -> - match Dal.Slot_index.of_int_opt i with - | Some index when flag -> Dal.Attestation.commit acc index - | None | Some _ -> acc) - Dal.Attestation.empty - attestation_flags - in - ( delegate, - Dal.Attestation. - { - attestor = signing_key delegate; - attestation; - level = Raw_level.of_int32_exn level; - } )) - attestations - |> return) - -let get_and_inject_dal_attestations state = - let level = Int32.succ state.level_state.current_level in - get_dal_attestations state ~level >>=? fun attestations -> - inject_dal_attestations state attestations - -let prepare_waiting_for_quorum state = - let consensus_threshold = - state.global_state.constants.parametric.consensus_threshold - in - let get_slot_voting_power ~slot = - match - SlotMap.find slot state.level_state.delegate_slots.all_delegate_slots - with - | Some {endorsing_power; first_slot} when Slot.equal slot first_slot -> - Some endorsing_power - | Some _ | None (* cannot happen if the map is correctly populated *) -> - None - in - let latest_proposal = state.level_state.latest_proposal.block in - (* assert (latest_proposal.block.round = state.round_state.current_round) ; *) - let candidate = - { - Operation_worker.hash = latest_proposal.hash; - round_watched = latest_proposal.round; - payload_hash_watched = latest_proposal.payload_hash; - } - in - (consensus_threshold, get_slot_voting_power, candidate) - -let start_waiting_for_preendorsement_quorum state = - let consensus_threshold, get_slot_voting_power, candidate = - prepare_waiting_for_quorum state - in - let operation_worker = state.global_state.operation_worker in - Operation_worker.monitor_preendorsement_quorum - operation_worker - ~consensus_threshold - ~get_slot_voting_power - candidate - -let start_waiting_for_endorsement_quorum state = - let consensus_threshold, get_slot_voting_power, candidate = - prepare_waiting_for_quorum state - in - let operation_worker = state.global_state.operation_worker in - Operation_worker.monitor_endorsement_quorum - operation_worker - ~consensus_threshold - ~get_slot_voting_power - candidate - -let compute_round proposal round_durations = - let open Protocol in - let open Baking_state in - let timestamp = Time.System.now () |> Time.System.to_protocol in - let predecessor_block = proposal.predecessor in - Environment.wrap_tzresult - @@ Alpha_context.Round.round_of_timestamp - round_durations - ~predecessor_timestamp:predecessor_block.shell.timestamp - ~predecessor_round:predecessor_block.round - ~timestamp - -let update_to_level state level_update = - let {new_level_proposal; compute_new_state} = level_update in - let cctxt = state.global_state.cctxt in - let delegates = state.global_state.delegates in - let new_level = new_level_proposal.block.shell.level in - let chain = `Hash state.global_state.chain_id in - (* Sync the context to clean-up potential GC artifacts *) - (match state.global_state.validation_mode with - | Node -> Lwt.return_unit - | Local index -> index.sync_fun ()) - >>= fun () -> - (if Int32.(new_level = succ state.level_state.current_level) then - return state.level_state.next_level_delegate_slots - else - Baking_state.compute_delegate_slots cctxt delegates ~level:new_level ~chain) - >>=? fun delegate_slots -> - Baking_state.compute_delegate_slots - cctxt - delegates - ~level:(Int32.succ new_level) - ~chain - >>=? fun next_level_delegate_slots -> - let round_durations = state.global_state.round_durations in - compute_round new_level_proposal round_durations >>?= fun current_round -> - compute_new_state ~current_round ~delegate_slots ~next_level_delegate_slots - >>= return - -let synchronize_round state {new_round_proposal; handle_proposal} = - Events.(emit synchronizing_round new_round_proposal.predecessor.hash) - >>= fun () -> - let round_durations = state.global_state.round_durations in - compute_round new_round_proposal round_durations >>?= fun current_round -> - if Round.(current_round < new_round_proposal.block.round) then - (* impossible *) - failwith - "synchronize_round: current round (%a) is behind the new proposal's \ - round (%a)" - Round.pp - current_round - Round.pp - new_round_proposal.block.round - else - let new_round_state = - {current_round; current_phase = Idle; delayed_quorum = None} - in - let new_state = {state with round_state = new_round_state} in - handle_proposal new_state >>= return - -(* TODO: https://gitlab.com/tezos/tezos/-/issues/4539 - Avoid updating the state here. - (See also comment in {!State_transitions.step}.) - - TODO: https://gitlab.com/tezos/tezos/-/issues/4538 - Improve/clarify when the state is recorded. -*) -let rec perform_action ~state_recorder state (action : action) = - match action with - | Do_nothing -> state_recorder ~new_state:state >>=? fun () -> return state - | Inject_block {kind; updated_state} -> - (match kind with - | Forge_and_inject block_to_bake -> - forge_signed_block ~state_recorder ~updated_state state block_to_bake - | Inject_only signed_block -> return (signed_block, updated_state)) - >>=? fun (signed_block, updated_state) -> - inject_block ~updated_state state signed_block - | Forge_block {block_to_bake; updated_state} -> - forge_signed_block ~state_recorder ~updated_state state block_to_bake - >|=? fun (signed_block, updated_state) -> - let updated_state = - { - updated_state with - level_state = - { - updated_state.level_state with - next_forged_block = Some signed_block; - }; - } - in - updated_state - | Inject_preendorsements {preendorsements} -> - inject_consensus_vote state preendorsements `Preendorsement >>=? fun () -> - perform_action ~state_recorder state Watch_proposal - | Inject_endorsements {endorsements} -> - state_recorder ~new_state:state >>=? fun () -> - inject_consensus_vote state endorsements `Endorsement >>=? fun () -> - (* We wait for endorsements to trigger the [Quorum_reached] - event *) - start_waiting_for_endorsement_quorum state >>= fun () -> - (* TODO: https://gitlab.com/tezos/tezos/-/issues/4667 - Also inject attestations for the migration block. *) - (* TODO: https://gitlab.com/tezos/tezos/-/issues/4671 - Don't inject multiple attestations? *) - get_and_inject_dal_attestations state >>=? fun () -> return state - | Update_to_level level_update -> - update_to_level state level_update >>=? fun (new_state, new_action) -> - perform_action ~state_recorder new_state new_action - | Synchronize_round round_update -> - synchronize_round state round_update >>=? fun (new_state, new_action) -> - perform_action ~state_recorder new_state new_action - | Watch_proposal -> - (* We wait for preendorsements to trigger the - [Prequorum_reached] event *) - start_waiting_for_preendorsement_quorum state >>= fun () -> return state diff --git a/src/proto_017_PtNairob/lib_delegate/baking_actions.mli b/src/proto_017_PtNairob/lib_delegate/baking_actions.mli deleted file mode 100644 index 861f3c89c1084606f099b77abbb297e094270081..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_actions.mli +++ /dev/null @@ -1,142 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context -open Baking_state - -type block_kind = - | Fresh of Operation_pool.pool - | Reproposal of { - consensus_operations : packed_operation list; - payload_hash : Block_payload_hash.t; - payload_round : Round.t; - payload : Operation_pool.payload; - } - -type block_to_bake = { - predecessor : block_info; - round : Round.t; - delegate : consensus_key_and_delegate; - kind : block_kind; - force_apply : bool; - (** if true, while baking the block, try and apply the block and its - operations instead of only validating them. this can be permanently - set using the [--force-apply] flag (see [force_apply_switch_arg] in - [baking_commands.ml]). *) -} - -type inject_block_kind = - | Forge_and_inject of block_to_bake - (** Forge and inject a freshly forged block. [block_to_bake] should be - used in the forging process. *) - | Inject_only of signed_block - (** Inject [signed_block]. The baker can pre-emptively forge a signed - block with the [Forge_block] action if it knows it is the next baker - and it is idle. *) - -type action = - | Do_nothing - | Inject_block of {kind : inject_block_kind; updated_state : state} - | Forge_block of {block_to_bake : block_to_bake; updated_state : state} - | Inject_preendorsements of { - preendorsements : (consensus_key_and_delegate * consensus_content) list; - } - | Inject_endorsements of { - endorsements : (consensus_key_and_delegate * consensus_content) list; - } - | Update_to_level of level_update - | Synchronize_round of round_update - | Watch_proposal - -and level_update = { - new_level_proposal : proposal; - compute_new_state : - current_round:Round.t -> - delegate_slots:delegate_slots -> - next_level_delegate_slots:delegate_slots -> - (state * action) Lwt.t; -} - -and round_update = { - new_round_proposal : proposal; - handle_proposal : state -> (state * action) Lwt.t; -} - -type t = action - -val generate_seed_nonce_hash : - Baking_configuration.nonce_config -> - consensus_key -> - Level.t -> - (Nonce_hash.t * Nonce.t) option tzresult Lwt.t - -val inject_block : - updated_state:state -> state -> signed_block -> state tzresult Lwt.t - -val sign_consensus_votes : - state -> - (consensus_key_and_delegate * consensus_content) list -> - [`Preendorsement | `Endorsement] -> - ((consensus_key * public_key_hash) * packed_operation * int32 * Round.t) list - tzresult - Lwt.t - -val inject_consensus_vote : - state -> - (consensus_key_and_delegate * consensus_content) list -> - [`Preendorsement | `Endorsement] -> - unit tzresult Lwt.t - -val sign_dal_attestations : - state -> - (consensus_key_and_delegate * Dal.Attestation.operation) list -> - (consensus_key_and_delegate * packed_operation * Dal.Attestation.t) list - tzresult - Lwt.t - -val get_dal_attestations : - state -> - level:Int32.t -> - (consensus_key_and_delegate * Dal.Attestation.operation) list tzresult Lwt.t - -val prepare_waiting_for_quorum : - state -> int * (slot:Slot.t -> int option) * Operation_worker.candidate - -val start_waiting_for_preendorsement_quorum : state -> unit Lwt.t - -val start_waiting_for_endorsement_quorum : state -> unit Lwt.t - -val update_to_level : state -> level_update -> (state * t) tzresult Lwt.t - -val pp_action : Format.formatter -> t -> unit - -val compute_round : proposal -> Round.round_durations -> Round.t tzresult - -val perform_action : - state_recorder:(new_state:state -> unit tzresult Lwt.t) -> - state -> - t -> - state tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_delegate/baking_cache.ml b/src/proto_017_PtNairob/lib_delegate/baking_cache.ml deleted file mode 100644 index 4cafd496adad75c29ac173bd98f8e54089d4e531..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_cache.ml +++ /dev/null @@ -1,92 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Cache structures used to memoize costly RPCs/computations. *) - -open Protocol.Alpha_context - -type round = Round.t - -module Block_cache = - Aches.Vache.Map (Aches.Vache.LRU_Precise) (Aches.Vache.Strong) (Block_hash) - -(** The [Timestamp_of_round_tbl] module allows to create memoization tables - to store function calls of [Round.timestamp_of_round]. *) -module Timestamp_of_round_cache = - Aches.Vache.Map (Aches.Vache.LRU_Precise) (Aches.Vache.Strong) - (struct - (* The type of keys is a tuple that corresponds to the arguments - of [Round.timestamp_of_round]. *) - type t = Timestamp.time * round * round - - let hash k = Hashtbl.hash k - - let equal (ts, r1, r2) (ts', r1', r2') = - Timestamp.(ts = ts') && Round.(r1 = r1') && Round.(r2 = r2') - end) - -module Round_cache_key = struct - type ts_interval = Timestamp.time * Timestamp.time - - (** The values that are intended to be used here are the - arguments are: predecessor_timestamp * predecessor_round * - timestamp_interval *) - type t = { - predecessor_timestamp : Timestamp.time; - predecessor_round : round; - time_interval : ts_interval; - } - - let hash {predecessor_timestamp; predecessor_round; _} = - Stdlib.Hashtbl.hash (predecessor_timestamp, predecessor_round) - - let equal - { - predecessor_timestamp = pred_t; - predecessor_round = pred_r; - time_interval = t_beg, t_end; - } - { - predecessor_timestamp = pred_t'; - predecessor_round = pred_r'; - time_interval = t_beg', t_end'; - } = - Timestamp.(pred_t = pred_t') - && Round.(pred_r = pred_r') - && Timestamp.(t_beg' <= t_beg) - && Timestamp.(t_end < t_end') -end - -module Round_timestamp_interval_cache = - Aches.Vache.Map (Aches.Vache.LRU_Precise) (Aches.Vache.Strong) - (Round_cache_key) - -module Cycle_cache = - Aches.Vache.Map (Aches.Vache.LRU_Precise) (Aches.Vache.Strong) - (struct - include Cycle - - let hash = Hashtbl.hash - end) diff --git a/src/proto_017_PtNairob/lib_delegate/baking_commands.ml b/src/proto_017_PtNairob/lib_delegate/baking_commands.ml deleted file mode 100644 index a8f766c7cb05ca43039844d5c524a0f58c25bb98..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_commands.ml +++ /dev/null @@ -1,541 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs *) -(* *) -(* 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 Client_proto_args - -let pidfile_arg = - Tezos_clic.arg - ~doc:"write process id in file" - ~short:'P' - ~long:"pidfile" - ~placeholder:"filename" - (Tezos_clic.parameter (fun _ s -> return s)) - -let may_lock_pidfile pidfile_opt f = - match pidfile_opt with - | None -> f () - | Some pidfile -> - Lwt_lock_file.try_with_lock - ~when_locked:(fun () -> - failwith "Failed to create the pidfile: %s" pidfile) - ~filename:pidfile - f - -let http_headers_env_variable = - "TEZOS_CLIENT_REMOTE_OPERATIONS_POOL_HTTP_HEADERS" - -let http_headers = - match Sys.getenv_opt http_headers_env_variable with - | None -> None - | Some contents -> - let lines = String.split_on_char '\n' contents in - Some - (List.fold_left - (fun acc line -> - match String.index_opt line ':' with - | None -> - invalid_arg - (Printf.sprintf - "Http headers: invalid %s environment variable, missing \ - colon" - http_headers_env_variable) - | Some pos -> - let header = String.trim (String.sub line 0 pos) in - let header = String.lowercase_ascii header in - if header <> "host" then - invalid_arg - (Printf.sprintf - "Http headers: invalid %s environment variable, only \ - 'host' headers are supported" - http_headers_env_variable) ; - let value = - String.trim - (String.sub line (pos + 1) (String.length line - pos - 1)) - in - (header, value) :: acc) - [] - lines) - -let operations_arg = - Tezos_clic.arg - ~long:"operations-pool" - ~placeholder:"file|uri" - ~doc: - (Printf.sprintf - "When specified, the baker will try to fetch operations from this \ - file (or uri) and to include retrieved operations in the block. The \ - expected format of the contents is a list of operations [ \ - alpha.operation ]. Environment variable '%s' may also be specified \ - to add headers to the requests (only 'host' headers are supported). \ - If the resource cannot be retrieved, e.g., if the file is absent, \ - unreadable, or the web service returns a 404 error, the resource is \ - simply ignored." - http_headers_env_variable) - (Tezos_clic.map_parameter - ~f:(fun uri -> - let open Baking_configuration in - match Uri.scheme uri with - | Some "http" | Some "https" -> - Operations_source.(Remote {uri; http_headers}) - | None | Some _ -> - (* acts as if it were file even though it might no be *) - Operations_source.(Local {filename = Uri.to_string uri})) - uri_parameter) - -let context_path_arg = - Tezos_clic.arg - ~long:"context" - ~placeholder:"path" - ~doc: - "When specified, the client will read in the local context at the \ - provided path in order to build the block, instead of relying on the \ - 'preapply' RPC." - string_parameter - -let force_apply_switch_arg = - Tezos_clic.switch - ~long:"force-apply" - ~doc:"Force the baker to not only validate but also apply operations." - () - -let endorsement_force_switch_arg = - Tezos_clic.switch - ~long:"force" - ~short:'f' - ~doc: - "Disable consistency, injection and double signature checks for \ - (pre)endorsements." - () - -let do_not_monitor_node_mempool_arg = - Tezos_clic.switch - ~long:"ignore-node-mempool" - ~doc: - "Ignore mempool operations from the node and do not subsequently monitor \ - them. Use in conjunction with --operations option to restrict the \ - observed operations to those of the mempool file." - () - -let keep_alive_arg = - Tezos_clic.switch - ~doc: - "Keep the daemon process alive: when the connection with the node is \ - lost, the daemon periodically tries to reach it." - ~short:'K' - ~long:"keep-alive" - () - -let liquidity_baking_toggle_vote_parameter = - Tezos_clic.parameter - ~autocomplete:(fun _ctxt -> return ["on"; "off"; "pass"]) - (let open Protocol.Alpha_context.Liquidity_baking in - fun _ctxt -> function - | "on" -> return LB_on - | "off" -> return LB_off - | "pass" -> return LB_pass - | s -> - failwith - "unexpected vote: %s, expected either \"on\", \"off\", or \"pass\"." - s) - -let liquidity_baking_toggle_vote_arg = - Tezos_clic.arg - ~doc: - "Vote to continue or end the liquidity baking subsidy. The possible \ - values for this option are: \"off\" to request ending the subsidy, \ - \"on\" to request continuing or restarting the subsidy, and \"pass\" to \ - abstain. Note that this \"option\" is mandatory!" - ~long:"liquidity-baking-toggle-vote" - ~placeholder:"vote" - liquidity_baking_toggle_vote_parameter - -let state_recorder_switch_arg = - let open Baking_configuration in - Tezos_clic.map_arg - ~f:(fun _cctxt flag -> if flag then return Filesystem else return Memory) - (Tezos_clic.switch - ~long:"record-state" - ~doc: - "If record-state flag is set, the baker saves all its internal \ - consensus state in the filesystem, otherwise just in memory." - ()) - -let get_delegates (cctxt : Protocol_client_context.full) - (pkhs : Signature.public_key_hash list) = - let proj_delegate (alias, public_key_hash, public_key, secret_key_uri) = - { - Baking_state.alias = Some alias; - public_key_hash; - public_key; - secret_key_uri; - } - in - (if pkhs = [] then - Client_keys.get_keys cctxt >>=? fun keys -> - List.map proj_delegate keys |> return - else - List.map_es - (fun pkh -> - Client_keys.get_key cctxt pkh >>=? function - | alias, pk, sk_uri -> return (proj_delegate (alias, pkh, pk, sk_uri))) - pkhs) - >>=? fun delegates -> - Tezos_signer_backends.Encrypted.decrypt_list - cctxt - (List.filter_map - (function - | {Baking_state.alias = Some alias; _} -> Some alias | _ -> None) - delegates) - >>=? fun () -> - let delegates_no_duplicates = List.sort_uniq compare delegates in - (if List.compare_lengths delegates delegates_no_duplicates <> 0 then - cctxt#warning - "Warning: the list of public key hash aliases contains duplicate hashes, \ - which are ignored" - else Lwt.return ()) - >>= fun () -> return delegates_no_duplicates - -let sources_param = - Tezos_clic.seq_of_param - (Client_keys.Public_key_hash.source_param - ~name:"baker" - ~desc: - "name of the delegate owning the endorsement/baking right or name of \ - the consensus key signing on the delegate's behalf") - -let endpoint_arg = - Tezos_clic.arg - ~long:"dal-node" - ~placeholder:"uri" - ~doc:"endpoint of the DAL node, e.g. 'http://localhost:8933'" - (Tezos_clic.parameter (fun _ s -> return @@ Uri.of_string s)) - -let block_count_arg = - Tezos_clic.default_arg - ~long:"count" - ~short:'n' - ~placeholder:"block count" - ~doc:"number of blocks to bake" - ~default:"1" - @@ Client_proto_args.positive_int_parameter () - -let delegate_commands () : Protocol_client_context.full Tezos_clic.command list - = - let open Tezos_clic in - let group = - {name = "delegate.client"; title = "Tenderbake client commands"} - in - [ - command - ~group - ~desc:"Forge and inject block using the delegates' rights." - (args12 - minimal_fees_arg - minimal_nanotez_per_gas_unit_arg - minimal_nanotez_per_byte_arg - minimal_timestamp_switch - force_apply_switch_arg - force_switch - operations_arg - context_path_arg - do_not_monitor_node_mempool_arg - endpoint_arg - block_count_arg - state_recorder_switch_arg) - (prefixes ["bake"; "for"] @@ sources_param) - (fun ( minimal_fees, - minimal_nanotez_per_gas_unit, - minimal_nanotez_per_byte, - minimal_timestamp, - force_apply, - force, - extra_operations, - context_path, - do_not_monitor_node_mempool, - dal_node_endpoint, - block_count, - state_recorder ) - pkhs - cctxt -> - get_delegates cctxt pkhs >>=? fun delegates -> - Baking_lib.bake - cctxt - ~minimal_nanotez_per_gas_unit - ~minimal_timestamp - ~minimal_nanotez_per_byte - ~minimal_fees - ~force_apply - ~force - ~monitor_node_mempool:(not do_not_monitor_node_mempool) - ?extra_operations - ?context_path - ?dal_node_endpoint - ~count:block_count - ~state_recorder - delegates); - command - ~group - ~desc:"Forge and inject an endorsement operation." - (args1 endorsement_force_switch_arg) - (prefixes ["endorse"; "for"] @@ sources_param) - (fun force pkhs cctxt -> - get_delegates cctxt pkhs >>=? fun delegates -> - Baking_lib.endorse ~force cctxt delegates); - command - ~group - ~desc:"Forge and inject a preendorsement operation." - (args1 endorsement_force_switch_arg) - (prefixes ["preendorse"; "for"] @@ sources_param) - (fun force pkhs cctxt -> - get_delegates cctxt pkhs >>=? fun delegates -> - Baking_lib.preendorse ~force cctxt delegates); - command - ~group - ~desc:"Send a Tenderbake proposal" - (args9 - minimal_fees_arg - minimal_nanotez_per_gas_unit_arg - minimal_nanotez_per_byte_arg - minimal_timestamp_switch - force_apply_switch_arg - force_switch - operations_arg - context_path_arg - state_recorder_switch_arg) - (prefixes ["propose"; "for"] @@ sources_param) - (fun ( minimal_fees, - minimal_nanotez_per_gas_unit, - minimal_nanotez_per_byte, - minimal_timestamp, - force_apply, - force, - extra_operations, - context_path, - state_recorder ) - sources - cctxt -> - get_delegates cctxt sources >>=? fun delegates -> - Baking_lib.propose - cctxt - ~minimal_nanotez_per_gas_unit - ~minimal_timestamp - ~minimal_nanotez_per_byte - ~minimal_fees - ~force_apply - ~force - ?extra_operations - ?context_path - ~state_recorder - delegates); - ] - -let directory_parameter = - Tezos_clic.parameter (fun _ p -> - if not (Sys.file_exists p && Sys.is_directory p) then - failwith "Directory doesn't exist: '%s'" p - else return p) - -let per_block_vote_file_arg = - Tezos_clic.arg - ~doc:"read per block votes as json file" - ~short:'V' - ~long:"votefile" - ~placeholder:"filename" - (Tezos_clic.parameter (fun (_cctxt : Protocol_client_context.full) file -> - let open Lwt_result_syntax in - let* file_exists = - protect - ~on_error:(fun _ -> - tzfail (Liquidity_baking_vote.Block_vote_file_not_found file)) - (fun () -> - let*! b = Lwt_unix.file_exists file in - return b) - in - if file_exists then return file - else tzfail (Liquidity_baking_vote.Block_vote_file_not_found file))) - -let pre_emptive_forge_time_arg = - Tezos_clic.arg - ~long:"pre-emptive-forge-time" - ~placeholder:"seconds" - ~doc: - "Sets the pre-emptive forge time optimization, in seconds. When set, the \ - baker, if it is the next level round 0 proposer, will start forging \ - after quorum has been reached in the current level while idly waiting \ - for it to end. When it is its time to propose, the baker will inject \ - the pre-emptively forged block immediately, allowing more time for the \ - network to reach quorum on it. Operators should note that the higher \ - this value `t`, the lower the operation inclusion window (specifically \ - `block_time - t`) which may lead to lower baking rewards. Defaults to \ - 15/% of block time. Set to 0 to ignore pre-emptive forging." - (Tezos_clic.parameter (fun _ s -> - try return (Q.of_string s) - with _ -> failwith "pre-emptive-forge-time expected int or float.")) - -let lookup_default_vote_file_path (cctxt : Protocol_client_context.full) = - let open Lwt_syntax in - let default_filename = Liquidity_baking_vote.default_vote_json_filename in - let file_exists path = - Lwt.catch (fun () -> Lwt_unix.file_exists path) (fun _ -> return_false) - in - let when_s pred x g = - let* b = pred x in - if b then return_some x else g () - in - (* Check in current working directory *) - when_s file_exists default_filename @@ fun () -> - (* Check in the baker directory *) - let base_dir_file = Filename.Infix.(cctxt#get_base_dir // default_filename) in - when_s file_exists base_dir_file @@ fun () -> return_none - -type baking_mode = Local of {local_data_dir_path : string} | Remote - -let baker_args = - Tezos_clic.args12 - pidfile_arg - minimal_fees_arg - minimal_nanotez_per_gas_unit_arg - minimal_nanotez_per_byte_arg - force_apply_switch_arg - keep_alive_arg - liquidity_baking_toggle_vote_arg - per_block_vote_file_arg - operations_arg - endpoint_arg - state_recorder_switch_arg - pre_emptive_forge_time_arg - -let run_baker - ( pidfile, - minimal_fees, - minimal_nanotez_per_gas_unit, - minimal_nanotez_per_byte, - force_apply, - keep_alive, - liquidity_baking_toggle_vote, - per_block_vote_file, - extra_operations, - dal_node_endpoint, - state_recorder, - pre_emptive_forge_time ) baking_mode sources cctxt = - may_lock_pidfile pidfile @@ fun () -> - (if per_block_vote_file = None then - (* If the liquidity baking file was not explicitly given, we - look into default locations. *) - lookup_default_vote_file_path cctxt - else Lwt.return per_block_vote_file) - >>= fun per_block_vote_file -> - (* We don't let the user run the baker without providing some - option (CLI, file path, or file in default location) for - the toggle vote. *) - Liquidity_baking_vote.load_liquidity_baking_config - ~per_block_vote_file_arg:per_block_vote_file - ~toggle_vote_arg:liquidity_baking_toggle_vote - >>=? fun liquidity_baking -> - get_delegates cctxt sources >>=? fun delegates -> - let context_path = - match baking_mode with - | Local {local_data_dir_path} -> - Some Filename.Infix.(local_data_dir_path // "context") - | Remote -> None - in - Client_daemon.Baker.run - cctxt - ~minimal_fees - ~minimal_nanotez_per_gas_unit - ~minimal_nanotez_per_byte - ~liquidity_baking - ?extra_operations - ?dal_node_endpoint - ?pre_emptive_forge_time - ~force_apply - ?context_path - ~chain:cctxt#chain - ~keep_alive - ~state_recorder - delegates - -let baker_commands () : Protocol_client_context.full Tezos_clic.command list = - let open Tezos_clic in - let group = - { - Tezos_clic.name = "delegate.baker"; - title = "Commands related to the baker daemon."; - } - in - [ - command - ~group - ~desc:"Launch the baker daemon." - baker_args - (prefixes ["run"; "with"; "local"; "node"] - @@ param - ~name:"node_data_path" - ~desc:"Path to the node data directory (e.g. $HOME/.tezos-node)" - directory_parameter - @@ sources_param) - (fun args local_data_dir_path sources cctxt -> - let baking_mode = Local {local_data_dir_path} in - run_baker args baking_mode sources cctxt); - command - ~group - ~desc:"Launch the baker daemon using RPCs only." - baker_args - (prefixes ["run"; "remotely"] @@ sources_param) - (fun args sources cctxt -> - let baking_mode = Remote in - run_baker args baking_mode sources cctxt); - command - ~group - ~desc:"Launch the VDF daemon" - (args2 pidfile_arg keep_alive_arg) - (prefixes ["run"; "vdf"] @@ stop) - (fun (pidfile, keep_alive) cctxt -> - may_lock_pidfile pidfile @@ fun () -> - Client_daemon.VDF.run cctxt ~chain:cctxt#chain ~keep_alive); - ] - -let accuser_commands () = - let open Tezos_clic in - let group = - { - Tezos_clic.name = "delegate.accuser"; - title = "Commands related to the accuser daemon."; - } - in - [ - command - ~group - ~desc:"Launch the accuser daemon" - (args3 pidfile_arg Client_proto_args.preserved_levels_arg keep_alive_arg) - (prefixes ["run"] @@ stop) - (fun (pidfile, preserved_levels, keep_alive) cctxt -> - may_lock_pidfile pidfile @@ fun () -> - Client_daemon.Accuser.run - cctxt - ~chain:cctxt#chain - ~preserved_levels - ~keep_alive); - ] diff --git a/src/proto_017_PtNairob/lib_delegate/baking_commands.mli b/src/proto_017_PtNairob/lib_delegate/baking_commands.mli deleted file mode 100644 index 02e2819da4b960f650fc50621ecbb9d053512bcc..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_commands.mli +++ /dev/null @@ -1,33 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs *) -(* *) -(* 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 delegate_commands : - unit -> Protocol_client_context.full Tezos_clic.command list - -val baker_commands : - unit -> Protocol_client_context.full Tezos_clic.command list - -val accuser_commands : - unit -> Protocol_client_context.full Tezos_clic.command list diff --git a/src/proto_017_PtNairob/lib_delegate/baking_commands_registration.ml b/src/proto_017_PtNairob/lib_delegate/baking_commands_registration.ml deleted file mode 100644 index 7a1b3cd90c685898afe7fd9e9c6f590338af8a9d..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_commands_registration.ml +++ /dev/null @@ -1,29 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs *) -(* *) -(* 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 () = - Client_commands.register Protocol.hash @@ fun _network -> - List.map (Tezos_clic.map_command (new Protocol_client_context.wrap_full)) - @@ Baking_commands.delegate_commands () diff --git a/src/proto_017_PtNairob/lib_delegate/baking_configuration.ml b/src/proto_017_PtNairob/lib_delegate/baking_configuration.ml deleted file mode 100644 index 26ac82616a3de03b57256d86412b99938f2d42d5..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_configuration.ml +++ /dev/null @@ -1,362 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 Operations_source = struct - type t = - | Local of {filename : string} - | Remote of {uri : Uri.t; http_headers : (string * string) list option} - - let pp ppf = function - | Local {filename} -> Format.pp_print_string ppf filename - | Remote {uri; _} -> Format.fprintf ppf "%a" Uri.pp uri - - let encoding = - let open Data_encoding in - union - ~tag_size:`Uint8 - [ - case - (Tag 1) - ~title:"Local" - (obj2 (req "filename" string) (req "kind" (constant "Local"))) - (function Local {filename} -> Some (filename, ()) | _ -> None) - (fun (filename, ()) -> Local {filename}); - case - (Tag 2) - ~title:"Remote" - (obj3 - (req "uri" string) - (opt "http_headers" (list (tup2 string string))) - (req "kind" (constant "Remote"))) - (function - | Remote {uri; http_headers} -> - Some (Uri.to_string uri, http_headers, ()) - | _ -> None) - (fun (uri_str, http_headers, ()) -> - Remote {uri = Uri.of_string uri_str; http_headers}); - ] -end - -open Protocol.Alpha_context - -type fees_config = { - minimal_fees : Tez.t; - minimal_nanotez_per_gas_unit : Q.t; - minimal_nanotez_per_byte : Q.t; -} - -type validation_config = - | Local of {context_path : string} - | Node - | ContextIndex of Abstract_context_index.t - -type nonce_config = Deterministic | Random - -type state_recorder_config = Filesystem | Memory - -type liquidity_baking_config = { - vote_file : string option; - liquidity_baking_vote : - Protocol.Alpha_context.Liquidity_baking.liquidity_baking_toggle_vote; -} - -type t = { - fees : fees_config; - nonce : nonce_config; - validation : validation_config; - retries_on_failure : int; - user_activated_upgrades : (int32 * Protocol_hash.t) list; - liquidity_baking : liquidity_baking_config; - force_apply : bool; - force : bool; - state_recorder : state_recorder_config; - extra_operations : Operations_source.t option; - dal_node_endpoint : Uri.t option; - pre_emptive_forge_time : Time.System.Span.t; -} - -let default_fees_config = - { - minimal_fees = - (match Tez.of_mutez 100L with None -> assert false | Some t -> t); - minimal_nanotez_per_gas_unit = Q.of_int 100; - minimal_nanotez_per_byte = Q.of_int 1000; - } - -let default_validation_config = Node - -(* Unclear if determinist nonces, and more importantly, if - [supports_deterministic_nonces] is supported. *) -let default_nonce_config = Random - -let default_retries_on_failure_config = 5 - -let default_user_activated_upgrades = [] - -let default_liquidity_baking_config = - { - vote_file = None; - liquidity_baking_vote = Protocol.Alpha_context.Liquidity_baking.LB_pass; - } - -let default_force = false - -let default_force_apply = false - -let default_state_recorder_config = Memory - -let default_extra_operations = None - -let default_pre_emptive_forge_time = Time.System.Span.of_seconds_exn 0. - -let default_config = - { - fees = default_fees_config; - nonce = default_nonce_config; - validation = default_validation_config; - retries_on_failure = default_retries_on_failure_config; - user_activated_upgrades = default_user_activated_upgrades; - liquidity_baking = default_liquidity_baking_config; - force_apply = default_force_apply; - force = default_force; - state_recorder = default_state_recorder_config; - extra_operations = default_extra_operations; - dal_node_endpoint = None; - pre_emptive_forge_time = default_pre_emptive_forge_time; - } - -let make ?(minimal_fees = default_fees_config.minimal_fees) - ?(minimal_nanotez_per_gas_unit = - default_fees_config.minimal_nanotez_per_gas_unit) - ?(minimal_nanotez_per_byte = default_fees_config.minimal_nanotez_per_byte) - ?(nonce = default_nonce_config) ?context_path - ?(retries_on_failure = default_retries_on_failure_config) - ?(user_activated_upgrades = default_user_activated_upgrades) - ?(liquidity_baking = default_liquidity_baking_config) - ?(force_apply = default_force_apply) ?(force = default_force) - ?(state_recorder = default_state_recorder_config) ?extra_operations - ?dal_node_endpoint - ?(pre_emptive_forge_time = default_pre_emptive_forge_time) () = - let fees = - {minimal_fees; minimal_nanotez_per_gas_unit; minimal_nanotez_per_byte} - in - let validation = - match context_path with - | None -> Node - | Some context_path -> Local {context_path} - in - { - fees; - validation; - nonce; - retries_on_failure; - user_activated_upgrades; - liquidity_baking; - force_apply; - force; - state_recorder; - extra_operations; - dal_node_endpoint; - pre_emptive_forge_time; - } - -let fees_config_encoding : fees_config Data_encoding.t = - let open Data_encoding in - let q_encoding = - conv (fun q -> Q.to_string q) (fun s -> Q.of_string s) string - in - conv - (fun {minimal_fees; minimal_nanotez_per_gas_unit; minimal_nanotez_per_byte} -> - (minimal_fees, minimal_nanotez_per_gas_unit, minimal_nanotez_per_byte)) - (fun (minimal_fees, minimal_nanotez_per_gas_unit, minimal_nanotez_per_byte) -> - {minimal_fees; minimal_nanotez_per_gas_unit; minimal_nanotez_per_byte}) - (obj3 - (req "minimal_fees" Tez.encoding) - (req "minimal_nanotez_per_gas_unit" q_encoding) - (req "minimal_nanotez_per_byte" q_encoding)) - -let validation_config_encoding = - let open Data_encoding in - union - ~tag_size:`Uint8 - [ - case - ~title:"Local" - (Tag 0) - (obj1 (req "local" string)) - (function Local {context_path} -> Some context_path | _ -> None) - (fun context_path -> Local {context_path}); - case - ~title:"Node" - (Tag 1) - (constant "node") - (function Node -> Some () | _ -> None) - (fun () -> Node); - ] - -let nonce_config_encoding = - let open Data_encoding in - union - ~tag_size:`Uint8 - [ - case - ~title:"Deterministic" - (Tag 0) - (constant "deterministic") - (function Deterministic -> Some () | _ -> None) - (fun () -> Deterministic); - case - ~title:"Random" - (Tag 1) - (constant "Random") - (function Random -> Some () | _ -> None) - (fun () -> Random); - ] - -let retries_on_failure_config_encoding = Data_encoding.int31 - -let user_activate_upgrades_config_encoding = - let open Data_encoding in - list (tup2 int32 Protocol_hash.encoding) - -let liquidity_baking_config_encoding = - let open Data_encoding in - def (String.concat "." [Protocol.name; "liquidity_baking_config"]) - @@ conv - (fun {vote_file; liquidity_baking_vote} -> - (vote_file, liquidity_baking_vote)) - (fun (vote_file, liquidity_baking_vote) -> - {vote_file; liquidity_baking_vote}) - (obj2 - (opt "per_block_vote_file" string) - (req - "liquidity_baking_vote" - Protocol.Alpha_context.Liquidity_baking - .liquidity_baking_toggle_vote_encoding)) - -let liquidity_baking_toggle_vote_config_encoding = - Protocol.Alpha_context.Liquidity_baking.liquidity_baking_toggle_vote_encoding - -let force_config_encoding = Data_encoding.bool - -let force_apply_config_encoding = Data_encoding.bool - -let state_recorder_config_encoding = - let open Data_encoding in - union - ~tag_size:`Uint8 - [ - case - ~title:"Filesystem" - (Tag 0) - (constant "filesystem") - (function Filesystem -> Some () | _ -> None) - (fun () -> Filesystem); - case - ~title:"Memory" - (Tag 1) - (constant "memory") - (function Memory -> Some () | _ -> None) - (fun () -> Memory); - ] - -let encoding : t Data_encoding.t = - let open Data_encoding in - def - (String.concat "." [Protocol.name; "baking_configuration"]) - ~title:"Baking configuration" - ~description:"Baking configuration" - @@ conv - (fun { - fees; - validation; - nonce; - retries_on_failure; - user_activated_upgrades; - liquidity_baking; - force_apply; - force; - state_recorder; - extra_operations; - dal_node_endpoint; - pre_emptive_forge_time; - } -> - ( ( fees, - validation, - nonce, - retries_on_failure, - user_activated_upgrades, - liquidity_baking, - force_apply, - force, - state_recorder, - pre_emptive_forge_time ), - (extra_operations, dal_node_endpoint) )) - (fun ( ( fees, - validation, - nonce, - retries_on_failure, - user_activated_upgrades, - liquidity_baking, - force_apply, - force, - state_recorder, - pre_emptive_forge_time ), - (extra_operations, dal_node_endpoint) ) -> - { - fees; - validation; - nonce; - retries_on_failure; - user_activated_upgrades; - liquidity_baking; - force_apply; - force; - state_recorder; - extra_operations; - dal_node_endpoint; - pre_emptive_forge_time; - }) - (merge_objs - (obj10 - (req "fees" fees_config_encoding) - (req "validation" validation_config_encoding) - (req "nonce" nonce_config_encoding) - (req "retries_on_failure" retries_on_failure_config_encoding) - (req - "user_activated_upgrades" - user_activate_upgrades_config_encoding) - (req "liquidity_baking" liquidity_baking_config_encoding) - (req "force_apply" force_apply_config_encoding) - (req "force" force_config_encoding) - (req "state_recorder" state_recorder_config_encoding) - (req "pre_emptive_forge_time" Time.System.Span.encoding)) - (obj2 - (opt "extra_operations" Operations_source.encoding) - (opt "dal_node_endpoint" Tezos_rpc.Encoding.uri_encoding))) - -let pp fmt t = - let json = Data_encoding.Json.construct encoding t in - Format.fprintf fmt "%a" Data_encoding.Json.pp json diff --git a/src/proto_017_PtNairob/lib_delegate/baking_configuration.mli b/src/proto_017_PtNairob/lib_delegate/baking_configuration.mli deleted file mode 100644 index 7b2bb4ea746f6f48f1f19515623e7287fc94bc31..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_configuration.mli +++ /dev/null @@ -1,134 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 Operations_source abstraction} *) -module Operations_source : sig - type t = - | Local of {filename : string} - (** local mempool resource located in [filename] *) - | Remote of {uri : Uri.t; http_headers : (string * string) list option} - (** remote resource located a [uri], with additional [http_headers] - parameters *) - - val encoding : t Data_encoding.t - - val pp : Format.formatter -> t -> unit -end - -type fees_config = { - minimal_fees : Protocol.Alpha_context.Tez.t; - minimal_nanotez_per_gas_unit : Q.t; - minimal_nanotez_per_byte : Q.t; -} - -type validation_config = - | Local of {context_path : string} - | Node - | ContextIndex of Abstract_context_index.t - -type nonce_config = Deterministic | Random - -type state_recorder_config = Filesystem | Memory - -type liquidity_baking_config = { - vote_file : string option; - liquidity_baking_vote : - Protocol.Alpha_context.Liquidity_baking.liquidity_baking_toggle_vote; -} - -type t = { - fees : fees_config; - nonce : nonce_config; - validation : validation_config; - retries_on_failure : int; - user_activated_upgrades : (int32 * Protocol_hash.t) list; - liquidity_baking : liquidity_baking_config; - force_apply : bool; - force : bool; - state_recorder : state_recorder_config; - extra_operations : Operations_source.t option; - dal_node_endpoint : Uri.t option; - pre_emptive_forge_time : Time.System.Span.t; -} - -val default_fees_config : fees_config - -val default_validation_config : validation_config - -val default_nonce_config : nonce_config - -val default_retries_on_failure_config : int - -val default_user_activated_upgrades : (int32 * Protocol_hash.t) list - -val default_liquidity_baking_config : liquidity_baking_config - -val default_force_apply : bool - -val default_force : bool - -val default_state_recorder_config : state_recorder_config - -val default_extra_operations : Operations_source.t option - -val default_pre_emptive_forge_time : Time.System.Span.t - -val default_config : t - -val make : - ?minimal_fees:Protocol.Alpha_context.Tez.t -> - ?minimal_nanotez_per_gas_unit:Q.t -> - ?minimal_nanotez_per_byte:Q.t -> - ?nonce:nonce_config -> - ?context_path:string -> - ?retries_on_failure:int -> - ?user_activated_upgrades:(int32 * Protocol_hash.t) list -> - ?liquidity_baking:liquidity_baking_config -> - ?force_apply:bool -> - ?force:bool -> - ?state_recorder:state_recorder_config -> - ?extra_operations:Operations_source.t -> - ?dal_node_endpoint:Uri.t -> - ?pre_emptive_forge_time:Time.System.Span.t -> - unit -> - t - -val fees_config_encoding : fees_config Data_encoding.t - -val validation_config_encoding : validation_config Data_encoding.t - -val nonce_config_encoding : nonce_config Data_encoding.t - -val retries_on_failure_config_encoding : int Data_encoding.t - -val user_activate_upgrades_config_encoding : - (int32 * Protocol_hash.t) list Data_encoding.t - -val liquidity_baking_toggle_vote_config_encoding : - Protocol.Alpha_context.Liquidity_baking.liquidity_baking_toggle_vote - Data_encoding.t - -val encoding : t Data_encoding.t - -val pp : Format.formatter -> t -> unit diff --git a/src/proto_017_PtNairob/lib_delegate/baking_errors.ml b/src/proto_017_PtNairob/lib_delegate/baking_errors.ml deleted file mode 100644 index 0332e0b7e510ec6c683f9af459d128acf58145b0..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_errors.ml +++ /dev/null @@ -1,65 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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_open_context_index of {context_path : string} - -type error += Node_connection_lost - -type error += Cannot_load_local_file of string - -let make_id id = String.concat "." [Protocol.name; id] - -let () = - Error_monad.register_error_kind - `Temporary - ~id:(make_id "cannot_open_context_index") - ~title:"Cannot open context index" - ~description:"Failed to open the context index at the given location" - ~pp:(fun fmt path -> - Format.fprintf fmt "Cannot open context index at %s" path) - Data_encoding.(obj1 (req "cannot_open_context_index" Data_encoding.string)) - (function - | Cannot_open_context_index {context_path} -> Some context_path - | _ -> None) - (fun context_path -> Cannot_open_context_index {context_path}) ; - register_error_kind - `Temporary - ~id:(make_id "baking_scheduling.node_connection_lost") - ~title:"Node connection lost" - ~description:"The connection with the node was lost." - ~pp:(fun fmt () -> Format.fprintf fmt "Lost connection with the node") - Data_encoding.empty - (function Node_connection_lost -> Some () | _ -> None) - (fun () -> Node_connection_lost) ; - register_error_kind - `Temporary - ~id:(make_id "baking_scheduling.cannot_load_local_file") - ~title:"Cannot load local file" - ~description:"Cannot load local file." - ~pp:(fun fmt filename -> - Format.fprintf fmt "Cannot load the local file %s" filename) - Data_encoding.(obj1 (req "file" string)) - (function Cannot_load_local_file s -> Some s | _ -> None) - (fun s -> Cannot_load_local_file s) diff --git a/src/proto_017_PtNairob/lib_delegate/baking_events.ml b/src/proto_017_PtNairob/lib_delegate/baking_events.ml deleted file mode 100644 index d8f0ace055c310b7e4fbf8707ac097e53a761d60..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_events.ml +++ /dev/null @@ -1,1079 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context - -let section = [Protocol.name; "baker"] - -let pp_int32 fmt n = Format.fprintf fmt "%ld" n - -let pp_int64 fmt n = Format.fprintf fmt "%Ld" n - -module State_transitions = struct - include Internal_event.Simple - - let section = section @ ["transitions"] - - let new_valid_proposal = - declare_3 - ~section - ~name:"new_valid_proposal" - ~level:Notice - ~msg:"received new proposal {block} at level {level}, round {round}" - ~pp1:Block_hash.pp - ("block", Block_hash.encoding) - ~pp2:pp_int32 - ("level", Data_encoding.int32) - ~pp3:Round.pp - ("round", Round.encoding) - - let new_head = - declare_3 - ~section - ~name:"new_head" - ~level:Notice - ~msg:"received new head {block} at level {level}, round {round}" - ~pp1:Block_hash.pp - ("block", Block_hash.encoding) - ~pp2:pp_int32 - ("level", Data_encoding.int32) - ~pp3:Round.pp - ("round", Round.encoding) - - let new_head_with_increasing_level = - declare_0 - ~section - ~name:"new_head_with_increasing_level" - ~level:Info - ~msg:"received new head with level increasing" - () - - let no_proposal_slot = - declare_3 - ~section - ~name:"no_proposal_slot" - ~level:Info - ~msg: - "end of round {current_round}; no proposal slot at level {level}, \ - round {next_round}" - ~pp1:Round.pp - ("current_round", Round.encoding) - ~pp2:pp_int32 - ("level", Data_encoding.int32) - ~pp3:Round.pp - ("next_round", Round.encoding) - - let proposal_slot = - declare_4 - ~section - ~name:"proposal_slot" - ~level:Info - ~msg: - "end of round {current_round}; proposal slot at level {level}, round \ - {next_round} for {delegate}" - ~pp1:Round.pp - ("current_round", Round.encoding) - ~pp2:pp_int32 - ("level", Data_encoding.int32) - ~pp3:Round.pp - ("next_round", Round.encoding) - ~pp4:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - - let new_head_while_waiting_for_qc = - declare_0 - ~section - ~name:"new_head_while_waiting_for_qc" - ~level:Info - ~msg:"received new head while waiting for a quorum" - () - - let applied_expected_proposal_received = - declare_1 - ~section - ~name:"applied_expected_proposal_received" - ~level:Info - ~msg:"received the expected application notice for {proposal}" - ~pp1:Block_hash.pp - ("proposal", Block_hash.encoding) - - let unexpected_new_head_while_waiting_for_application = - declare_0 - ~section - ~name:"unexpected_new_head_while_waiting_for_application" - ~level:Info - ~msg:"received new head while waiting for another proposal's application" - () - - let new_valid_proposal_while_waiting_for_qc = - declare_0 - ~section - ~name:"new_valid_proposal_while_waiting_for_qc" - ~level:Info - ~msg:"received new valid proposal while waiting for a quorum" - () - - let valid_proposal_received_after_application = - declare_0 - ~section - ~name:"valid_proposal_received_after_application" - ~level:Info - ~msg:"received valid proposal for a block already applied" - () - - let unexpected_proposal_round = - declare_2 - ~section - ~name:"unexpected_proposal_round" - ~level:Info - ~msg: - "unexpected proposal round, expected: {expected_round}, got: \ - {proposal_round}" - ~pp1:Round.pp - ("expected_round", Round.encoding) - ~pp2:Round.pp - ("proposal_round", Round.encoding) - - let proposal_for_round_already_seen = - declare_3 - ~section - ~name:"proposal_for_round_already_seen" - ~level:Warning - ~msg: - "proposal {new_proposal} for current round ({current_round}) has \ - already been seen {previous_proposal}" - ~pp1:Block_hash.pp - ("new_proposal", Block_hash.encoding) - ~pp2:Round.pp - ("current_round", Round.encoding) - ~pp3:Block_hash.pp - ("previous_proposal", Block_hash.encoding) - - let updating_latest_proposal = - declare_1 - ~section - ~name:"updating_latest_proposal" - ~msg:"updating latest proposal to {block_hash}" - ~level:Info - ~pp1:Block_hash.pp - ("block_hash", Block_hash.encoding) - - let baker_is_ahead_of_node = - declare_2 - ~section - ~name:"baker_is_ahead" - ~level:Info - ~msg: - "baker (level: {baker_level}) is ahead of the node (level: \ - {node_level})" - ~pp1:pp_int32 - ("baker_level", Data_encoding.int32) - ~pp2:pp_int32 - ("node_level", Data_encoding.int32) - - let new_proposal_is_on_another_branch = - declare_2 - ~section - ~name:"new_proposal_is_on_another_branch" - ~level:Info - ~msg: - "received a proposal on another branch - current: current \ - pred{current_branch}, new pred {new_branch}" - ~pp1:Block_hash.pp - ("current_branch", Block_hash.encoding) - ~pp2:Block_hash.pp - ("new_branch", Block_hash.encoding) - - let switching_branch = - declare_0 - ~section - ~name:"switching_branch" - ~level:Info - ~msg:"switching branch" - () - - let branch_proposal_has_better_fitness = - declare_0 - ~section - ~name:"branch_proposal_has_better_fitness" - ~level:Info - ~msg:"different branch proposal has a better fitness than us" - () - - let branch_proposal_has_no_prequorum = - declare_0 - ~section - ~name:"branch_proposal_has_no_prequorum" - ~level:Info - ~msg:"different branch proposal has no prequorum but we do" - () - - let branch_proposal_has_lower_prequorum = - declare_0 - ~section - ~name:"branch_proposal_has_lower_prequorum" - ~level:Info - ~msg:"different branch proposal has a lower prequorum than us" - () - - let branch_proposal_has_better_prequorum = - declare_0 - ~section - ~name:"branch_proposal_has_better_prequorum" - ~level:Info - ~msg:"different branch proposal has a better prequorum" - () - - let branch_proposal_has_same_prequorum = - declare_0 - ~section - ~name:"branch_proposal_has_same_prequorum" - ~level:Error - ~msg:"different branch proposal has the same prequorum" - () - - let attempting_preendorse_proposal = - declare_1 - ~section - ~name:"attempting_preendorsing_proposal" - ~level:Info - ~msg:"attempting to preendorse proposal {block_hash}" - ~pp1:Block_hash.pp - ("block_hash", Block_hash.encoding) - - let skipping_invalid_proposal = - declare_0 - ~section - ~name:"skipping_invalid_proposal" - ~level:Info - ~msg:"invalid proposal, skipping" - () - - let outdated_proposal = - declare_1 - ~section - ~name:"outdated_proposal" - ~level:Debug - ~msg:"outdated proposal {block_hash}" - ~pp1:Block_hash.pp - ("block_hash", Block_hash.encoding) - - let preparing_fresh_block = - declare_2 - ~section - ~name:"preparing_fresh_block" - ~level:Info - ~msg:"preparing fresh block for {delegate} at round {round}" - ~pp1:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ~pp2:Round.pp - ("round", Round.encoding) - - let no_need_forge_block = - declare_2 - ~section - ~name:"no_need_forge_block" - ~level:Info - ~msg: - "found preemptively forged block. no need to forge block for \ - {delegate} at round {round}" - ~pp1:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ~pp2:Round.pp - ("round", Round.encoding) - - let no_endorsable_payload_fresh_block = - declare_0 - ~section - ~name:"no_endorsable_payload_fresh_block" - ~level:Info - ~msg:"no endorsable payload, proposing fresh block" - () - - let repropose_block = - declare_1 - ~section - ~name:"repropose_block" - ~level:Info - ~msg:"repropose block with payload {payload}" - ~pp1:Block_payload_hash.pp - ("payload", Block_payload_hash.encoding) - - let unexpected_prequorum_received = - declare_2 - ~section - ~name:"unexpected_prequorum_received" - ~level:Info - ~msg: - "unexpected prequorum received for {received_hash} instead of \ - {expected_hash}" - ~pp1:Block_hash.pp - ("received_hash", Block_hash.encoding) - ~pp2:Block_hash.pp - ("expected_hash", Block_hash.encoding) - - let unexpected_quorum_received = - declare_2 - ~section - ~name:"unexpected_quorum_received" - ~level:Info - ~msg: - "unexpected quorum received for {received_hash} instead of \ - {expected_hash}" - ~pp1:Block_hash.pp - ("received_hash", Block_hash.encoding) - ~pp2:Block_hash.pp - ("expected_hash", Block_hash.encoding) - - let step_current_phase = - declare_2 - ~section - ~name:"step_current_phase" - ~level:Debug - ~msg:"automaton step: current phase {phase}, event {event}" - ~pp1:Baking_state.pp_phase - ("phase", Baking_state.phase_encoding) - ~pp2:Baking_state.pp_event - ("event", Baking_state.event_encoding) -end - -module Node_rpc = struct - include Internal_event.Simple - - let section = section @ ["rpc"] - - let error_while_monitoring_heads = - declare_1 - ~section - ~name:"error_while_monitoring_heads" - ~level:Error - ~msg:"error while monitoring heads {trace}" - ~pp1:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let error_while_monitoring_valid_proposals = - declare_1 - ~section - ~name:"error_while_monitoring_valid_proposals" - ~level:Error - ~msg:"error while monitoring valid proposals {trace}" - ~pp1:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) -end - -module Scheduling = struct - include Internal_event.Simple - - let section = section @ ["scheduling"] - - let error_while_baking = - declare_1 - ~section - ~name:"error_while_baking" - ~level:Warning - ~msg:"error while baking {trace}" - ~pp1:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let waiting_for_new_head = - declare_0 - ~section - ~name:"waiting_for_new_head" - ~level:Info - ~msg:"no possible timeout, waiting for a new head to arrive..." - () - - let compute_next_timeout_elected_block = - declare_2 - ~section - ~name:"compute_next_timeout_elected_block" - ~level:Debug - ~msg: - "found an elected block at level {level}, round {round}... checking \ - baking rights" - ~pp1:pp_int32 - ("level", Data_encoding.int32) - ~pp2:Round.pp - ("round", Round.encoding) - - let proposal_already_injected = - declare_0 - ~section - ~name:"proposal_already_injected" - ~level:Debug - ~msg:"proposal already injected for next level, skipping..." - () - - let next_potential_slot = - declare_4 - ~section - ~name:"next_potential_slot" - ~level:Info - ~msg: - "next potential slot for level {level} is at round {round} at \ - {timestamp} for {delegate}" - ~pp1:pp_int32 - ("level", Data_encoding.int32) - ~pp2:Round.pp - ("round", Round.encoding) - ~pp3:Timestamp.pp - ("timestamp", Timestamp.encoding) - ~pp4:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - - let waiting_end_of_round = - declare_3 - ~section - ~name:"waiting_end_of_round" - ~level:Info - ~msg:"waiting {timespan} until end of round {round} at {timestamp}" - ~pp1:Ptime.Span.pp - ("timespan", Time.System.Span.encoding) - ~pp2:pp_int32 - ("round", Data_encoding.int32) - ~pp3:Timestamp.pp - ("timestamp", Timestamp.encoding) - - let waiting_delayed_end_of_round = - declare_4 - ~section - ~name:"waiting_delayed_end_of_round" - ~level:Info - ~msg: - "waiting {timespan} until {timestamp} (end of round {round} plus \ - {delay}s delay)" - ~pp1:Ptime.Span.pp - ("timespan", Time.System.Span.encoding) - ~pp2:pp_int32 - ("round", Data_encoding.int32) - ~pp3:Timestamp.pp - ("timestamp", Timestamp.encoding) - ~pp4:pp_int64 - ("delay", Data_encoding.int64) - - let waiting_time_to_bake = - declare_2 - ~section - ~name:"waiting_time_to_bake" - ~level:Info - ~msg:"waiting {timespan} until it's time to bake at {timestamp}" - ~pp1:Ptime.Span.pp - ("timespan", Time.System.Span.encoding) - ~pp2:Timestamp.pp - ("timestamp", Timestamp.encoding) - - let no_need_to_wait_for_proposal = - declare_0 - ~section - ~name:"no_need_to_wait_for_proposal" - ~level:Info - ~msg:"no need to wait to propose a block" - () - - let state_synchronized_to_round = - declare_1 - ~section - ~name:"state_synchronized_to_round" - ~level:Debug - ~msg:"state synchronized to round {round}" - ~pp1:Round.pp - ("round", Round.encoding) - - let proposal_in_the_future = - declare_1 - ~section - ~name:"proposal_in_the_future" - ~level:Debug - ~msg:"received proposal in the future {block_hash}" - ~pp1:Block_hash.pp - ("block_hash", Block_hash.encoding) - - let process_proposal_in_the_future = - declare_1 - ~section - ~name:"process_proposal_in_the_future" - ~level:Debug - ~msg:"process proposal received in the future with hash {block_hash}" - ~pp1:Block_hash.pp - ("block_hash", Block_hash.encoding) - - let waiting_to_forge_block = - declare_2 - ~section - ~name:"waiting_to_forge_block" - ~level:Info - ~msg:"waiting {timespan} until it's time to forge block at {timestamp}" - ~pp1:Ptime.Span.pp - ("timespan", Time.System.Span.encoding) - ~pp2:Timestamp.pp - ("timestamp", Timestamp.encoding) - - let no_need_to_wait_to_forge_block = - declare_0 - ~section - ~name:"no_need_to_wait_to_forge_block" - ~level:Info - ~msg:"no need to wait to forge a block" - () - - let first_baker_of_next_level = - declare_0 - ~section - ~name:"first_baker_of_next_level" - ~level:Info - ~msg: - "first baker of next level found among delegates. pre-emptively \ - forging block." - () -end - -module Lib = struct - include Internal_event.Simple - - let section = section @ ["lib"] - - let attempting_preendorse_proposal = - declare_1 - ~section - ~name:"attempting_preendorsing_proposal" - ~level:Debug - ~msg:"attempting to preendorse proposal {proposal}" - ~pp1:Baking_state.pp_proposal - ("proposal", Baking_state.proposal_encoding) - - let attempting_endorse_proposal = - declare_1 - ~section - ~name:"attempting_endorsing_proposal" - ~level:Debug - ~msg:"attempting to endorse proposal {proposal}" - ~pp1:Baking_state.pp_proposal - ("proposal", Baking_state.proposal_encoding) -end - -module Actions = struct - include Internal_event.Simple - - let section = section @ ["actions"] - - let skipping_preendorsement = - declare_4 - ~section - ~name:"skipping_preendorsement" - ~level:Error - ~msg: - "unable to sign preendorsement for {delegate} at level {level}, round \ - {round} -- {trace}" - ~pp1:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ~pp2:pp_int32 - ("level", Data_encoding.int32) - ~pp3:Round.pp - ("round", Round.encoding) - ~pp4:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let skipping_endorsement = - declare_4 - ~section - ~name:"skipping_endorsement" - ~level:Error - ~msg: - "unable to sign endorsement for {delegate} at level {level}, round \ - {round} -- {trace}" - ~pp1:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ~pp2:pp_int32 - ("level", Data_encoding.int32) - ~pp3:Round.pp - ("round", Round.encoding) - ~pp4:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let skipping_attestation = - declare_4 - ~section - ~name:"skipping_attestation" - ~level:Error - ~msg: - "unable to sign attestation for {delegate} at level {level}, round \ - {round} -- {trace}" - ~pp1:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ~pp2:pp_int32 - ("level", Data_encoding.int32) - ~pp3:Round.pp - ("round", Round.encoding) - ~pp4:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let failed_to_inject_preendorsement = - declare_2 - ~section - ~name:"failed_to_inject_preendorsement" - ~level:Error - ~msg:"failed to inject preendorsement for {delegate} -- {trace}" - ~pp1:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ~pp2:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let failed_to_inject_endorsement = - declare_2 - ~section - ~name:"failed_to_inject_endorsement" - ~level:Error - ~msg:"failed to inject endorsement for {delegate} -- {trace}" - ~pp1:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ~pp2:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let potential_double_baking = - declare_2 - ~section - ~name:"potential_double_baking" - ~level:Warning - ~msg:"potential double baking detected at level {level}, round {round}" - ~pp1:pp_int32 - ~pp2:Round.pp - ("level", Data_encoding.int32) - ("round", Round.encoding) - - let preendorsement_injected = - declare_4 - ~section - ~name:"preendorsement_injected" - ~level:Notice - ~msg: - "injected preendorsement {ophash} for {delegate} for level {level}, \ - round {round}" - ~pp1:Operation_hash.pp - ("ophash", Operation_hash.encoding) - ~pp2:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ~pp3:pp_int32 - ("level", Data_encoding.int32) - ~pp4:Round.pp - ("round", Round.encoding) - - let endorsement_injected = - declare_4 - ~section - ~name:"endorsement_injected" - ~level:Notice - ~msg: - "injected endorsement {ophash} for {delegate} for level {level}, round \ - {round}" - ~pp1:Operation_hash.pp - ("ophash", Operation_hash.encoding) - ~pp2:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ~pp3:pp_int32 - ("level", Data_encoding.int32) - ~pp4:Round.pp - ("round", Round.encoding) - - let attestation_injected = - declare_3 - ~section - ~name:"attestation_injected" - ~level:Notice - ~msg:"injected attestation {ophash} with bitset {bitset} for {delegate}" - ~pp1:Operation_hash.pp - ("ophash", Operation_hash.encoding) - ~pp2:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - ~pp3:Z.pp_print - ("bitset", Data_encoding.n) - - let synchronizing_round = - declare_1 - ~section - ~name:"synchronizing_round" - ~level:Info - ~msg:"synchronizing round after block {block}" - ~pp1:Block_hash.pp - ("block", Block_hash.encoding) - - let prepare_forging_block = - declare_3 - ~section - ~name:"prepare_forging_block" - ~level:Debug - ~msg: - "prepare forging block at level {level}, round {round} for {delegate}" - ~pp1:pp_int32 - ~pp2:Round.pp - ~pp3:Baking_state.pp_consensus_key_and_delegate - ("level", Data_encoding.int32) - ("round", Round.encoding) - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - - let forging_block = - declare_3 - ~section - ~name:"forging_block" - ~level:Info - ~msg:"forging block at level {level}, round {round} for {delegate}" - ~pp1:pp_int32 - ~pp2:Round.pp - ~pp3:Baking_state.pp_consensus_key_and_delegate - ("level", Data_encoding.int32) - ("round", Round.encoding) - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - - let injecting_block = - declare_3 - ~section - ~name:"injecting_block" - ~level:Debug - ~msg:"injecting block at level {level}, round {round} for {delegate}" - ~pp1:pp_int32 - ~pp2:Round.pp - ~pp3:Baking_state.pp_consensus_key_and_delegate - ("level", Data_encoding.int32) - ("round", Round.encoding) - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - - let block_injected = - declare_4 - ~section - ~name:"block_injected" - ~level:Notice - ~msg: - "block {block} at level {level}, round {round} injected for {delegate}" - ~pp1:Block_hash.pp - ~pp2:pp_int32 - ~pp3:Round.pp - ~pp4:Baking_state.pp_consensus_key_and_delegate - ("block", Block_hash.encoding) - ("level", Data_encoding.int32) - ("round", Round.encoding) - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - - let signing_preendorsement = - declare_1 - ~section - ~name:"signing_preendorsement" - ~level:Info - ~msg:"signing preendorsement for {delegate}" - ~pp1:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - - let signing_endorsement = - declare_1 - ~section - ~name:"signing_endorsement" - ~level:Info - ~msg:"signing endorsement for {delegate}" - ~pp1:Baking_state.pp_consensus_key_and_delegate - ("delegate", Baking_state.consensus_key_and_delegate_encoding) - - let invalid_json_file = - declare_1 - ~section - ~name:"invalid_json_file" - ~level:Warning - ~msg:"{filename} is not a valid JSON file" - ("filename", Data_encoding.string) - - let no_operations_found_in_file = - declare_1 - ~section - ~name:"no_operations_found_in_file" - ~level:Warning - ~msg:"no operations found in file {filename}" - ("filename", Data_encoding.string) - - let cannot_fetch_operations = - declare_1 - ~section - ~name:"cannot_fetch_operations" - ~level:Error - ~msg:"cannot fetch operations: {errs}" - ("errs", Error_monad.(TzTrace.encoding error_encoding)) - - let vote_for_liquidity_baking_toggle = - declare_1 - ~section - ~name:"vote_for_liquidity_baking_toggle" - ~level:Notice - ~msg:"Voting {value} for liquidity baking toggle vote" - ( "value", - Protocol.Alpha_context.Liquidity_baking - .liquidity_baking_toggle_vote_encoding ) - - let no_dal_node = - declare_0 - ~section - ~name:"no_dal_node" - ~level:Notice - ~msg: - "DAL feature enabled, but no DAL node specified: cannot fetch \ - attestations" - () -end - -module VDF = struct - include Internal_event.Simple - - let section = section @ ["vdf"] - - let vdf_revelation_injected = - declare_3 - ~section - ~name:"vdf_revelation_injected" - ~level:Notice - ~msg: - "Injected VDF revelation for cycle {cycle} (chain {chain} with \ - operation {ophash})" - ~pp1:pp_int32 - ("cycle", Data_encoding.int32) - ~pp2:Format.pp_print_string - ("chain", Data_encoding.string) - ~pp3:Operation_hash.pp - ("ophash", Operation_hash.encoding) - - let vdf_daemon_error = - declare_2 - ~section - ~name:"vdf_daemon_error" - ~level:Error - ~msg:"{worker}: error while running VDF daemon: {errors}" - ~pp1:Format.pp_print_string - ("worker", Data_encoding.string) - ~pp2:pp_print_top_error_of_trace - ("errors", Error_monad.(TzTrace.encoding error_encoding)) - - let vdf_daemon_connection_lost = - declare_1 - ~section - ~name:"vdf_daemon_connection_lost" - ~level:Error - ~msg:"Connection to node lost, VDF daemon {worker} exiting" - ~pp1:Format.pp_print_string - ("worker", Data_encoding.string) - - let vdf_daemon_cannot_kill_computation = - declare_1 - ~section - ~name:"vdf_daemon_cannot_kill_computation" - ~level:Error - ~msg:"Error when killining running computation: {error}" - ~pp1:Format.pp_print_string - ("error", Data_encoding.string) - - let vdf_info = - declare_1 - ~section - ~name:"vdf_internal" - ~level:Notice - ~msg:"{msg}" - ~pp1:Format.pp_print_string - ("msg", Data_encoding.string) -end - -module Nonces = struct - include Internal_event.Simple - - let section = section @ ["nonces"] - - let found_nonce_to_reveal = - declare_2 - ~section - ~name:"found_nonce_to_reveal" - ~level:Notice - ~msg:"found nonce to reveal for block {block}, level {level}" - ~pp1:Block_hash.pp - ("block", Block_hash.encoding) - ~pp2:pp_int32 - ("level", Data_encoding.int32) - - let revealing_nonce = - declare_3 - ~section - ~name:"revealing_nonce" - ~level:Notice - ~msg: - "revealing nonce of level {level} (chain {chain} with operation \ - {ophash})" - ~pp1:pp_int32 - ("level", Data_encoding.int32) - ~pp2:Format.pp_print_string - ("chain", Data_encoding.string) - ~pp3:Operation_hash.pp - ("ophash", Operation_hash.encoding) - - let cannot_fetch_chain_head_level = - declare_0 - ~section - ~name:"cannot_fetch_chain_head_level" - ~level:Error - ~msg:"cannot fetch chain head level, aborting nonces filtering" - () - - let incoherent_nonce = - declare_1 - ~section - ~name:"incoherent_nonce" - ~level:Error - ~msg:"incoherent nonce for level {level}" - ~pp1:pp_int32 - ("level", Data_encoding.int32) - - let cannot_read_nonces = - declare_1 - ~section - ~name:"cannot_read_nonces" - ~level:Error - ~msg:"cannot read nonces {trace}" - ~pp1:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let cannot_retrieve_unrevealed_nonces = - declare_1 - ~section - ~name:"cannot_retrieve_unrevealed_nonces" - ~level:Error - ~msg:"cannot retrieve unrevealed nonces {trace}" - ~pp1:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let cannot_inject_nonces = - declare_1 - ~section - ~name:"cannot_inject_nonces" - ~level:Error - ~msg:"cannot inject nonces {trace}" - ~pp1:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let cant_retrieve_block_header_for_nonce = - declare_2 - ~section - ~name:"cant_retrieve_block_header_for_nonce" - ~level:Warning - ~msg:"cannot retrieve block header {header} associated with nonce {trace}" - ("header", Data_encoding.string) - ~pp2:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let too_many_nonces = - declare_1 - ~section - ~name:"too_many_nonces" - ~level:Warning - ~msg: - "too many nonces associated with blocks unknown by node in \ - '$TEZOS_CLIENT/{filename}'. After checking that these blocks were \ - never included in the chain (e.g., via a block explorer), consider \ - using `octez-client filter orphan nonces` to clear them." - ("filename", Data_encoding.string) - - let registering_nonce = - declare_1 - ~section - ~name:"registering_nonce" - ~level:Info - ~msg:"registering nonce for block {block}" - ~pp1:Block_hash.pp - ("block", Block_hash.encoding) - - let nothing_to_reveal = - declare_1 - ~section - ~name:"nothing_to_reveal" - ~level:Info - ~msg:"nothing to reveal for block {block}" - ~pp1:Block_hash.pp - ("block", Block_hash.encoding) - - let revelation_worker_started = - declare_0 - ~section - ~name:"revelation_worker_started" - ~level:Info - ~msg:"revelation worker started" - () -end - -module Liquidity_baking = struct - include Internal_event.Simple - - let reading_per_block = - declare_1 - ~section - ~name:"reading_per_block" - ~level:Notice - ~msg:"reading liquidity baking vote file: {path}" - ("path", Data_encoding.string) - - let liquidity_baking_toggle_vote = - declare_1 - ~section - ~name:"liquidity_baking_toggle_vote" - ~level:Notice - ~msg:"liquidity baking toggle vote = {value}" - ( "value", - Protocol.Alpha_context.Liquidity_baking - .liquidity_baking_toggle_vote_encoding ) - - let per_block_vote_file_fail = - declare_1 - ~section - ~name:"per_block_vote_file_error" - ~level:Error - ~msg:"Error reading the block vote file: {errors}" - ~pp1:pp_print_top_error_of_trace - ("errors", Error_monad.(TzTrace.encoding error_encoding)) -end - -module Selection = struct - include Internal_event.Simple - - let section = section @ ["operation_selection"] - - let invalid_operation_filtered = - declare_2 - ~section - ~name:"invalid_operation_filtered" - ~level:Warning - ~msg:"filtered invalid operation {op}: {errors}" - ~pp1:Operation_hash.pp - ("op", Operation_hash.encoding) - ~pp2:pp_print_top_error_of_trace - ("errors", Error_monad.(TzTrace.encoding error_encoding)) - - let cannot_serialize_operation_metadata = - declare_1 - ~section - ~name:"cannot_serialize_operation_metadata" - ~level:Warning - ~msg:"cannot serialize operation {op} metadata" - ~pp1:Operation_hash.pp - ("op", Operation_hash.encoding) -end diff --git a/src/proto_017_PtNairob/lib_delegate/baking_files.ml b/src/proto_017_PtNairob/lib_delegate/baking_files.ml deleted file mode 100644 index 38339e2fe5554dcfaa7e5140ad6c95acbd5568a0..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_files.ml +++ /dev/null @@ -1,37 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 = string - -let resolve_location ~chain_id (kind : 'a) : 'a location = - let basename = - match kind with - | `Highwatermarks -> "highwatermark" - | `State -> "baker_state" - | `Nonce -> "nonce" - in - Format.asprintf "%a_%s" Chain_id.pp_short chain_id basename - -let filename x = x diff --git a/src/proto_017_PtNairob/lib_delegate/baking_files.mli b/src/proto_017_PtNairob/lib_delegate/baking_files.mli deleted file mode 100644 index 01146f7d0744cc8501dcf8766cf5308a4a29652b..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_files.mli +++ /dev/null @@ -1,33 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 - -val resolve_location : - chain_id:Chain_id.t -> - ([< `Highwatermarks | `Nonce | `State] as 'kind) -> - 'kind location - -val filename : [< `Highwatermarks | `Nonce | `State] location -> string diff --git a/src/proto_017_PtNairob/lib_delegate/baking_highwatermarks.ml b/src/proto_017_PtNairob/lib_delegate/baking_highwatermarks.ml deleted file mode 100644 index dde6c22d0a20685a94d5186bae8ec6692eaec6d5..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_highwatermarks.ml +++ /dev/null @@ -1,261 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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_client_context -open Protocol.Alpha_context - -type highwatermark = {round : Round.t; level : int32} - -let highwatermark_encoding : highwatermark Data_encoding.t = - let open Data_encoding in - conv - (fun {round; level} -> (round, level)) - (fun (round, level) -> {round; level}) - (obj2 - (req "round" Protocol.Alpha_context.Round.encoding) - (req "level" int32)) - -let pp_highwatermark fmt {round; level} = - Format.fprintf fmt "level: %ld, round: %a" level Round.pp round - -type error += Block_previously_baked of highwatermark - -type error += Block_previously_preendorsed of highwatermark - -type error += Block_previously_endorsed of highwatermark - -let () = - register_error_kind - `Permanent - ~id:"highwatermarks.block_previously_baked" - ~title:"Block previously baked" - ~description:"Trying to bake a block at a level previously baked" - ~pp:(fun ppf highwatermark -> - Format.fprintf - ppf - "A block with a higher watermark than the current one (%a) was \ - previously baked." - pp_highwatermark - highwatermark) - highwatermark_encoding - (function - | Block_previously_baked highwatermark -> Some highwatermark | _ -> None) - (fun highwatermark -> Block_previously_baked highwatermark) ; - register_error_kind - `Permanent - ~id:"highwatermarks.block_previously_preendorsed" - ~title:"Block previously preendorsed" - ~description: - "Trying to preendorse a block at a level previously preendorsed" - ~pp:(fun ppf highwatermark -> - Format.fprintf - ppf - "A preendorsement with a higher watermark than the current one (%a) \ - was already produced." - pp_highwatermark - highwatermark) - highwatermark_encoding - (function - | Block_previously_preendorsed highwatermark -> Some highwatermark - | _ -> None) - (fun highwatermark -> Block_previously_preendorsed highwatermark) ; - register_error_kind - `Permanent - ~id:"highwatermarks.block_previously_endorsed" - ~title:"Block previously endorsed" - ~description:"Trying to endorse a block at a level previously endorsed" - ~pp:(fun ppf highwatermark -> - Format.fprintf - ppf - "An endorsement with a higher watermark than the current one (%a) was \ - already produced." - pp_highwatermark - highwatermark) - highwatermark_encoding - (function - | Block_previously_endorsed highwatermark -> Some highwatermark - | _ -> None) - (fun highwatermark -> Block_previously_endorsed highwatermark) - -module DelegateMap = Map.Make (struct - type t = Signature.Public_key_hash.t - - let compare = Signature.Public_key_hash.compare -end) - -let highwatermark_delegate_map_encoding = - let open Data_encoding in - conv - DelegateMap.bindings - DelegateMap.( - fun l -> List.fold_left (fun map (k, v) -> add k v map) empty l) - (list - (obj2 - (req "delegate" Signature.Public_key_hash.encoding) - (req "highwatermark" highwatermark_encoding))) - -type highwatermarks = { - blocks : highwatermark DelegateMap.t; - preendorsements : highwatermark DelegateMap.t; - endorsements : highwatermark DelegateMap.t; -} - -type t = highwatermarks - -let encoding = - let open Data_encoding in - conv - (fun {blocks; preendorsements; endorsements} -> - (blocks, preendorsements, endorsements)) - (fun (blocks, preendorsements, endorsements) -> - {blocks; preendorsements; endorsements}) - (obj3 - (req "blocks" highwatermark_delegate_map_encoding) - (req "preendorsements" highwatermark_delegate_map_encoding) - (req "endorsements" highwatermark_delegate_map_encoding)) - -let empty = - { - blocks = DelegateMap.empty; - preendorsements = DelegateMap.empty; - endorsements = DelegateMap.empty; - } - -(* We do not lock these functions. The caller will be already locked. *) -let load (cctxt : #Protocol_client_context.full) location : t tzresult Lwt.t = - protect (fun () -> - cctxt#load (Baking_files.filename location) encoding ~default:empty) - -let save_highwatermarks (cctxt : #Protocol_client_context.full) filename - highwatermarks : unit tzresult Lwt.t = - protect (fun () -> - (* TODO: improve the backend so we don't write partial informations *) - cctxt#write filename highwatermarks encoding) - -let may_sign highwatermarks ~delegate ~level ~round = - match DelegateMap.find delegate highwatermarks with - | None -> true - | Some highwatermark -> - if Compare.Int32.(highwatermark.level < level) then true - else if Compare.Int32.(highwatermark.level = level) then - Round.(highwatermark.round < round) - else false - -let may_sign_block cctxt (location : [`Highwatermarks] Baking_files.location) - ~delegate ~level ~round = - load cctxt location >>=? fun all_highwatermarks -> - return @@ may_sign all_highwatermarks.blocks ~delegate ~level ~round - -let may_sign_preendorsement all_highwatermarks ~delegate ~level ~round = - may_sign all_highwatermarks.preendorsements ~delegate ~level ~round - -let may_sign_endorsement all_highwatermarks ~delegate ~level ~round = - may_sign all_highwatermarks.endorsements ~delegate ~level ~round - -let record map ~delegate ~new_level ~new_round = - DelegateMap.update - delegate - (function - | None -> Some {level = new_level; round = new_round} - | Some ({level; round} as prev) -> - if Compare.Int32.(new_level > level) then - Some {level = new_level; round = new_round} - else if Compare.Int32.(new_level = level) then - if Round.(new_round > round) then - Some {level = new_level; round = new_round} - else Some prev - else Some prev) - map - -let record_block (cctxt : #Protocol_client_context.full) location ~delegate - ~level ~round = - let filename = Baking_files.filename location in - load cctxt location >>=? fun highwatermarks -> - let new_blocks = - record highwatermarks.blocks ~delegate ~new_level:level ~new_round:round - in - save_highwatermarks cctxt filename {highwatermarks with blocks = new_blocks} - -let record_preendorsement (cctxt : #Protocol_client_context.full) location - ~delegate ~level ~round = - let filename = Baking_files.filename location in - load cctxt location >>=? fun highwatermarks -> - let new_preendorsements = - record - highwatermarks.preendorsements - ~delegate - ~new_level:level - ~new_round:round - in - save_highwatermarks - cctxt - filename - {highwatermarks with preendorsements = new_preendorsements} - -let record_endorsement (cctxt : #Protocol_client_context.full) location - ~delegate ~level ~round = - let filename = Baking_files.filename location in - load cctxt location >>=? fun highwatermarks -> - let new_endorsements = - record - highwatermarks.endorsements - ~delegate - ~new_level:level - ~new_round:round - in - save_highwatermarks - cctxt - filename - {highwatermarks with endorsements = new_endorsements} - -let record_all_preendorsements all_highwatermarks cctxt location ~delegates - ~level ~round = - let new_preendorsements = - List.fold_left - (fun map delegate -> - record map ~delegate ~new_level:level ~new_round:round) - all_highwatermarks.preendorsements - delegates - in - let filename = Baking_files.filename location in - save_highwatermarks - cctxt - filename - {all_highwatermarks with preendorsements = new_preendorsements} - -let record_all_endorsements all_highwatermarks cctxt location ~delegates ~level - ~round = - let new_endorsements = - List.fold_left - (fun map delegate -> - record map ~delegate ~new_level:level ~new_round:round) - all_highwatermarks.endorsements - delegates - in - let filename = Baking_files.filename location in - save_highwatermarks - cctxt - filename - {all_highwatermarks with endorsements = new_endorsements} diff --git a/src/proto_017_PtNairob/lib_delegate/baking_highwatermarks.mli b/src/proto_017_PtNairob/lib_delegate/baking_highwatermarks.mli deleted file mode 100644 index 24e785f092435eaff02945bee3bdb9a33d017b9f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_highwatermarks.mli +++ /dev/null @@ -1,107 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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.Alpha_context - -type highwatermark = {round : Round.t; level : int32} - -type error += Block_previously_baked of highwatermark - -type error += Block_previously_preendorsed of highwatermark - -type error += Block_previously_endorsed of highwatermark - -type t - -val encoding : t Data_encoding.t - -val load : - #Protocol_client_context.full -> - [`Highwatermarks] Baking_files.location -> - t tzresult Lwt.t - -val may_sign_block : - #Protocol_client_context.full -> - [`Highwatermarks] Baking_files.location -> - delegate:Signature.public_key_hash -> - level:int32 -> - round:Round.t -> - bool tzresult Lwt.t - -val may_sign_preendorsement : - t -> - delegate:Signature.public_key_hash -> - level:int32 -> - round:Round.t -> - bool - -val may_sign_endorsement : - t -> - delegate:Signature.public_key_hash -> - level:int32 -> - round:Round.t -> - bool - -val record_block : - #Protocol_client_context.full -> - [`Highwatermarks] Baking_files.location -> - delegate:Signature.public_key_hash -> - level:int32 -> - round:Round.t -> - unit tzresult Lwt.t - -val record_preendorsement : - #Protocol_client_context.full -> - [`Highwatermarks] Baking_files.location -> - delegate:Signature.public_key_hash -> - level:int32 -> - round:Round.t -> - unit tzresult Lwt.t - -val record_endorsement : - #Protocol_client_context.full -> - [`Highwatermarks] Baking_files.location -> - delegate:Signature.public_key_hash -> - level:int32 -> - round:Round.t -> - unit tzresult Lwt.t - -val record_all_preendorsements : - t -> - #Protocol_client_context.full -> - [`Highwatermarks] Baking_files.location -> - delegates:public_key_hash list -> - level:int32 -> - round:Round.t -> - unit tzresult Lwt.t - -val record_all_endorsements : - t -> - #Protocol_client_context.full -> - [`Highwatermarks] Baking_files.location -> - delegates:public_key_hash list -> - level:int32 -> - round:Round.t -> - unit tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_delegate/baking_lib.ml b/src/proto_017_PtNairob/lib_delegate/baking_lib.ml deleted file mode 100644 index 7c0d0f99cf1b319a63ed65ac3d682d46a560e9c9..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_lib.ml +++ /dev/null @@ -1,652 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 -open Alpha_context -open Baking_state - -let create_state cctxt ?synchronize ?monitor_node_mempool ~config - ~current_proposal delegates = - let open Lwt_result_syntax in - let chain = cctxt#chain in - let monitor_node_operations = monitor_node_mempool in - let*! operation_worker = - Operation_worker.create ?monitor_node_operations cctxt - in - Baking_scheduling.create_initial_state - cctxt - ?synchronize - ~chain - config - operation_worker - ~current_proposal - delegates - -let get_current_proposal cctxt ?cache () = - let open Lwt_result_syntax in - let* block_stream, _block_stream_stopper = - Node_rpc.monitor_heads cctxt ?cache ~chain:cctxt#chain () - in - Lwt_stream.peek block_stream >>= function - | Some current_head -> return (block_stream, current_head) - | None -> failwith "head stream unexpectedly ended" - -module Events = Baking_events.Lib - -let preendorse (cctxt : Protocol_client_context.full) ?(force = false) delegates - = - let open State_transitions in - let open Lwt_result_syntax in - let cache = Baking_cache.Block_cache.create 10 in - let* _, current_proposal = get_current_proposal cctxt ~cache () in - let config = Baking_configuration.make ~force () in - let* state = create_state cctxt ~config ~current_proposal delegates in - let proposal = state.level_state.latest_proposal in - let*! () = - Events.( - emit attempting_preendorse_proposal state.level_state.latest_proposal) - in - let* () = - if force then return_unit - else - is_acceptable_proposal_for_current_level state proposal >>= function - | Invalid -> cctxt#error "Cannot preendorse an invalid proposal" - | Outdated_proposal -> - cctxt#error "Cannot preendorse an outdated proposal" - | Valid_proposal -> return_unit - in - let consensus_list = make_consensus_list state proposal in - let*! () = - cctxt#message - "@[Preendorsing for:@ %a@]" - Format.( - pp_print_list - ~pp_sep:pp_print_space - Baking_state.pp_consensus_key_and_delegate) - (List.map fst consensus_list) - in - Baking_actions.inject_consensus_vote state consensus_list `Preendorsement - -let endorse (cctxt : Protocol_client_context.full) ?(force = false) delegates = - let open State_transitions in - let open Lwt_result_syntax in - let cache = Baking_cache.Block_cache.create 10 in - let* _, current_proposal = get_current_proposal cctxt ~cache () in - let config = Baking_configuration.make ~force () in - create_state cctxt ~config ~current_proposal delegates >>=? fun state -> - let proposal = state.level_state.latest_proposal in - let*! () = - Events.(emit attempting_endorse_proposal state.level_state.latest_proposal) - in - let* () = - if force then return_unit - else - is_acceptable_proposal_for_current_level state proposal >>= function - | Invalid -> cctxt#error "Cannot endorse an invalid proposal" - | Outdated_proposal -> cctxt#error "Cannot endorse an outdated proposal" - | Valid_proposal -> return_unit - in - let consensus_list = make_consensus_list state proposal in - let*! () = - cctxt#message - "@[Endorsing for:@ %a@]" - Format.( - pp_print_list - ~pp_sep:pp_print_space - Baking_state.pp_consensus_key_and_delegate) - (List.map fst consensus_list) - in - let* () = - Baking_state.may_record_new_state ~previous_state:state ~new_state:state - in - Baking_actions.inject_consensus_vote state consensus_list `Endorsement - -let bake_at_next_level state = - let open Lwt_result_syntax in - let cctxt = state.global_state.cctxt in - Baking_scheduling.compute_next_potential_baking_time_at_next_level state - >>= function - | None -> cctxt#error "No baking slot found for the delegates" - | Some (timestamp, round) -> - let*! () = - cctxt#message - "Waiting until %a for round %a" - Timestamp.pp - timestamp - Round.pp - round - in - let*! () = - Option.value - ~default:Lwt.return_unit - (Baking_scheduling.sleep_until timestamp) - in - return (Baking_state.Timeout (Time_to_bake_next_level {at_round = round})) - -(* Simulate the end of the current round to bootstrap the automaton - or endorse the block if necessary *) -let first_automaton_event state = - match state.level_state.elected_block with - | None -> Lwt.return (Baking_scheduling.compute_bootstrap_event state) - | Some _elected_block -> - (* If there is an elected block we can directly bake at next - level after waiting its date *) - bake_at_next_level state - -let endorsements_endorsing_power state endorsements = - let get_endorsement_voting_power {slot; _} = - match - SlotMap.find slot state.level_state.delegate_slots.all_delegate_slots - with - | None -> assert false - | Some {endorsing_power; _} -> endorsing_power - in - List.sort_uniq compare endorsements - |> List.fold_left - (fun power endorsement -> - power + get_endorsement_voting_power endorsement) - 0 - -let generic_endorsing_power (filter : packed_operation list -> 'a list) - (extract : 'a -> consensus_content) state = - let current_mempool = - Operation_worker.get_current_operations state.global_state.operation_worker - in - let latest_proposal = state.level_state.latest_proposal in - let block_round = latest_proposal.block.round in - let shell_level = latest_proposal.block.shell.level in - let endorsements = - filter (Operation_pool.Operation_set.elements current_mempool.consensus) - in - let endorsements_in_mempool = - List.filter_map - (fun v -> - let consensus_content = extract v in - if - Round.(consensus_content.round = block_round) - && Compare.Int32.( - Raw_level.to_int32 consensus_content.level = shell_level) - then Some consensus_content - else None) - endorsements - in - let power = endorsements_endorsing_power state endorsements_in_mempool in - (power, endorsements) - -let state_endorsing_power = - generic_endorsing_power - Operation_pool.filter_endorsements - (fun - ({ - protocol_data = {contents = Single (Endorsement consensus_content); _}; - _; - } : - Kind.endorsement operation) - -> consensus_content) - -let do_action (state, action) = - let state_recorder ~new_state = - Baking_state.may_record_new_state ~previous_state:state ~new_state - in - Baking_actions.perform_action ~state_recorder state action - -let propose_at_next_level ~minimal_timestamp state = - let open Lwt_result_syntax in - let cctxt = state.global_state.cctxt in - assert (Option.is_some state.level_state.elected_block) ; - if minimal_timestamp then - let* minimal_round, delegate = - match - Baking_scheduling.first_potential_round_at_next_level - state - ~earliest_round:Round.zero - with - | None -> cctxt#error "No potential baking slot for the given delegates." - | Some first_potential_round -> return first_potential_round - in - let pool = - Operation_worker.get_current_operations - state.global_state.operation_worker - in - let kind = Baking_actions.Fresh pool in - let block_to_bake : Baking_actions.block_to_bake = - { - Baking_actions.predecessor = state.level_state.latest_proposal.block; - round = minimal_round; - delegate; - kind; - force_apply = state.global_state.config.force_apply; - } - in - let state_recorder ~new_state = - Baking_state.may_record_new_state ~previous_state:state ~new_state - in - let* state = - Baking_actions.perform_action - ~state_recorder - state - (Inject_block - {kind = Forge_and_inject block_to_bake; updated_state = state}) - in - let*! () = - cctxt#message - "Proposed block at round %a on top of %a " - Round.pp - block_to_bake.round - Block_hash.pp - block_to_bake.predecessor.hash - in - return state - else - let* event = bake_at_next_level state in - let* state = State_transitions.step state event >>= do_action in - cctxt#message "Proposal injected" >>= fun () -> return state - -let endorsement_quorum state = - let power, endorsements = state_endorsing_power state in - if - Compare.Int.( - power >= state.global_state.constants.parametric.consensus_threshold) - then Some (power, endorsements) - else None - -(* Here's the sketch of the algorithm: - Do I have an endorsement quorum for the current block or an elected block? - - Yes :: wait and propose at next level - - No :: - Is the current proposal at the right round? - - Yes :: fail propose - - No :: - Is there a preendorsement quorum or does the last proposal contain a prequorum? - - Yes :: repropose block with right payload and preendorsements for current round - - No :: repropose fresh block for current round *) -let propose (cctxt : Protocol_client_context.full) ?minimal_fees - ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?force_apply ?force - ?(minimal_timestamp = false) ?extra_operations ?context_path ?state_recorder - delegates = - let open Lwt_result_syntax in - let cache = Baking_cache.Block_cache.create 10 in - let* _block_stream, current_proposal = get_current_proposal cctxt ~cache () in - let config = - Baking_configuration.make - ?minimal_fees - ?minimal_nanotez_per_gas_unit - ?minimal_nanotez_per_byte - ?context_path - ?force_apply - ?force - ?extra_operations - ?state_recorder - () - in - let* state = create_state cctxt ~config ~current_proposal delegates in - (* Make sure the operation worker is populated to avoid empty blocks - being proposed. *) - let* () = - Operation_worker.retrieve_pending_operations - cctxt - state.global_state.operation_worker - in - let* _ = - match state.level_state.elected_block with - | Some _ -> propose_at_next_level ~minimal_timestamp state - | None -> ( - match endorsement_quorum state with - | Some (_voting_power, endorsement_qc) -> - let state = - { - state with - round_state = - { - state.round_state with - current_phase = Baking_state.Awaiting_endorsements; - }; - } - in - let latest_proposal = state.level_state.latest_proposal.block in - let candidate = - { - Operation_worker.hash = latest_proposal.hash; - round_watched = latest_proposal.round; - payload_hash_watched = latest_proposal.payload_hash; - } - in - let* state = - State_transitions.step - state - (Baking_state.Quorum_reached (candidate, endorsement_qc)) - >>= do_action - (* this will register the elected block *) - in - propose_at_next_level ~minimal_timestamp state - | None -> ( - Baking_scheduling.compute_bootstrap_event state >>?= fun event -> - let*! state, _action = State_transitions.step state event in - let latest_proposal = state.level_state.latest_proposal in - let open State_transitions in - let round = state.round_state.current_round in - is_acceptable_proposal_for_current_level state latest_proposal - >>= function - | Invalid | Outdated_proposal -> ( - let slotmap = - state.level_state.delegate_slots.own_delegate_slots - in - match State_transitions.round_proposer state slotmap round with - | Some (delegate, _) -> - let*! action = - State_transitions.propose_block_action - state - delegate - round - state.level_state.latest_proposal - in - do_action (state, action) >>=? fun state -> - let*! () = - cctxt#message - "Reproposed block at level %ld on round %a" - state.level_state.current_level - Round.pp - state.round_state.current_round - in - return state - | None -> cctxt#error "No slots for current round") - | Valid_proposal -> - cctxt#error - "Cannot propose: there's already a valid proposal for the \ - current round %a" - Round.pp - round)) - in - return_unit - -let repropose (cctxt : Protocol_client_context.full) ?force ?force_round - delegates = - let open Lwt_result_syntax in - let cache = Baking_cache.Block_cache.create 10 in - let* _block_stream, current_proposal = get_current_proposal cctxt ~cache () in - let config = Baking_configuration.make ?force () in - let* state = create_state cctxt ~config ~current_proposal delegates in - (* Make sure the operation worker is populated to avoid empty blocks - being proposed. *) - let*? event = Baking_scheduling.compute_bootstrap_event state in - let*! state, _action = State_transitions.step state event in - let latest_proposal = state.level_state.latest_proposal in - let open State_transitions in - let round = - match force_round with - | Some x -> x - | None -> state.round_state.current_round - in - let*! proposal_validity = - is_acceptable_proposal_for_current_level state latest_proposal - in - match proposal_validity with - | Invalid | Outdated_proposal -> ( - let slotmap = state.level_state.delegate_slots.own_delegate_slots in - match State_transitions.round_proposer state slotmap round with - | Some (delegate, _) -> - let*! action = - State_transitions.propose_block_action - state - delegate - round - state.level_state.latest_proposal - in - let* state = do_action (state, action) in - let*! () = - cctxt#message - "Reproposed block at level %ld on round %a" - state.level_state.current_level - Round.pp - state.round_state.current_round - in - return_unit - | None -> cctxt#error "No slots for current round") - | Valid_proposal -> - cctxt#error - "Cannot propose: there's already a valid proposal for the current \ - round %a" - Round.pp - round - -let bake_using_automaton ~count config state heads_stream = - let open Lwt_result_syntax in - let cctxt = state.global_state.cctxt in - let* initial_event = first_automaton_event state in - let current_level = state.level_state.latest_proposal.block.shell.level in - let loop_state = - Baking_scheduling.create_loop_state - ~heads_stream - state.global_state.operation_worker - in - let stop_on_next_level_block = function - | New_head_proposal proposal -> - Compare.Int32.( - proposal.block.shell.level >= Int32.(add current_level (of_int count))) - | _ -> false - in - Baking_scheduling.automaton_loop - ~stop_on_event:stop_on_next_level_block - ~config - ~on_error:(fun err -> Lwt.return (Error err)) - loop_state - state - initial_event - >>=? function - | Some (New_head_proposal proposal) -> - let*! () = - cctxt#message - "Last injected block: %a (level %ld)" - Block_hash.pp - proposal.block.hash - proposal.block.shell.level - in - return_unit - | _ -> cctxt#error "Baking loop unexpectedly ended" - -(* endorse the latest proposal and bake with it *) -let rec baking_minimal_timestamp ~count state - (block_stream : proposal Lwt_stream.t) = - let open Lwt_result_syntax in - let cctxt = state.global_state.cctxt in - let latest_proposal = state.level_state.latest_proposal in - let own_endorsements = - State_transitions.make_consensus_list state latest_proposal - in - let current_mempool = - Operation_worker.get_current_operations state.global_state.operation_worker - in - let endorsements_in_mempool = - Operation_pool.( - filter_endorsements (Operation_set.elements current_mempool.consensus)) - |> List.filter_map - (fun - ({ - protocol_data = - {contents = Single (Endorsement consensus_content); _}; - _; - } : - Kind.endorsement operation) - -> - if - Round.(consensus_content.round = latest_proposal.block.round) - && Compare.Int32.( - Raw_level.to_int32 consensus_content.level - = latest_proposal.block.shell.level) - then Some consensus_content - else None) - in - let total_voting_power = - List.fold_left - (fun endorsements own -> snd own :: endorsements) - endorsements_in_mempool - own_endorsements - |> endorsements_endorsing_power state - in - let consensus_threshold = - state.global_state.constants.parametric.consensus_threshold - in - let* () = - if Compare.Int.(total_voting_power < consensus_threshold) then - cctxt#error - "Delegates do not have enough voting power. Only %d is available while \ - %d is required." - total_voting_power - consensus_threshold - else return_unit - in - let* minimal_round, delegate = - match - Baking_scheduling.first_potential_round_at_next_level - state - ~earliest_round:Round.zero - with - | None -> cctxt#error "No potential baking slot for the given delegates." - | Some first_potential_round -> return first_potential_round - in - let* signed_endorsements = - Baking_actions.sign_consensus_votes state own_endorsements `Endorsement - in - let pool = - Operation_pool.add_operations - current_mempool - (List.map (fun (_, x, _, _) -> x) signed_endorsements) - in - let next_level = Int32.succ latest_proposal.block.shell.level in - let* own_dal_attestations = - Baking_actions.get_dal_attestations state ~level:next_level - in - let* signed_dal_attestations = - Baking_actions.sign_dal_attestations state own_dal_attestations - in - let pool = - Operation_pool.add_operations - pool - (List.map (fun (_delegate, op, _bitset) -> op) signed_dal_attestations) - in - let kind = Baking_actions.Fresh pool in - let block_to_bake : Baking_actions.block_to_bake = - { - Baking_actions.predecessor = latest_proposal.block; - round = minimal_round; - delegate; - kind; - force_apply = state.global_state.config.force_apply; - } - in - let state_recorder ~new_state = - Baking_state.may_record_new_state ~previous_state:state ~new_state - in - let* new_state = - Baking_actions.perform_action - ~state_recorder - state - (Inject_block - {kind = Forge_and_inject block_to_bake; updated_state = state}) - in - let*! () = cctxt#message "Injected block at minimal timestamp" in - if count <= 1 then return_unit - else - let*! () = - Lwt_stream.junk_while_s - (fun proposal -> - Lwt.return - Compare.Int32.( - proposal.Baking_state.block.shell.level <> next_level)) - block_stream - in - let*! next_level_proposal = - let*! r = Lwt_stream.get block_stream in - match r with - | None -> cctxt#error "Stream unexpectedly ended" - | Some b -> Lwt.return b - in - let*! new_state, action = - State_transitions.step new_state (New_head_proposal next_level_proposal) - in - let* new_state = - match action with - | Update_to_level update -> - let* new_state, _preendorse_action = - Baking_actions.update_to_level new_state update - in - return - { - new_state with - round_state = - { - Baking_state.current_round = Round.zero; - current_phase = Idle; - delayed_quorum = None; - }; - } - | _ -> - (* Algorithmically, this will always be an update_to_level - action. *) - assert false - in - baking_minimal_timestamp ~count:(pred count) new_state block_stream - -let bake (cctxt : Protocol_client_context.full) ?minimal_fees - ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?force_apply ?force - ?(minimal_timestamp = false) ?extra_operations - ?(monitor_node_mempool = true) ?context_path ?dal_node_endpoint ?(count = 1) - ?state_recorder delegates = - let open Lwt_result_syntax in - let config = - Baking_configuration.make - ?minimal_fees - ?minimal_nanotez_per_gas_unit - ?minimal_nanotez_per_byte - ?context_path - ?force_apply - ?force - ?extra_operations - ?dal_node_endpoint - ?state_recorder - () - in - let cache = Baking_cache.Block_cache.create 10 in - let* block_stream, current_proposal = get_current_proposal cctxt ~cache () in - let* state = - create_state - cctxt - ~monitor_node_mempool - ~synchronize:(not minimal_timestamp) - ~config - ~current_proposal - delegates - in - let* () = - when_ monitor_node_mempool (fun () -> - (* Make sure the operation worker is populated to avoid empty - blocks being baked *) - Operation_worker.retrieve_pending_operations - cctxt - state.global_state.operation_worker) - in - if not minimal_timestamp then - bake_using_automaton ~count config state block_stream - else baking_minimal_timestamp ~count state block_stream diff --git a/src/proto_017_PtNairob/lib_delegate/baking_lib.mli b/src/proto_017_PtNairob/lib_delegate/baking_lib.mli deleted file mode 100644 index e51b1ee2e93272b02ddc9c305566d164124cf7dd..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_lib.mli +++ /dev/null @@ -1,83 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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.Alpha_context - -(** {1 API} *) - -val bake : - Protocol_client_context.full -> - ?minimal_fees:Tez.t -> - ?minimal_nanotez_per_gas_unit:Q.t -> - ?minimal_nanotez_per_byte:Q.t -> - ?force_apply:bool -> - ?force:bool -> - ?minimal_timestamp:bool -> - ?extra_operations:Baking_configuration.Operations_source.t -> - ?monitor_node_mempool:bool -> - ?context_path:string -> - ?dal_node_endpoint:Uri.t -> - (* Number of baked blocks. Defaults to 1. *) - ?count:int -> - ?state_recorder:Baking_configuration.state_recorder_config -> - Baking_state.consensus_key list -> - unit tzresult Lwt.t - -val preendorse : - Protocol_client_context.full -> - ?force:bool -> - Baking_state.consensus_key list -> - unit tzresult Lwt.t - -val endorse : - Protocol_client_context.full -> - ?force:bool -> - Baking_state.consensus_key list -> - unit tzresult Lwt.t - -val propose : - Protocol_client_context.full -> - ?minimal_fees:Tez.t -> - ?minimal_nanotez_per_gas_unit:Q.t -> - ?minimal_nanotez_per_byte:Q.t -> - ?force_apply:bool -> - ?force:bool -> - ?minimal_timestamp:bool -> - ?extra_operations:Baking_configuration.Operations_source.t -> - ?context_path:string -> - ?state_recorder:Baking_configuration.state_recorder_config -> - Baking_state.consensus_key list -> - unit tzresult Lwt.t - -(** [repropose] tries to bake a new block proposal on the same level - as the current head. If provided, the proposal will use the - [force_round] argument as its reproposal round, otherwise the - current tenderbake round will be used. *) -val repropose : - Protocol_client_context.full -> - ?force:bool -> - ?force_round:Round.t -> - Baking_state.consensus_key list -> - unit tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_delegate/baking_nonces.ml b/src/proto_017_PtNairob/lib_delegate/baking_nonces.ml deleted file mode 100644 index 04179803fa3d197557a5e5cfde81bae3bd51d445..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_nonces.ml +++ /dev/null @@ -1,361 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context -open Baking_cache -module Events = Baking_events.Nonces - -type state = { - cctxt : Protocol_client_context.full; - chain : Chain_services.chain; - constants : Constants.t; - config : Baking_configuration.nonce_config; - nonces_location : [`Nonce] Baking_files.location; - mutable last_predecessor : Block_hash.t; - cycle_cache : Block_hash.t list Cycle_cache.t; - (** This cache is used to avoid calling expensive RPCs at each - block. Still, this component's logic is very inefficient and - should be refactored. This cache is intended as "duct tape" - until a proper refactoring happens. *) -} - -type t = state - -type nonces = Nonce.t Block_hash.Map.t - -let empty = Block_hash.Map.empty - -let encoding = - let open Data_encoding in - def "seed_nonce" - @@ conv - (fun m -> - Block_hash.Map.fold (fun hash nonce acc -> (hash, nonce) :: acc) m []) - (fun l -> - List.fold_left - (fun map (hash, nonce) -> Block_hash.Map.add hash nonce map) - Block_hash.Map.empty - l) - @@ list (obj2 (req "block" Block_hash.encoding) (req "nonce" Nonce.encoding)) - -let may_migrate (wallet : Protocol_client_context.full) location = - let base_dir = wallet#get_base_dir in - let current_file = - Filename.Infix.((base_dir // Baking_files.filename location) ^ "s") - in - Lwt_unix.file_exists current_file >>= function - | true -> - (* Migration already occured *) - Lwt.return_unit - | false -> ( - let legacy_file = Filename.Infix.(base_dir // "nonces") in - Lwt_unix.file_exists legacy_file >>= function - | false -> - (* Do nothing *) - Lwt.return_unit - | true -> Lwt_utils_unix.copy_file ~src:legacy_file ~dst:current_file) - -let load (wallet : #Client_context.wallet) location = - wallet#load (Baking_files.filename location) ~default:empty encoding - -let save (wallet : #Client_context.wallet) location nonces = - wallet#write (Baking_files.filename location) nonces encoding - -let mem nonces hash = Block_hash.Map.mem hash nonces - -let find_opt nonces hash = Block_hash.Map.find hash nonces - -let add nonces hash nonce = Block_hash.Map.add hash nonce nonces - -let remove nonces hash = Block_hash.Map.remove hash nonces - -let remove_all nonces nonces_to_remove = - Block_hash.Map.fold - (fun hash _ acc -> remove acc hash) - nonces_to_remove - nonces - -let get_block_level_opt cctxt ~chain ~block = - Shell_services.Blocks.Header.shell_header cctxt ~chain ~block () >>= function - | Ok {level; _} -> Lwt.return_some level - | Error errs -> - Events.( - emit - cant_retrieve_block_header_for_nonce - (Block_services.to_string block, errs)) - >>= fun () -> Lwt.return_none - -let get_outdated_nonces {cctxt; constants; chain; _} nonces = - let {Constants.parametric = {blocks_per_cycle; preserved_cycles; _}; _} = - constants - in - get_block_level_opt cctxt ~chain ~block:(`Head 0) >>= function - | None -> - Events.(emit cannot_fetch_chain_head_level ()) >>= fun () -> - return (empty, empty) - | Some current_level -> - let current_cycle = Int32.(div current_level blocks_per_cycle) in - let is_older_than_preserved_cycles block_level = - let block_cycle = Int32.(div block_level blocks_per_cycle) in - Int32.sub current_cycle block_cycle > Int32.of_int preserved_cycles - in - Block_hash.Map.fold - (fun hash nonce acc -> - acc >>=? fun (orphans, outdated) -> - get_block_level_opt cctxt ~chain ~block:(`Hash (hash, 0)) >>= function - | Some level -> - if is_older_than_preserved_cycles level then - return (orphans, add outdated hash nonce) - else acc - | None -> return (add orphans hash nonce, outdated)) - nonces - (return (empty, empty)) - -let filter_outdated_nonces state nonces = - get_outdated_nonces state nonces >>=? fun (orphans, outdated_nonces) -> - when_ - (Block_hash.Map.cardinal orphans >= 50) - (fun () -> - Events.( - emit too_many_nonces (Baking_files.filename state.nonces_location ^ "s")) - >>= fun () -> return_unit) - >>=? fun () -> return (remove_all nonces outdated_nonces) - -let blocks_from_previous_cycle {cctxt; chain; _} = - let block = `Head 0 in - Plugin.RPC.levels_in_current_cycle cctxt ~offset:(-1l) (chain, block) - >>= function - | Error (Tezos_rpc.Context.Not_found _ :: _) -> return_nil - | Error _ as err -> Lwt.return err - | Ok (first, last) -> ( - Shell_services.Blocks.hash cctxt ~chain ~block () >>=? fun hash -> - Shell_services.Blocks.Header.shell_header cctxt ~chain ~block () - >>=? fun {level; _} -> - (* FIXME: crappy algorithm, change this *) - (* Compute how many blocks below current level we should ask for *) - let length = Int32.to_int (Int32.sub level (Raw_level.to_int32 first)) in - Shell_services.Blocks.list cctxt ~chain ~heads:[hash] ~length () - (* Looks like this function call retrieves a list of blocks ordered from - latest to earliest - decreasing order of insertion in the chain *) - >>=? - function - | [blocks] -> - if Int32.equal level (Raw_level.to_int32 last) then - (* We have just retrieved a block list of the right size starting at - first until last *) - return blocks - else - (* Remove all the latest blocks from last up to length*) - List.drop_n - (length - Int32.to_int (Raw_level.diff last first)) - blocks - |> return - | l -> - failwith - "Baking_nonces.blocks_from_current_cycle: unexpected block list of \ - size %d (expected 1)" - (List.length l)) - -let cached_blocks_from_previous_cycle ({cctxt; chain; cycle_cache; _} as state) - = - Plugin.RPC.current_level cctxt (chain, `Head 0) - >>=? fun {cycle = current_cycle; _} -> - match Cycle.pred current_cycle with - | None -> - (* This will be [None] iff [current_cycle = 0] which only - occurs during genesis. *) - return_nil - | Some cycle_key -> ( - match Cycle_cache.find_opt cycle_cache cycle_key with - | Some blocks -> return blocks - | None -> - blocks_from_previous_cycle state >>=? fun blocks -> - Cycle_cache.replace cycle_cache cycle_key blocks ; - return blocks) - -let get_unrevealed_nonces ({cctxt; chain; _} as state) nonces = - cached_blocks_from_previous_cycle state >>=? fun blocks -> - List.filter_map_es - (fun hash -> - match find_opt nonces hash with - | None -> return_none - | Some nonce -> ( - get_block_level_opt cctxt ~chain ~block:(`Hash (hash, 0)) >>= function - | Some level -> ( - Lwt.return (Environment.wrap_tzresult (Raw_level.of_int32 level)) - >>=? fun level -> - Alpha_services.Nonce.get cctxt (chain, `Head 0) level - >>=? function - | Missing nonce_hash when Nonce.check_hash nonce nonce_hash -> - Events.( - emit found_nonce_to_reveal (hash, Raw_level.to_int32 level)) - >>= fun () -> return_some (level, nonce) - | Missing _nonce_hash -> - Events.(emit incoherent_nonce (Raw_level.to_int32 level)) - >>= fun () -> return_none - | Forgotten -> return_none - | Revealed _ -> return_none) - | None -> return_none)) - blocks - -(* Nonce creation *) - -let generate_seed_nonce (nonce_config : Baking_configuration.nonce_config) - (delegate : Baking_state.consensus_key) level = - (match nonce_config with - | Deterministic -> - let data = Data_encoding.Binary.to_bytes_exn Raw_level.encoding level in - Client_keys.deterministic_nonce delegate.secret_key_uri data - >>=? fun nonce -> - return (Data_encoding.Binary.of_bytes_exn Nonce.encoding nonce) - | Random -> ( - match - Nonce.of_bytes (Tezos_crypto.Rand.generate Constants.nonce_length) - with - | Error _errs -> assert false - | Ok nonce -> return nonce)) - >>=? fun nonce -> return (Nonce.hash nonce, nonce) - -let register_nonce (cctxt : #Protocol_client_context.full) ~chain_id block_hash - nonce = - Events.(emit registering_nonce block_hash) >>= fun () -> - (* Register the nonce *) - let nonces_location = Baking_files.resolve_location ~chain_id `Nonce in - cctxt#with_lock @@ fun () -> - load cctxt nonces_location >>=? fun nonces -> - let nonces = add nonces block_hash nonce in - save cctxt nonces_location nonces >>=? fun () -> return_unit - -let inject_seed_nonce_revelation (cctxt : #Protocol_client_context.full) ~chain - ~block ~branch nonces = - match nonces with - | [] -> Events.(emit nothing_to_reveal branch) >>= fun () -> return_unit - | _ -> - List.iter_es - (fun (level, nonce) -> - Plugin.RPC.Forge.seed_nonce_revelation - cctxt - (chain, block) - ~branch - ~level - ~nonce - () - >>=? fun bytes -> - let bytes = Signature.concat bytes Signature.zero in - Shell_services.Injection.operation ~async:true cctxt ~chain bytes - >>=? fun oph -> - Events.( - emit - revealing_nonce - (Raw_level.to_int32 level, Chain_services.to_string chain, oph)) - >>= fun () -> return_unit) - nonces - -(** [reveal_potential_nonces] reveal registered nonces *) -let reveal_potential_nonces state new_proposal = - let {cctxt; chain; nonces_location; last_predecessor; _} = state in - let new_predecessor_hash = new_proposal.Baking_state.predecessor.hash in - if - Block_hash.(last_predecessor <> new_predecessor_hash) - && not (Baking_state.is_first_block_in_protocol new_proposal) - then ( - (* only try revealing nonces when the proposal's predecessor is a new one *) - state.last_predecessor <- new_predecessor_hash ; - let block = `Head 0 in - let branch = new_predecessor_hash in - (* improve concurrency *) - cctxt#with_lock @@ fun () -> - load cctxt nonces_location >>= function - | Error err -> - Events.(emit cannot_read_nonces err) >>= fun () -> return_unit - | Ok nonces -> ( - get_unrevealed_nonces state nonces >>= function - | Error err -> - Events.(emit cannot_retrieve_unrevealed_nonces err) >>= fun () -> - return_unit - | Ok [] -> return_unit - | Ok nonces_to_reveal -> ( - inject_seed_nonce_revelation - cctxt - ~chain - ~block - ~branch - nonces_to_reveal - >>= function - | Error err -> - Events.(emit cannot_inject_nonces err) >>= fun () -> return_unit - | Ok () -> - (* If some nonces are to be revealed it means: - - We entered a new cycle and we can clear old nonces ; - - A revelation was not included yet in the cycle beginning. - So, it is safe to only filter outdated_nonces there *) - filter_outdated_nonces state nonces >>=? fun live_nonces -> - save cctxt nonces_location live_nonces >>=? fun () -> - return_unit))) - else return_unit - -(* We suppose that the block stream is cloned by the caller *) -let start_revelation_worker cctxt config chain_id constants block_stream = - let nonces_location = Baking_files.resolve_location ~chain_id `Nonce in - may_migrate cctxt nonces_location >>= fun () -> - let chain = `Hash chain_id in - let canceler = Lwt_canceler.create () in - let should_shutdown = ref false in - let state = - { - cctxt; - chain; - constants; - config; - nonces_location; - last_predecessor = Block_hash.zero; - cycle_cache = Cycle_cache.create 2; - } - in - let rec worker_loop () = - Lwt_canceler.on_cancel canceler (fun () -> - should_shutdown := true ; - Lwt.return_unit) ; - Lwt_stream.get block_stream >>= function - | None -> - (* The head stream closed meaning that the connection - with the node was interrupted: exit *) - return_unit - | Some new_proposal -> - if !should_shutdown then return_unit - else - reveal_potential_nonces state new_proposal >>=? fun () -> - worker_loop () - in - Lwt.dont_wait - (fun () -> - Lwt.finalize - (fun () -> - Events.(emit revelation_worker_started ()) >>= fun () -> - worker_loop () >>= fun _ -> (* never ending loop *) Lwt.return_unit) - (fun () -> (* TODO *) Lwt.return_unit)) - (fun _exn -> ()) ; - Lwt.return canceler diff --git a/src/proto_017_PtNairob/lib_delegate/baking_nonces.mli b/src/proto_017_PtNairob/lib_delegate/baking_nonces.mli deleted file mode 100644 index 5b7d2a9d4c4eefb81315f197209c8402e849c871..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_nonces.mli +++ /dev/null @@ -1,109 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context -open Baking_cache - -type state = { - cctxt : Protocol_client_context.full; - chain : Chain_services.chain; - constants : Constants.t; - config : Baking_configuration.nonce_config; - nonces_location : [`Nonce] Baking_files.location; - mutable last_predecessor : Block_hash.t; - cycle_cache : Block_hash.t list Cycle_cache.t; -} - -type t = state - -type nonces = Nonce.t Block_hash.Map.t - -val empty : Nonce.t Block_hash.Map.t - -val encoding : Nonce.t Block_hash.Map.t Data_encoding.t - -val load : - #Client_context.wallet -> - [< `Highwatermarks | `Nonce | `State] Baking_files.location -> - Nonce.t Block_hash.Map.t tzresult Lwt.t - -val save : - #Client_context.wallet -> - [< `Highwatermarks | `Nonce | `State] Baking_files.location -> - Nonce.t Block_hash.Map.t -> - unit tzresult Lwt.t - -val mem : Nonce.t Block_hash.Map.t -> Block_hash.t -> bool - -val find_opt : Nonce.t Block_hash.Map.t -> Block_hash.t -> Nonce.t option - -val get_block_level_opt : - #Tezos_rpc.Context.simple -> - chain:Block_services.chain -> - block:Block_services.block -> - int32 option Lwt.t - -val get_outdated_nonces : - t -> - Nonce.t Block_hash.Map.t -> - (Nonce.t Block_hash.Map.t * Nonce.t Block_hash.Map.t) tzresult Lwt.t - -val filter_outdated_nonces : - t -> Nonce.t Block_hash.Map.t -> Nonce.t Block_hash.Map.t tzresult Lwt.t - -val get_unrevealed_nonces : - t -> Nonce.t Block_hash.Map.t -> (Raw_level.t * Nonce.t) list tzresult Lwt.t - -val generate_seed_nonce : - Baking_configuration.nonce_config -> - Baking_state.consensus_key -> - Raw_level.t -> - (Nonce_hash.t * Nonce.t) tzresult Lwt.t - -val register_nonce : - #Protocol_client_context.full -> - chain_id:Chain_id.t -> - Block_hash.t -> - Nonce.t -> - unit tzresult Lwt.t - -val inject_seed_nonce_revelation : - #Protocol_client_context.full -> - chain:Chain_services.chain -> - block:Block_services.block -> - branch:Block_hash.t -> - (Raw_level.t * Nonce.t) list -> - unit tzresult Lwt.t - -val reveal_potential_nonces : t -> Baking_state.proposal -> unit tzresult Lwt.t - -val start_revelation_worker : - Protocol_client_context.full -> - Baking_configuration.nonce_config -> - Chain_id.t -> - Constants.t -> - Baking_state.proposal Lwt_stream.t -> - Lwt_canceler.t Lwt.t diff --git a/src/proto_017_PtNairob/lib_delegate/baking_pow.ml b/src/proto_017_PtNairob/lib_delegate/baking_pow.ml deleted file mode 100644 index 5a7306a3e31c6f464c2aa9715fa9e7086c9ee66c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_pow.ml +++ /dev/null @@ -1,133 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 default_constant = "\x00\x00\x00\x05" - -let with_version_constant = - let commit_hash = - match - Hex.to_string (`Hex Tezos_version_value.Current_git_info.commit_hash) - with - | None -> Tezos_version_value.Current_git_info.commit_hash - | Some s -> s - in - if String.length commit_hash >= 4 then String.sub commit_hash 0 4 - else default_constant - -let with_version_constant_len = String.length with_version_constant - -let proof_of_work_nonce = - let out = - Bytes.make Alpha_context.Constants.proof_of_work_nonce_size '\000' - in - let () = - Bytes.blit_string with_version_constant 0 out 0 with_version_constant_len - in - out - -(* [proof_of_work_nonce] will be modified in place so we make a clean copy to expose to the outside *) -let empty_proof_of_work_nonce = Bytes.copy proof_of_work_nonce - -let max_z_len = - Alpha_context.Constants.proof_of_work_nonce_size - with_version_constant_len - -(* Make a string of zeros to restore [proof_of_work_nonce] to its original value in 1 operation *) -let zeros = String.make max_z_len '\000' - -let mine ~proof_of_work_threshold shell builder = - match - Option.bind - (Data_encoding.Binary.fixed_length Block_payload_hash.encoding) - (fun payload -> - Option.map - (fun round -> - let shell = - Data_encoding.Binary.length - Block_header.shell_header_encoding - shell - in - shell + payload + round + with_version_constant_len) - (Data_encoding.Binary.fixed_length Round_repr.encoding)) - (* Where to put the proof of work value is in the bytes of the encoded header *) - with - | None -> failwith "Cannot compute block header offset" - | Some offset -> - let () = - (* Restore proof_of_work_nonce to its original value. *) - Bytes.blit_string - zeros - 0 - proof_of_work_nonce - with_version_constant_len - max_z_len - in - (* Build the binary of the block header with 0 as proof of work and compute its hash. *) - let block_0 = builder proof_of_work_nonce in - let block_header = - Data_encoding.Binary.to_bytes_exn - Alpha_context.Block_header.encoding - Alpha_context.Block_header. - { - shell; - protocol_data = {contents = block_0; signature = Signature.zero}; - } - in - let block_hash = Block_header.hash_raw block_header in - let block_hash_bytes = Block_hash.to_bytes block_hash in - (* The loop edits [block_header] and [block_hash] (by editing its subpart [block_hash_bytes]!) in place. *) - let rec loop z = - let z_len = (Z.numbits z + 7) / 8 in - if z_len > max_z_len then - failwith - "Client_baking_pow.mine: couldn't find nonce for required proof of \ - work" - else ( - Bytes.blit_string (Z.to_bits z) 0 block_header offset z_len ; - (if Hacl_star.AutoConfig2.(has_feature VEC256) then - Hacl_star.Hacl.Blake2b_256.Noalloc.hash - else Hacl_star.Hacl.Blake2b_32.Noalloc.hash) - ~key:Bytes.empty - ~msg:block_header - ~digest:block_hash_bytes ; - if - Alpha_context.Block_header.Proof_of_work.check_hash - block_hash - proof_of_work_threshold - then - let () = - Bytes.blit_string - (Z.to_bits z) - 0 - proof_of_work_nonce - with_version_constant_len - z_len - in - let block = builder proof_of_work_nonce in - return block - else loop (Z.succ z)) - in - loop Z.zero diff --git a/src/proto_017_PtNairob/lib_delegate/baking_pow.mli b/src/proto_017_PtNairob/lib_delegate/baking_pow.mli deleted file mode 100644 index ad5975c9190c36548ac45ecb4fa80147bb320908..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_pow.mli +++ /dev/null @@ -1,40 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 - -(** A null proof-of-work nonce. This should only be used to nonsensical blocks - of the correct size and shape. *) -val empty_proof_of_work_nonce : Bytes.t - -(** [mine ~proof_of_work_threshold chain block header builder] returns a block with a valid - proof-of-work nonce. The function [builder], provided by the caller, is used - to make the block. All the internal logic of generating nonces and checking - for the proof-of-work threshold is handled by [mine]. *) -val mine : - proof_of_work_threshold:int64 -> - Block_header.shell_header -> - (Bytes.t -> Alpha_context.Block_header.contents) -> - Alpha_context.Block_header.contents tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_delegate/baking_scheduling.ml b/src/proto_017_PtNairob/lib_delegate/baking_scheduling.ml deleted file mode 100644 index 18a5db499bcbadb15069f365de7cb30d032e18db..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_scheduling.ml +++ /dev/null @@ -1,915 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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.Alpha_context -module Events = Baking_events.Scheduling -open Baking_state - -type loop_state = { - heads_stream : Baking_state.proposal Lwt_stream.t; - get_valid_blocks_stream : Baking_state.proposal Lwt_stream.t Lwt.t; - qc_stream : Operation_worker.event Lwt_stream.t; - future_block_stream : - [`New_future_head of proposal | `New_future_valid_proposal of proposal] - Lwt_stream.t; - push_future_block : - [`New_future_head of proposal | `New_future_valid_proposal of proposal] -> - unit; - mutable last_get_head_event : - [`New_head_proposal of proposal option] Lwt.t option; - mutable last_get_valid_block_event : - [`New_valid_proposal of proposal option] Lwt.t option; - mutable last_future_block_event : - [`New_future_head of proposal | `New_future_valid_proposal of proposal] - Lwt.t - option; - mutable last_get_qc_event : - [`QC_reached of Operation_worker.event option] Lwt.t option; -} - -type events = - [ `New_future_head of proposal - | `New_future_valid_proposal of proposal - | `New_valid_proposal of proposal option - | `New_head_proposal of proposal option - | `QC_reached of Operation_worker.event option - | `Termination - | `Timeout of timeout_kind ] - Lwt.t - -let create_loop_state ?get_valid_blocks_stream ~heads_stream operation_worker = - let future_block_stream, push_future_block = Lwt_stream.create () in - let get_valid_blocks_stream = - match get_valid_blocks_stream with - | None -> Lwt.return (Lwt_stream.create () |> fst) - | Some vbs_t -> vbs_t - in - { - heads_stream; - get_valid_blocks_stream; - qc_stream = Operation_worker.get_quorum_event_stream operation_worker; - future_block_stream; - push_future_block = (fun x -> push_future_block (Some x)); - last_get_head_event = None; - last_get_valid_block_event = None; - last_future_block_event = None; - last_get_qc_event = None; - } - -let find_in_known_round_intervals known_round_intervals ~predecessor_timestamp - ~predecessor_round ~now = - let open Baking_cache in - Round_timestamp_interval_cache.( - find_opt - known_round_intervals - {predecessor_timestamp; predecessor_round; time_interval = (now, now)}) - -(** Memoization wrapper for [Round.timestamp_of_round]. *) -let timestamp_of_round state ~predecessor_timestamp ~predecessor_round ~round = - let open Baking_cache in - let known_timestamps = state.global_state.cache.known_timestamps in - match - Timestamp_of_round_cache.find_opt - known_timestamps - (predecessor_timestamp, predecessor_round, round) - with - (* Compute and register the timestamp if not already existing. *) - | None -> - Protocol.Alpha_context.Round.timestamp_of_round - state.global_state.round_durations - ~predecessor_timestamp - ~predecessor_round - ~round - >>? fun ts -> - Timestamp_of_round_cache.replace - known_timestamps - (predecessor_timestamp, predecessor_round, round) - ts ; - ok ts - (* If it already exists, just fetch from the memoization table. *) - | Some ts -> ok ts - -let sleep_until_ptime ptime = - let delay = Ptime.diff ptime (Time.System.now ()) in - if Ptime.Span.compare delay Ptime.Span.zero < 0 then None - else Some (Lwt_unix.sleep (Ptime.Span.to_float_s delay)) - -(** The function is blocking until it is [time]. *) -let sleep_until time = - (* Sleeping is a system op, baking is a protocol op, this is where we convert *) - let time = Time.System.of_protocol_exn time in - sleep_until_ptime time - -(* Only allocate once the termination promise *) -let terminated = Lwt_exit.clean_up_starts >|= fun _ -> `Termination - -let rec wait_next_event ~timeout loop_state = - (* TODO? should we prioritize head events/timeouts to resynchronize if needs be ? *) - let get_head_event () = - (* n.b. we should also consume the available elements in the - block_stream before starting baking. *) - match loop_state.last_get_head_event with - | None -> - let t = - Lwt_stream.get loop_state.heads_stream >>= fun e -> - Lwt.return (`New_head_proposal e) - in - loop_state.last_get_head_event <- Some t ; - t - | Some t -> t - in - let get_valid_block_event () = - match loop_state.last_get_valid_block_event with - | None -> - let t = - loop_state.get_valid_blocks_stream >>= fun valid_blocks_stream -> - Lwt_stream.get valid_blocks_stream >|= fun e -> `New_valid_proposal e - in - loop_state.last_get_valid_block_event <- Some t ; - t - | Some t -> t - in - let get_future_block_event () = - (* n.b. we should also consume the available elements in the - block_stream before starting baking. *) - match loop_state.last_future_block_event with - | None -> - let t = - Lwt_stream.get loop_state.future_block_stream >|= function - | None -> - (* unreachable, we never close the stream *) - assert false - | Some future_proposal -> future_proposal - in - loop_state.last_future_block_event <- Some t ; - t - | Some t -> t - in - let get_qc_event () = - match loop_state.last_get_qc_event with - | None -> - let t = - Lwt_stream.get loop_state.qc_stream >|= fun e -> `QC_reached e - in - loop_state.last_get_qc_event <- Some t ; - t - | Some t -> t - in - (* event construction *) - let open Baking_state in - Lwt.choose - [ - terminated; - (get_head_event () :> events); - (get_valid_block_event () :> events); - (get_future_block_event () :> events); - (get_qc_event () :> events); - (timeout :> events); - ] - >>= function - (* event matching *) - | `Termination -> - (* Exit the loop *) - return_none - | `New_valid_proposal None -> - (* Node connection lost *) - loop_state.last_get_valid_block_event <- None ; - fail Baking_errors.Node_connection_lost - | `New_head_proposal None -> - (* Node connection lost *) - loop_state.last_get_head_event <- None ; - fail Baking_errors.Node_connection_lost - | `QC_reached None -> - (* Not supposed to happen: exit the loop *) - loop_state.last_get_qc_event <- None ; - return_none - | `New_valid_proposal (Some proposal) -> ( - loop_state.last_get_valid_block_event <- None ; - (* Is the block in the future? *) - match sleep_until proposal.block.shell.timestamp with - | Some waiter -> - (* If so, wait until its timestamp is reached before advertising it *) - Events.(emit proposal_in_the_future proposal.block.hash) >>= fun () -> - Lwt.dont_wait - (fun () -> - waiter >>= fun () -> - loop_state.push_future_block (`New_future_valid_proposal proposal) ; - Lwt.return_unit) - (fun _exn -> ()) ; - wait_next_event ~timeout loop_state - | None -> return_some (New_valid_proposal proposal)) - | `New_head_proposal (Some proposal) -> ( - loop_state.last_get_head_event <- None ; - (* Is the block in the future? *) - match sleep_until proposal.block.shell.timestamp with - | Some waiter -> - (* If so, wait until its timestamp is reached before advertising it *) - Events.(emit proposal_in_the_future proposal.block.hash) >>= fun () -> - Lwt.dont_wait - (fun () -> - waiter >>= fun () -> - loop_state.push_future_block (`New_future_head proposal) ; - Lwt.return_unit) - (fun _exn -> ()) ; - wait_next_event ~timeout loop_state - | None -> return_some (New_head_proposal proposal)) - | `New_future_head proposal -> - Events.(emit process_proposal_in_the_future proposal.block.hash) - >>= fun () -> - loop_state.last_future_block_event <- None ; - return_some (New_head_proposal proposal) - | `New_future_valid_proposal proposal -> - Events.(emit process_proposal_in_the_future proposal.block.hash) - >>= fun () -> - loop_state.last_future_block_event <- None ; - return_some (New_valid_proposal proposal) - | `QC_reached - (Some (Operation_worker.Prequorum_reached (candidate, preendorsement_qc))) - -> - loop_state.last_get_qc_event <- None ; - return_some (Prequorum_reached (candidate, preendorsement_qc)) - | `QC_reached - (Some (Operation_worker.Quorum_reached (candidate, endorsement_qc))) -> - loop_state.last_get_qc_event <- None ; - return_some (Quorum_reached (candidate, endorsement_qc)) - | `Timeout e -> return_some (Timeout e) - -(** From the current [state], the function returns an optional - association pair, which consists of the next round timestamp and its - round. *) -let compute_next_round_time state = - let open Baking_state in - let proposal = - match state.level_state.endorsable_payload with - | None -> state.level_state.latest_proposal - | Some {proposal; _} -> proposal - in - if Baking_state.is_first_block_in_protocol proposal then None - else - match state.level_state.next_level_proposed_round with - | Some _proposed_round -> - (* TODO? do something, if we don't, we won't be able to - repropose a block at next level. *) - None - | None -> ( - let predecessor_timestamp = proposal.predecessor.shell.timestamp in - let predecessor_round = proposal.predecessor.round in - let next_round = Round.succ state.round_state.current_round in - match - timestamp_of_round - state - ~predecessor_timestamp - ~predecessor_round - ~round:next_round - with - | Ok timestamp -> Some (timestamp, next_round) - | _ -> assert false) - -(** [first_potential_round_at_next_level state ~earliest_round] yields - an optional pair of the earliest possible round (at or after - [earliest_round]), along with the delegate having the slot to - propose. - - In particular when the required round value is higher than the - consensus committee size, an Euclidean division allows to - recycle. Then, the earliest round when it exists is extracted. This - is meant to be multiplied back again to find the round value. *) -let first_potential_round_at_next_level state ~earliest_round = - let open Baking_state in - let slots = state.level_state.next_level_delegate_slots.own_delegate_slots in - let rounds = - state.level_state.next_level_delegate_slots.all_slots_by_round - |> Array.to_seqi - |> Seq.fold_left - (fun acc (round, slot) -> - if SlotMap.mem slot slots then (round, slot) :: acc else acc) - [] - |> List.rev - in - match Round.to_int earliest_round with - | Error _ -> None - | Ok earliest_round -> ( - let consensus_committee_size = - state.global_state.constants.parametric.consensus_committee_size - in - let q = earliest_round / consensus_committee_size in - let r = earliest_round mod consensus_committee_size in - let first_round = List.find (fun (round, _) -> round >= r) rounds in - match first_round with - | None -> None - | Some (round, slot) -> ( - SlotMap.find slot slots |> function - | None -> None - | Some (delegate, _) -> ( - (* TODO? check with [Node_rpc.first_proposer_round] if we also need the q+1 *) - match Round.of_int ((q * consensus_committee_size) + round) with - | Error _ -> None - | Ok first_potential_round -> - Some (first_potential_round, delegate)))) - -(** From the current [state], the function returns an optional - association pair, which consists of the next baking timestamp and - its baking round. In that case, an elected block must exist. *) -let compute_next_potential_baking_time_at_next_level state = - let open Protocol.Alpha_context in - let open Baking_state in - match state.level_state.elected_block with - | None -> Lwt.return_none - | Some elected_block -> ( - Events.( - emit - compute_next_timeout_elected_block - ( elected_block.proposal.block.shell.level, - elected_block.proposal.block.round )) - >>= fun () -> - (* Do we have baking rights for the next level ? *) - (* Determine the round for the next level *) - let predecessor_timestamp = - elected_block.proposal.block.shell.timestamp - in - let predecessor_round = elected_block.proposal.block.round in - let now = Time.System.now () |> Time.System.to_protocol in - (* Lookup the next slot information if already stored in the - memoization table [Round_timestamp_interval_tbl]. *) - match - find_in_known_round_intervals - state.global_state.cache.round_timestamps - ~predecessor_timestamp - ~predecessor_round - ~now - with - | Some (first_potential_baking_time, first_potential_round, delegate) -> ( - (* Check if we already have proposed something at next - level *) - match state.level_state.next_level_proposed_round with - | Some proposed_round - when Round.(proposed_round >= first_potential_round) -> - Events.(emit proposal_already_injected ()) >>= fun () -> - Lwt.return_none - | None | Some _ -> - Events.( - emit - next_potential_slot - ( Int32.succ state.level_state.current_level, - first_potential_round, - first_potential_baking_time, - delegate )) - >>= fun () -> - Lwt.return_some - (first_potential_baking_time, first_potential_round)) - | None -> ( - let round_durations = state.global_state.round_durations in - (* Compute the timestamp at which the new level will start at - round 0.*) - Round.timestamp_of_round - round_durations - ~predecessor_timestamp - ~predecessor_round - ~round:Round.zero - |> function - | Error _ -> Lwt.return_none - | Ok min_possible_time -> ( - (* If this timestamp exists and is not yet outdated, the - earliest round to bake is thereby 0. Otherwise, we - compute the round from the current timestamp. This - possibly means the baker has been late. *) - (if Time.Protocol.(now < min_possible_time) then ok Round.zero - else - Environment.wrap_tzresult - @@ Round.round_of_timestamp - round_durations - ~predecessor_timestamp - ~predecessor_round - ~timestamp:now) - |> function - | Error _ -> Lwt.return_none - | Ok earliest_round -> ( - (* There does not necessarily exists a slot that is - equal to [earliest_round]. We must find the earliest - slot after this value for which a validator is - designated to propose. *) - match - first_potential_round_at_next_level state ~earliest_round - with - | None -> Lwt.return_none - | Some (first_potential_round, delegate) -> ( - (* Check if we already have proposed something at next - level. If so, we can skip. Otherwise, we recompute - the timestamp for the - [first_potential_round]. Finally, from this - [first_potential_baking_time], we can return. *) - match state.level_state.next_level_proposed_round with - | Some proposed_round - when Round.(proposed_round >= first_potential_round) -> - Events.(emit proposal_already_injected ()) - >>= fun () -> Lwt.return_none - | None | Some _ -> ( - timestamp_of_round - state - ~predecessor_timestamp - ~predecessor_round - ~round:first_potential_round - |> function - | Error _ -> Lwt.return_none - | Ok first_potential_baking_time -> - Events.( - emit - next_potential_slot - ( Int32.succ state.level_state.current_level, - first_potential_round, - first_potential_baking_time, - delegate )) - >>= fun () -> - (* memoize this *) - let () = - let this_round_duration = - Round.round_duration - round_durations - first_potential_round - in - let end_first_potential_baking_time = - Timestamp.( - first_potential_baking_time - +? this_round_duration) - |> function - | Ok x -> x - | Error _ -> assert false - in - Baking_cache.( - Round_timestamp_interval_cache.replace - state.global_state.cache.round_timestamps - { - predecessor_timestamp; - predecessor_round; - time_interval = - ( first_potential_baking_time, - end_first_potential_baking_time ); - } - ( first_potential_baking_time, - first_potential_round, - delegate )) - in - Lwt.return_some - ( first_potential_baking_time, - first_potential_round ))))))) - -(** From the current [state], the function returns an Lwt promise that - fulfills once the nearest timeout is expired and at which the state - machine will react. - - Both subfunctions [wait_baking_time] and [wait_end_of_round] are - using the blocking function - [Baking_scheduling.sleep_until]. However, this call is binded into - a Lwt promise. Hence, it just won't get fulfilled until sleep time - has elapsed. Once the promise is fulfilled, - [Baking_scheduling.wait_next_event] handles with [Lwt.choose] to - react and trigger event [Timeout]. *) -let compute_next_timeout state : Baking_state.timeout_kind Lwt.t tzresult Lwt.t - = - (* FIXME: this function (may) try to instantly repropose a block *) - let open Baking_state in - let wait_end_of_round ?(delta = 0L) (next_round_time, next_round) = - let next_time = Time.Protocol.add next_round_time delta in - let now = Time.System.now () in - let delay = Ptime.diff (Time.System.of_protocol_exn next_time) now in - let current_round = Int32.pred @@ Round.to_int32 next_round in - (if delta = 0L then - Events.(emit waiting_end_of_round (delay, current_round, next_time)) - else - Events.( - emit - waiting_delayed_end_of_round - (delay, current_round, next_time, delta))) - >>= fun () -> - let end_of_round = - Lwt.return - @@ End_of_round {ending_round = state.round_state.current_round} - in - match sleep_until next_time with - | None -> return end_of_round - | Some t -> return (t >>= fun () -> end_of_round) - in - let wait_baking_time_next_level (next_baking_time, next_baking_round) = - let now = Time.System.now () in - let delay = Ptime.diff (Time.System.of_protocol_exn next_baking_time) now in - match sleep_until next_baking_time with - | None -> - Events.(emit no_need_to_wait_for_proposal ()) >>= fun () -> - return - (Lwt.return (Time_to_bake_next_level {at_round = next_baking_round})) - | Some t -> - Events.(emit waiting_time_to_bake (delay, next_baking_time)) - >>= fun () -> - return - ( t >>= fun () -> - Lwt.return (Time_to_bake_next_level {at_round = next_baking_round}) - ) - in - let delay_next_round_timeout next_round = - (* we only delay if it's our turn to bake *) - match - State_transitions.round_proposer - state - state.level_state.delegate_slots.own_delegate_slots - (snd next_round) - with - | Some _ -> - let delta = - state.global_state.constants.parametric.minimal_block_delay - |> Period.to_seconds - |> fun d -> Int64.div d 5L - in - (* NB: this means 6 seconds delay, if the first round duration is - 30. *) - wait_end_of_round ~delta next_round - | None -> wait_end_of_round next_round - in - let should_wait_to_forge_block (_next_baking_time, next_baking_round) = - Option.is_some state.level_state.elected_block - && Round.compare Round.zero next_baking_round = 0 - && Option.is_none state.level_state.next_forged_block - in - let waiting_to_forge_block (next_baking_time, _next_baking_round) = - Events.(emit first_baker_of_next_level ()) >>= fun () -> - let now = Time.System.now () in - let next_baking_ptime = Time.System.of_protocol_exn next_baking_time in - let pre_emptive_forge_time = - state.global_state.config.pre_emptive_forge_time - in - let next_forging_ptime = - match Ptime.sub_span next_baking_ptime pre_emptive_forge_time with - | Some ptime -> ptime - | None -> - (* This branch can only be reached if the Ptime operations above - fail. In practice, it should be unreachable. *) - assert false - in - let delay = Ptime.diff next_forging_ptime now in - match sleep_until_ptime next_forging_ptime with - | None -> - Events.(emit no_need_to_wait_to_forge_block ()) >>= fun () -> - return (Lwt.return Time_to_forge_block) - | Some t -> - Events.( - emit - waiting_to_forge_block - (delay, Time.System.to_protocol next_forging_ptime)) - >>= fun () -> return (t >>= fun () -> Lwt.return Time_to_forge_block) - in - (* TODO: re-use what has been done in round_synchronizer.ml *) - (* Compute the timestamp of the next possible round. *) - let next_round = compute_next_round_time state in - compute_next_potential_baking_time_at_next_level state >>= fun next_baking -> - match (next_round, next_baking) with - | None, None -> - Events.(emit waiting_for_new_head ()) >>= fun () -> - return (Lwt_utils.never_ending () >>= fun () -> assert false) - (* We have no slot at the next level in the near future, we will - patiently wait for the next round. *) - | Some next_round, None -> ( - (* If there is an elected block, then we make the assumption - that the bakers at the next level have also received an - endorsement quorum, and we delay a bit injecting at the next - round, so that there are not two blocks injected at the same - time. *) - match state.level_state.elected_block with - | None -> wait_end_of_round next_round - | Some _elected_block -> delay_next_round_timeout next_round) - (* There is no timestamp for a successor round but there is for a - future baking slot. If we are the next level baker at round 0, - quorum has been reached for this level, and no block being forged, - we will wait to forge, otherwise we will wait to bake *) - | None, Some next_baking -> - if should_wait_to_forge_block next_baking then - waiting_to_forge_block next_baking - else wait_baking_time_next_level next_baking - (* We choose the earliest timestamp between waiting to bake and - waiting for the next round. *) - | ( Some ((next_round_time, next_round) as next_round_info), - Some ((next_baking_time, _) as next_baking) ) -> - (* If we can bake at the next level before the end of the next - round, then do so. This is because the proposed block will have - a smaller timestamp than the earliest block at next level built - on top of the proposal made at the next round (at the current - level). *) - let round_durations = state.global_state.round_durations in - let next_round_duration = - Round.round_duration round_durations next_round |> Period.to_seconds - in - if - Time.Protocol.( - next_baking_time < add next_round_time next_round_duration) - then - if should_wait_to_forge_block next_baking then - waiting_to_forge_block next_baking - else wait_baking_time_next_level next_baking - else - (* same observation is in the [(Some next_round, None)] case *) - delay_next_round_timeout next_round_info - -(* initialises endorsable_payload with the PQC included in the latest block - if there is one and if it's more recent than the one loaded from disk - if any *) -let may_initialise_with_latest_proposal_pqc state = - let p = state.level_state.latest_proposal in - match p.block.prequorum with - | None -> return state - | Some pqc -> ( - match state.level_state.endorsable_payload with - | Some ep when ep.prequorum.round >= pqc.round -> - (*do not change the endorsable_payload loaded from disk if it's - more recent *) - return state - | Some _ | None -> - return - { - state with - level_state = - { - state.level_state with - endorsable_payload = Some {prequorum = pqc; proposal = p}; - }; - }) - -let create_round_durations constants = - let first_round_duration = - constants.Constants.parametric.minimal_block_delay - in - let delay_increment_per_round = - constants.parametric.delay_increment_per_round - in - Environment.wrap_tzresult - (Round.Durations.create ~first_round_duration ~delay_increment_per_round) - -let create_dal_node_rpc_ctxt endpoint = - let open Tezos_rpc_http_client_unix in - let rpc_config = - {Tezos_rpc_http_client_unix.RPC_client_unix.default_config with endpoint} - in - let media_types = - Tezos_rpc_http.Media_type.Command_line.of_command_line rpc_config.media_type - in - new RPC_client_unix.http_ctxt rpc_config media_types - -let create_initial_state cctxt ?(synchronize = true) ~chain config - operation_worker ~(current_proposal : Baking_state.proposal) ?constants - delegates = - (* FIXME? consider saved endorsable value *) - let open Protocol in - let open Baking_state in - Shell_services.Chain.chain_id cctxt ~chain () >>=? fun chain_id -> - (match constants with - | Some c -> return c - | None -> Alpha_services.Constants.all cctxt (`Hash chain_id, `Head 0)) - >>=? fun constants -> - create_round_durations constants >>?= fun round_durations -> - Baking_state.( - match config.Baking_configuration.validation with - | Node -> return Node - | Local {context_path} -> - Baking_simulator.load_context ~context_path >>=? fun index -> - return (Local index) - | ContextIndex index -> return (Local index)) - >>=? fun validation_mode -> - let cache = Baking_state.create_cache () in - let global_state = - { - cctxt; - chain_id; - config; - constants; - round_durations; - operation_worker; - validation_mode; - delegates; - cache; - dal_node_rpc_ctxt = - (* TODO: https://gitlab.com/tezos/tezos/-/issues/4674 - Treat case when no endpoint was given and DAL is enabled *) - Option.map create_dal_node_rpc_ctxt config.dal_node_endpoint; - } - in - let chain = `Hash chain_id in - let current_level = current_proposal.block.shell.level in - Baking_state.compute_delegate_slots - cctxt - delegates - ~level:current_level - ~chain - >>=? fun delegate_slots -> - Baking_state.compute_delegate_slots - cctxt - delegates - ~level:(Int32.succ current_level) - ~chain - >>=? fun next_level_delegate_slots -> - let elected_block = - if Baking_state.is_first_block_in_protocol current_proposal then - (* If the last block is a protocol transition, we admit it as a - final block *) - Some {proposal = current_proposal; endorsement_qc = []} - else None - in - let level_state = - { - current_level = current_proposal.block.shell.level; - latest_proposal = current_proposal; - is_latest_proposal_applied = - true (* this proposal is expected to be the current head *); - locked_round = None; - endorsable_payload = None; - elected_block; - delegate_slots; - next_level_delegate_slots; - next_level_proposed_round = None; - next_forged_block = None; - } - in - (if synchronize then - create_round_durations constants >>? fun round_durations -> - Baking_actions.compute_round current_proposal round_durations - >>? fun current_round -> - ok {current_round; current_phase = Idle; delayed_quorum = None} - else - ok - { - Baking_state.current_round = Round.zero; - current_phase = Idle; - delayed_quorum = None; - }) - >>?= fun round_state -> - let state = {global_state; level_state; round_state} in - (* Try loading locked round and endorsable round from disk *) - Baking_state.may_load_endorsable_data state >>=? fun state -> - may_initialise_with_latest_proposal_pqc state - -let compute_bootstrap_event state = - let open Baking_state in - (* Check if we are in the current round *) - if - Round.( - state.level_state.latest_proposal.block.round - = state.round_state.current_round) - then - (* If so, then trigger the new proposal event to possibly preendorse *) - ok @@ Baking_state.New_head_proposal state.level_state.latest_proposal - else - (* Otherwise, trigger the end of round to check whether we - need to propose at this level or not *) - Environment.wrap_tzresult @@ Round.pred state.round_state.current_round - >>? fun ending_round -> - ok @@ Baking_state.Timeout (End_of_round {ending_round}) - -let rec automaton_loop ?(stop_on_event = fun _ -> false) ~config ~on_error - loop_state state event = - let state_recorder ~new_state = - match config.Baking_configuration.state_recorder with - | Baking_configuration.Filesystem -> - Baking_state.may_record_new_state ~previous_state:state ~new_state - | Baking_configuration.Memory -> return_unit - in - State_transitions.step state event >>= fun (state', action) -> - (Baking_actions.perform_action ~state_recorder state' action >>= function - | Ok state'' -> return state'' - | Error error -> - on_error error >>=? fun () -> - (* Still try to record the intermediate state; ignore potential - errors. *) - state_recorder ~new_state:state' >>= fun _ -> return state') - >>=? fun state'' -> - compute_next_timeout state'' >>=? fun next_timeout -> - wait_next_event ~timeout:(next_timeout >|= fun e -> `Timeout e) loop_state - >>=? function - | None -> - (* Termination *) - return_none - | Some event -> - if stop_on_event event then return_some event - else - automaton_loop ~stop_on_event ~config ~on_error loop_state state'' event - -let perform_sanity_check cctxt ~chain_id = - let open Baking_errors in - let prefix_base_dir f = Filename.Infix.(cctxt#get_base_dir // f) in - let nonces_location = Baking_files.resolve_location ~chain_id `Nonce in - Baking_nonces.load cctxt nonces_location - |> trace - (Cannot_load_local_file - (prefix_base_dir (Baking_files.filename nonces_location) ^ "s")) - >>=? fun _ -> - let highwatermarks_location = - Baking_files.resolve_location ~chain_id `Highwatermarks - in - Baking_highwatermarks.load cctxt highwatermarks_location - |> trace - (Cannot_load_local_file - (prefix_base_dir (Baking_files.filename highwatermarks_location) ^ "s")) - >>=? fun _ -> - let state_location = Baking_files.resolve_location ~chain_id `State in - Baking_state.load_endorsable_data cctxt state_location - |> trace - (Cannot_load_local_file - (prefix_base_dir (Baking_files.filename state_location))) - >>=? fun _ -> return_unit - -let run cctxt ?canceler ?(stop_on_event = fun _ -> false) - ?(on_error = fun _ -> return_unit) ?constants ~chain config delegates = - let open Lwt_result_syntax in - Shell_services.Chain.chain_id cctxt ~chain () >>=? fun chain_id -> - perform_sanity_check cctxt ~chain_id >>=? fun () -> - let cache = Baking_cache.Block_cache.create 10 in - Node_rpc.monitor_heads cctxt ~cache ~chain () - >>=? fun (heads_stream, _block_stream_stopper) -> - (Lwt_stream.get heads_stream >>= function - | Some current_head -> return current_head - | None -> failwith "head stream unexpectedly ended") - >>=? fun current_proposal -> - Operation_worker.create cctxt >>= fun operation_worker -> - Option.iter - (fun canceler -> - Lwt_canceler.on_cancel canceler (fun () -> - Operation_worker.shutdown_worker operation_worker >>= fun _ -> - Lwt.return_unit)) - canceler ; - create_initial_state - cctxt - ~chain - config - operation_worker - ~current_proposal - ?constants - delegates - >>=? fun initial_state -> - let cloned_block_stream = Lwt_stream.clone heads_stream in - Baking_nonces.start_revelation_worker - cctxt - initial_state.global_state.config.nonce - initial_state.global_state.chain_id - initial_state.global_state.constants - cloned_block_stream - >>= fun revelation_worker_canceler -> - Option.iter - (fun canceler -> - Lwt_canceler.on_cancel canceler (fun () -> - Lwt_canceler.cancel revelation_worker_canceler >>= fun _ -> - Lwt.return_unit)) - canceler ; - (* FIXME: currently, the client streamed RPC call will hold until at - least one element is present in the stream. This is fixed by: - https://gitlab.com/nomadic-labs/resto/-/merge_requests/50. Until - then, we await the promise completion of the RPC call later - on. *) - let get_valid_blocks_stream = - let*! vbs = Node_rpc.monitor_valid_proposals cctxt ~cache ~chain () in - match vbs with - | Error _ -> Stdlib.failwith "Failed to get the validated blocks stream" - | Ok (vbs, _) -> Lwt.return vbs - in - let loop_state = - create_loop_state - ~get_valid_blocks_stream - ~heads_stream - initial_state.global_state.operation_worker - in - let on_error err = - Events.(emit error_while_baking err) >>= fun () -> - (* TODO? retry a bounded number of time *) - (* let retries = config.Baking_configuration.retries_on_failure in *) - on_error err - in - compute_bootstrap_event initial_state >>?= fun initial_event -> - protect - ~on_error:(fun err -> - Option.iter_es Lwt_canceler.cancel canceler >>= fun _ -> - Lwt.return_error err) - (fun () -> - automaton_loop - ~stop_on_event - ~config - ~on_error - loop_state - initial_state - initial_event - >>=? fun _ignored_event -> return_unit) diff --git a/src/proto_017_PtNairob/lib_delegate/baking_scheduling.mli b/src/proto_017_PtNairob/lib_delegate/baking_scheduling.mli deleted file mode 100644 index 10f4a9858c082e8ef4edaabf802814dc6b183007..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_scheduling.mli +++ /dev/null @@ -1,90 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 Baking_state -open Protocol.Alpha_context - -type loop_state - -val create_loop_state : - ?get_valid_blocks_stream:proposal Lwt_stream.t Lwt.t -> - heads_stream:proposal Lwt_stream.t -> - Operation_worker.t -> - loop_state - -val sleep_until : Time.Protocol.t -> unit Lwt.t option - -(** An event monitor using the streams in [loop_state] (to create - promises) and a timeout promise [timeout]. The function reacts to a - promise being fulfilled by firing an event [Baking_state.event]. *) -val wait_next_event : - timeout:[`Timeout of timeout_kind] Lwt.t -> - loop_state -> - (event option, error trace) result Lwt.t - -val compute_next_round_time : state -> (Time.Protocol.t * Round.t) option - -val first_potential_round_at_next_level : - state -> - earliest_round:Round.t -> - (Round.t * consensus_key_and_delegate) option - -val compute_next_potential_baking_time_at_next_level : - state -> (Time.Protocol.t * Round.t) option Lwt.t - -val compute_next_timeout : state -> timeout_kind Lwt.t tzresult Lwt.t - -val create_initial_state : - Protocol_client_context.full -> - ?synchronize:bool -> - chain:Chain_services.chain -> - Baking_configuration.t -> - Operation_worker.t -> - current_proposal:proposal -> - ?constants:Constants.t -> - consensus_key list -> - state tzresult Lwt.t - -val compute_bootstrap_event : state -> event tzresult - -val automaton_loop : - ?stop_on_event:(event -> bool) -> - config:Baking_configuration.t -> - on_error:(tztrace -> (unit, tztrace) result Lwt.t) -> - loop_state -> - state -> - event -> - event option tzresult Lwt.t - -val run : - Protocol_client_context.full -> - ?canceler:Lwt_canceler.t -> - ?stop_on_event:(event -> bool) -> - ?on_error:(tztrace -> unit tzresult Lwt.t) -> - ?constants:Constants.t -> - chain:Chain_services.chain -> - Baking_configuration.t -> - consensus_key list -> - unit tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_delegate/baking_simulator.ml b/src/proto_017_PtNairob/lib_delegate/baking_simulator.ml deleted file mode 100644 index 2907f976914627a3e7433654fb956e232cd939c3..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_simulator.ml +++ /dev/null @@ -1,193 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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_client_context -open Protocol -open Alpha_context - -type error += Failed_to_checkout_context - -type error += Invalid_context - -let () = - register_error_kind - `Permanent - ~id:"Client_baking_simulator.failed_to_checkout_context" - ~title:"Failed to checkout context" - ~description:"The given context hash does not exists in the context." - ~pp:(fun ppf () -> Format.fprintf ppf "Failed to checkout the context") - Data_encoding.unit - (function Failed_to_checkout_context -> Some () | _ -> None) - (fun () -> Failed_to_checkout_context) ; - register_error_kind - `Permanent - ~id:"Client_baking_simulator.invalid_context" - ~title:"Invalid context" - ~description:"Occurs when the context is inconsistent." - ~pp:(fun ppf () -> Format.fprintf ppf "The given context is invalid.") - Data_encoding.unit - (function Invalid_context -> Some () | _ -> None) - (fun () -> Invalid_context) - -type incremental = { - predecessor : Baking_state.block_info; - context : Tezos_protocol_environment.Context.t; - state : Protocol.validation_state * Protocol.application_state option; - rev_operations : Operation.packed list; - header : Tezos_base.Block_header.shell_header; -} - -let load_context ~context_path = - protect (fun () -> - Context.init ~readonly:true context_path >>= fun index -> - return (Abstract_context_index.abstract index)) - -let check_context_consistency (abstract_index : Abstract_context_index.t) - context_hash = - protect (fun () -> - (* Hypothesis : the version key exists *) - let version_key = ["version"] in - abstract_index.checkout_fun context_hash >>= function - | None -> fail Failed_to_checkout_context - | Some context -> ( - Context_ops.mem context version_key >>= function - | true -> return_unit - | false -> fail Invalid_context)) - -let begin_construction ~timestamp ~protocol_data ~force_apply - ~pred_resulting_context_hash (abstract_index : Abstract_context_index.t) - pred_block chain_id = - protect (fun () -> - let {Baking_state.shell = pred_shell; hash = pred_hash; _} = pred_block in - abstract_index.checkout_fun pred_resulting_context_hash >>= function - | None -> fail Failed_to_checkout_context - | Some context -> - let header : Tezos_base.Block_header.shell_header = - Tezos_base.Block_header. - { - predecessor = pred_hash; - proto_level = pred_shell.proto_level; - validation_passes = 0; - fitness = pred_shell.fitness; - timestamp; - level = pred_shell.level; - context = Context_hash.zero (* fake context hash *); - operations_hash = - Operation_list_list_hash.zero (* fake op hash *); - } - in - let mode = - Lifted_protocol.Construction - { - predecessor_hash = pred_hash; - timestamp; - block_header_data = protocol_data; - } - in - Lifted_protocol.begin_validation - context - chain_id - mode - ~predecessor:pred_shell - ~cache:`Lazy - >>=? fun validation_state -> - (if force_apply then - Lifted_protocol.begin_application - context - chain_id - mode - ~predecessor:pred_shell - ~cache:`Lazy - >>=? return_some - else return_none) - >>=? fun application_state -> - let state = (validation_state, application_state) in - return - { - predecessor = pred_block; - context; - state; - rev_operations = []; - header; - }) - -let ( let** ) x k = - let open Lwt_result_syntax in - let*! x in - let*? x = Environment.wrap_tzresult x in - k x - -let add_operation st (op : Operation.packed) = - protect (fun () -> - let validation_state, application_state = st.state in - let oph = Operation.hash_packed op in - let** validation_state = - Protocol.validate_operation - ~check_signature:false - (* We assume that the operation has already been validated in the - node, therefore the signature has already been checked, but we - still need to validate it again because the context may be - different. *) - validation_state - oph - op - in - let** application_state, receipt = - match application_state with - | Some application_state -> - Protocol.apply_operation application_state oph op - >>=? fun (application_state, receipt) -> - return (Some application_state, Some receipt) - | None -> return (None, None) - in - let state = (validation_state, application_state) in - return ({st with state; rev_operations = op :: st.rev_operations}, receipt)) - -let finalize_construction inc = - protect (fun () -> - let validation_state, application_state = inc.state in - let** () = Protocol.finalize_validation validation_state in - let** result = - match application_state with - | Some application_state -> ( - Protocol.finalize_application application_state (Some inc.header) - >>= function - | Ok (vr, metadata) -> - let new_vr = - Tezos_protocol_environment. - { - context = vr.context; - fitness = vr.fitness; - message = vr.message; - max_operations_ttl = vr.max_operations_ttl; - last_finalized_block_level = vr.last_allowed_fork_level; - last_preserved_block_level = vr.last_allowed_fork_level; - } - in - return_some (new_vr, metadata) - | Error e -> Lwt.return (Error e)) - | None -> return_none - in - return result) diff --git a/src/proto_017_PtNairob/lib_delegate/baking_simulator.mli b/src/proto_017_PtNairob/lib_delegate/baking_simulator.mli deleted file mode 100644 index c5155ac45ee06f912c05bf3b90d61a972a01454c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_simulator.mli +++ /dev/null @@ -1,81 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 -open Alpha_context - -type incremental = { - predecessor : Baking_state.block_info; - context : Tezos_protocol_environment.Context.t; - state : validation_state * application_state option; - rev_operations : Operation.packed list; - header : Tezos_base.Block_header.shell_header; -} - -val load_context : - context_path:string -> Abstract_context_index.t tzresult Lwt.t - -(** Make sure that the given context is consistent by trying to read in it *) -val check_context_consistency : - Abstract_context_index.t -> Context_hash.t -> unit tzresult Lwt.t - -(** [begin_construction ~timestamp ~protocol_data ~force_apply abstract_context - predecessor chain_id] creates a new [incremental] value with an empty - operation list. A [context] is recovered from the [abstract_index] and the - resulting_context_hash from [predecessor]. This context is used to create a - [validation_state] and an [application_state] (if [force_apply] is set). A - partial [shell_header] is created from [predecessor] information and - [timestamp]. *) -val begin_construction : - timestamp:Time.Protocol.t -> - protocol_data:block_header_data -> - force_apply:bool -> - pred_resulting_context_hash:Context_hash.t -> - Abstract_context_index.t -> - Baking_state.block_info -> - Chain_id.t -> - incremental tzresult Lwt.t - -(** [add_operation incremental op] validates [op] in - [incremental.validation_state] without checking its signature. Indeed, the - operation has already been validated in the node so it has a correct - signature. We still need to validate it again because the context may be - different. [op] is also applied if [incremental] has been created with - [force_apply] set. This function returns an [incremental] with updated - operations list and [validation_state] (and [application_state]). *) -val add_operation : - incremental -> - Operation.packed -> - (incremental * operation_receipt option) tzresult Lwt.t - -(** [finalize_construction incremental] calls the [finalize_validation] of the - protocol on the [validation_state] from [incremental]. If [incremental] has - been created with [force_apply] set, [finalize_application] is also called - and its results returned. *) -val finalize_construction : - incremental -> - (Tezos_protocol_environment.validation_result * block_header_metadata) option - tzresult - Lwt.t diff --git a/src/proto_017_PtNairob/lib_delegate/baking_state.ml b/src/proto_017_PtNairob/lib_delegate/baking_state.ml deleted file mode 100644 index cd67f9aa65522425c920c522aeb66714ab174d5e..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_state.ml +++ /dev/null @@ -1,954 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context -open Protocol_client_context - -(** A consensus key (aka, a validator) is identified by its alias name, its - public key, its public key hash, and its secret key. *) -type consensus_key = { - alias : string option; - public_key : Signature.Public_key.t; - public_key_hash : Signature.Public_key_hash.t; - secret_key_uri : Client_keys.sk_uri; -} - -let consensus_key_encoding = - let open Data_encoding in - conv - (fun {alias; public_key; public_key_hash; secret_key_uri} -> - ( alias, - public_key, - public_key_hash, - Uri.to_string (secret_key_uri :> Uri.t) )) - (fun (alias, public_key, public_key_hash, secret_key_uri) -> - { - alias; - public_key; - public_key_hash; - secret_key_uri = - (match Client_keys.make_sk_uri (Uri.of_string secret_key_uri) with - | Ok sk -> sk - | Error e -> Format.kasprintf Stdlib.failwith "%a" pp_print_trace e); - }) - (obj4 - (req "alias" (option string)) - (req "public_key" Signature.Public_key.encoding) - (req "public_key_hash" Signature.Public_key_hash.encoding) - (req "secret_key_uri" string)) - -let pp_consensus_key fmt {alias; public_key_hash; _} = - match alias with - | None -> Format.fprintf fmt "%a" Signature.Public_key_hash.pp public_key_hash - | Some alias -> - Format.fprintf - fmt - "%s (%a)" - alias - Signature.Public_key_hash.pp - public_key_hash - -type consensus_key_and_delegate = consensus_key * Signature.Public_key_hash.t - -let consensus_key_and_delegate_encoding = - let open Data_encoding in - merge_objs - consensus_key_encoding - (obj1 (req "delegate" Signature.Public_key_hash.encoding)) - -let pp_consensus_key_and_delegate fmt (consensus_key, delegate) = - if Signature.Public_key_hash.equal consensus_key.public_key_hash delegate then - pp_consensus_key fmt consensus_key - else - Format.fprintf - fmt - "%a@,on behalf of %a" - pp_consensus_key - consensus_key - Signature.Public_key_hash.pp - delegate - -type validation_mode = Node | Local of Abstract_context_index.t - -type prequorum = { - level : int32; - round : Round.t; - block_payload_hash : Block_payload_hash.t; - preendorsements : Kind.preendorsement operation list; -} - -type block_info = { - hash : Block_hash.t; - shell : Block_header.shell_header; - payload_hash : Block_payload_hash.t; - payload_round : Round.t; - round : Round.t; - prequorum : prequorum option; - quorum : Kind.endorsement operation list; - dal_attestations : Kind.dal_attestation operation list; - payload : Operation_pool.payload; -} - -type cache = { - known_timestamps : Timestamp.time Baking_cache.Timestamp_of_round_cache.t; - round_timestamps : - (Timestamp.time * Round.t * consensus_key_and_delegate) - Baking_cache.Round_timestamp_interval_cache.t; -} - -type global_state = { - (* client context *) - cctxt : Protocol_client_context.full; - (* chain id *) - chain_id : Chain_id.t; - (* baker configuration *) - config : Baking_configuration.t; - (* protocol constants *) - constants : Constants.t; - (* round durations *) - round_durations : Round.round_durations; - (* worker that monitor and aggregates new operations *) - operation_worker : Operation_worker.t; - (* the validation mode used by the baker*) - validation_mode : validation_mode; - (* the delegates on behalf of which the baker is running *) - delegates : consensus_key list; - cache : cache; - dal_node_rpc_ctxt : Tezos_rpc.Context.generic option; -} - -let prequorum_encoding = - let open Data_encoding in - conv - (fun {level; round; block_payload_hash; preendorsements} -> - (level, round, block_payload_hash, List.map Operation.pack preendorsements)) - (fun (level, round, block_payload_hash, preendorsements) -> - { - level; - round; - block_payload_hash; - preendorsements = - List.filter_map Operation_pool.unpack_preendorsement preendorsements; - }) - (obj4 - (req "level" int32) - (req "round" Round.encoding) - (req "block_payload_hash" Block_payload_hash.encoding) - (req "preendorsements" (list (dynamic_size Operation.encoding)))) - -let block_info_encoding = - let open Data_encoding in - conv - (fun { - hash; - shell; - payload_hash; - payload_round; - round; - prequorum; - quorum; - dal_attestations; - payload; - } -> - ( hash, - shell, - payload_hash, - payload_round, - round, - prequorum, - List.map Operation.pack quorum, - List.map Operation.pack dal_attestations, - payload )) - (fun ( hash, - shell, - payload_hash, - payload_round, - round, - prequorum, - quorum, - dal_attestations, - payload ) -> - { - hash; - shell; - payload_hash; - payload_round; - round; - prequorum; - quorum = List.filter_map Operation_pool.unpack_endorsement quorum; - dal_attestations = - List.filter_map Operation_pool.unpack_dal_attestation dal_attestations; - payload; - }) - (obj9 - (req "hash" Block_hash.encoding) - (req "shell" Block_header.shell_header_encoding) - (req "payload_hash" Block_payload_hash.encoding) - (req "payload_round" Round.encoding) - (req "round" Round.encoding) - (req "prequorum" (option prequorum_encoding)) - (req "quorum" (list (dynamic_size Operation.encoding))) - (req "dal_attestations" (list (dynamic_size Operation.encoding))) - (req "payload" Operation_pool.payload_encoding)) - -let round_of_shell_header shell_header = - Environment.wrap_tzresult - @@ Fitness.from_raw shell_header.Tezos_base.Block_header.fitness - >>? fun fitness -> ok (Fitness.round fitness) - -module SlotMap : Map.S with type key = Slot.t = Map.Make (Slot) - -(** An endorsing slot consists of the public key hash of a delegate, a - list of slots (i.e., a list of position indexes in the slot map, in - other words the list of rounds when it will be the proposer), and - its endorsing power. *) -type endorsing_slot = {first_slot : Slot.t; endorsing_power : int} - -(* FIXME: determine if the slot map should contain all slots or just - the first one *) -(* We also use the delegate slots as proposal slots *) -(* TODO: make sure that this is correct *) -type delegate_slots = { - (* be careful not to duplicate endorsing slots with different slots - keys: always use the first slot in the slots list *) - own_delegate_slots : (consensus_key_and_delegate * endorsing_slot) SlotMap.t; - all_delegate_slots : endorsing_slot SlotMap.t; - all_slots_by_round : Slot.t array; -} - -type proposal = {block : block_info; predecessor : block_info} - -let proposal_encoding = - let open Data_encoding in - conv - (fun {block; predecessor} -> (block, predecessor)) - (fun (block, predecessor) -> {block; predecessor}) - (obj2 - (req "block" block_info_encoding) - (req "predecessor" block_info_encoding)) - -let is_first_block_in_protocol {block; predecessor; _} = - Compare.Int.(block.shell.proto_level <> predecessor.shell.proto_level) - -type locked_round = {payload_hash : Block_payload_hash.t; round : Round.t} - -let locked_round_encoding = - let open Data_encoding in - conv - (fun {payload_hash; round} -> (payload_hash, round)) - (fun (payload_hash, round) -> {payload_hash; round}) - (obj2 - (req "payload_hash" Block_payload_hash.encoding) - (req "round" Round.encoding)) - -type endorsable_payload = {proposal : proposal; prequorum : prequorum} - -let endorsable_payload_encoding = - let open Data_encoding in - conv - (fun {proposal; prequorum} -> (proposal, prequorum)) - (fun (proposal, prequorum) -> {proposal; prequorum}) - (obj2 - (req "proposal" proposal_encoding) - (req "prequorum" prequorum_encoding)) - -type elected_block = { - proposal : proposal; - endorsement_qc : Kind.endorsement Operation.t list; -} - -type signed_block = { - round : Round.t; - delegate : consensus_key_and_delegate; - block_header : block_header; - operations : Tezos_base.Operation.t list list; -} - -(* Updated only when we receive a block at a different level. - - N.B. it may be our own: implying that we should not update unless - we already baked a block *) -type level_state = { - current_level : int32; - latest_proposal : proposal; - is_latest_proposal_applied : bool; - (* Last proposal received where we injected an endorsement (thus we - have seen 2f+1 preendorsements) *) - locked_round : locked_round option; - (* Latest payload where we've seen a proposal reach 2f+1 preendorsements *) - endorsable_payload : endorsable_payload option; - (* Block for which we've seen 2f+1 endorsements and that we may bake onto *) - elected_block : elected_block option; - delegate_slots : delegate_slots; - next_level_delegate_slots : delegate_slots; - next_level_proposed_round : Round.t option; - next_forged_block : signed_block option; - (* Block that is preemptively forged for the next level when baker is - round 0 proposer. *) -} - -type phase = - | Idle - | Awaiting_preendorsements - | Awaiting_endorsements - | Awaiting_application - -let phase_encoding = - let open Data_encoding in - union - ~tag_size:`Uint8 - [ - case - ~title:"Idle" - (Tag 0) - (constant "Idle") - (function Idle -> Some () | _ -> None) - (fun () -> Idle); - case - ~title:"Awaiting_preendorsements" - (Tag 1) - (constant "Awaiting_preendorsements") - (function Awaiting_preendorsements -> Some () | _ -> None) - (fun () -> Awaiting_preendorsements); - case - ~title:"Awaiting_application" - (Tag 2) - (constant "Awaiting_application") - (function Awaiting_application -> Some () | _ -> None) - (fun () -> Awaiting_application); - case - ~title:"Awaiting_endorsements" - (Tag 3) - (constant "Awaiting_endorsements") - (function Awaiting_endorsements -> Some () | _ -> None) - (fun () -> Awaiting_endorsements); - ] - -type round_state = { - current_round : Round.t; - current_phase : phase; - delayed_quorum : Kind.endorsement operation list option; -} - -type state = { - global_state : global_state; - level_state : level_state; - round_state : round_state; -} - -type t = state - -let update_current_phase state new_phase = - {state with round_state = {state.round_state with current_phase = new_phase}} - -type timeout_kind = - | End_of_round of {ending_round : Round.t} - | Time_to_bake_next_level of {at_round : Round.t} - | Time_to_forge_block - -let timeout_kind_encoding = - let open Data_encoding in - union - [ - case - (Tag 0) - ~title:"End_of_round" - (obj2 - (req "kind" (constant "End_of_round")) - (req "round" Round.encoding)) - (function - | End_of_round {ending_round} -> Some ((), ending_round) | _ -> None) - (fun ((), ending_round) -> End_of_round {ending_round}); - case - (Tag 1) - ~title:"Time_to_bake_next_level" - (obj2 - (req "kind" (constant "Time_to_bake_next_level")) - (req "round" Round.encoding)) - (function - | Time_to_bake_next_level {at_round} -> Some ((), at_round) - | _ -> None) - (fun ((), at_round) -> Time_to_bake_next_level {at_round}); - ] - -type event = - | New_valid_proposal of proposal - | New_head_proposal of proposal - | Prequorum_reached of - Operation_worker.candidate * Kind.preendorsement operation list - | Quorum_reached of - Operation_worker.candidate * Kind.endorsement operation list - | Timeout of timeout_kind - -let event_encoding = - let open Data_encoding in - union - [ - case - (Tag 0) - ~title:"New_valid_proposal" - (tup2 (constant "New_valid_proposal") proposal_encoding) - (function New_valid_proposal p -> Some ((), p) | _ -> None) - (fun ((), p) -> New_valid_proposal p); - case - (Tag 1) - ~title:"New_head_proposal" - (tup2 (constant "New_head_proposal") proposal_encoding) - (function New_head_proposal p -> Some ((), p) | _ -> None) - (fun ((), p) -> New_head_proposal p); - case - (Tag 2) - ~title:"Prequorum_reached" - (tup3 - (constant "Prequorum_reached") - Operation_worker.candidate_encoding - (Data_encoding.list (dynamic_size Operation.encoding))) - (function - | Prequorum_reached (candidate, ops) -> - Some ((), candidate, List.map Operation.pack ops) - | _ -> None) - (fun ((), candidate, ops) -> - Prequorum_reached - (candidate, Operation_pool.filter_preendorsements ops)); - case - (Tag 3) - ~title:"Quorum_reached" - (tup3 - (constant "Quorum_reached") - Operation_worker.candidate_encoding - (Data_encoding.list (dynamic_size Operation.encoding))) - (function - | Quorum_reached (candidate, ops) -> - Some ((), candidate, List.map Operation.pack ops) - | _ -> None) - (fun ((), candidate, ops) -> - Quorum_reached (candidate, Operation_pool.filter_endorsements ops)); - case - (Tag 4) - ~title:"Timeout" - (tup2 (constant "Timeout") timeout_kind_encoding) - (function Timeout tk -> Some ((), tk) | _ -> None) - (fun ((), tk) -> Timeout tk); - ] - -(* Disk state *) - -module Events = struct - include Internal_event.Simple - - let section = [Protocol.name; "baker"; "disk"] - - let incompatible_stored_state = - declare_0 - ~section - ~name:"incompatible_stored_state" - ~level:Warning - ~msg:"found an outdated or corrupted baking state: discarding it" - () -end - -type state_data = { - level_data : int32; - locked_round_data : locked_round option; - endorsable_payload_data : endorsable_payload option; -} - -let state_data_encoding = - let open Data_encoding in - conv - (fun {level_data; locked_round_data; endorsable_payload_data} -> - (level_data, locked_round_data, endorsable_payload_data)) - (fun (level_data, locked_round_data, endorsable_payload_data) -> - {level_data; locked_round_data; endorsable_payload_data}) - (obj3 - (req "level" int32) - (req "locked_round" (option locked_round_encoding)) - (req "endorsable_payload" (option endorsable_payload_encoding))) - -let record_state (state : state) = - let cctxt = state.global_state.cctxt in - let location = - Baking_files.resolve_location ~chain_id:state.global_state.chain_id `State - in - let filename = - Filename.Infix.(cctxt#get_base_dir // Baking_files.filename location) - in - protect @@ fun () -> - cctxt#with_lock @@ fun () -> - let level_data = state.level_state.current_level in - let locked_round_data = state.level_state.locked_round in - let endorsable_payload_data = state.level_state.endorsable_payload in - let bytes = - Data_encoding.Binary.to_bytes_exn - state_data_encoding - {level_data; locked_round_data; endorsable_payload_data} - in - let filename_tmp = filename ^ "_tmp" in - Lwt_io.with_file - ~flags:[Unix.O_CREAT; O_WRONLY; O_TRUNC; O_CLOEXEC; O_SYNC] - ~mode:Output - filename_tmp - (fun channel -> - Lwt_io.write_from_exactly channel bytes 0 (Bytes.length bytes)) - >>= fun () -> - Lwt_unix.rename filename_tmp filename >>= fun () -> return_unit - -type error += Broken_locked_values_invariant - -let () = - register_error_kind - `Permanent - ~id:"Baking_state.broken_locked_values_invariant" - ~title:"Broken locked values invariant" - ~description: - "The expected consistency invariant on locked values does not hold" - ~pp:(fun ppf () -> - Format.fprintf - ppf - "The expected consistency invariant on locked values does not hold") - Data_encoding.unit - (function Broken_locked_values_invariant -> Some () | _ -> None) - (fun () -> Broken_locked_values_invariant) - -let may_record_new_state ~previous_state ~new_state = - if new_state.global_state.config.state_recorder = Baking_configuration.Memory - then return_unit - else - let { - current_level = previous_current_level; - locked_round = previous_locked_round; - endorsable_payload = previous_endorsable_payload; - _; - } = - previous_state.level_state - in - let { - current_level = new_current_level; - locked_round = new_locked_round; - endorsable_payload = new_endorsable_payload; - _; - } = - new_state.level_state - in - let is_new_state_consistent = - Compare.Int32.(new_current_level > previous_current_level) - || new_current_level = previous_current_level - && - if Compare.Int32.(new_current_level = previous_current_level) then - let is_new_locked_round_consistent = - match (new_locked_round, previous_locked_round) with - | None, None -> true - | Some _, None -> true - | None, Some _ -> false - | Some new_locked_round, Some previous_locked_round -> - Round.(new_locked_round.round >= previous_locked_round.round) - in - let is_new_endorsable_payload_consistent = - match (new_endorsable_payload, previous_endorsable_payload) with - | None, None -> true - | Some _, None -> true - | None, Some _ -> false - | Some new_endorsable_payload, Some previous_endorsable_payload -> - Round.( - new_endorsable_payload.proposal.block.round - >= previous_endorsable_payload.proposal.block.round) - in - is_new_locked_round_consistent - && is_new_endorsable_payload_consistent - else true - in - fail_unless is_new_state_consistent Broken_locked_values_invariant - >>=? fun () -> - let has_not_changed = - previous_state.level_state.current_level - == new_state.level_state.current_level - && previous_state.level_state.locked_round - == new_state.level_state.locked_round - && previous_state.level_state.endorsable_payload - == new_state.level_state.endorsable_payload - in - if has_not_changed then return_unit else record_state new_state - -let load_endorsable_data cctxt location = - protect (fun () -> - let filename = - Filename.Infix.(cctxt#get_base_dir // Baking_files.filename location) - in - Lwt_unix.file_exists filename >>= function - | false -> return_none - | true -> - Lwt_io.with_file - ~flags:[Unix.O_EXCL; O_RDONLY; O_CLOEXEC] - ~mode:Input - filename - (fun channel -> - Lwt_io.read channel >>= fun str -> - match - Data_encoding.Binary.of_string_opt state_data_encoding str - with - | Some state_data -> return_some state_data - | None -> - (* The stored state format is incompatible: discard it. *) - Events.(emit incompatible_stored_state ()) >>= fun () -> - return_none)) - -let may_load_endorsable_data state = - let cctxt = state.global_state.cctxt in - let chain_id = state.global_state.chain_id in - let location = Baking_files.resolve_location ~chain_id `State in - protect ~on_error:(fun _ -> return state) @@ fun () -> - cctxt#with_lock @@ fun () -> - load_endorsable_data cctxt location >>=? function - | None -> return state - | Some {level_data; locked_round_data; endorsable_payload_data} -> - if Compare.Int32.(state.level_state.current_level = level_data) then - let loaded_level_state = - { - state.level_state with - locked_round = locked_round_data; - endorsable_payload = endorsable_payload_data; - } - in - return {state with level_state = loaded_level_state} - else return state - -(* Helpers *) - -module DelegateSet = struct - include Set.Make (struct - type t = consensus_key - - let compare {public_key_hash = pkh; _} {public_key_hash = pkh'; _} = - Signature.Public_key_hash.compare pkh pkh' - end) - - let find_pkh pkh s = - let exception Found of elt in - try - iter - (fun ({public_key_hash; _} as delegate) -> - if Signature.Public_key_hash.equal pkh public_key_hash then - raise (Found delegate) - else ()) - s ; - None - with Found d -> Some d -end - -let cache_size_limit = 100 - -let compute_delegate_slots (cctxt : Protocol_client_context.full) - ?(block = `Head 0) ~level ~chain delegates = - let own_delegates = DelegateSet.of_list delegates in - Environment.wrap_tzresult (Raw_level.of_int32 level) >>?= fun level -> - Plugin.RPC.Validators.get cctxt (chain, block) ~levels:[level] - >>=? fun endorsing_rights -> - let own_delegate_slots, all_delegate_slots = - List.fold_left - (fun (own_map, all_map) slot -> - let {Plugin.RPC.Validators.consensus_key; delegate; slots; _} = slot in - let endorsing_slot = - { - endorsing_power = List.length slots; - first_slot = Stdlib.List.hd slots; - } - in - let all_map = - List.fold_left - (fun all_map slot -> SlotMap.add slot endorsing_slot all_map) - all_map - slots - in - let own_map = - match DelegateSet.find_pkh consensus_key own_delegates with - | Some consensus_key -> - List.fold_left - (fun own_map slot -> - SlotMap.add - slot - ((consensus_key, delegate), endorsing_slot) - own_map) - own_map - slots - | None -> own_map - in - (own_map, all_map)) - (SlotMap.empty, SlotMap.empty) - endorsing_rights - in - let all_slots_by_round = - all_delegate_slots |> SlotMap.bindings |> List.split |> fst |> Array.of_list - in - return {own_delegate_slots; all_delegate_slots; all_slots_by_round} - -let create_cache () = - let open Baking_cache in - { - known_timestamps = Timestamp_of_round_cache.create cache_size_limit; - round_timestamps = Round_timestamp_interval_cache.create cache_size_limit; - } - -(* Pretty-printers *) - -let pp_validation_mode fmt = function - | Node -> Format.fprintf fmt "node" - | Local _ -> Format.fprintf fmt "local" - -let pp_global_state fmt {chain_id; config; validation_mode; delegates; _} = - Format.fprintf - fmt - "@[Global state:@ chain_id: %a@ @[config:@ %a@]@ \ - validation_mode: %a@ @[delegates:@ %a@]@]" - Chain_id.pp - chain_id - Baking_configuration.pp - config - pp_validation_mode - validation_mode - Format.(pp_print_list pp_consensus_key) - delegates - -let pp_option pp fmt = function - | None -> Format.fprintf fmt "none" - | Some v -> Format.fprintf fmt "%a" pp v - -let pp_prequorum fmt {level; round; block_payload_hash; preendorsements} = - Format.fprintf - fmt - "level: %ld, round: %a, payload_hash: %a, preendorsements: %d" - level - Round.pp - round - Block_payload_hash.pp_short - block_payload_hash - (List.length preendorsements) - -let pp_block_info fmt - { - hash; - shell; - payload_hash; - round; - prequorum; - quorum; - dal_attestations; - payload; - payload_round; - } = - Format.fprintf - fmt - "@[Block:@ hash: %a@ payload_hash: %a@ level: %ld@ round: %a@ \ - prequorum: %a@ quorum: %d endorsements@ dal_attestations: %d@ payload: \ - %a@ payload round: %a@]" - Block_hash.pp - hash - Block_payload_hash.pp_short - payload_hash - shell.level - Round.pp - round - (pp_option pp_prequorum) - prequorum - (List.length quorum) - (List.length dal_attestations) - Operation_pool.pp_payload - payload - Round.pp - payload_round - -let pp_proposal fmt {block; _} = pp_block_info fmt block - -let pp_locked_round fmt ({payload_hash; round} : locked_round) = - Format.fprintf - fmt - "payload hash: %a, round: %a" - Block_payload_hash.pp_short - payload_hash - Round.pp - round - -let pp_endorsable_payload fmt {proposal; prequorum} = - Format.fprintf - fmt - "proposal: %a, prequorum: %a" - Block_hash.pp - proposal.block.hash - pp_prequorum - prequorum - -let pp_elected_block fmt {proposal; endorsement_qc} = - Format.fprintf - fmt - "@[%a@ nb quorum endorsements: %d@]" - pp_block_info - proposal.block - (List.length endorsement_qc) - -let pp_endorsing_slot fmt - (consensus_key_and_delegate, {first_slot; endorsing_power}) = - Format.fprintf - fmt - "slots: @[first_slot: %a@],@ delegate: %a,@ endorsing_power: %d" - Slot.pp - first_slot - pp_consensus_key_and_delegate - consensus_key_and_delegate - endorsing_power - -let pp_delegate_slots fmt {own_delegate_slots; _} = - Format.fprintf - fmt - "@[%a@]" - Format.( - pp_print_list ~pp_sep:pp_print_cut (fun fmt (slot, endorsing_slot) -> - Format.fprintf - fmt - "slot: %a, %a" - Slot.pp - slot - pp_endorsing_slot - endorsing_slot)) - (SlotMap.bindings own_delegate_slots) - -let pp_next_forged_block fmt - {delegate = consensus_key_and_delegate; block_header; _} = - Format.fprintf - fmt - "predecessor block hash: %a, payload hash: %a, level: %ld, delegate: %a" - Block_hash.pp - block_header.shell.predecessor - Block_payload_hash.pp_short - block_header.protocol_data.contents.payload_hash - block_header.shell.level - pp_consensus_key_and_delegate - consensus_key_and_delegate - -let pp_level_state fmt - { - current_level; - latest_proposal; - is_latest_proposal_applied; - locked_round; - endorsable_payload; - elected_block; - delegate_slots; - next_level_delegate_slots; - next_level_proposed_round; - next_forged_block; - } = - Format.fprintf - fmt - "@[Level state:@ current level: %ld@ @[proposal (applied:%b):@ \ - %a@]@ locked round: %a@ endorsable payload: %a@ elected block: %a@ @[own delegate slots:@ %a@]@ @[next level own delegate slots:@ %a@]@ \ - next level proposed round: %a@ @next forged block: %a@]" - current_level - is_latest_proposal_applied - pp_proposal - latest_proposal - (pp_option pp_locked_round) - locked_round - (pp_option pp_endorsable_payload) - endorsable_payload - (pp_option pp_elected_block) - elected_block - pp_delegate_slots - delegate_slots - pp_delegate_slots - next_level_delegate_slots - (pp_option Round.pp) - next_level_proposed_round - (pp_option pp_next_forged_block) - next_forged_block - -let pp_phase fmt = function - | Idle -> Format.fprintf fmt "idle" - | Awaiting_preendorsements -> Format.fprintf fmt "awaiting preendorsements" - | Awaiting_application -> Format.fprintf fmt "awaiting application" - | Awaiting_endorsements -> Format.fprintf fmt "awaiting endorsements" - -let pp_round_state fmt {current_round; current_phase; delayed_quorum} = - Format.fprintf - fmt - "@[Round state:@ round: %a,@ phase: %a,@ delayed quorum: %a@]" - Round.pp - current_round - pp_phase - current_phase - (pp_option Format.pp_print_int) - (Option.map List.length delayed_quorum) - -let pp fmt {global_state; level_state; round_state} = - Format.fprintf - fmt - "@[State:@ %a@ %a@ %a@]" - pp_global_state - global_state - pp_level_state - level_state - pp_round_state - round_state - -let pp_timeout_kind fmt = function - | End_of_round {ending_round} -> - Format.fprintf fmt "end of round %a" Round.pp ending_round - | Time_to_bake_next_level {at_round} -> - Format.fprintf fmt "time to bake next level at round %a" Round.pp at_round - | Time_to_forge_block -> Format.fprintf fmt "time to forge block" - -let pp_event fmt = function - | New_valid_proposal proposal -> - Format.fprintf - fmt - "new valid proposal received: %a" - pp_block_info - proposal.block - | New_head_proposal proposal -> - Format.fprintf - fmt - "new head proposal received: %a" - pp_block_info - proposal.block - | Prequorum_reached (candidate, preendos) -> - Format.fprintf - fmt - "prequorum reached with %d preendorsements for %a at round %a" - (List.length preendos) - Block_hash.pp - candidate.Operation_worker.hash - Round.pp - candidate.round_watched - | Quorum_reached (candidate, endos) -> - Format.fprintf - fmt - "quorum reached with %d endorsements for %a at round %a" - (List.length endos) - Block_hash.pp - candidate.Operation_worker.hash - Round.pp - candidate.round_watched - | Timeout kind -> - Format.fprintf fmt "timeout reached: %a" pp_timeout_kind kind diff --git a/src/proto_017_PtNairob/lib_delegate/baking_state.mli b/src/proto_017_PtNairob/lib_delegate/baking_state.mli deleted file mode 100644 index 2d8c42e4debc7410fb53c9e9995a1a97d0015c44..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_state.mli +++ /dev/null @@ -1,254 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context - -type consensus_key = { - alias : string option; - public_key : Signature.public_key; - public_key_hash : Signature.public_key_hash; - secret_key_uri : Client_keys.sk_uri; -} - -val consensus_key_encoding : consensus_key Data_encoding.t - -val pp_consensus_key : Format.formatter -> consensus_key -> unit - -type consensus_key_and_delegate = consensus_key * Signature.Public_key_hash.t - -val consensus_key_and_delegate_encoding : - consensus_key_and_delegate Data_encoding.t - -val pp_consensus_key_and_delegate : - Format.formatter -> consensus_key_and_delegate -> unit - -type validation_mode = Node | Local of Abstract_context_index.t - -type prequorum = { - level : int32; - round : Round.t; - block_payload_hash : Block_payload_hash.t; - preendorsements : Kind.preendorsement operation list; -} - -type block_info = { - hash : Block_hash.t; - shell : Block_header.shell_header; - payload_hash : Block_payload_hash.t; - payload_round : Round.t; - round : Round.t; - prequorum : prequorum option; - quorum : Kind.endorsement operation list; - dal_attestations : Kind.dal_attestation operation list; - payload : Operation_pool.payload; -} - -type cache = { - known_timestamps : Timestamp.time Baking_cache.Timestamp_of_round_cache.t; - round_timestamps : - (Timestamp.time * Round.t * consensus_key_and_delegate) - Baking_cache.Round_timestamp_interval_cache.t; -} - -type global_state = { - cctxt : Protocol_client_context.full; - chain_id : Chain_id.t; - config : Baking_configuration.t; - constants : Constants.t; - round_durations : Round.round_durations; - operation_worker : Operation_worker.t; - validation_mode : validation_mode; - delegates : consensus_key list; - cache : cache; - dal_node_rpc_ctxt : Tezos_rpc.Context.generic option; -} - -val block_info_encoding : block_info Data_encoding.t - -val round_of_shell_header : Block_header.shell_header -> Round.t tzresult - -module SlotMap : Map.S with type key = Slot.t - -type endorsing_slot = {first_slot : Slot.t; endorsing_power : int} - -type delegate_slots = { - own_delegate_slots : (consensus_key_and_delegate * endorsing_slot) SlotMap.t; - all_delegate_slots : endorsing_slot SlotMap.t; - all_slots_by_round : Slot.t array; -} - -type proposal = {block : block_info; predecessor : block_info} - -val proposal_encoding : proposal Data_encoding.t - -(** Identify the first block of the protocol, ie. the block that - activates the current protocol. - - This block should be baked by the baker of the previous protocol - (that's why this same block is also referred to as the last block - of the previous protocol). It is always considered final and - therefore is not endorsed.*) -val is_first_block_in_protocol : proposal -> bool - -type locked_round = {payload_hash : Block_payload_hash.t; round : Round.t} - -val locked_round_encoding : locked_round Data_encoding.t - -type endorsable_payload = {proposal : proposal; prequorum : prequorum} - -val endorsable_payload_encoding : endorsable_payload Data_encoding.t - -type elected_block = { - proposal : proposal; - endorsement_qc : Kind.endorsement operation list; -} - -type signed_block = { - round : Round.t; - delegate : consensus_key_and_delegate; - block_header : block_header; - operations : Tezos_base.Operation.t list list; -} - -type level_state = { - current_level : int32; - latest_proposal : proposal; - is_latest_proposal_applied : bool; - locked_round : locked_round option; - endorsable_payload : endorsable_payload option; - elected_block : elected_block option; - delegate_slots : delegate_slots; - next_level_delegate_slots : delegate_slots; - next_level_proposed_round : Round.t option; - next_forged_block : signed_block option; -} - -type phase = - | Idle - | Awaiting_preendorsements - | Awaiting_endorsements - | Awaiting_application - -val phase_encoding : phase Data_encoding.t - -type round_state = { - current_round : Round.t; - current_phase : phase; - delayed_quorum : Kind.endorsement operation list option; -} - -type state = { - global_state : global_state; - level_state : level_state; - round_state : round_state; -} - -type t = state - -val update_current_phase : t -> phase -> t - -type timeout_kind = - | End_of_round of {ending_round : Round.t} - | Time_to_bake_next_level of {at_round : Round.t} - | Time_to_forge_block - -val timeout_kind_encoding : timeout_kind Data_encoding.t - -type event = - | New_valid_proposal of proposal - | New_head_proposal of proposal - | Prequorum_reached of - Operation_worker.candidate * Kind.preendorsement operation list - | Quorum_reached of - Operation_worker.candidate * Kind.endorsement operation list - | Timeout of timeout_kind - -val event_encoding : event Data_encoding.t - -type state_data = { - level_data : int32; - locked_round_data : locked_round option; - endorsable_payload_data : endorsable_payload option; -} - -val state_data_encoding : state_data Data_encoding.t - -val record_state : t -> unit tzresult Lwt.t - -val may_record_new_state : - previous_state:t -> new_state:t -> unit tzresult Lwt.t - -val load_endorsable_data : - Protocol_client_context.full -> - [`State] Baking_files.location -> - state_data option tzresult Lwt.t - -val may_load_endorsable_data : t -> t tzresult Lwt.t - -(** @param block default to [`Head 0]*) -val compute_delegate_slots : - Protocol_client_context.full -> - ?block:Block_services.block -> - level:int32 -> - chain:Shell_services.chain -> - consensus_key list -> - delegate_slots tzresult Lwt.t - -val create_cache : unit -> cache - -val pp_validation_mode : Format.formatter -> validation_mode -> unit - -val pp_global_state : Format.formatter -> global_state -> unit - -val pp_option : - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit - -val pp_block_info : Format.formatter -> block_info -> unit - -val pp_proposal : Format.formatter -> proposal -> unit - -val pp_locked_round : Format.formatter -> locked_round -> unit - -val pp_endorsable_payload : Format.formatter -> endorsable_payload -> unit - -val pp_elected_block : Format.formatter -> elected_block -> unit - -val pp_endorsing_slot : - Format.formatter -> consensus_key_and_delegate * endorsing_slot -> unit - -val pp_delegate_slots : Format.formatter -> delegate_slots -> unit - -val pp_level_state : Format.formatter -> level_state -> unit - -val pp_phase : Format.formatter -> phase -> unit - -val pp_round_state : Format.formatter -> round_state -> unit - -val pp : Format.formatter -> t -> unit - -val pp_timeout_kind : Format.formatter -> timeout_kind -> unit - -val pp_event : Format.formatter -> event -> unit diff --git a/src/proto_017_PtNairob/lib_delegate/baking_vdf.ml b/src/proto_017_PtNairob/lib_delegate/baking_vdf.ml deleted file mode 100644 index 67f59f451532956971ee779902bc005a9dda65c9..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_vdf.ml +++ /dev/null @@ -1,501 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context -open Client_baking_blocks -module Events = Baking_events.VDF - -type vdf_solution = Seed_repr.vdf_solution - -type vdf_setup = Seed_repr.vdf_setup - -type forked_process = {pid : int; ch_in : Lwt_io.input_channel} - -type status = - | Not_started - | Started of vdf_setup * forked_process - | Finished of vdf_setup * vdf_solution - | Injected - | Invalid - -type 'a state = { - cctxt : Protocol_client_context.full; - constants : Constants.t; - mutable block_stream : (block_info, 'a) result Lwt_stream.t; - mutable stream_stopper : Tezos_rpc.Context.stopper option; - mutable cycle : Cycle.t option; - mutable computation_status : status; -} - -let init_block_stream_with_stopper cctxt chain = - Client_baking_blocks.monitor_heads - ~next_protocols:(Some [Protocol.hash]) - cctxt - chain - -let stop_block_stream state = - Option.iter - (fun stopper -> - stopper () ; - state.stream_stopper <- None) - state.stream_stopper - -let emit_with_level msg level = - let level_i32 = Raw_level.to_int32 level in - Events.(emit vdf_info) (Printf.sprintf "%s (level %ld)" msg level_i32) - -let emit_revelation_not_injected cycle = - let open Lwt_result_syntax in - let*! () = - Events.(emit vdf_info) - (Printf.sprintf - "VDF revelation was NOT injected for cycle %ld" - (Cycle.to_int32 cycle)) - in - return_unit - -let log_errors_and_continue ~name p = - let open Lwt_syntax in - let* p in - match p with - | Ok () -> return_unit - | Error errs -> Events.(emit vdf_daemon_error) (name, errs) - -let get_seed_computation cctxt chain_id hash = - let chain = `Hash chain_id in - let block = `Hash (hash, 0) in - Alpha_services.Seed_computation.get cctxt (chain, block) - -let get_level_info cctxt level = - let open Lwt_result_syntax in - let level = Raw_level.to_int32 level in - let* {protocol_data = {level_info; _}; _} = - Protocol_client_context.Alpha_block_services.metadata - cctxt - ~chain:cctxt#chain - ~block:(`Level level) - () - in - return level_info - -let is_in_nonce_revelation_stage constants (level : Level.t) = - let open Lwt_result_syntax in - let {Constants.parametric = {nonce_revelation_threshold; _}; _} = constants in - return - (Vdf_helpers.is_in_nonce_revelation_stage - ~nonce_revelation_threshold - ~level) - -(* Checks if the VDF setup saved in the state is equal to the one computed - from a seed *) -let eq_vdf_setup vdf_setup seed_discriminant seed_challenge = - let open Environment.Vdf in - let saved_discriminant, saved_challenge = vdf_setup in - let discriminant, challenge = - Seed.generate_vdf_setup ~seed_discriminant ~seed_challenge - in - Bytes.equal - (discriminant_to_bytes discriminant) - (discriminant_to_bytes saved_discriminant) - && Bytes.equal - (challenge_to_bytes challenge) - (challenge_to_bytes saved_challenge) - -(* Forge the VDF revelation operation and inject it if: - * - it is correct wrt the VDF setup for the current cycle - * - we are still in the VDF revelation stage - * If successful or if the seed no longer needs to be injected, - * update the computation status. *) -let inject_vdf_revelation cctxt state setup solution chain_id hash - (level_info : Level.t) = - let open Lwt_result_syntax in - let chain = `Hash chain_id in - let block = `Hash (hash, 0) in - let level = level_info.level in - let* seed_computation = get_seed_computation cctxt chain_id hash in - match seed_computation with - | Vdf_revelation_stage {seed_discriminant; seed_challenge} -> - if eq_vdf_setup setup seed_discriminant seed_challenge then ( - let* op_bytes = - Plugin.RPC.Forge.vdf_revelation - cctxt - (chain, block) - ~branch:hash - ~solution - () - in - let op_bytes = Tezos_crypto.Signature.V_latest.(concat op_bytes zero) in - let* op_hash = - Shell_services.Injection.operation cctxt ~chain op_bytes - in - (* If injection is successful, update the status to [Injected]. *) - state.computation_status <- Injected ; - let*! () = - Events.(emit vdf_revelation_injected) - ( Cycle.to_int32 level_info.cycle, - Chain_services.to_string chain, - op_hash ) - in - return_unit) - else ( - (* The VDF setup saved in the state is different from the one computed - * from the on-chain seed. In practice this would indicate a bug, since - * it would either mean that the cycle has changed and we have not - * detected it or that the VDF setup changed mid-cycle. *) - state.computation_status <- Invalid ; - let*! () = - emit_with_level "Error injecting VDF: setup has been updated" level - in - return_unit) - | Nonce_revelation_stage -> - state.computation_status <- Not_started ; - let*! () = emit_with_level "Not injecting VDF: new cycle started" level in - return_unit - | Computation_finished -> - state.computation_status <- Injected ; - let*! () = emit_with_level "Not injecting VDF: already injected" level in - return_unit - -(* Launch the heavy VDF computation as a separate process. This is done in order - * to not block the main process, allowing it to continue monitoring blocks and - * to cancel or restart the VDF computation if needed. *) -let fork_vdf_computation state ((discriminant, challenge) as setup) level = - let open Lwt_syntax in - let ch_in, forked_out = Lwt_io.pipe () in - match Lwt_unix.fork () with - | 0 -> ( - (* In the forked process, try to compute the VDF solution, write it - * to [forked_out], then exit. *) - let* () = Lwt_io.close ch_in in - let solution = - Environment.Vdf.prove - discriminant - challenge - state.constants.parametric.vdf_difficulty - in - match - Data_encoding.Binary.to_bytes Seed.vdf_solution_encoding solution - with - | Ok encoded -> - let* () = Lwt_io.write_value forked_out encoded in - exit 0 - | Error _ -> - let* () = Events.(emit vdf_info) "Error encoding VDF solution" in - exit 1) - | pid -> - (* In the main process, change the computation status to [Started], - record the forked process data, and continue. *) - let* () = Lwt_io.close forked_out in - state.computation_status <- Started (setup, {pid; ch_in}) ; - let* () = - emit_with_level - (Printf.sprintf "Started to compute VDF, pid: %d" pid) - level - in - return_unit - -(* Check whether the VDF computation process has exited and read the result. - * Update the computation status accordingly. *) -let get_vdf_solution_if_ready cctxt state proc setup chain_id hash - (level_info : Level.t) = - let open Lwt_result_syntax in - let level = level_info.level in - let*! status = Lwt_unix.waitpid [WNOHANG] proc.pid in - match status with - | 0, _ -> - (* If the process is still running, continue *) - let*! () = emit_with_level "Skipping, VDF computation launched" level in - return_unit - | _, WEXITED 0 -> ( - (* If the process has exited normally, read the solution, update - * the status to [Finished], and attempt to inject the VDF - * revelation. *) - let*! encoded_solution = Lwt_io.read_value proc.ch_in in - match - Data_encoding.Binary.of_bytes - Seed.vdf_solution_encoding - encoded_solution - with - | Ok solution -> - let*! () = Lwt_io.close proc.ch_in in - state.computation_status <- Finished (setup, solution) ; - let*! () = emit_with_level "Finished VDF computation" level in - inject_vdf_revelation - cctxt - state - setup - solution - chain_id - hash - level_info - | Error _ -> - let*! () = Events.(emit vdf_info) "Error decoding VDF solution" in - state.computation_status <- Not_started ; - return_unit) - | _, WEXITED _ | _, WSIGNALED _ | _, WSTOPPED _ -> - (* If process has exited abnormally, reset the computation status to - * [Not_started] and continue *) - state.computation_status <- Not_started ; - let*! () = - Events.(emit vdf_info) "VDF computation process exited abnormally" - in - return_unit - -let kill_forked_process {pid; _} = - let open Lwt_syntax in - let* () = - match Unix.kill pid Sys.sigterm with - | () -> - Events.(emit vdf_info) - (Printf.sprintf - "Sent SIGTERM to VDF computation process (pid %d)" - pid) - | exception Unix.Unix_error (err, _, _) -> - let msg = Printf.sprintf "%s (pid %d)" (Unix.error_message err) pid in - Events.(emit vdf_daemon_cannot_kill_computation) msg - in - let* pid, status = Lwt_unix.waitpid [] pid in - let status = - match status with - | WEXITED n -> Printf.sprintf "WEXITED %d" n - | WSIGNALED n -> Printf.sprintf "WSIGNALED %d" n - | WSTOPPED n -> Printf.sprintf "WSTOPPED %d" n - in - Events.(emit vdf_info) - (Printf.sprintf - "Exit status for child VDF computation process %d: %s" - pid - status) - -(* Kill the VDF computation process if one was launched. *) -let maybe_kill_running_vdf_computation state = - let open Lwt_syntax in - match state.computation_status with - | Started (_, proc) -> - let* () = kill_forked_process proc in - return_unit - | _ -> return_unit - -(* Checks if the cycle of the last processed block is different from the cycle - * of the block at [level_info]. *) -let check_new_cycle state (level_info : Level.t) = - let open Lwt_result_syntax in - let current_cycle = level_info.cycle in - match state.cycle with - | None -> - (* First processed block, initialise [state.cycle] *) - state.cycle <- Some current_cycle ; - return_unit - | Some cycle -> - if Cycle.(cycle < current_cycle) then ( - (* The cycle of this block is different from the cycle of the last - * processed block. Emit an event if the VDF for the previous cycle - * has not been injected, kill any running VDF computation, and - * reset the computation status. *) - let* () = - match state.computation_status with - | Injected -> return_unit - | Started ((_ : vdf_setup), proc) -> - let*! () = kill_forked_process proc in - emit_revelation_not_injected cycle - | Not_started | Finished _ | Invalid -> - emit_revelation_not_injected cycle - in - state.cycle <- Some current_cycle ; - state.computation_status <- Not_started ; - return_unit) - else return_unit - -(* The daemon's main job is to launch the VDF computation as soon as it - * can (i.e., when the nonce revelation stage ends) and to inject - * the VDF solution as soon as it finishes computing it. - * Additionally, it must cancel a running VDF computation if its result - * is no longer required and restart a computation if it failed. - * The daemon processes the stream of blocks and monitors both - * the level of the head within a cycle and the [Seed_computation] RPC. - * The core of this function is a pattern match on the product of - * [seed_computation] (the on-chain status of the seed computation) - * and [state.computation_status] (the internal status of the daemon). - * - * [seed_computation] is reset at the beginning of a cycle to - * [Nonce_revelation_stage], mirroring the on-chain change of the computation - * status. No action is taken while in this state. - * After [nonce_revelation_threshold] blocks, the status becomes - * [Vdf_revelation_stage]. A call to the RPC confirms this and provides the seed - * required to launch the VDF computation. - * If a VDF revelation operation is injected before the end of the cycle, - * the status is updated to [Computation_finished]. If a VDF computation is - * running at that point (i.e., another daemon injected first), - * it is canceled. *) -let process_new_block (cctxt : #Protocol_client_context.full) state - {hash; chain_id; protocol; next_protocol; level; _} = - let open Lwt_result_syntax in - if Protocol_hash.(protocol <> next_protocol) then - (* If the protocol has changed, emit an event on every new block and take - * no further action. It is expected that the daemon corresponding to - * the new protocol is used instead. *) - let*! () = Delegate_events.Denunciator.(emit protocol_change_detected) () in - return_unit - else - let* level_info = get_level_info cctxt level in - (* If head is in a new cycle record it in [state.cycle] and reset - * [state.computation_status] to [Not_started]. *) - let* () = check_new_cycle state level_info in - (* If the chain is in the nonce revelation stage, there is nothing to do. *) - let* out = is_in_nonce_revelation_stage state.constants level_info in - if out then - let*! () = - emit_with_level "Skipping, still in nonce revelation stage" level - in - return_unit - else - (* Enter main loop if we are not in the nonce revelation stage and - * the expected protocol has been activated. *) - match state.computation_status with - | Not_started -> ( - let* seed_computation = get_seed_computation cctxt chain_id hash in - match seed_computation with - | Vdf_revelation_stage {seed_discriminant; seed_challenge} -> - (* The chain is in the VDF revelation stage and the computation - * has not been started, so it is started here, in a separate - * process. The computation status is updated to [Started]. *) - let setup = - Seed.generate_vdf_setup ~seed_discriminant ~seed_challenge - in - let*! () = fork_vdf_computation state setup level in - return_unit - | Computation_finished -> - let*! () = - emit_with_level - "Skipping, VDF solution has already been injected" - level - in - return_unit - | Nonce_revelation_stage -> - (* At this point the chain cannot be in the nonce revelation - * stage. This is checked in [is_in_nonce_revelation_stage]. *) - assert false) - | Started (setup, proc) -> ( - let* seed_computation = get_seed_computation cctxt chain_id hash in - match seed_computation with - | Vdf_revelation_stage _ -> - (* The chain is in the VDF computation stage and we have - * previously started the computation. Check whether it is - * finished and, if so, update the computation status to - * [Finished] and immediately inject the solution. *) - let* () = - get_vdf_solution_if_ready - cctxt - state - proc - setup - chain_id - hash - level_info - in - return_unit - | Computation_finished -> - (* The chain is no longer in the VDF revelation stage because - * the solution has already been injected: abort the running - * computation. *) - let*! () = kill_forked_process proc in - let*! () = - emit_with_level - "VDF solution already injected, aborting VDF computation" - level - in - state.computation_status <- Injected ; - return_unit - | Nonce_revelation_stage -> - (* At this point the chain cannot be in the nonce revelation - * stage. This is checked in [is_in_nonce_revelation_stage]. *) - assert false) - | Finished (setup, solution) -> - (* VDF solution computed, but not injected. We are only in this case - * if the first attempt to inject, right after getting the solution, - * was unsuccessful. While the chain is in the VDF revelation stage, - * and the solution has not been injected (computation status is - * [Finished]), we try to inject. If successful, the computation - * status is updated to [Injected]. *) - inject_vdf_revelation - cctxt - state - setup - solution - chain_id - hash - level_info - | Injected -> - let*! () = - emit_with_level "Skipping, VDF solution already injected" level - in - return_unit - | Invalid -> - let*! () = emit_with_level "Skipping, failed to compute VDF" level in - return_unit - -let start_vdf_worker (cctxt : Protocol_client_context.full) ~canceler constants - chain = - let open Lwt_result_syntax in - let* block_stream, stream_stopper = - init_block_stream_with_stopper cctxt chain - in - let state = - { - cctxt; - constants; - block_stream; - stream_stopper = Some stream_stopper; - cycle = None; - computation_status = Not_started; - } - in - Lwt_canceler.on_cancel canceler (fun () -> - let*! () = maybe_kill_running_vdf_computation state in - stop_block_stream state ; - Lwt.return_unit) ; - let rec worker_loop () = - let*! b = - Lwt.choose - [ - (Lwt_exit.clean_up_starts >|= fun _ -> `Termination); - (Lwt_stream.get state.block_stream >|= fun e -> `Block e); - ] - in - match b with - | `Termination -> return_unit - | `Block (None | Some (Error _)) -> - (* Exit when the node is unavailable *) - stop_block_stream state ; - let*! () = Events.(emit vdf_daemon_connection_lost) name in - tzfail Baking_errors.Node_connection_lost - | `Block (Some (Ok bi)) -> - let*! () = - log_errors_and_continue ~name @@ process_new_block cctxt state bi - in - worker_loop () - in - worker_loop () diff --git a/src/proto_017_PtNairob/lib_delegate/baking_vdf.mli b/src/proto_017_PtNairob/lib_delegate/baking_vdf.mli deleted file mode 100644 index 84751f723af86d8ab942bcba6f8e211f217162d0..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/baking_vdf.mli +++ /dev/null @@ -1,33 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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.Alpha_context - -val start_vdf_worker : - Protocol_client_context.full -> - canceler:Lwt_canceler.t -> - Constants.t -> - Chain_services.chain -> - unit tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_delegate/block_forge.ml b/src/proto_017_PtNairob/lib_delegate/block_forge.ml deleted file mode 100644 index 01a06159e467e4855fa1c5ab7ec30d0fae8f7f0d..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/block_forge.ml +++ /dev/null @@ -1,500 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context - -type unsigned_block = { - unsigned_block_header : Block_header.t; - operations : Tezos_base.Operation.t list list; -} - -type simulation_kind = - | Filter of Operation_pool.Prioritized.t - | Apply of { - ordered_pool : Operation_pool.ordered_pool; - payload_hash : Block_payload_hash.t; - } - -type simulation_mode = Local of Context.index | Node - -(* [forge_faked_protocol_data ?payload_hash ~payload_round ~seed_nonce_hash - ~liquidity_baking_toggle_vote] forges a fake [block_header_data] with - [payload_hash] ([zero] by default), [payload_round], [seed_nonce_hash], - [liquidity_baking_toggle_vote] and with an empty [proof_of_work_nonce] and a - dummy [signature]. *) -let forge_faked_protocol_data ?(payload_hash = Block_payload_hash.zero) - ~payload_round ~seed_nonce_hash ~liquidity_baking_toggle_vote () = - Block_header. - { - contents = - { - payload_hash; - payload_round; - seed_nonce_hash; - proof_of_work_nonce = Baking_pow.empty_proof_of_work_nonce; - liquidity_baking_toggle_vote; - }; - signature = Signature.zero; - } - -let convert_operation (op : packed_operation) : Tezos_base.Operation.t = - { - shell = op.shell; - proto = - Data_encoding.Binary.to_bytes_exn - Alpha_context.Operation.protocol_data_encoding - op.protocol_data; - } - -(* [finalize_block_header] updates the [shell_header] that was created - with dummy fields at the beginning of the block construction. It - increments the [level] and sets the actual [operations_hash], - [fitness], [validation_passes], and [context] (the predecessor - resulting context hash). - - When the operations from the block have been applied, the [fitness] - is simply retrieved from the [validation_result]. Otherwise, the - [fitness] is computed from the [round] and [locked_round] - arguments. *) -let finalize_block_header ~shell_header ~validation_result ~operations_hash - ~(pred_info : Baking_state.block_info) ~pred_resulting_context_hash ~round - ~locked_round = - let open Lwt_result_syntax in - let* fitness = - match validation_result with - | Some {Tezos_protocol_environment.fitness; _} -> return fitness - | None -> - let*? level = - Environment.wrap_tzresult @@ Raw_level.of_int32 - @@ Int32.succ shell_header.Tezos_base.Block_header.level - in - let*? fitness = - Environment.wrap_tzresult - @@ Fitness.create - ~level - ~round - ~predecessor_round:pred_info.round - ~locked_round - in - return (Fitness.to_raw fitness) - in - let validation_passes = List.length Main.validation_passes in - let header = - Tezos_base.Block_header. - { - shell_header with - level = Int32.succ shell_header.level; - validation_passes; - operations_hash; - fitness; - context = pred_resulting_context_hash; - } - in - return header - -let retain_live_operations_only ~live_blocks operation_pool = - Operation_pool.Prioritized.filter - (fun ({shell; _} : packed_operation) -> - Block_hash.Set.mem shell.branch live_blocks) - operation_pool - -(* [check_protocol_changed] checks whether the protocol will change with the current - block. This function returns true if the block is the last of an [adoption] - period. It can also return true if an [user_activated_upgrades] is given. *) -let check_protocol_changed ~user_activated_upgrades ~level - ~(validation_result : Tezos_protocol_environment.validation_result option) - ~(incremental : Baking_simulator.incremental) = - let open Lwt_result_syntax in - match - Tezos_base.Block_header.get_forced_protocol_upgrade - ~user_activated_upgrades - ~level - with - | None -> ( - match validation_result with - | None -> ( - let context = Validate.get_initial_ctxt (fst incremental.state) in - let* voting_period = - Lwt.map - Environment.wrap_tzresult - (Voting_period.get_current context) - in - match voting_period.kind with - | Voting_period.Proposal | Exploration | Cooldown | Promotion -> - return false - | Adoption -> - Lwt.map - Environment.wrap_tzresult - (Voting_period.is_last_block context)) - | Some validation_result -> - let*! next_protocol = - Context_ops.get_protocol validation_result.context - in - return Protocol_hash.(Protocol.hash <> next_protocol)) - | Some next_protocol -> return Protocol_hash.(Protocol.hash <> next_protocol) - -(* [filter_via_node] filters operations using - {!Operation_selection.filter_operations_without_simulation} and then applies - them in a block via {!Node_rpc.preapply_block}. [filter_via_node] returns a - [shell_header], the list of operations that have been applied in the block - and the [payload_hash] corresponding to these operations. *) -let filter_via_node ~chain_id ~fees_config ~hard_gas_limit_per_block - ~faked_protocol_data ~timestamp ~(pred_info : Baking_state.block_info) - ~payload_round ~operation_pool cctxt = - let open Lwt_result_syntax in - let chain = `Hash chain_id in - let filtered_operations = - Operation_selection.filter_operations_without_simulation - fees_config - ~hard_gas_limit_per_block - operation_pool - in - let* shell_header, preapply_result = - Node_rpc.preapply_block - cctxt - ~chain - ~head:pred_info.hash - ~timestamp - ~protocol_data:faked_protocol_data - filtered_operations - in - (* only retain valid operations *) - let operations = - List.map (fun l -> List.map snd l.Preapply_result.applied) preapply_result - in - let payload_hash = - let operation_hashes = - Stdlib.List.tl operations |> List.flatten - |> List.map Tezos_base.Operation.hash - in - Block_payload.hash - ~predecessor_hash:shell_header.predecessor - ~payload_round - operation_hashes - in - return (shell_header, operations, payload_hash) - -(* [filter_with_context] filters operations using a local context via - {!Operation_selection.filter_operations_with_simulation} and a fresh state - from {!Baking_simulator.begin_construction}. [finalize_block_header] is then - called and a [shell_header], the list of operations and the corresponding - [payload_hash] are returned. If the block is a transition block, - [filter_via_node] is called to return these values. *) -let filter_with_context ~chain_id ~fees_config ~hard_gas_limit_per_block - ~faked_protocol_data ~user_activated_upgrades ~timestamp - ~(pred_info : Baking_state.block_info) ~pred_resulting_context_hash - ~force_apply ~round ~context_index ~payload_round ~operation_pool cctxt = - let open Lwt_result_syntax in - let* incremental = - Baking_simulator.begin_construction - ~timestamp - ~protocol_data:faked_protocol_data - ~force_apply - ~pred_resulting_context_hash - context_index - pred_info - chain_id - in - let* {Operation_selection.operations; validation_result; operations_hash; _} = - Operation_selection.filter_operations_with_simulation - incremental - fees_config - ~hard_gas_limit_per_block - operation_pool - in - let* changed = - check_protocol_changed - ~level:(Int32.succ pred_info.shell.level) - ~user_activated_upgrades - ~validation_result - ~incremental - in - if changed then - (* Fallback to processing via node, which knows both old and new protocol. *) - filter_via_node - ~chain_id - ~fees_config - ~hard_gas_limit_per_block - ~faked_protocol_data - ~timestamp - ~pred_info - ~payload_round - ~operation_pool - cctxt - else - let* shell_header = - finalize_block_header - ~shell_header:incremental.header - ~validation_result - ~operations_hash - ~pred_info - ~pred_resulting_context_hash - ~round - ~locked_round:None - in - let operations = List.map (List.map convert_operation) operations in - let payload_hash = - let operation_hashes = - Stdlib.List.tl operations |> List.flatten - |> List.map Tezos_base.Operation.hash - in - Block_payload.hash - ~predecessor_hash:shell_header.predecessor - ~payload_round - operation_hashes - in - return (shell_header, operations, payload_hash) - -(* [apply_via_node] applies already filtered and validated operations in a block - via {!Node_rpc.preapply_block}. A [shell_header] is recovered from this call - and returned alongside of the list of operations and the payload_hash. *) -let apply_via_node ~chain_id ~faked_protocol_data ~timestamp - ~(pred_info : Baking_state.block_info) ~ordered_pool ~payload_hash cctxt = - let open Lwt_result_syntax in - let chain = `Hash chain_id in - let operations = Operation_pool.ordered_to_list_list ordered_pool in - let* shell_header, _preapply_result = - Node_rpc.preapply_block - cctxt - ~chain - ~head:pred_info.hash - ~timestamp - ~protocol_data:faked_protocol_data - operations - in - let operations = List.map (List.map convert_operation) operations in - return (shell_header, operations, payload_hash) - -(* [apply_with_context] is similar to [filter_with_context] but filters - consensus operations only from an [ordered_pool] via - {!Operation_selection.filter_consensus_operations_only}. *) -let apply_with_context ~chain_id ~faked_protocol_data ~user_activated_upgrades - ~timestamp ~(pred_info : Baking_state.block_info) - ~pred_resulting_context_hash ~force_apply ~round ~ordered_pool - ~context_index ~payload_hash cctxt = - let open Lwt_result_syntax in - let* incremental = - Baking_simulator.begin_construction - ~timestamp - ~protocol_data:faked_protocol_data - ~force_apply - ~pred_resulting_context_hash - context_index - pred_info - chain_id - in - (* We still need to filter endorsements. Two endorsements could be - referring to the same slot. *) - let* incremental, ordered_pool = - Operation_selection.filter_consensus_operations_only - incremental - ordered_pool - in - let operations = Operation_pool.ordered_to_list_list ordered_pool in - let operations_hash = - Operation_list_list_hash.compute - (List.map - (fun sl -> - Operation_list_hash.compute (List.map Operation.hash_packed sl)) - operations) - in - (* We need to compute the final [operations_hash] before - finalizing the block because it will be used in the cache's nonce. *) - let incremental = - {incremental with header = {incremental.header with operations_hash}} - in - let* validation_result = Baking_simulator.finalize_construction incremental in - let validation_result = Option.map fst validation_result in - let* changed = - check_protocol_changed - ~level:(Int32.succ pred_info.shell.level) - ~user_activated_upgrades - ~validation_result - ~incremental - in - if changed then - (* Fallback to processing via node, which knows both old and new protocol. *) - apply_via_node - ~chain_id - ~faked_protocol_data - ~timestamp - ~pred_info - ~ordered_pool - ~payload_hash - cctxt - else - let locked_round_when_no_validation_result = - (* [locked_round] will not be used in [finalize_block_header] if there is - a [validation_result] *) - if Option.is_some validation_result then None - else - List.find_map - (fun {protocol_data = Operation_data protocol_data; _} -> - match protocol_data.contents with - | Single (Preendorsement {round; _}) -> Some round - | _ -> None) - (Option.value (List.hd operations) ~default:[]) - in - let* shell_header = - finalize_block_header - ~shell_header:incremental.header - ~validation_result - ~operations_hash - ~pred_info - ~pred_resulting_context_hash - ~round - ~locked_round:locked_round_when_no_validation_result - in - let operations = List.map (List.map convert_operation) operations in - return (shell_header, operations, payload_hash) - -(* [forge] a new [unsigned_block] in accordance with [simulation_kind] and - [simulation_mode] *) -let forge (cctxt : #Protocol_client_context.full) ~chain_id - ~(pred_info : Baking_state.block_info) ~pred_resulting_context_hash - ~pred_live_blocks ~timestamp ~round ~liquidity_baking_toggle_vote - ~user_activated_upgrades fees_config ~force_apply ~seed_nonce_hash - ~payload_round simulation_mode simulation_kind constants = - let open Lwt_result_syntax in - let hard_gas_limit_per_block = - constants.Constants.Parametric.hard_gas_limit_per_block - in - let simulation_kind = - match simulation_kind with - | Filter operation_pool -> - (* We cannot include operations that are not live with respect - to our predecessor otherwise the node would reject the block. *) - let filtered_pool = - retain_live_operations_only - ~live_blocks:pred_live_blocks - operation_pool - in - Filter filtered_pool - | Apply _ as x -> x - in - let* shell_header, operations, payload_hash = - match (simulation_mode, simulation_kind) with - | Baking_state.Node, Filter operation_pool -> - let faked_protocol_data = - forge_faked_protocol_data - ~payload_round - ~seed_nonce_hash - ~liquidity_baking_toggle_vote - () - in - filter_via_node - ~chain_id - ~faked_protocol_data - ~fees_config - ~hard_gas_limit_per_block - ~timestamp - ~pred_info - ~payload_round - ~operation_pool - cctxt - | Node, Apply {ordered_pool; payload_hash} -> - let faked_protocol_data = - forge_faked_protocol_data - ~payload_hash - ~payload_round - ~seed_nonce_hash - ~liquidity_baking_toggle_vote - () - in - apply_via_node - ~chain_id - ~faked_protocol_data - ~timestamp - ~pred_info - ~ordered_pool - ~payload_hash - cctxt - | Local context_index, Filter operation_pool -> - let faked_protocol_data = - forge_faked_protocol_data - ~payload_round - ~seed_nonce_hash - ~liquidity_baking_toggle_vote - () - in - filter_with_context - ~chain_id - ~faked_protocol_data - ~fees_config - ~hard_gas_limit_per_block - ~user_activated_upgrades - ~timestamp - ~pred_info - ~pred_resulting_context_hash - ~force_apply - ~round - ~context_index - ~payload_round - ~operation_pool - cctxt - | Local context_index, Apply {ordered_pool; payload_hash} -> - let faked_protocol_data = - forge_faked_protocol_data - ~payload_hash - ~payload_round - ~seed_nonce_hash - ~liquidity_baking_toggle_vote - () - in - apply_with_context - ~chain_id - ~faked_protocol_data - ~user_activated_upgrades - ~timestamp - ~pred_info - ~pred_resulting_context_hash - ~force_apply - ~round - ~ordered_pool - ~context_index - ~payload_hash - cctxt - in - let* contents = - Baking_pow.mine - ~proof_of_work_threshold:constants.proof_of_work_threshold - shell_header - (fun proof_of_work_nonce -> - { - Block_header.payload_hash; - payload_round; - seed_nonce_hash; - proof_of_work_nonce; - liquidity_baking_toggle_vote; - }) - in - let unsigned_block_header = - { - Block_header.shell = shell_header; - protocol_data = {contents; signature = Signature.zero}; - } - in - return {unsigned_block_header; operations} diff --git a/src/proto_017_PtNairob/lib_delegate/block_forge.mli b/src/proto_017_PtNairob/lib_delegate/block_forge.mli deleted file mode 100644 index 7afc2ce9791f20e0309badd6ccc15a1c7e344e83..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/block_forge.mli +++ /dev/null @@ -1,60 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context - -type unsigned_block = { - unsigned_block_header : Block_header.t; - operations : Tezos_base.Operation.t list list; -} - -type simulation_kind = - | Filter of Operation_pool.Prioritized.t - | Apply of { - ordered_pool : Operation_pool.ordered_pool; - payload_hash : Block_payload_hash.t; - } - -type simulation_mode = Local of Context.index | Node - -val forge : - #Protocol_client_context.full -> - chain_id:Chain_id.t -> - pred_info:Baking_state.block_info -> - pred_resulting_context_hash:Context_hash.t -> - pred_live_blocks:Block_hash.Set.t -> - timestamp:Time.Protocol.t -> - round:Round.t -> - liquidity_baking_toggle_vote:Liquidity_baking.liquidity_baking_toggle_vote -> - user_activated_upgrades:User_activated.upgrades -> - Baking_configuration.fees_config -> - force_apply:bool -> - seed_nonce_hash:Nonce_hash.t option -> - payload_round:Round.t -> - Baking_state.validation_mode -> - simulation_kind -> - Constants.Parametric.t -> - unsigned_block tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_delegate/client_baking_blocks.ml b/src/proto_017_PtNairob/lib_delegate/client_baking_blocks.ml deleted file mode 100644 index 1655719777cffbde6c763efe73433aa9f71b7a18..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/client_baking_blocks.ml +++ /dev/null @@ -1,236 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 -open Alpha_context -open Protocol_client_context - -type block_info = { - hash : Block_hash.t; - chain_id : Chain_id.t; - predecessor : Block_hash.t; - fitness : Bytes.t list; - timestamp : Time.Protocol.t; - protocol : Protocol_hash.t; - next_protocol : Protocol_hash.t; - proto_level : int; - level : Raw_level.t; - context : Context_hash.t; -} - -let raw_info cctxt ?(chain = `Main) hash shell_header = - let block = `Hash (hash, 0) in - Shell_services.Chain.chain_id cctxt ~chain () >>=? fun chain_id -> - Shell_services.Blocks.protocols cctxt ~chain ~block () - >>=? fun {current_protocol = protocol; next_protocol} -> - let { - Tezos_base.Block_header.predecessor; - fitness; - timestamp; - level; - context; - proto_level; - _; - } = - shell_header - in - match Raw_level.of_int32 level with - | Ok level -> - return - { - hash; - chain_id; - predecessor; - fitness; - timestamp; - protocol; - next_protocol; - proto_level; - level; - context; - } - | Error _ -> failwith "Cannot convert level into int32" - -let info cctxt ?(chain = `Main) block = - Shell_services.Blocks.hash cctxt ~chain ~block () >>=? fun hash -> - Shell_services.Blocks.Header.shell_header cctxt ~chain ~block () - >>=? fun shell_header -> raw_info cctxt ~chain hash shell_header - -module Block_seen_event = struct - type t = { - hash : Block_hash.t; - header : Tezos_base.Block_header.t; - occurrence : [`Valid_blocks of Chain_id.t | `Heads]; - } - - let make hash header occurrence = {hash; header; occurrence} - - module Definition = struct - let section = None - - let name = "block-seen-" ^ Protocol.name - - type nonrec t = t - - let encoding = - let open Data_encoding in - let v0_encoding = - conv - (function {hash; header; occurrence} -> (hash, occurrence, header)) - (fun (hash, occurrence, header) -> make hash header occurrence) - (obj3 - (req "hash" Block_hash.encoding) - (* Occurrence has to come before header, because: - (Invalid_argument - "Cannot merge two objects when the left element is of - variable length and the right one of dynamic - length. You should use the reverse order, or wrap the - second one with Data_encoding.dynamic_size.") *) - (req - "occurrence" - (union - [ - case - ~title:"heads" - (Tag 0) - (obj1 (req "occurrence-kind" (constant "heads"))) - (function `Heads -> Some () | _ -> None) - (fun () -> `Heads); - case - ~title:"valid-blocks" - (Tag 1) - (obj2 - (req "occurrence-kind" (constant "valid-blocks")) - (req "chain-id" Chain_id.encoding)) - (function - | `Valid_blocks ch -> Some ((), ch) | _ -> None) - (fun ((), ch) -> `Valid_blocks ch); - ])) - (req "header" Tezos_base.Block_header.encoding)) - in - With_version.(encoding ~name (first_version v0_encoding)) - - let pp ~all_fields:_ ~block:_ ppf {hash; _} = - Format.fprintf ppf "Saw block %a" Block_hash.pp_short hash - - let doc = "Block observed while monitoring a blockchain." - - let level = Internal_event.Info - end - - module Event = Internal_event.Make (Definition) -end - -let monitor_applied_blocks cctxt ?chains ?protocols ~next_protocols () = - Monitor_services.applied_blocks cctxt ?chains ?protocols ?next_protocols () - >>=? fun (block_stream, stop) -> - return - ( Lwt_stream.map_s - (fun (chain, block, header, _ops) -> - Block_seen_event.( - Event.emit (make block header (`Valid_blocks chain))) - >>=? fun () -> - raw_info - cctxt - ~chain:(`Hash chain) - block - header.Tezos_base.Block_header.shell) - block_stream, - stop ) - -let monitor_heads cctxt ~next_protocols chain = - let open Lwt_result_syntax in - let* block_stream, stop = - Monitor_services.heads cctxt ?next_protocols chain - in - return - ( Lwt_stream.map_s - (fun (block, ({Tezos_base.Block_header.shell; _} as header)) -> - let* () = Block_seen_event.(Event.emit (make block header `Heads)) in - raw_info cctxt ~chain block shell) - block_stream, - stop ) - -type error += - | Unexpected_empty_block_list of { - chain : string; - block_hash : Block_hash.t; - length : int; - } - -let () = - register_error_kind - `Permanent - ~id:"Client_baking_blocks.unexpected_empty_block_list" - ~title:"Unexpected empty blocklist" - ~description: - "The block list retrieved by Shell_services.Blocks.list is empty" - ~pp:(fun ppf (chain, block_hash, length) -> - Format.fprintf - ppf - "Unexpected empty block list retrieved from chain %s at block %a, \ - length %d" - chain - Block_hash.pp - block_hash - length) - Data_encoding.( - obj3 - (req "chain" string) - (req "block_hash" Block_hash.encoding) - (req "length" int31)) - (function - | Unexpected_empty_block_list {chain; block_hash; length} -> - Some (chain, block_hash, length) - | _ -> None) - (fun (chain, block_hash, length) -> - Unexpected_empty_block_list {chain; block_hash; length}) - -let blocks_from_current_cycle cctxt ?(chain = `Main) block ?(offset = 0l) () = - Shell_services.Blocks.hash cctxt ~chain ~block () >>=? fun hash -> - Shell_services.Blocks.Header.shell_header cctxt ~chain ~block () - >>=? fun {level; _} -> - Plugin.RPC.levels_in_current_cycle cctxt ~offset (chain, block) >>= function - | Error (Tezos_rpc.Context.Not_found _ :: _) -> return_nil - | Error _ as err -> Lwt.return err - | Ok (first, last) -> - let length = Int32.to_int (Int32.sub level (Raw_level.to_int32 first)) in - (Shell_services.Blocks.list cctxt ~chain ~heads:[hash] ~length () - >>=? function - | hd :: _ -> return hd - | [] -> - fail - (Unexpected_empty_block_list - { - chain = Block_services.chain_to_string chain; - block_hash = hash; - length; - })) - >>=? fun head -> - let blocks = - List.drop_n (length - Int32.to_int (Raw_level.diff last first)) head - in - if Int32.equal level (Raw_level.to_int32 last) then return (hash :: blocks) - else return blocks diff --git a/src/proto_017_PtNairob/lib_delegate/client_baking_blocks.mli b/src/proto_017_PtNairob/lib_delegate/client_baking_blocks.mli deleted file mode 100644 index 8426c19b899485d7a033693d4236d6e7882b47c4..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/client_baking_blocks.mli +++ /dev/null @@ -1,68 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 -open Alpha_context - -type block_info = { - hash : Block_hash.t; - chain_id : Chain_id.t; - predecessor : Block_hash.t; - fitness : Bytes.t list; - timestamp : Time.Protocol.t; - protocol : Protocol_hash.t; - next_protocol : Protocol_hash.t; - proto_level : int; - level : Raw_level.t; - context : Context_hash.t; -} - -val info : - #Protocol_client_context.rpc_context -> - ?chain:Chain_services.chain -> - Block_services.block -> - block_info tzresult Lwt.t - -val monitor_applied_blocks : - #Protocol_client_context.rpc_context -> - ?chains:Chain_services.chain list -> - ?protocols:Protocol_hash.t list -> - next_protocols:Protocol_hash.t list option -> - unit -> - (block_info tzresult Lwt_stream.t * Tezos_rpc.Context.stopper) tzresult Lwt.t - -val monitor_heads : - #Protocol_client_context.rpc_context -> - next_protocols:Protocol_hash.t list option -> - Chain_services.chain -> - (block_info tzresult Lwt_stream.t * Tezos_rpc.Context.stopper) tzresult Lwt.t - -val blocks_from_current_cycle : - #Protocol_client_context.rpc_context -> - ?chain:Chain_services.chain -> - Block_services.block -> - ?offset:int32 -> - unit -> - Block_hash.t list tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_delegate/client_baking_denunciation.ml b/src/proto_017_PtNairob/lib_delegate/client_baking_denunciation.ml deleted file mode 100644 index aa9c790101e8a15733b17b1d4e458bccc0f70031..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/client_baking_denunciation.ml +++ /dev/null @@ -1,599 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 -open Alpha_context -open Protocol_client_context -open Client_baking_blocks -module Events = Delegate_events.Denunciator -module B_Events = Delegate_events.Baking_scheduling - -module HLevel = Hashtbl.Make (struct - type t = Chain_id.t * Raw_level.t * Round.t - - let equal (c, l, r) (c', l', r') = - Chain_id.equal c c' && Raw_level.equal l l' && Round.equal r r' - - let hash (c, lvl, r) = Hashtbl.hash (c, lvl, r) -end) - -(* Blocks are associated to the delegates who baked them *) -module Delegate_map = Signature.Public_key_hash.Map - -module Validators_cache = - Aches.Vache.Map (Aches.Vache.FIFO_Precise) (Aches.Vache.Strong) - (struct - type t = Raw_level.t - - let equal = Raw_level.equal - - let hash = Hashtbl.hash - end) - -(* type of operations stream, as returned by monitor_operations RPC *) -type ops_stream = - ((Operation_hash.t * packed_operation) * error trace option) list Lwt_stream.t - -type 'kind recorded_consensus = - | No_operation_seen - | Operation_seen of { - operation : 'kind operation; - previously_denounced_oph : Operation_hash.t option; - } - -type recorded_consensus_operations = { - endorsement : Kind.endorsement recorded_consensus; - preendorsement : Kind.preendorsement recorded_consensus; -} - -type 'a state = { - (* Validators rights for the last preserved levels *) - validators_rights : public_key_hash Slot.Map.t Validators_cache.t; - (* Consensus operations seen so far *) - consensus_operations_table : - recorded_consensus_operations Delegate_map.t HLevel.t; - (* Blocks received so far *) - blocks_table : Block_hash.t Delegate_map.t HLevel.t; - (* Maximum delta of level to register *) - preserved_levels : int; - (* Highest level seen in a block *) - mutable highest_level_encountered : Raw_level.t; - (* This constant allows to set at which frequency (expressed in blocks levels) - the tables above are cleaned. Cleaning the table means removing information - stored about old levels up to - 'highest_level_encountered - preserved_levels'. - *) - clean_frequency : int; - (* the decreasing cleaning countdown for the next cleaning *) - mutable cleaning_countdown : int; - (* stream of all valid blocks *) - blocks_stream : (block_info, 'a) result Lwt_stream.t; - (* operations stream. Reset on new heads flush *) - mutable ops_stream : ops_stream; - (* operatons stream stopper. Used when a q new *) - mutable ops_stream_stopper : unit -> unit; -} - -let create_state ~preserved_levels blocks_stream ops_stream ops_stream_stopper = - let clean_frequency = max 1 (preserved_levels / 10) in - let validators_rights = Validators_cache.create (preserved_levels + 2) in - (* We keep rights for [preserved_levels] in the past, and 2 levels in the - future from [highest_level_encountered] *) - Lwt.return - { - validators_rights; - consensus_operations_table = HLevel.create preserved_levels; - blocks_table = HLevel.create preserved_levels; - preserved_levels; - highest_level_encountered = Raw_level.root (* 0l *); - clean_frequency; - cleaning_countdown = clean_frequency; - blocks_stream; - ops_stream; - ops_stream_stopper; - } - -(* We choose a previous offset (5 blocks from head) to ensure that the - injected operation is branched from a valid - predecessor. Denunciation operations can be emitted when the - consensus is under attack and may occur so you want to inject the - operation from a block which is considered "final". *) -let get_block_offset level = - match Raw_level.of_int32 5l with - | Ok min_level -> - let offset = Raw_level.diff level min_level in - if Compare.Int32.(offset >= 0l) then Lwt.return (`Head 5) - else - (* offset < 0l *) - let negative_offset = Int32.to_int offset in - (* We cannot inject at at level 0 : this is the genesis - level. We inject starting from level 1 thus the '- 1'. *) - Lwt.return (`Head (5 + negative_offset - 1)) - | Error errs -> - Events.(emit invalid_level_conversion) (Environment.wrap_tztrace errs) - >>= fun () -> Lwt.return (`Head 0) - -let get_payload_hash (type kind) (op_kind : kind consensus_operation_type) - (op : kind Operation.t) = - match (op_kind, op.protocol_data.contents) with - | Preendorsement, Single (Preendorsement consensus_content) - | Endorsement, Single (Endorsement consensus_content) -> - consensus_content.block_payload_hash - -let get_slot (type kind) (op_kind : kind consensus_operation_type) - (op : kind Operation.t) = - match (op_kind, op.protocol_data.contents) with - | Preendorsement, Single (Preendorsement consensus_content) - | Endorsement, Single (Endorsement consensus_content) -> - consensus_content.slot - -let double_consensus_op_evidence (type kind) : - kind consensus_operation_type -> - #Protocol_client_context.full -> - 'a -> - branch:Block_hash.t -> - op1:kind Alpha_context.operation -> - op2:kind Alpha_context.operation -> - unit -> - bytes Environment.Error_monad.shell_tzresult Lwt.t = function - | Endorsement -> Plugin.RPC.Forge.double_endorsement_evidence - | Preendorsement -> Plugin.RPC.Forge.double_preendorsement_evidence - -let lookup_recorded_consensus (type kind) consensus_key - (op_kind : kind consensus_operation_type) map : kind recorded_consensus = - match Delegate_map.find consensus_key map with - | None -> No_operation_seen - | Some {endorsement; preendorsement} -> ( - match op_kind with - | Endorsement -> endorsement - | Preendorsement -> preendorsement) - -let add_consensus_operation (type kind) consensus_key - (op_kind : kind consensus_operation_type) - (recorded_operation : kind recorded_consensus) map = - Delegate_map.update - consensus_key - (fun x -> - let record = - Option.value - ~default: - { - endorsement = No_operation_seen; - preendorsement = No_operation_seen; - } - x - in - match op_kind with - | Endorsement -> Some {record with endorsement = recorded_operation} - | Preendorsement -> Some {record with preendorsement = recorded_operation}) - map - -let get_validator_rights state cctxt level = - let open Lwt_result_syntax in - match Validators_cache.find_opt state.validators_rights level with - | None -> - let* validators = - Plugin.RPC.Validators.get cctxt (cctxt#chain, `Head 0) ~levels:[level] - in - let validators = - List.fold_left - (fun acc ({consensus_key; slots; _} : RPC.Validators.t) -> - List.fold_left - (fun acc slot -> Slot.Map.add slot consensus_key acc) - acc - slots) - Slot.Map.empty - validators - in - Validators_cache.replace state.validators_rights level validators ; - return validators - | Some t -> return t - -let process_consensus_op (type kind) state cctxt - (op_kind : kind consensus_operation_type) (new_op : kind Operation.t) - chain_id level round slot = - let open Lwt_result_syntax in - let diff = Raw_level.diff state.highest_level_encountered level in - if Int32.(diff > of_int state.preserved_levels) then - (* We do not handle operations older than [preserved_levels] *) - let*! () = - Events.(emit consensus_operation_too_old) (Operation.hash new_op) - in - return_unit - else if diff < -2l then - (* We do not handle operations too far in the future *) - let*! () = - Events.(emit consensus_operation_too_far_in_future) - (Operation.hash new_op) - in - return_unit - else - let* endorsing_rights = get_validator_rights state cctxt level in - match Slot.Map.find slot endorsing_rights with - | None -> - (* We do not handle operations that do not have a valid slot *) - return_unit - | Some consensus_key -> ( - let round_map = - Option.value ~default:Delegate_map.empty - @@ HLevel.find - state.consensus_operations_table - (chain_id, level, round) - in - match lookup_recorded_consensus consensus_key op_kind round_map with - | No_operation_seen -> - return - @@ HLevel.add - state.consensus_operations_table - (chain_id, level, round) - (add_consensus_operation - consensus_key - op_kind - (Operation_seen - {operation = new_op; previously_denounced_oph = None}) - round_map) - | Operation_seen {operation = existing_op; previously_denounced_oph} - when Block_payload_hash.( - get_payload_hash op_kind existing_op - <> get_payload_hash op_kind new_op) - || Slot.(get_slot op_kind existing_op <> slot) - || Block_hash.(existing_op.shell.branch <> new_op.shell.branch) - -> - (* Same level, round, and delegate, and: - different payload hash OR different slot OR different branch *) - let new_op_hash, existing_op_hash = - (Operation.hash new_op, Operation.hash existing_op) - in - let op1, op2 = - if Operation_hash.(new_op_hash < existing_op_hash) then - (new_op, existing_op) - else (existing_op, new_op) - in - let*! block = get_block_offset level in - let chain = `Hash chain_id in - let* block_hash = - Alpha_block_services.hash cctxt ~chain ~block () - in - let* bytes = - double_consensus_op_evidence - op_kind - cctxt - (`Hash chain_id, block) - ~branch:block_hash - ~op1 - ~op2 - () - in - let bytes = Signature.concat bytes Signature.zero in - let double_op_detected, double_op_denounced = - Events.( - match op_kind with - | Endorsement -> - (double_endorsement_detected, double_endorsement_denounced) - | Preendorsement -> - ( double_preendorsement_detected, - double_preendorsement_denounced )) - in - let*! () = - Events.(emit double_op_detected) (new_op_hash, existing_op_hash) - in - let* op_hash = - Shell_services.Injection.private_operation cctxt ~chain bytes - in - let*! () = - match previously_denounced_oph with - | Some oph -> Events.(emit double_consensus_already_denounced) oph - | None -> Lwt.return_unit - in - HLevel.replace - state.consensus_operations_table - (chain_id, level, round) - (add_consensus_operation - consensus_key - op_kind - (Operation_seen - { - operation = new_op; - previously_denounced_oph = Some op_hash; - }) - round_map) ; - let*! () = Events.(emit double_op_denounced) (op_hash, bytes) in - return_unit - | _ -> return_unit) - -let process_operations (cctxt : #Protocol_client_context.full) state - (endorsements : 'a list) ~packed_op chain_id = - List.iter_es - (fun op -> - let {shell; protocol_data; _} = packed_op op in - match protocol_data with - | Operation_data - ({contents = Single (Preendorsement {round; slot; level; _}); _} as - protocol_data) -> - let new_preendorsement : Kind.preendorsement Alpha_context.operation = - {shell; protocol_data} - in - process_consensus_op - state - cctxt - Preendorsement - new_preendorsement - chain_id - level - round - slot - | Operation_data - ({contents = Single (Endorsement {round; slot; level; _}); _} as - protocol_data) -> - let new_endorsement : Kind.endorsement Alpha_context.operation = - {shell; protocol_data} - in - process_consensus_op - state - cctxt - Endorsement - new_endorsement - chain_id - level - round - slot - | _ -> - (* not a consensus operation *) - return_unit) - endorsements - -let context_block_header cctxt ~chain b_hash = - Alpha_block_services.header cctxt ~chain ~block:(`Hash (b_hash, 0)) () - >>=? fun ({shell; protocol_data; _} : Alpha_block_services.block_header) -> - return {Alpha_context.Block_header.shell; protocol_data} - -let process_block (cctxt : #Protocol_client_context.full) state - (header : Alpha_block_services.block_info) = - match header with - | {hash; metadata = None; _} -> - Events.(emit unexpected_pruned_block) hash >>= fun () -> return_unit - | { - Alpha_block_services.chain_id; - hash = new_hash; - metadata = Some {protocol_data = {baker; level_info = {level; _}; _}; _}; - header = {shell = {fitness; _}; _}; - _; - } -> ( - let fitness = Fitness.from_raw fitness in - Lwt.return - (match fitness with - | Ok fitness -> Ok (Fitness.round fitness) - | Error errs -> Error (Environment.wrap_tztrace errs)) - >>=? fun round -> - let chain = `Hash chain_id in - let map = - Option.value ~default:Delegate_map.empty - @@ HLevel.find state.blocks_table (chain_id, level, round) - in - match Delegate_map.find baker.delegate map with - | None -> - return - @@ HLevel.add - state.blocks_table - (chain_id, level, round) - (Delegate_map.add baker.delegate new_hash map) - | Some existing_hash when Block_hash.(existing_hash = new_hash) -> - (* This case should never happen *) - Events.(emit double_baking_but_not) () >>= fun () -> - return - @@ HLevel.replace - state.blocks_table - (chain_id, level, round) - (Delegate_map.add baker.delegate new_hash map) - | Some existing_hash -> - (* If a previous block made by this pkh is found for - the same (level, round) we inject a double_baking_evidence *) - context_block_header cctxt ~chain existing_hash >>=? fun bh1 -> - context_block_header cctxt ~chain new_hash >>=? fun bh2 -> - let hash1 = Block_header.hash bh1 in - let hash2 = Block_header.hash bh2 in - let bh1, bh2 = - if Block_hash.(hash1 < hash2) then (bh1, bh2) else (bh2, bh1) - in - (* If the blocks are on different chains then skip it *) - get_block_offset level >>= fun block -> - Alpha_block_services.hash cctxt ~chain ~block () - >>=? fun block_hash -> - Plugin.RPC.Forge.double_baking_evidence - cctxt - (chain, block) - ~branch:block_hash - ~bh1 - ~bh2 - () - >>=? fun bytes -> - let bytes = Signature.concat bytes Signature.zero in - Events.(emit double_baking_detected) () >>= fun () -> - Shell_services.Injection.operation cctxt ~chain bytes - >>=? fun op_hash -> - Events.(emit double_baking_denounced) (op_hash, bytes) >>= fun () -> - return - @@ HLevel.replace - state.blocks_table - (chain_id, level, round) - (Delegate_map.add baker.delegate new_hash map)) - -(* Remove levels that are lower than the - [highest_level_encountered] minus [preserved_levels] *) -let cleanup_old_operations state = - state.cleaning_countdown <- state.cleaning_countdown - 1 ; - if state.cleaning_countdown < 0 then ( - (* It's time to remove old levels *) - state.cleaning_countdown <- state.clean_frequency ; - let highest_level_encountered = - Int32.to_int (Raw_level.to_int32 state.highest_level_encountered) - in - let diff = highest_level_encountered - state.preserved_levels in - let threshold = - if diff < 0 then Raw_level.root - else - Raw_level.of_int32 (Int32.of_int diff) |> function - | Ok threshold -> threshold - | Error _ -> Raw_level.root - in - let filter hmap = - HLevel.filter_map_inplace - (fun (_, level, _) x -> - if Raw_level.(level < threshold) then None else Some x) - hmap - in - filter state.consensus_operations_table ; - filter state.blocks_table) - -(* Each new block is processed : - - Checking that every baker injected only once at this level - - Checking that every (pre)endorser operated only once at this level -*) -let process_new_block (cctxt : #Protocol_client_context.full) state - {hash; chain_id; level; protocol; next_protocol; _} = - if Protocol_hash.(protocol <> next_protocol) then - Events.(emit protocol_change_detected) () >>= fun () -> return_unit - else - Events.(emit accuser_saw_block) (level, hash) >>= fun () -> - let chain = `Hash chain_id in - let block = `Hash (hash, 0) in - state.highest_level_encountered <- - Raw_level.max level state.highest_level_encountered ; - (* Processing blocks *) - (Alpha_block_services.info cctxt ~chain ~block () >>= function - | Ok block_info -> ( - process_block cctxt state block_info >>=? fun () -> - (* Processing (pre)endorsements in the block *) - match block_info.operations with - | consensus_ops :: _ -> - let packed_op {Alpha_block_services.shell; protocol_data; _} = - {shell; protocol_data} - in - process_operations cctxt state consensus_ops ~packed_op chain_id - | _ -> - (* Should not happen as a block should contain 4 lists of - operations, the first list being dedicated to consensus - operations. *) - Events.(emit fetch_operations_error hash) >>= fun () -> return_unit - ) - | Error errs -> - Events.(emit accuser_block_error) (hash, errs) >>= fun () -> - return_unit) - >>=? fun () -> - cleanup_old_operations state ; - return_unit - -let process_new_block cctxt state bi = - process_new_block cctxt state bi >>= function - | Ok () -> Events.(emit accuser_processed_block) bi.hash >>= Lwt.return - | Error errs -> - Events.(emit accuser_block_error) (bi.hash, errs) >>= Lwt.return - -let log_errors_and_continue ~name p = - p >>= function - | Ok () -> Lwt.return_unit - | Error errs -> B_Events.(emit daemon_error) (name, errs) - -let start_ops_monitor cctxt = - Alpha_block_services.Mempool.monitor_operations - cctxt - ~chain:cctxt#chain - ~validated:true - ~branch_delayed:true - ~branch_refused:false - ~refused:false - ~outdated:false - () - -let create (cctxt : #Protocol_client_context.full) ?canceler ~preserved_levels - valid_blocks_stream = - B_Events.(emit daemon_setup) name >>= fun () -> - start_ops_monitor cctxt >>=? fun (ops_stream, ops_stream_stopper) -> - create_state - ~preserved_levels - valid_blocks_stream - ops_stream - ops_stream_stopper - >>= fun state -> - Option.iter - (fun canceler -> - Lwt_canceler.on_cancel canceler (fun () -> - state.ops_stream_stopper () ; - Lwt.return_unit)) - canceler ; - let last_get_block = ref None in - let get_block () = - match !last_get_block with - | None -> - let t = Lwt_stream.get state.blocks_stream >|= fun e -> `Block e in - last_get_block := Some t ; - t - | Some t -> t - in - let last_get_ops = ref None in - let get_ops () = - match !last_get_ops with - | None -> - let t = Lwt_stream.get state.ops_stream >|= fun e -> `Operations e in - last_get_ops := Some t ; - t - | Some t -> t - in - Chain_services.chain_id cctxt () >>=? fun chain_id -> - (* main loop *) - (* Only allocate once the termination promise *) - let terminated = Lwt_exit.clean_up_starts >|= fun _ -> `Termination in - let rec worker_loop () = - Lwt.choose [terminated; get_block (); get_ops ()] >>= function - (* event matching *) - | `Termination -> return_unit - | `Block (None | Some (Error _)) -> - (* exit when the node is unavailable *) - last_get_block := None ; - B_Events.(emit daemon_connection_lost) name >>= fun () -> - fail Baking_errors.Node_connection_lost - | `Block (Some (Ok bi)) -> - last_get_block := None ; - process_new_block cctxt state bi >>= fun () -> worker_loop () - | `Operations None -> - (* restart a new operations monitor stream *) - last_get_ops := None ; - state.ops_stream_stopper () ; - start_ops_monitor cctxt >>=? fun (ops_stream, ops_stream_stopper) -> - state.ops_stream <- ops_stream ; - state.ops_stream_stopper <- ops_stream_stopper ; - worker_loop () - | `Operations (Some ops) -> - last_get_ops := None ; - log_errors_and_continue ~name - @@ process_operations - cctxt - state - ops - ~packed_op:(fun ((_h, op), _errl) -> op) - chain_id - >>= fun () -> worker_loop () - in - B_Events.(emit daemon_start) name >>= fun () -> worker_loop () diff --git a/src/proto_017_PtNairob/lib_delegate/client_baking_denunciation.mli b/src/proto_017_PtNairob/lib_delegate/client_baking_denunciation.mli deleted file mode 100644 index 46e784d132b49cef5f5e031d1d41bc55161c493a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/client_baking_denunciation.mli +++ /dev/null @@ -1,31 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 create : - #Protocol_client_context.full -> - ?canceler:Lwt_canceler.t -> - preserved_levels:int -> - Client_baking_blocks.block_info tzresult Lwt_stream.t -> - unit tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_delegate/client_baking_scheduling.ml b/src/proto_017_PtNairob/lib_delegate/client_baking_scheduling.ml deleted file mode 100644 index f34bf9da1c20f917da6b953d4e60e3614da40588..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/client_baking_scheduling.ml +++ /dev/null @@ -1,33 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 Events = Delegate_events.Baking_scheduling - -let sleep_until time = - (* Sleeping is a system op, baking is a protocol op, this is where we convert *) - let time = Time.System.of_protocol_exn time in - let delay = Ptime.diff time (Time.System.now ()) in - if Ptime.Span.compare delay Ptime.Span.zero < 0 then None - else Some (Lwt_unix.sleep (Ptime.Span.to_float_s delay)) diff --git a/src/proto_017_PtNairob/lib_delegate/client_baking_scheduling.mli b/src/proto_017_PtNairob/lib_delegate/client_baking_scheduling.mli deleted file mode 100644 index ae4a323ca1cc629d459f37d5f86c4e08618c8eb1..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/client_baking_scheduling.mli +++ /dev/null @@ -1,54 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 sleep_until : Time.Protocol.t -> unit Lwt.t option - -(* val wait_for_first_event : - * name:string -> 'event tzresult Lwt_stream.t -> 'event Lwt.t - * - * val main : - * name:string -> - * cctxt:(#Protocol_client_context.full as 'a) -> - * stream:'event tzresult Lwt_stream.t -> - * state_maker:('event -> 'state tzresult Lwt.t) -> - * pre_loop:('a -> 'state -> 'event -> unit tzresult Lwt.t) -> - * compute_timeout:('state -> 'timesup Lwt.t) -> - * timeout_k:('a -> 'state -> 'timesup -> unit tzresult Lwt.t) -> - * event_k:('a -> 'state -> 'event -> unit tzresult Lwt.t) -> - * finalizer:('state -> unit Lwt.t) -> - * unit tzresult Lwt.t *) - -(** [main ~name ~cctxt ~stream ~state_maker ~pre_loop ~timeout_maker ~timeout_k - ~event_k] is an infinitely running loop that - monitors new events arriving on [stream]. The loop exits when the - [stream] gives an error. - - The function [pre_loop] is called before the loop starts. - - The loop maintains a state (of type ['state]) initialized by [state_maker] - and passed to the callbacks [timeout_maker] (used to set up waking-up - timeouts), [timeout_k] (when a computed timeout happens), and [event_k] - (when a new event arrives on the stream). -*) diff --git a/src/proto_017_PtNairob/lib_delegate/client_daemon.ml b/src/proto_017_PtNairob/lib_delegate/client_daemon.ml deleted file mode 100644 index 2f7a86787a2b0c4ff734fe56cb57bf0cebd51375..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/client_daemon.ml +++ /dev/null @@ -1,225 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 rec retry (cctxt : #Protocol_client_context.full) ?max_delay ~delay ~factor - ~tries f x = - f x >>= function - | Ok _ as r -> Lwt.return r - | Error - (RPC_client_errors.Request_failed {error = Connection_failed _; _} :: _) - as err - when tries > 0 -> ( - cctxt#message "Connection refused, retrying in %.2f seconds..." delay - >>= fun () -> - Lwt.pick - [ - (Lwt_unix.sleep delay >|= fun () -> `Continue); - (Lwt_exit.clean_up_starts >|= fun _ -> `Killed); - ] - >>= function - | `Killed -> Lwt.return err - | `Continue -> - let next_delay = delay *. factor in - let delay = - Option.fold - ~none:next_delay - ~some:(fun max_delay -> Float.min next_delay max_delay) - max_delay - in - retry cctxt ?max_delay ~delay ~factor ~tries:(tries - 1) f x) - | Error _ as err -> Lwt.return err - -let rec retry_on_disconnection (cctxt : #Protocol_client_context.full) f = - f () >>= function - | Ok () -> return_unit - | Error (Baking_errors.Node_connection_lost :: _) -> - cctxt#warning - "Lost connection with the node. Retrying to establish connection..." - >>= fun () -> - (* Wait forever when the node stops responding... *) - Client_confirmations.wait_for_bootstrapped - ~retry:(retry cctxt ~max_delay:10. ~delay:1. ~factor:1.5 ~tries:max_int) - cctxt - >>=? fun () -> retry_on_disconnection cctxt f - | Error err -> - cctxt#error "Unexpected error: %a. Exiting..." pp_print_trace err - -let await_protocol_start (cctxt : #Protocol_client_context.full) ~chain = - cctxt#message "Waiting for protocol %s to start..." Protocol.name - >>= fun () -> Node_rpc.await_protocol_activation cctxt ~chain () - -module Baker = struct - let run (cctxt : Protocol_client_context.full) ?minimal_fees - ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?liquidity_baking - ?extra_operations ?dal_node_endpoint ?pre_emptive_forge_time ?force_apply - ?context_path ?state_recorder ~chain ~keep_alive delegates = - let process () = - Config_services.user_activated_upgrades cctxt - >>=? fun user_activated_upgrades -> - Shell_services.Chain.chain_id cctxt ~chain:cctxt#chain () - >>=? fun chain_id -> - Protocol.Alpha_services.Constants.all cctxt (`Hash chain_id, `Head 0) - >>=? fun constants -> - (let block_time_s = - Int64.to_float - (Protocol.Alpha_context.Period.to_seconds - constants.parametric.minimal_block_delay) - in - match Option.map Q.to_float pre_emptive_forge_time with - | Some t -> - if t >= block_time_s then - failwith - "pre-emptive-forge-time must be less than current block time \ - (<= %f seconds)" - block_time_s - else return (t, block_time_s) - | None -> return (Float.mul 0.15 block_time_s, block_time_s)) - >>=? fun (pre_emptive_forge_time, block_time_s) -> - let msg = - if pre_emptive_forge_time <> 0. then - cctxt#message - "pre-emptive-forge-time optimization set to %fs. Operation \ - inclusion window is ~%fs. Caution: Setting this too high may \ - result in reduced block proposal rewards." - pre_emptive_forge_time - (Float.sub block_time_s pre_emptive_forge_time) - else Lwt.return_unit - in - Lwt.map (fun () -> ok pre_emptive_forge_time) msg - >>=? fun pre_emptive_forge_time -> - let pre_emptive_forge_time = - Time.System.Span.of_seconds_exn pre_emptive_forge_time - in - let config = - Baking_configuration.make - ?minimal_fees - ?minimal_nanotez_per_gas_unit - ?minimal_nanotez_per_byte - ?liquidity_baking - ?extra_operations - ?dal_node_endpoint - ~pre_emptive_forge_time - ?force_apply - ?context_path - ~user_activated_upgrades - ?state_recorder - () - in - cctxt#message - "Baker v%a (%s) for %a started." - Tezos_version.Version.pp - Tezos_version_value.Current_git_info.version - Tezos_version_value.Current_git_info.abbreviated_commit_hash - Protocol_hash.pp_short - Protocol.hash - >>= fun () -> - let canceler = Lwt_canceler.create () in - let _ = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _ -> - cctxt#message "Shutting down the baker..." >>= fun () -> - Lwt_canceler.cancel canceler >>= fun _ -> Lwt.return_unit) - in - Baking_scheduling.run cctxt ~canceler ~chain ~constants config delegates - in - Client_confirmations.wait_for_bootstrapped - ~retry:(retry cctxt ~delay:1. ~factor:1.5 ~tries:5) - cctxt - >>=? fun () -> - await_protocol_start cctxt ~chain >>=? fun () -> - if keep_alive then retry_on_disconnection cctxt process else process () -end - -module Accuser = struct - let run (cctxt : #Protocol_client_context.full) ~chain ~preserved_levels - ~keep_alive = - let process () = - cctxt#message - "Accuser v%a (%s) for %a started." - Tezos_version.Version.pp - Tezos_version_value.Current_git_info.version - Tezos_version_value.Current_git_info.abbreviated_commit_hash - Protocol_hash.pp_short - Protocol.hash - >>= fun () -> - Client_baking_blocks.monitor_applied_blocks - ~next_protocols:(Some [Protocol.hash]) - cctxt - ~chains:[chain] - () - >>=? fun (valid_blocks_stream, _) -> - let canceler = Lwt_canceler.create () in - let _ = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _ -> - cctxt#message "Shutting down the accuser..." >>= fun () -> - Lwt_canceler.cancel canceler >>= fun _ -> Lwt.return_unit) - in - Client_baking_denunciation.create - cctxt - ~canceler - ~preserved_levels - valid_blocks_stream - in - Client_confirmations.wait_for_bootstrapped - ~retry:(retry cctxt ~delay:1. ~factor:1.5 ~tries:5) - cctxt - >>=? fun () -> - await_protocol_start cctxt ~chain >>=? fun () -> - if keep_alive then retry_on_disconnection cctxt process else process () -end - -module VDF = struct - let run (cctxt : Protocol_client_context.full) ~chain ~keep_alive = - let open Lwt_result_syntax in - let process () = - let*! () = - cctxt#message - "VDF daemon v%a (%s) for %a started." - Tezos_version.Version.pp - Tezos_version_value.Current_git_info.version - Tezos_version_value.Current_git_info.abbreviated_commit_hash - Protocol_hash.pp_short - Protocol.hash - in - let* chain_id = Shell_services.Chain.chain_id cctxt ~chain () in - let* constants = - Protocol.Alpha_services.Constants.all cctxt (`Hash chain_id, `Head 0) - in - let canceler = Lwt_canceler.create () in - let _ = - Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _ -> - let*! () = cctxt#message "Shutting down the VDF daemon..." in - let*! _ = Lwt_canceler.cancel canceler in - Lwt.return_unit) - in - Baking_vdf.start_vdf_worker cctxt ~canceler constants chain - in - let* () = - Client_confirmations.wait_for_bootstrapped - ~retry:(retry cctxt ~delay:1. ~factor:1.5 ~tries:5) - cctxt - in - let* () = await_protocol_start cctxt ~chain in - if keep_alive then retry_on_disconnection cctxt process else process () -end diff --git a/src/proto_017_PtNairob/lib_delegate/client_daemon.mli b/src/proto_017_PtNairob/lib_delegate/client_daemon.mli deleted file mode 100644 index 4ea7226ecc8619dbcc55a3833d4961ca0f88322c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/client_daemon.mli +++ /dev/null @@ -1,67 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Daemons directly supported by lib_delegate *) - -(** {1 Baker daemon} *) -module Baker : sig - val run : - Protocol_client_context.full -> - ?minimal_fees:Protocol.Alpha_context.Tez.t -> - ?minimal_nanotez_per_gas_unit:Q.t -> - ?minimal_nanotez_per_byte:Q.t -> - ?liquidity_baking:Baking_configuration.liquidity_baking_config -> - ?extra_operations:Baking_configuration.Operations_source.t -> - ?dal_node_endpoint:Uri.t -> - ?pre_emptive_forge_time:Q.t -> - ?force_apply:bool -> - ?context_path:string -> - ?state_recorder:Baking_configuration.state_recorder_config -> - chain:Shell_services.chain -> - keep_alive:bool -> - Baking_state.consensus_key list -> - unit tzresult Lwt.t -end - -(** {1 Accuser daemon} *) - -module Accuser : sig - val run : - #Protocol_client_context.full -> - chain:Chain_services.chain -> - preserved_levels:int -> - keep_alive:bool -> - unit tzresult Lwt.t -end - -(** {1 VDF computation daemon} *) - -module VDF : sig - val run : - Protocol_client_context.full -> - chain:Chain_services.chain -> - keep_alive:bool -> - unit tzresult Lwt.t -end diff --git a/src/proto_017_PtNairob/lib_delegate/delegate_events.ml b/src/proto_017_PtNairob/lib_delegate/delegate_events.ml deleted file mode 100644 index 665e85e55e73299b139273f383613c613ac58c6c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/delegate_events.ml +++ /dev/null @@ -1,250 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Tocqueville Group, 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 level = Internal_event.Notice - -(* Ignore the value in the output. *) -let pp_ignore fmt _ = Format.pp_print_string fmt "" - -module Denunciator = struct - include Internal_event.Simple - - let section = [Protocol.name; "delegate"; "denunciation"] - - let invalid_level_conversion = - declare_1 - ~section - ~level:Error - ~name:"invalid_level_conversion" - ~msg:"invalid level conversion: {errors}" - ~pp1:pp_print_top_error_of_trace - ("errors", Error_monad.(TzTrace.encoding error_encoding)) - - let double_endorsement_detected = - declare_2 - ~section - ~level - ~name:"double_endorsement_detected" - ~msg:"double endorsement detected" - ("existing_endorsement", Operation_hash.encoding) - ("new_endorsement", Operation_hash.encoding) - - let double_endorsement_denounced = - declare_2 - ~section - ~level - ~name:"double_endorsement_denounced" - ~msg:"double endorsement evidence injected: {hash}" - ("hash", Operation_hash.encoding) - ~pp2:pp_ignore - ("bytes", Data_encoding.bytes) - - let double_preendorsement_detected = - declare_2 - ~section - ~level - ~name:"double_preendorsement_detected" - ~msg:"double preendorsement detected" - ("existing_preendorsement", Operation_hash.encoding) - ("new_preendorsement", Operation_hash.encoding) - - let double_preendorsement_denounced = - declare_2 - ~section - ~level - ~name:"double_preendorsement_denounced" - ~msg:"double preendorsement evidence injected: {hash}" - ("hash", Operation_hash.encoding) - ~pp2:pp_ignore - ("bytes", Data_encoding.bytes) - - let double_consensus_already_denounced = - declare_1 - ~section - ~level:Debug - ~name:"double_consensus_already_denounced" - ~msg:"double consensus operation already denounced in {hash}" - ("hash", Operation_hash.encoding) - - let consensus_operation_too_old = - declare_1 - ~section - ~level:Debug - ~name:"consensus_operation_too_old" - ~msg:"operation {hash} is too old to be handled" - ("hash", Operation_hash.encoding) - - let consensus_operation_too_far_in_future = - declare_1 - ~section - ~level:Debug - ~name:"consensus_operation_too_far_in_future" - ~msg:"operation {hash} too far in the future" - ("hash", Operation_hash.encoding) - - let inconsistent_endorsement = - declare_1 - ~section - ~level:Error - ~name:"inconsistent_endorsement" - ~msg:"inconsistent endorsement found {hash}" - ("hash", Operation_hash.encoding) - - let unexpected_pruned_block = - declare_1 - ~section - ~level:Error - ~name:"unexpected_pruned_block" - ~msg:"unexpected pruned block: {hash}" - ("hash", Block_hash.encoding) - - let double_baking_but_not = - declare_0 - ~section - ~level:Debug - ~name:"double_baking_but_not" - ~msg:"double baking detected but block hashes are equivalent; skipping" - () - - let double_baking_detected = - declare_0 - ~section - ~level - ~name:"double_baking_detected" - ~msg:"double baking detected" - () - - let double_baking_denounced = - declare_2 - ~section - ~level - ~name:"double_baking_denounced" - ~msg:"double baking evidence injected {hash}" - ("hash", Operation_hash.encoding) - ~pp2:pp_ignore - ("bytes", Data_encoding.bytes) - - let protocol_change_detected = - declare_0 - ~section - ~level:Error - ~name:"protocol_change_detected" - ~msg:"protocol changing detected; skipping the block" - () - - let accuser_saw_block = - declare_2 - ~section - ~level:Debug - ~name:"accuser_saw_block" - ~msg:"block level: {level}" - ("level", Alpha_context.Raw_level.encoding) - ("hash", Block_hash.encoding) - - let fetch_operations_error = - declare_1 - ~section - ~level:Error - ~name:"fetch_operations_error" - ~msg:"error while fetching operations of block {hash}" - ("hash", Block_hash.encoding) - ~pp1:Block_hash.pp - - let accuser_processed_block = - declare_1 - ~section - ~level - ~name:"accuser_processed_block" - ~msg:"block {hash} registered" - ("hash", Block_hash.encoding) - - let accuser_block_error = - declare_2 - ~section - ~level:Error - ~name:"accuser_block_error" - ~msg:"error while processing block {hash} {errors}" - ~pp2:pp_print_top_error_of_trace - ("hash", Block_hash.encoding) - ("errors", Error_monad.(TzTrace.encoding error_encoding)) -end - -module Baking_scheduling = struct - include Internal_event.Simple - - let section = [Protocol.name; "delegate"; "baking-scheduling"] - - let cannot_fetch_event = - declare_1 - ~section - ~level:Info - ~name:"cannot_fetch_event" - ~msg:"{worker}: can't fetch the current event; waiting for new event" - ("worker", Data_encoding.string) - - let daemon_error = - declare_2 - ~section - ~level:Error - ~name:"daemon_error" - ~msg:"{worker}: error while baking: {errors}" - ~pp2:pp_print_top_error_of_trace - ("worker", Data_encoding.string) - ("errors", Error_monad.(TzTrace.encoding error_encoding)) - - let daemon_setup = - declare_1 - ~section - ~level:Info - ~name:"daemon_setup" - ~msg:"setting up before the {worker} can start" - ("worker", Data_encoding.string) - - let daemon_connection_lost = - declare_1 - ~section - ~level:Error - ~name:"daemon_connection_lost" - ~msg:"connection to node lost, {worker} exiting" - ("worker", Data_encoding.string) - - let daemon_wakeup = - declare_1 - ~section - ~level:Debug - ~name:"daemon_wakeup" - ~msg:"waking up for {worker}" - ("worker", Data_encoding.string) - - let daemon_start = - declare_1 - ~section - ~level:Info - ~name:"daemon_start" - ~msg:"starting {worker} daemon" - ("worker", Data_encoding.string) -end diff --git a/src/proto_017_PtNairob/lib_delegate/dune b/src/proto_017_PtNairob/lib_delegate/dune deleted file mode 100644 index 2365890d6145dd8b63270b9ad2828281f7f05dd4..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/dune +++ /dev/null @@ -1,109 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name tezos_baking_017_PtNairob) - (public_name octez-protocol-017-PtNairob-libs.baking) - (instrumentation (backend bisect_ppx)) - (libraries - octez-libs.base - octez-libs.clic - octez-version.value - tezos-protocol-017-PtNairob.protocol - octez-protocol-017-PtNairob-libs.plugin - octez-proto-libs.protocol-environment - octez-shell-libs.shell-services - octez-shell-libs.client-base - octez-protocol-017-PtNairob-libs.client - octez-shell-libs.client-commands - octez-libs.stdlib - octez-libs.stdlib-unix - octez-shell-libs.shell-context - octez-libs.tezos-context - octez-libs.tezos-context.memory - octez-libs.rpc-http-client-unix - octez-shell-libs.context-ops - octez-libs.rpc - octez-libs.rpc-http - octez-libs.crypto-dal - tezos-dal-node-services - lwt-canceler - lwt-exit - uri) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_protocol_017_PtNairob - -open Tezos_protocol_plugin_017_PtNairob - -open Tezos_shell_services - -open Tezos_client_base - -open Tezos_client_017_PtNairob - -open Tezos_client_commands - -open Tezos_stdlib - -open Tezos_stdlib_unix - -open Tezos_shell_context - -open Tezos_context - -open Tezos_context_ops - -open Tezos_rpc_http - -open Tezos_crypto_dal) - (modules (:standard \ Baking_commands Baking_commands_registration))) - -(library - (name tezos_baking_017_PtNairob_commands) - (public_name octez-protocol-017-PtNairob-libs.baking-commands) - (instrumentation (backend bisect_ppx)) - (libraries - octez-libs.base - tezos-protocol-017-PtNairob.protocol - octez-libs.stdlib-unix - octez-proto-libs.protocol-environment - octez-shell-libs.shell-services - octez-shell-libs.client-base - octez-protocol-017-PtNairob-libs.client - octez-shell-libs.client-commands - octez-protocol-017-PtNairob-libs.baking - octez-libs.rpc - uri) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_protocol_017_PtNairob - -open Tezos_stdlib_unix - -open Tezos_shell_services - -open Tezos_client_base - -open Tezos_client_017_PtNairob - -open Tezos_client_commands - -open Tezos_baking_017_PtNairob) - (modules Baking_commands)) - -(library - (name tezos_baking_017_PtNairob_commands_registration) - (public_name octez-protocol-017-PtNairob-libs.baking-commands.registration) - (instrumentation (backend bisect_ppx)) - (libraries - octez-libs.base - tezos-protocol-017-PtNairob.protocol - octez-proto-libs.protocol-environment - octez-shell-libs.shell-services - octez-shell-libs.client-base - octez-protocol-017-PtNairob-libs.client - octez-shell-libs.client-commands - octez-protocol-017-PtNairob-libs.baking - octez-protocol-017-PtNairob-libs.baking-commands - octez-libs.rpc) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezos_base.TzPervasives - -open Tezos_protocol_017_PtNairob - -open Tezos_shell_services - -open Tezos_client_base - -open Tezos_client_017_PtNairob - -open Tezos_client_commands - -open Tezos_baking_017_PtNairob - -open Tezos_baking_017_PtNairob_commands) - (modules Baking_commands_registration)) diff --git a/src/proto_017_PtNairob/lib_delegate/liquidity_baking_vote.ml b/src/proto_017_PtNairob/lib_delegate/liquidity_baking_vote.ml deleted file mode 100644 index a7afef165a95c38b4db9f9d977afb7a8406d80fc..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/liquidity_baking_vote.ml +++ /dev/null @@ -1,215 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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_client_context -module Events = Baking_events.Liquidity_baking - -let default_vote_json_filename = "per_block_votes.json" - -let vote_file_content_encoding = - let open Data_encoding in - def - (String.concat "." [Protocol.name; "vote_file_content"]) - (obj1 - (req - "liquidity_baking_toggle_vote" - Protocol.Alpha_context.Liquidity_baking - .liquidity_baking_toggle_vote_encoding)) - -type error += Block_vote_file_not_found of string - -type error += Block_vote_file_invalid of string - -type error += Block_vote_file_wrong_content of string - -type error += Block_vote_file_missing_liquidity_baking_toggle_vote of string - -type error += Missing_vote_on_startup - -let () = - register_error_kind - `Permanent - ~id:"liquidity_baking_vote.block_vote_file_not_found" - ~title: - "The provided block vote file path does not point to an existing file." - ~description: - "A block vote file path was provided on the command line but the path \ - does not point to an existing file." - ~pp:(fun ppf file_path -> - Format.fprintf - ppf - "@[The provided block vote file path \"%s\" does not point to an \ - existing file.@]" - file_path) - Data_encoding.(obj1 (req "file_path" string)) - (function - | Block_vote_file_not_found file_path -> Some file_path | _ -> None) - (fun file_path -> Block_vote_file_not_found file_path) ; - register_error_kind - `Permanent - ~id:"liquidity_baking_vote.block_vote_file_invalid" - ~title: - "The provided block vote file path does not point to a valid JSON file." - ~description: - "A block vote file path was provided on the command line but the path \ - does not point to a valid JSON file." - ~pp:(fun ppf file_path -> - Format.fprintf - ppf - "@[The provided block vote file path \"%s\" does not point to a valid \ - JSON file. The file exists but its content is not valid JSON.@]" - file_path) - Data_encoding.(obj1 (req "file_path" string)) - (function Block_vote_file_invalid file_path -> Some file_path | _ -> None) - (fun file_path -> Block_vote_file_invalid file_path) ; - register_error_kind - `Permanent - ~id:"liquidity_baking_vote.block_vote_file_wrong_content" - ~title:"The content of the provided block vote file is unexpected." - ~description: - "The block vote file is valid JSON but its content is not the expected \ - one." - ~pp:(fun ppf file_path -> - Format.fprintf - ppf - "@[The provided block vote file \"%s\" is a valid JSON file but its \ - content is unexpected. Expecting a JSON file containing either \ - '{\"liquidity_baking_toggle_vote\": \"on\"}', or \ - '{\"liquidity_baking_toggle_vote\": \"off\"}', or \ - '{\"liquidity_baking_toggle_vote\": \"pass\"}'.@]" - file_path) - Data_encoding.(obj1 (req "file_path" string)) - (function - | Block_vote_file_wrong_content file_path -> Some file_path | _ -> None) - (fun file_path -> Block_vote_file_wrong_content file_path) ; - register_error_kind - `Permanent - ~id: - "liquidity_baking_vote.block_vote_file_missing_liquidity_baking_toggle_vote" - ~title: - "In the provided block vote file, no entry for liquidity baking toggle \ - vote was found" - ~description: - "In the provided block vote file, no entry for liquidity baking toggle \ - vote was found." - ~pp:(fun ppf file_path -> - Format.fprintf - ppf - "@[In the provided block vote file \"%s\", the \ - \"liquidity_baking_toggle_vote\" boolean field is missing. Expecting \ - a JSON file containing either '{\"liquidity_baking_toggle_vote\": \ - \"on\"}', or '{\"liquidity_baking_toggle_vote\": \"off\"}', or \ - '{\"liquidity_baking_toggle_vote\": \"pass\"}'.@]" - file_path) - Data_encoding.(obj1 (req "file_path" string)) - (function - | Block_vote_file_missing_liquidity_baking_toggle_vote file_path -> - Some file_path - | _ -> None) - (fun file_path -> - Block_vote_file_missing_liquidity_baking_toggle_vote file_path) ; - register_error_kind - `Permanent - ~id:"liquidity_baking_vote.missing_vote_on_startup" - ~title:"Missing vote on startup" - ~description: - "No CLI flag, file path, or vote file in default location provided on \ - startup" - ~pp:(fun fmt () -> - Format.fprintf - fmt - "Missing liquidity baking toggle vote, please use either the \ - --liquidity-baking-toggle-vote or --votefile option or a vote file in \ - the default location: per_block_votes.json in the current working \ - directory or in the baker directory.") - Data_encoding.empty - (function Missing_vote_on_startup -> Some () | _ -> None) - (fun () -> Missing_vote_on_startup) - -let check_file_exists file = - let open Lwt_result_syntax in - let*! file_exists = - Lwt.catch (fun () -> Lwt_unix.file_exists file) (fun _ -> Lwt.return_false) - in - if file_exists then return_unit else tzfail (Block_vote_file_not_found file) - -let read_liquidity_baking_toggle_vote ~per_block_vote_file : 'a tzresult Lwt.t = - let open Lwt_result_syntax in - let*! () = Events.(emit reading_per_block) per_block_vote_file in - let* () = check_file_exists per_block_vote_file in - let* votes_json = - trace - (Block_vote_file_invalid per_block_vote_file) - (Lwt_utils_unix.Json.read_file per_block_vote_file) - in - let* liquidity_baking_toggle_vote = - trace - (Block_vote_file_wrong_content per_block_vote_file) - (protect (fun () -> - return - (Data_encoding.Json.destruct vote_file_content_encoding votes_json))) - in - return liquidity_baking_toggle_vote - -let read_liquidity_baking_toggle_vote_no_fail ~default_liquidity_baking_vote - ~per_block_vote_file = - read_liquidity_baking_toggle_vote ~per_block_vote_file >>= function - | Ok vote -> Lwt.return vote - | Error errs -> - Events.(emit per_block_vote_file_fail) errs >>= fun () -> - Lwt.return default_liquidity_baking_vote - -let load_liquidity_baking_config ~per_block_vote_file_arg - ~(toggle_vote_arg : - Protocol.Alpha_context.Liquidity_baking.liquidity_baking_toggle_vote - option) : Baking_configuration.liquidity_baking_config tzresult Lwt.t = - let open Lwt_result_syntax in - (* If a vote file is given, it takes priority. Otherwise, we expect - a toggle vote argument to be passed. *) - let* config = - match (per_block_vote_file_arg, toggle_vote_arg) with - | None, None -> tzfail Missing_vote_on_startup - | None, Some vote -> - return - {Baking_configuration.vote_file = None; liquidity_baking_vote = vote} - | Some per_block_vote_file, _ -> ( - let*! (res : _ tzresult) = - read_liquidity_baking_toggle_vote ~per_block_vote_file - in - match res with - | Ok vote -> - return - { - Baking_configuration.vote_file = Some per_block_vote_file; - liquidity_baking_vote = vote; - } - | Error errs -> - Events.(emit per_block_vote_file_fail) errs >>= fun () -> - tzfail Missing_vote_on_startup) - in - let*! () = - Events.(emit liquidity_baking_toggle_vote) config.liquidity_baking_vote - in - return config diff --git a/src/proto_017_PtNairob/lib_delegate/liquidity_baking_vote.mli b/src/proto_017_PtNairob/lib_delegate/liquidity_baking_vote.mli deleted file mode 100644 index e74b38031771ee63727514ea8dcc853ab5c1a5ad..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/liquidity_baking_vote.mli +++ /dev/null @@ -1,71 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs *) -(* *) -(* 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 module is used to load the baker's liquidity baking vote - configurations. When a file is given as configuration, its content - is expected to be a valid JSON matching the following examples: - - {v {"liquidity_baking_toggle_vote": "on"} v} - - {v {"liquidity_baking_toggle_vote": "off"} v} - - {v {"liquidity_baking_toggle_vote": "pass"} v} - - Moreover, in order to handle dynamic voting (i.e. change the - baker's vote without having to restart it), each time a block is - being built, the baker will try and read the vote file present in - the config in order to check for updated votes. -*) - -open Protocol.Alpha_context - -type error += Block_vote_file_not_found of string - -type error += Block_vote_file_invalid of string - -type error += Block_vote_file_wrong_content of string - -type error += Block_vote_file_missing_liquidity_baking_toggle_vote of string - -type error += Missing_vote_on_startup - -(** Default vote file name that should be looked up when the baker - starts. *) -val default_vote_json_filename : string - -(** Reads the content of [per_block_vote_file] and returns a vote. If - any error occurs (e.g. Non-existing file, unparsable content, - etc.), [default_liquidity_baking_vote] will be returned. *) -val read_liquidity_baking_toggle_vote_no_fail : - default_liquidity_baking_vote:Liquidity_baking.liquidity_baking_toggle_vote -> - per_block_vote_file:string -> - Liquidity_baking.liquidity_baking_toggle_vote Lwt.t - -(** Load a liquidity baking configuration given two possible - arguments. If neither are provided, it fails. Otherwise, it tries, - in priority, to read the [per_block_vote_file_arg] file if it is - given and loads a config using its content. Otherwise, the - [toggle_vote_arg] is used. *) -val load_liquidity_baking_config : - per_block_vote_file_arg:string option -> - toggle_vote_arg:Liquidity_baking.liquidity_baking_toggle_vote option -> - Baking_configuration.liquidity_baking_config tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_delegate/logging.ml b/src/proto_017_PtNairob/lib_delegate/logging.ml deleted file mode 100644 index ed9cb18c9db3b27cb86a0f8b5f5f4bcc9c855936..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/logging.ml +++ /dev/null @@ -1,167 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 -open Alpha_context - -let timestamp_tag = - Tag.def ~doc:"Timestamp when event occurred" "timestamp" Time.System.pp_hum - -let valid_ops = Tag.def ~doc:"Valid Operations" "valid_ops" Format.pp_print_int - -let op_count = - Tag.def ~doc:"Number of operations" "op_count" Format.pp_print_int - -let refused_ops = - Tag.def ~doc:"Refused Operations" "refused_ops" Format.pp_print_int - -let bake_priority_tag = - Tag.def ~doc:"Baking priority" "bake_priority" Format.pp_print_int - -let fitness_tag = Tag.def ~doc:"Fitness" "fitness" Fitness.pp - -let current_slots_tag = - Tag.def - ~doc:"Number of baking slots that can be baked at this time" - "current_slots" - Format.pp_print_int - -let future_slots_tag = - Tag.def - ~doc:"Number of baking slots in the foreseeable future but not yet bakeable" - "future_slots" - Format.pp_print_int - -let timespan_tag = Tag.def ~doc:"Timespan in seconds" "timespan" Ptime.Span.pp - -let filename_tag = Tag.def ~doc:"Filename" "filename" Format.pp_print_text - -let signed_header_tag = - Tag.def ~doc:"Signed header" "signed_header" (fun fmt x -> - Hex.pp fmt (Hex.of_bytes x)) - -let signed_operation_tag = - Tag.def ~doc:"Signed operation" "signed_operation" (fun fmt x -> - Hex.pp fmt (Hex.of_bytes x)) - -let operations_tag = - Tag.def - ~doc:"Block Operations" - "operations" - (Format.pp_print_list - ~pp_sep:(fun ppf () -> Format.fprintf ppf "+") - (fun ppf operations -> Format.fprintf ppf "%d" (List.length operations))) - -let raw_operations_tag = - Tag.def ~doc:"Raw operations" "raw_operations" (fun fmt raw_ops -> - let pp_op fmt op = - let json = Data_encoding.Json.construct Operation.raw_encoding op in - Format.fprintf fmt "%a" Data_encoding.Json.pp json - in - Format.fprintf - fmt - "@[%a@]" - (Format.pp_print_list ~pp_sep:Format.pp_print_cut pp_op) - raw_ops) - -let bake_op_count_tag = - Tag.def ~doc:"Bake Operation Count" "operation_count" Format.pp_print_int - -let endorsement_slot_tag = - Tag.def ~doc:"Endorsement Slot" "endorsement_slot" Format.pp_print_int - -let endorsement_slots_tag = - Tag.def - ~doc:"Endorsement Slots" - "endorsement_slots" - Format.(fun ppf v -> pp_print_int ppf (List.length v)) - -let denounced_endorsements_slots_tag = - Tag.def - ~doc:"Endorsement Slots" - "denounced_endorsement_slots" - Format.(pp_print_list pp_print_int) - -let denouncement_source_tag = - Tag.def ~doc:"Denounce Source" "source" Format.pp_print_text - -let level_tag = Tag.def ~doc:"Level" "level" Raw_level.pp - -let nonce_tag = - Tag.def - ~doc:"Nonce" - "nonce" - Data_encoding.Json.( - fun ppf nonce -> pp ppf (construct Nonce.encoding nonce)) - -let chain_tag = - Tag.def - ~doc:"Chain selector" - "chain" - Format.( - fun ppf chain -> - pp_print_string ppf @@ Block_services.chain_to_string chain) - -let block_tag = - Tag.def - ~doc:"Block selector" - "block" - Format.( - fun ppf block -> pp_print_string ppf @@ Block_services.to_string block) - -let worker_tag = - Tag.def ~doc:"Worker in which event occurred" "worker" Format.pp_print_text - -let block_header_tag = - Tag.def ~doc:"Raw block header" "block_header" (fun ppf _ -> - Format.fprintf ppf "[raw block header]") - -let conflicting_endorsements_tag = - Tag.def - ~doc:"Two conflicting endorsements signed by the same key" - "conflicting_endorsements" - Format.( - fun ppf (a, b) -> - fprintf - ppf - "%a / %a" - Operation_hash.pp - (Operation.hash a) - Operation_hash.pp - (Operation.hash b)) - -let conflicting_preendorsements_tag = - Tag.def - ~doc:"Two conflicting preendorsements signed by the same key" - "conflicting_preendorsements" - Format.( - fun ppf (a, b) -> - fprintf - ppf - "%a / %a" - Operation_hash.pp - (Operation.hash a) - Operation_hash.pp - (Operation.hash b)) diff --git a/src/proto_017_PtNairob/lib_delegate/logging.mli b/src/proto_017_PtNairob/lib_delegate/logging.mli deleted file mode 100644 index 5e10680ae6124478b390df02ddf417fc017b599e..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/logging.mli +++ /dev/null @@ -1,83 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 -open Alpha_context - -val timestamp_tag : Time.System.t Tag.def - -val valid_ops : int Tag.def - -val op_count : int Tag.def - -val refused_ops : int Tag.def - -val bake_priority_tag : int Tag.def - -val fitness_tag : Fitness.t Tag.def - -val current_slots_tag : int Tag.def - -val future_slots_tag : int Tag.def - -val timespan_tag : Time.System.Span.t Tag.def - -val filename_tag : string Tag.def - -val signed_header_tag : Bytes.t Tag.def - -val signed_operation_tag : Bytes.t Tag.def - -val operations_tag : Tezos_base.Operation.t list list Tag.def - -val raw_operations_tag : Operation.raw list Tag.def - -val bake_op_count_tag : int Tag.def - -val endorsement_slot_tag : int Tag.def - -val endorsement_slots_tag : int list Tag.def - -val denounced_endorsements_slots_tag : int list Tag.def - -val denouncement_source_tag : string Tag.def - -val level_tag : Raw_level.t Tag.def - -val nonce_tag : Nonce.t Tag.def - -val chain_tag : Block_services.chain Tag.def - -val block_tag : Block_services.block Tag.def - -val worker_tag : string Tag.def - -val block_header_tag : Block_header.t Tag.def - -val conflicting_endorsements_tag : - (Kind.endorsement operation * Kind.endorsement operation) Tag.def - -val conflicting_preendorsements_tag : - (Kind.preendorsement operation * Kind.preendorsement operation) Tag.def diff --git a/src/proto_017_PtNairob/lib_delegate/node_rpc.ml b/src/proto_017_PtNairob/lib_delegate/node_rpc.ml deleted file mode 100644 index 2fae4652e15e12be22d6ca7fc07814d4c90f77d8..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/node_rpc.ml +++ /dev/null @@ -1,297 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context -open Baking_cache -open Baking_state -module Lifted_protocol = Tezos_protocol_017_PtNairob_lifted.Lifted_protocol -module Block_services = Block_services.Make (Lifted_protocol) (Lifted_protocol) -module Events = Baking_events.Node_rpc - -let inject_block cctxt ?(force = false) ~chain signed_block_header operations = - let signed_shell_header_bytes = - Data_encoding.Binary.to_bytes_exn Block_header.encoding signed_block_header - in - Shell_services.Injection.block - ~async:true - cctxt - ~chain - ~force - signed_shell_header_bytes - operations - -let inject_operation cctxt ~chain operation = - let encoded_op = - Data_encoding.Binary.to_bytes_exn Operation.encoding operation - in - Shell_services.Injection.operation cctxt ~async:true ~chain encoded_op - -let preapply_block cctxt ~chain ~head ~timestamp ~protocol_data operations = - Block_services.Helpers.Preapply.block - cctxt - ~chain - ~timestamp - ~block:(`Hash (head, 0)) - operations - ~protocol_data - -let extract_prequorum preendorsements = - match preendorsements with - | h :: _ -> - let ({protocol_data = {contents = Single (Preendorsement content); _}; _}) - = - (h : Kind.preendorsement Operation.t) - in - Some - { - level = Raw_level.to_int32 content.level; - round = content.round; - block_payload_hash = content.block_payload_hash; - preendorsements; - } - | _ -> None - -let info_of_header_and_ops ~in_protocol block_hash block_header operations = - let open Result_syntax in - let shell = block_header.Tezos_base.Block_header.shell in - let dummy_payload_hash = Block_payload_hash.zero in - let* round = - Environment.wrap_tzresult @@ Fitness.round_from_raw shell.fitness - in - let payload_hash, payload_round, prequorum, quorum, dal_attestations, payload - = - if not in_protocol then - (* The first block in the protocol is baked using the previous - protocol, the encodings might change. The baker's logic is to - consider final the first block of a new protocol and not - endorse it. Therefore, we do not need to have the correct - values here. *) - ( dummy_payload_hash, - Round.zero, - None, - [], - [], - Operation_pool.empty_payload ) - else - let payload_hash, payload_round = - match - Data_encoding.Binary.of_bytes_opt - Protocol.block_header_data_encoding - block_header.protocol_data - with - | Some {contents = {payload_hash; payload_round; _}; _} -> - (payload_hash, payload_round) - | None -> assert false - in - let preendorsements, quorum, dal_attestations, payload = - WithExceptions.Option.get - ~loc:__LOC__ - (Operation_pool.extract_operations_of_list_list operations) - in - let prequorum = Option.bind preendorsements extract_prequorum in - (payload_hash, payload_round, prequorum, quorum, dal_attestations, payload) - in - return - { - hash = block_hash; - shell; - payload_hash; - payload_round; - round; - prequorum; - quorum; - dal_attestations; - payload; - } - -let compute_block_info cctxt ~in_protocol ?operations ~chain block_hash - block_header = - let open Lwt_result_syntax in - let* operations = - match operations with - | None when not in_protocol -> return_nil - | None -> - let open Protocol_client_context in - let* operations = - Alpha_block_services.Operations.operations - cctxt - ~chain - ~block:(`Hash (block_hash, 0)) - () - in - let packed_operations = - List.map - (fun l -> - List.map - (fun {Alpha_block_services.shell; protocol_data; _} -> - {Alpha_context.shell; protocol_data}) - l) - operations - in - return packed_operations - | Some operations -> - let parse_op (raw_op : Tezos_base.Operation.t) = - let protocol_data = - Data_encoding.Binary.of_bytes_exn - Operation.protocol_data_encoding - raw_op.proto - in - {shell = raw_op.shell; protocol_data} - in - protect @@ fun () -> return (List.map (List.map parse_op) operations) - in - let*? block_info = - info_of_header_and_ops ~in_protocol block_hash block_header operations - in - return block_info - -let proposal cctxt ?(cache : block_info Block_cache.t option) ?operations ~chain - block_hash (block_header : Tezos_base.Block_header.t) = - let open Lwt_result_syntax in - let predecessor_hash = block_header.shell.predecessor in - let pred_block = `Hash (predecessor_hash, 0) in - let predecessor_opt = - Option.bind cache (fun cache -> Block_cache.find_opt cache predecessor_hash) - in - let* is_proposal_in_protocol, predecessor = - match predecessor_opt with - | Some predecessor -> - return - ( predecessor.shell.proto_level = block_header.shell.proto_level, - predecessor ) - | None -> - let* { - current_protocol = pred_current_protocol; - next_protocol = pred_next_protocol; - } = - Shell_services.Blocks.protocols cctxt ~chain ~block:pred_block () - in - let is_proposal_in_protocol = - Protocol_hash.(pred_next_protocol = Protocol.hash) - in - let* predecessor = - let in_protocol = - Protocol_hash.(pred_current_protocol = Protocol.hash) - in - let* raw_header_b = - Shell_services.Blocks.raw_header cctxt ~chain ~block:pred_block () - in - let predecessor_header = - Data_encoding.Binary.of_bytes_exn - Tezos_base.Block_header.encoding - raw_header_b - in - compute_block_info - cctxt - ~in_protocol - ~chain - predecessor_hash - predecessor_header - in - Option.iter - (fun cache -> Block_cache.replace cache predecessor_hash predecessor) - cache ; - return (is_proposal_in_protocol, predecessor) - in - let block_opt = - Option.bind cache (fun cache -> Block_cache.find_opt cache block_hash) - in - let* block = - match block_opt with - | Some pi -> return pi - | None -> - let* pi = - compute_block_info - cctxt - ~in_protocol:is_proposal_in_protocol - ?operations - ~chain - block_hash - block_header - in - Option.iter (fun cache -> Block_cache.replace cache block_hash pi) cache ; - return pi - in - return {block; predecessor} - -let proposal cctxt ?cache ?operations ~chain block_hash block_header = - protect @@ fun () -> - proposal cctxt ?cache ?operations ~chain block_hash block_header - -let monitor_valid_proposals cctxt ~chain ?cache () = - let open Lwt_result_syntax in - let next_protocols = [Protocol.hash] in - let* block_stream, stopper = - Monitor_services.validated_blocks cctxt ~chains:[chain] ~next_protocols () - in - let stream = - let map (_chain_id, block_hash, block_header, operations) = - let*! map_result = - proposal cctxt ?cache ~operations ~chain block_hash block_header - in - match map_result with - | Ok proposal -> Lwt.return_some proposal - | Error err -> - let*! () = Events.(emit error_while_monitoring_valid_proposals err) in - Lwt.return_none - in - Lwt_stream.filter_map_s map block_stream - in - return (stream, stopper) - -let monitor_heads cctxt ~chain ?cache () = - let open Lwt_result_syntax in - let next_protocols = [Protocol.hash] in - let* block_stream, stopper = - Monitor_services.heads cctxt ~next_protocols chain - in - let stream = - let map (block_hash, block_header) = - let*! map_result = proposal cctxt ?cache ~chain block_hash block_header in - match map_result with - | Ok proposal -> Lwt.return_some proposal - | Error err -> - let*! () = Events.(emit error_while_monitoring_heads err) in - Lwt.return_none - in - Lwt_stream.filter_map_s map block_stream - in - return (stream, stopper) - -let await_protocol_activation cctxt ~chain () = - Monitor_services.heads cctxt ~next_protocols:[Protocol.hash] chain - >>=? fun (block_stream, stop) -> - Lwt_stream.get block_stream >>= fun _ -> - stop () ; - return_unit - -let get_attestable_slots dal_node_rpc_ctxt pkh ~level = - Tezos_rpc.Context.make_call - Tezos_dal_node_services.Services.get_attestable_slots - dal_node_rpc_ctxt - (((), pkh), level) - () - () diff --git a/src/proto_017_PtNairob/lib_delegate/node_rpc.mli b/src/proto_017_PtNairob/lib_delegate/node_rpc.mli deleted file mode 100644 index 6d5da2d6e9713cf61eb7fc9dc732da0dd7d41a1f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/node_rpc.mli +++ /dev/null @@ -1,92 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context - -(** Inject a block. - - @param force defaults to [false] - @return block hash of the newly injected block -*) -val inject_block : - #Protocol_client_context.full -> - ?force:bool -> - chain:Shell_services.chain -> - Block_header.t -> - Tezos_base.Operation.t list list -> - Block_hash.t tzresult Lwt.t - -(** Inject an operation. - - @return operation hash of the newly injected operation -*) -val inject_operation : - #Protocol_client_context.full -> - chain:Shell_services.chain -> - packed_operation -> - Operation_hash.t tzresult Lwt.t - -(** Preapply a block using the node validation mechanism.*) -val preapply_block : - #Protocol_client_context.full -> - chain:Shell_services.chain -> - head:Block_hash.t -> - timestamp:Time.Protocol.t -> - protocol_data:Protocol.block_header_data -> - packed_operation list list -> - (Tezos_base.Block_header.shell_header * error Preapply_result.t list) tzresult - Lwt.t - -(** Monitor validated blocks/proposals from the node. *) -val monitor_valid_proposals : - #Protocol_client_context.rpc_context -> - chain:Shell_services.chain -> - ?cache:Baking_state.block_info Baking_cache.Block_cache.t -> - unit -> - (Baking_state.proposal Lwt_stream.t * (unit -> unit)) tzresult Lwt.t - -(** Monitor heads from the node. *) -val monitor_heads : - #Protocol_client_context.rpc_context -> - chain:Shell_services.chain -> - ?cache:Baking_state.block_info Baking_cache.Block_cache.t -> - unit -> - (Baking_state.proposal Lwt_stream.t * (unit -> unit)) tzresult Lwt.t - -(** Await the current protocol to be activated. *) -val await_protocol_activation : - #Protocol_client_context.rpc_context -> - chain:Shell_services.chain -> - unit -> - unit tzresult Lwt.t - -(** [get_attestable_slots ctxt pkk ~level] calls the DAL node RPC - /profiles//attested_levels//attestable_slots *) -val get_attestable_slots : - Tezos_rpc.Context.generic -> - public_key_hash -> - level:int32 -> - Tezos_dal_node_services.Types.attestable_slots tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_delegate/operation_pool.ml b/src/proto_017_PtNairob/lib_delegate/operation_pool.ml deleted file mode 100644 index a654562fcb436a6b7d979ceb21cd5c12d4805d6e..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/operation_pool.ml +++ /dev/null @@ -1,413 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context - -(* Should we use a better ordering ? *) - -type 'collection t = { - consensus : 'collection; - votes : 'collection; - anonymous : 'collection; - managers : 'collection; -} - -let compare_op op1 op2 = - try Stdlib.compare op1 op2 - with _ -> - (* FIXME some operations (e.g. tx_rollup_rejection) pack - functional values which could raise an exception. In this - specific case, we default to comparing their hashes. *) - Operation_hash.compare - (Alpha_context.Operation.hash_packed op1) - (Alpha_context.Operation.hash_packed op2) - -module Prioritized_operation = struct - (* Higher priority operations will be included first *) - type t = Prioritized of int * packed_operation | Low of packed_operation - - let extern ?(priority = 1) op = Prioritized (priority, op) - - let node op = Low op - - let packed = function Prioritized (_, op) | Low op -> op - - let compare_priority t1 t2 = - match (t1, t2) with - | Prioritized _, Low _ -> 1 - | Low _, Prioritized _ -> -1 - | Low _, Low _ -> 0 - | Prioritized (p0, _), Prioritized (p1, _) -> Compare.Int.compare p0 p1 - - let compare a b = - let c = compare_priority a b in - if c <> 0 then c else compare_op (packed a) (packed b) -end - -module Operation_set = Set.Make (struct - type t = packed_operation - - let compare = compare_op -end) - -module Prioritized_operation_set = struct - include Set.Make (struct - type t = Prioritized_operation.t - - let compare = Prioritized_operation.compare - end) - - let operations set = elements set |> List.map Prioritized_operation.packed -end - -(* TODO refine this: unpack operations *) -type pool = Operation_set.t t - -(* TODO refine this: unpack operations *) -type ordered_pool = packed_operation list t - -let ordered_pool_encoding = - let open Data_encoding in - conv - (fun {consensus; votes; anonymous; managers} -> - (consensus, votes, anonymous, managers)) - (fun (consensus, votes, anonymous, managers) -> - {consensus; votes; anonymous; managers}) - (obj4 - (req "ordered_consensus" (list (dynamic_size Operation.encoding))) - (req "ordered_votes" (list (dynamic_size Operation.encoding))) - (req "ordered_anonymouns" (list (dynamic_size Operation.encoding))) - (req "ordered_managers" (list (dynamic_size Operation.encoding)))) - -type payload = { - votes_payload : packed_operation list; - anonymous_payload : packed_operation list; - managers_payload : packed_operation list; -} - -let empty_payload = - {votes_payload = []; anonymous_payload = []; managers_payload = []} - -let payload_encoding = - let open Data_encoding in - conv - (fun {votes_payload; anonymous_payload; managers_payload} -> - (votes_payload, anonymous_payload, managers_payload)) - (fun (votes_payload, anonymous_payload, managers_payload) -> - {votes_payload; anonymous_payload; managers_payload}) - (obj3 - (req "votes_payload" (list (dynamic_size Operation.encoding))) - (req "anonymous_payload" (list (dynamic_size Operation.encoding))) - (req "managers_payload" (list (dynamic_size Operation.encoding)))) - -let pp_payload fmt {votes_payload; anonymous_payload; managers_payload} = - Format.fprintf - fmt - "[votes: %d, anonymous: %d, managers: %d]" - (List.length votes_payload) - (List.length anonymous_payload) - (List.length managers_payload) - -let empty = - { - consensus = Operation_set.empty; - votes = Operation_set.empty; - anonymous = Operation_set.empty; - managers = Operation_set.empty; - } - -let empty_ordered = {consensus = []; votes = []; anonymous = []; managers = []} - -let pp_pool fmt {consensus; votes; anonymous; managers} = - Format.fprintf - fmt - "[consensus: %d, votes: %d, anonymous: %d, managers: %d]" - (Operation_set.cardinal consensus) - (Operation_set.cardinal votes) - (Operation_set.cardinal anonymous) - (Operation_set.cardinal managers) - -let pp_ordered_pool fmt {consensus; votes; anonymous; managers} = - Format.fprintf - fmt - "[consensus: %d, votes: %d, anonymous: %d, managers: %d]" - (List.length consensus) - (List.length votes) - (List.length anonymous) - (List.length managers) - -let classify op = - (* Hypothesis: acceptable passes on an ill-formed operation returns - None. *) - let pass = Main.acceptable_pass op in - match pass with - | None -> `Bad - | Some pass -> - let open Operation_repr in - if pass = consensus_pass then `Consensus - (* TODO filter outdated consensus ops ? *) - else if pass = voting_pass then `Votes - else if pass = anonymous_pass then `Anonymous - else if pass = manager_pass then `Managers - else `Bad - -let add_operation_to_pool add classify pool operation = - match classify operation with - | `Consensus -> - let consensus = add operation pool.consensus in - {pool with consensus} - | `Votes -> - let votes = add operation pool.votes in - {pool with votes} - | `Anonymous -> - let anonymous = add operation pool.anonymous in - {pool with anonymous} - | `Managers -> - let managers = add operation pool.managers in - {pool with managers} - | `Bad -> pool - -let add_operation = add_operation_to_pool Operation_set.add classify - -let add_operations pool ops = List.fold_left add_operation pool ops - -type consensus_filter = { - level : int32; - round : Round.t; - payload_hash : Block_payload_hash.t; -} - -(** From a pool of operations [operation_pool], the function filters - out the endorsements that are different from the [current_level], - the [current_round] or the optional [current_block_payload_hash], - as well as preendorsements. *) -let filter_with_relevant_consensus_ops ~(endorsement_filter : consensus_filter) - ~(preendorsement_filter : consensus_filter option) operation_set = - Operation_set.filter - (fun {protocol_data; _} -> - match (protocol_data, preendorsement_filter) with - (* 1a. Remove preendorsements. *) - | Operation_data {contents = Single (Preendorsement _); _}, None -> false - (* 1b. Filter preendorsements. *) - | ( Operation_data - { - contents = - Single (Preendorsement {level; round; block_payload_hash; _}); - _; - }, - Some - {level = level'; round = round'; payload_hash = block_payload_hash'} - ) -> - Compare.Int32.(Raw_level.to_int32 level = level') - && Round.(round = round') - && Block_payload_hash.(block_payload_hash = block_payload_hash') - (* 2. Filter endorsements. *) - | ( Operation_data - { - contents = - Single (Endorsement {level; round; block_payload_hash; _}); - _; - }, - _ ) -> - Compare.Int32.(Raw_level.to_int32 level = endorsement_filter.level) - && Round.(round = endorsement_filter.round) - && Block_payload_hash.( - block_payload_hash = endorsement_filter.payload_hash) - (* 3. Preserve all non-consensus operations. *) - | _ -> true) - operation_set - -let unpack_preendorsement packed_preendorsement = - let {shell; protocol_data = Operation_data data} = packed_preendorsement in - match data with - | {contents = Single (Preendorsement _); _} -> - Some ({shell; protocol_data = data} : Kind.preendorsement Operation.t) - | _ -> None - -let unpack_endorsement packed_endorsement = - let {shell; protocol_data = Operation_data data} = packed_endorsement in - match data with - | {contents = Single (Endorsement _); _} -> - Some ({shell; protocol_data = data} : Kind.endorsement Operation.t) - | _ -> None - -let unpack_dal_attestation packed_dal_attestation = - let {shell; protocol_data = Operation_data data} = packed_dal_attestation in - match data with - | {contents = Single (Dal_attestation _); _} -> - Some ({shell; protocol_data = data} : Kind.dal_attestation Operation.t) - | _ -> None - -let filter_preendorsements ops = - List.filter_map - (function - | { - shell = {branch}; - protocol_data = - Operation_data - ({contents = Single (Preendorsement _); _} as content); - _; - } -> - Some - ({shell = {branch}; protocol_data = content} - : Kind.preendorsement operation) - | _ -> None) - ops - -let filter_endorsements ops = - List.filter_map - (function - | { - shell = {branch}; - protocol_data = - Operation_data ({contents = Single (Endorsement _); _} as content); - _; - } -> - Some - ({shell = {branch}; protocol_data = content} - : Kind.endorsement operation) - | _ -> None) - ops - -let ordered_to_list_list {consensus; votes; anonymous; managers} = - [consensus; votes; anonymous; managers] - -let ordered_of_list_list = function - | [consensus; votes; anonymous; managers] -> - Some {consensus; votes; anonymous; managers} - | _ -> None - -let payload_of_ordered_pool {votes; anonymous; managers; _} = - { - votes_payload = votes; - anonymous_payload = anonymous; - managers_payload = managers; - } - -let ordered_pool_of_payload ~consensus_operations - {votes_payload; anonymous_payload; managers_payload} = - { - consensus = consensus_operations; - votes = votes_payload; - anonymous = anonymous_payload; - managers = managers_payload; - } - -let extract_operations_of_list_list = function - | [consensus; votes_payload; anonymous_payload; managers_payload] -> - let preendorsements, endorsements, dal_attestations = - List.fold_left - (fun ( (preendorsements : Kind.preendorsement Operation.t list), - (endorsements : Kind.endorsement Operation.t list), - (dal_attestations : Kind.dal_attestation Operation.t list) ) - packed_op -> - let {shell; protocol_data = Operation_data data} = packed_op in - match data with - | {contents = Single (Preendorsement _); _} -> - ( {shell; protocol_data = data} :: preendorsements, - endorsements, - dal_attestations ) - | {contents = Single (Endorsement _); _} -> - ( preendorsements, - {shell; protocol_data = data} :: endorsements, - dal_attestations ) - | {contents = Single (Dal_attestation _); _} -> - ( preendorsements, - endorsements, - {shell; protocol_data = data} :: dal_attestations ) - | _ -> - (* unreachable *) - (preendorsements, endorsements, dal_attestations)) - ([], [], []) - consensus - (* N.b. the order doesn't matter *) - in - let preendorsements = - if preendorsements = [] then None else Some preendorsements - in - let payload = {votes_payload; anonymous_payload; managers_payload} in - Some (preendorsements, endorsements, dal_attestations, payload) - | _ -> None - -let filter_pool p {consensus; votes; anonymous; managers} = - { - consensus = Operation_set.filter p consensus; - votes = Operation_set.filter p votes; - anonymous = Operation_set.filter p anonymous; - managers = Operation_set.filter p managers; - } - -module Prioritized = struct - type nonrec t = Prioritized_operation_set.t t - - let of_operation_set (operation_set : Operation_set.t) = - Operation_set.fold - (fun elt set -> - Prioritized_operation_set.add (Prioritized_operation.node elt) set) - operation_set - Prioritized_operation_set.empty - - let of_pool (pool : pool) : t = - { - consensus = of_operation_set pool.consensus; - votes = of_operation_set pool.votes; - anonymous = of_operation_set pool.anonymous; - managers = of_operation_set pool.managers; - } - - let add_operation = - add_operation_to_pool Prioritized_operation_set.add (fun op -> - classify (Prioritized_operation.packed op)) - - let add_external_operation pool priority operation = - add_operation pool (Prioritized_operation.extern ~priority operation) - - let add_operations prioritized_pool operations = - List.fold_left add_operation prioritized_pool operations - - (* [merge_external_operations] considers that the list of operation - represents an ordererd list of operation with the head having the highest - prioritiy. - *) - let merge_external_operations pool - (external_operations : packed_operation list) = - List.fold_left_i - (fun i pool op -> add_external_operation pool (-i) op) - pool - external_operations - - let filter p {consensus; votes; anonymous; managers} = - let filter = - Prioritized_operation_set.filter (fun pop -> - p (Prioritized_operation.packed pop)) - in - { - consensus = filter consensus; - votes = filter votes; - anonymous = filter anonymous; - managers = filter managers; - } -end diff --git a/src/proto_017_PtNairob/lib_delegate/operation_pool.mli b/src/proto_017_PtNairob/lib_delegate/operation_pool.mli deleted file mode 100644 index 67ddb289a78bbfccf29faf2eb189ef167b0acc2b..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/operation_pool.mli +++ /dev/null @@ -1,172 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context - -module Operation_set : Set.S with type elt = packed_operation - -(** Generic base type for pools *) -type 'collection t = { - consensus : 'collection; - votes : 'collection; - anonymous : 'collection; - managers : 'collection; -} - -(** A pool of operations for a single origin, or undifferenciated origin, - typically used for operations coming from the node *) -type pool = Operation_set.t t - -(** A pool of operations for a single origin, or undifferenciated origin, - typically used for operations coming from the node *) - -(** on pool *) -val empty : pool - -val pp_pool : Format.formatter -> pool -> unit - -val filter_pool : (packed_operation -> bool) -> pool -> pool - -val add_operation : pool -> packed_operation -> pool - -val add_operations : pool -> packed_operation list -> pool - -(** {2 Ordered pool of operations} *) -type ordered_pool = packed_operation list t - -val ordered_pool_encoding : ordered_pool Data_encoding.t - -val empty_ordered : ordered_pool - -val pp_ordered_pool : Format.formatter -> ordered_pool -> unit - -type payload = { - votes_payload : packed_operation list; - anonymous_payload : packed_operation list; - managers_payload : packed_operation list; -} - -val empty_payload : payload - -val payload_encoding : payload Data_encoding.t - -val pp_payload : Format.formatter -> payload -> unit - -val payload_of_ordered_pool : ordered_pool -> payload - -val ordered_pool_of_payload : - consensus_operations:packed_operation list -> payload -> ordered_pool - -type consensus_filter = { - level : int32; - round : Round.t; - payload_hash : Block_payload_hash.t; -} - -val filter_with_relevant_consensus_ops : - endorsement_filter:consensus_filter -> - preendorsement_filter:consensus_filter option -> - Operation_set.t -> - Operation_set.t - -val unpack_preendorsement : - packed_operation -> Kind.preendorsement operation option - -val unpack_endorsement : packed_operation -> Kind.endorsement operation option - -val unpack_dal_attestation : - packed_operation -> Kind.dal_attestation operation option - -val filter_preendorsements : - packed_operation list -> Kind.preendorsement operation list - -val filter_endorsements : - packed_operation list -> Kind.endorsement operation list - -val ordered_to_list_list : ordered_pool -> packed_operation list list - -val ordered_of_list_list : packed_operation list list -> ordered_pool option - -(** [preendorsements] <> None => (List.length preendorsements > 0) *) -val extract_operations_of_list_list : - packed_operation list list -> - (Kind.preendorsement operation list option - * Kind.endorsement operation list - * Kind.dal_attestation operation list - * payload) - option - -module Prioritized_operation : sig - type t - - (** prioritize operations coming from an external source (file, uri, ...). - An operation with higher [priority] (aka a bigger integer) will be - included before others with lower [priority]. *) - val extern : ?priority:int -> packed_operation -> t - - (** prioritize operations coming from a node *) - val node : packed_operation -> t - - (** [packed t] retrieves the [packed_operation] wrapped inside [t] *) - val packed : t -> packed_operation - - (** [compare_priority o1 o2] compares whether [o1] has higher priority than [o2] *) - val compare_priority : t -> t -> int - - (** [compare] is [compare_priority] when non-zero. This is suitable to - construct sets of prioritized operations **) - val compare : t -> t -> int -end - -module Prioritized_operation_set : sig - include Set.S with type elt = Prioritized_operation.t - - (** [operations set] is [elements set |> List.map Prioritized_operation.packed]*) - val operations : t -> packed_operation list -end - -(** Pool of prioritized operations *) -module Prioritized : sig - (** Same record fields as [type pool], but with a different set base *) - type nonrec t = Prioritized_operation_set.t t - - (** [of_pool pool] transforms [pool] into a prioritized pool of operations of - low priority. *) - val of_pool : pool -> t - - (** [merge_external_operations ?initial_priority pool extern_ops] creates a prioritized pool - from a [pool] and [extern_ops] coming from an external source, which we - prioritize. - - Priorities for these operations is given according to the order of the - list. The first element of the list has highest priority. - *) - val merge_external_operations : t -> packed_operation list -> t - - val filter : (packed_operation -> bool) -> t -> t - - val add_operations : t -> Prioritized_operation.t list -> t -end diff --git a/src/proto_017_PtNairob/lib_delegate/operation_selection.ml b/src/proto_017_PtNairob/lib_delegate/operation_selection.ml deleted file mode 100644 index 29c6a2d3dac242fb418aef0b67a0b85698a25e17..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/operation_selection.ml +++ /dev/null @@ -1,396 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 -open Alpha_context -open Operation_pool -module Events = Baking_events.Selection - -let quota = Main.validation_passes - -let consensus_quota = Stdlib.List.nth quota Operation_repr.consensus_pass - -let votes_quota = Stdlib.List.nth quota Operation_repr.voting_pass - -let anonymous_quota = Stdlib.List.nth quota Operation_repr.anonymous_pass - -let managers_quota = Stdlib.List.nth quota Operation_repr.manager_pass - -type prioritized_manager = { - op : Prioritized_operation.t; - size : int; - fee : Tez.t; - gas : Fixed_point_repr.integral_tag Gas.Arith.t; - weight : Q.t; - source : public_key_hash; - counter : Manager_counter.t; -} - -module PrioritizedManagerSet = Set.Make (struct - type t = prioritized_manager - - (* We order the operations by their weights except if they belong - to the same manager, if they do, we order them by their - counter. *) - let compare {source; counter; weight; op; _} - {source = source'; counter = counter'; weight = weight'; op = op'; _} = - (* Be careful with the [compare] *) - let cmp_src = Signature.Public_key_hash.compare source source' in - if cmp_src = 0 then - (* we want the smallest counter first *) - let c = Manager_counter.compare counter counter' in - if c <> 0 then c - else - let c = Prioritized_operation.compare_priority op' op in - if c <> 0 then c else Q.compare weight' weight - (* if same counter, biggest weight first *) - else - let c = Prioritized_operation.compare_priority op' op in - if c <> 0 then c - else - (* We want the biggest weight first *) - let c = Q.compare weight' weight in - if c <> 0 then c else cmp_src -end) - -(* Note: This weight is also used by the plugin and the prevalidator to sort - operations in the pending mempool. - See {!Tezos_protocol_plugin_alpha.Plugin.Mempool.weight_manager_operation}. *) -let prioritize_manager ~max_size ~hard_gas_limit_per_block ~minimal_fees - ~minimal_nanotez_per_gas_unit ~minimal_nanotez_per_byte operation = - let op = Operation_pool.Prioritized_operation.packed operation in - let {protocol_data = Operation_data {contents; _}; _} = op in - let open Operation in - let l = to_list (Contents_list contents) in - List.fold_left_e - (fun ((first_source, first_counter, total_fee, total_gas) as acc) -> - function - | Contents (Manager_operation {source; counter; fee; gas_limit; _}) -> - (Environment.wrap_tzresult @@ Tez.(total_fee +? fee)) - >>? fun total_fee -> - (* There is only one unique source per packed transaction *) - let first_source = Option.value ~default:source first_source in - (* We only care about the first counter *) - let first_counter = Option.value ~default:counter first_counter in - ok - ( Some first_source, - Some first_counter, - total_fee, - Gas.Arith.add total_gas gas_limit ) - | _ -> ok acc) - (None, None, Tez.zero, Gas.Arith.zero) - l - |> function - | Ok (Some source, Some counter, fee, gas) -> - if Tez.(fee < minimal_fees) then None - else - let size = Data_encoding.Binary.length Operation.encoding op in - let size_f = Q.of_int size in - let gas_f = Q.of_bigint (Gas.Arith.integral_to_z gas) in - let fee_f = Q.of_int64 (Tez.to_mutez fee) in - let size_ratio = Q.(size_f / Q.of_int max_size) in - let gas_ratio = - Q.( - gas_f - / Q.of_bigint (Gas.Arith.integral_to_z hard_gas_limit_per_block)) - in - let weight = Q.(fee_f / max size_ratio gas_ratio) in - let fees_in_nanotez = - Q.mul (Q.of_int64 (Tez.to_mutez fee)) (Q.of_int 1000) - in - let enough_fees_for_gas = - let minimal_fees_in_nanotez = - Q.mul - minimal_nanotez_per_gas_unit - (Q.of_bigint @@ Gas.Arith.integral_to_z gas) - in - Q.compare minimal_fees_in_nanotez fees_in_nanotez <= 0 - in - let enough_fees_for_size = - let minimal_fees_in_nanotez = - Q.mul minimal_nanotez_per_byte (Q.of_int size) - in - Q.compare minimal_fees_in_nanotez fees_in_nanotez <= 0 - in - if enough_fees_for_size && enough_fees_for_gas then - Some {op = operation; size; weight; fee; gas; source; counter} - else None - | _ -> None - -let prioritize_managers ~hard_gas_limit_per_block ~minimal_fees - ~minimal_nanotez_per_gas_unit ~minimal_nanotez_per_byte managers = - Prioritized_operation_set.fold - (fun op acc -> - match - prioritize_manager - ~max_size:managers_quota.max_size - ~hard_gas_limit_per_block - ~minimal_fees - ~minimal_nanotez_per_gas_unit - ~minimal_nanotez_per_byte - op - with - | None -> acc - | Some w_op -> PrioritizedManagerSet.add w_op acc) - managers - PrioritizedManagerSet.empty - -(** Simulation *) - -type simulation_result = { - validation_result : Tezos_protocol_environment.validation_result option; - block_header_metadata : block_header_metadata option; - operations : packed_operation list list; - operations_hash : Operation_list_list_hash.t; -} - -let validate_operation inc op = - Baking_simulator.add_operation inc op >>= function - | Error errs -> - Events.(emit invalid_operation_filtered) (Operation.hash_packed op, errs) - >>= fun () -> Lwt.return_none - | Ok (resulting_state, None) -> - (* No receipt if force_apply is not set *) - Lwt.return_some resulting_state - | Ok (resulting_state, Some receipt) -> ( - (* Check that the metadata are serializable/deserializable *) - let encoding_result = - let enc = Protocol.operation_receipt_encoding in - Option.bind - (Data_encoding.Binary.to_bytes_opt enc receipt) - (Data_encoding.Binary.of_bytes_opt enc) - in - match encoding_result with - | None -> - Events.(emit cannot_serialize_operation_metadata) - (Operation.hash_packed op) - >>= fun () -> Lwt.return_none - | Some _b -> Lwt.return_some resulting_state) - -let filter_valid_operations_up_to_quota inc (ops, quota) = - let {Tezos_protocol_environment.max_size; max_op} = quota in - let exception Full of (Baking_simulator.incremental * packed_operation list) - in - try - List.fold_left_s - (fun (inc, curr_size, nb_ops, acc) op -> - let op_size = - Data_encoding.Binary.length Alpha_context.Operation.encoding op - in - let new_size = curr_size + op_size in - if new_size > max_size then Lwt.return (inc, curr_size, nb_ops, acc) - else ( - Option.iter - (fun max_op -> if max_op = nb_ops + 1 then raise (Full (inc, acc))) - max_op ; - validate_operation inc op >>= function - | None -> Lwt.return (inc, curr_size, nb_ops, acc) - | Some inc' -> Lwt.return (inc', new_size, nb_ops + 1, op :: acc))) - (inc, 0, 0, []) - ops - >>= fun (inc, _, _, l) -> Lwt.return (inc, List.rev l) - with Full (inc, l) -> Lwt.return (inc, List.rev l) - -let filter_valid_managers_up_to_quota inc ~hard_gas_limit_per_block (ops, quota) - = - let open Lwt_syntax in - let {Tezos_protocol_environment.max_size; max_op} = quota in - let rec loop (inc, curr_size, nb_ops, remaining_gas, acc) = function - | [] -> return (inc, List.rev acc) - | {op; size = op_size; gas = op_gas; _} :: l -> ( - match max_op with - | Some max_op when max_op = nb_ops + 1 -> return (inc, List.rev acc) - | None | Some _ -> ( - if Gas.Arith.(remaining_gas < op_gas) then - (* If the remaining available gas is lower than the - considered operation's gas, we ignore this operation. *) - loop (inc, curr_size, nb_ops, remaining_gas, acc) l - else - let new_size = curr_size + op_size in - if new_size > max_size then - (* We ignore the operation if summing its size to the - size of managers operations already validated is - greater than the quota. *) - loop (inc, curr_size, nb_ops, remaining_gas, acc) l - else - let packed_op = Prioritized_operation.packed op in - let* inc'_opt = validate_operation inc packed_op in - match inc'_opt with - | None -> loop (inc, curr_size, nb_ops, remaining_gas, acc) l - | Some inc' -> - let new_remaining_gas = - Gas.Arith.sub remaining_gas op_gas - in - loop - ( inc', - new_size, - succ nb_ops, - new_remaining_gas, - packed_op :: acc ) - l)) - in - loop (inc, 0, 0, hard_gas_limit_per_block, []) ops - -let filter_operations_with_simulation initial_inc fees_config - ~hard_gas_limit_per_block {consensus; votes; anonymous; managers} = - let open Lwt_result_syntax in - let { - Baking_configuration.minimal_fees; - minimal_nanotez_per_gas_unit; - minimal_nanotez_per_byte; - } = - fees_config - in - filter_valid_operations_up_to_quota - initial_inc - (Prioritized_operation_set.operations consensus, consensus_quota) - >>= fun (inc, consensus) -> - filter_valid_operations_up_to_quota - inc - (Prioritized_operation_set.operations votes, votes_quota) - >>= fun (inc, votes) -> - filter_valid_operations_up_to_quota - inc - (Prioritized_operation_set.operations anonymous, anonymous_quota) - >>= fun (inc, anonymous) -> - (* Sort the managers *) - let prioritized_managers = - prioritize_managers - ~hard_gas_limit_per_block - ~minimal_fees - ~minimal_nanotez_per_gas_unit - ~minimal_nanotez_per_byte - managers - in - let*! inc, managers = - filter_valid_managers_up_to_quota - inc - ~hard_gas_limit_per_block - (PrioritizedManagerSet.elements prioritized_managers, managers_quota) - in - let operations = [consensus; votes; anonymous; managers] in - let operations_hash = - Operation_list_list_hash.compute - (List.map - (fun sl -> - Operation_list_hash.compute (List.map Operation.hash_packed sl)) - operations) - in - let inc = {inc with header = {inc.header with operations_hash}} in - Baking_simulator.finalize_construction inc >>=? function - | Some (validation_result, block_header_metadata) -> - return - { - validation_result = Some validation_result; - block_header_metadata = Some block_header_metadata; - operations; - operations_hash; - } - | None -> - return - { - validation_result = None; - block_header_metadata = None; - operations; - operations_hash; - } - -let filter_valid_operations_up_to_quota_without_simulation (ops, quota) = - let {Tezos_protocol_environment.max_size; max_op} = quota in - let exception Full of packed_operation list in - try - List.fold_left - (fun (curr_size, nb_ops, acc) op -> - let op_size = - Data_encoding.Binary.length Alpha_context.Operation.encoding op - in - let new_size = curr_size + op_size in - if new_size > max_size then (curr_size, nb_ops, acc) - else ( - Option.iter - (fun max_op -> if max_op = nb_ops + 1 then raise (Full acc)) - max_op ; - (new_size, nb_ops + 1, op :: acc))) - (0, 0, []) - ops - |> fun (_, _, l) -> List.rev l - with Full l -> List.rev l - -let filter_operations_without_simulation fees_config ~hard_gas_limit_per_block - {consensus; votes; anonymous; managers} = - let consensus = - filter_valid_operations_up_to_quota_without_simulation - (Prioritized_operation_set.operations consensus, consensus_quota) - in - let votes = - filter_valid_operations_up_to_quota_without_simulation - (Prioritized_operation_set.operations votes, votes_quota) - in - let anonymous = - filter_valid_operations_up_to_quota_without_simulation - (Prioritized_operation_set.operations anonymous, anonymous_quota) - in - let { - Baking_configuration.minimal_fees; - minimal_nanotez_per_gas_unit; - minimal_nanotez_per_byte; - } = - fees_config - in - (* Sort the managers *) - let prioritized_managers = - prioritize_managers - ~hard_gas_limit_per_block - ~minimal_fees - ~minimal_nanotez_per_gas_unit - ~minimal_nanotez_per_byte - managers - in - let managers = - filter_valid_operations_up_to_quota_without_simulation - ( PrioritizedManagerSet.elements prioritized_managers - |> List.map (fun {op; _} -> Prioritized_operation.packed op), - managers_quota ) - in - let operations = [consensus; votes; anonymous; managers] in - operations - -let filter_consensus_operations_only inc - ({consensus; votes; anonymous; managers} as ordered_pool) = - filter_valid_operations_up_to_quota inc (consensus, consensus_quota) - >>= fun (incremental, filtered_consensus) -> - let payload = Operation_pool.payload_of_ordered_pool ordered_pool in - List.fold_left_es - (fun inc op -> - Baking_simulator.add_operation inc op >>=? fun (inc, _) -> return inc) - incremental - (List.flatten [votes; anonymous; managers]) - >>=? fun incremental -> - let filtered_pool = - Operation_pool.ordered_pool_of_payload - ~consensus_operations:filtered_consensus - payload - in - return (incremental, filtered_pool) diff --git a/src/proto_017_PtNairob/lib_delegate/operation_selection.mli b/src/proto_017_PtNairob/lib_delegate/operation_selection.mli deleted file mode 100644 index d83fd0dda258c5c7017567d9cabe24a2e98a714e..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/operation_selection.mli +++ /dev/null @@ -1,71 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 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 -open Alpha_context -open Tezos_protocol_environment - -type simulation_result = { - validation_result : validation_result option; - block_header_metadata : Apply_results.block_metadata option; - operations : packed_operation list list; - operations_hash : Operation_list_list_hash.t; -} - -(** [filter_operations_with_simulation incremental fees_config - ~hard_gas_limit_per_block ops] tries to validate prioritized operations (and - apply them if [incremental] has been initialised with an - [application_state]) and filter them regarding the quota of each validation - pass. Manager operations are prioritized based on a weight computed from - their fees/gas/bytes. [filter_operations_with_simulation] function returns a - [simulation_result], containing the validated operation, their resulting - [operations_hash], optional [validation_result] and [block_header_metadata] - if the operations were applied. *) -val filter_operations_with_simulation : - Baking_simulator.incremental -> - Baking_configuration.fees_config -> - hard_gas_limit_per_block:Gas.Arith.integral -> - Operation_pool.Prioritized.t -> - simulation_result tzresult Lwt.t - -(** [filter_operations_without_simulation fees_config ~hard_gas_limit_per_block - ops] is similar to [filter_operations_with_simulation] but does not validate - (and apply) operations from [ops] and returns only the operations instead of - a [simulation_result]. - - Hypothesis: operations from [ops] have previously been validated. *) -val filter_operations_without_simulation : - Baking_configuration.fees_config -> - hard_gas_limit_per_block:Gas.Arith.integral -> - Operation_pool.Prioritized.t -> - packed_operation list list - -(** [filter_consensus_operations_only incremental ops] is similar to - [filter_operations_with_simulation] but only filters consensus operations - from [ops]. *) -val filter_consensus_operations_only : - Baking_simulator.incremental -> - Operation_pool.ordered_pool -> - (Baking_simulator.incremental * Operation_pool.ordered_pool) tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_delegate/operation_worker.ml b/src/proto_017_PtNairob/lib_delegate/operation_worker.ml deleted file mode 100644 index 04cb5d00f033f94e3724a405bcaaee07b536df50..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/operation_worker.ml +++ /dev/null @@ -1,600 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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_client_context -open Protocol -open Alpha_context - -module Events = struct - include Internal_event.Simple - - let section = [Protocol.name; "baker"; "operation_worker"] - - let pp_int = Format.pp_print_int - - let loop_failed = - declare_1 - ~section - ~name:"loop_failed" - ~level:Error - ~msg:"loop failed with {trace}" - ~pp1:Error_monad.pp_print_trace - ("trace", Error_monad.trace_encoding) - - let ended = - declare_1 - ~section - ~name:"ended" - ~level:Error - ~msg:"ended with error {stacktrace}" - ("stacktrace", Data_encoding.string) - - let pqc_reached = - declare_2 - ~section - ~name:"pqc_reached" - ~level:Debug - ~msg: - "prequorum reached (voting power: {voting_power}, {preendorsements} \ - preendorsements)" - ~pp1:pp_int - ("voting_power", Data_encoding.int31) - ~pp2:pp_int - ("preendorsements", Data_encoding.int31) - - let preendorsements_received = - declare_4 - ~section - ~name:"preendorsements_received" - ~level:Debug - ~msg: - "received {count} preendorsements (power: {delta_power}) (total voting \ - power: {voting_power}, {preendorsements} preendorsements)" - ~pp1:pp_int - ("count", Data_encoding.int31) - ~pp2:pp_int - ("delta_power", Data_encoding.int31) - ~pp3:pp_int - ("voting_power", Data_encoding.int31) - ~pp4:pp_int - ("preendorsements", Data_encoding.int31) - - let qc_reached = - declare_2 - ~section - ~name:"qc_reached" - ~level:Debug - ~msg: - "quorum reached (voting power: {voting_power}, {endorsements} \ - endorsements)" - ~pp1:pp_int - ("voting_power", Data_encoding.int31) - ~pp2:pp_int - ("endorsements", Data_encoding.int31) - - let endorsements_received = - declare_4 - ~section - ~name:"endorsements_received" - ~level:Debug - ~msg: - "received {count} endorsements (power: {delta_power}) (total voting \ - power: {voting_power}, {endorsements} endorsements)" - ~pp1:pp_int - ("count", Data_encoding.int31) - ~pp2:pp_int - ("delta_power", Data_encoding.int31) - ~pp3:pp_int - ("voting_power", Data_encoding.int31) - ~pp4:pp_int - ("endorsements", Data_encoding.int31) - - let starting_new_monitoring = - declare_0 - ~section - ~name:"starting_new_monitoring" - ~level:Debug - ~msg:"starting new monitoring" - () - - let end_of_stream = - declare_0 - ~section - ~name:"end_of_stream" - ~level:Debug - ~msg:"end of stream" - () - - (* info messages *) - let shutting_down = - declare_0 - ~section - ~name:"shutting_down" - ~level:Info - ~msg:"shutting down operation worker" - () -end - -type candidate = { - hash : Block_hash.t; - round_watched : Round.t; - payload_hash_watched : Block_payload_hash.t; -} - -let candidate_encoding = - let open Data_encoding in - conv - (fun {hash; round_watched; payload_hash_watched} -> - (hash, round_watched, payload_hash_watched)) - (fun (hash, round_watched, payload_hash_watched) -> - {hash; round_watched; payload_hash_watched}) - (obj3 - (req "hash" Block_hash.encoding) - (req "round_watched" Round.encoding) - (req "payload_hash_watched" Block_payload_hash.encoding)) - -type event = - | Prequorum_reached of candidate * Kind.preendorsement operation list - | Quorum_reached of candidate * Kind.endorsement operation list - -let compare_consensus_contents (op1 : consensus_content) - (op2 : consensus_content) = - Compare.or_else (Raw_level.compare op1.level op2.level) @@ fun () -> - Compare.or_else (Round.compare op1.round op2.round) @@ fun () -> - Compare.or_else (Slot.compare op1.slot op2.slot) @@ fun () -> - Block_payload_hash.compare op1.block_payload_hash op2.block_payload_hash - -module Preendorsement_set = Set.Make (struct - type t = Kind.preendorsement operation - - let compare - ({protocol_data = {contents = Single (Preendorsement op1); _}; shell = _} : - t) - ({protocol_data = {contents = Single (Preendorsement op2); _}; shell = _} : - t) = - compare_consensus_contents op1 op2 -end) - -module Endorsement_set = Set.Make (struct - type t = Kind.endorsement operation - - let compare - ({protocol_data = {contents = Single (Endorsement op1); _}; shell = _} : - t) - ({protocol_data = {contents = Single (Endorsement op2); _}; shell = _} : - t) = - compare_consensus_contents op1 op2 -end) - -type pqc_watched = { - candidate_watched : candidate; - get_slot_voting_power : slot:Slot.t -> int option; - consensus_threshold : int; - mutable current_voting_power : int; - mutable preendorsements_received : Preendorsement_set.t; - mutable preendorsements_count : int; -} - -type qc_watched = { - candidate_watched : candidate; - get_slot_voting_power : slot:Slot.t -> int option; - consensus_threshold : int; - mutable current_voting_power : int; - mutable endorsements_received : Endorsement_set.t; - mutable endorsements_count : int; -} - -type watch_kind = Pqc_watch of pqc_watched | Qc_watch of qc_watched - -type quorum_event_stream = { - stream : event Lwt_stream.t; - push : event option -> unit; -} - -type t = { - mutable operation_pool : Operation_pool.pool; - mutable canceler : Lwt_canceler.t; - mutable proposal_watched : watch_kind option; - qc_event_stream : quorum_event_stream; - lock : Lwt_mutex.t; - monitor_node_operations : bool; (* Keep on monitoring node operations *) -} - -let monitor_operations (cctxt : #Protocol_client_context.full) = - Alpha_block_services.Mempool.monitor_operations - cctxt - ~chain:cctxt#chain - ~validated:true - ~branch_delayed:true - ~branch_refused:false - ~refused:false - () - >>=? fun (operation_stream, stream_stopper) -> - let operation_stream = - Lwt_stream.map - (fun ops -> List.map (fun ((_, op), _) -> op) ops) - operation_stream - in - Shell_services.Blocks.Header.shell_header - cctxt - ~chain:cctxt#chain - ~block:(`Head 0) - () - >>=? fun shell_header -> - let round = - match Fitness.(round_from_raw shell_header.fitness) with - | Ok r -> r - | Error _ -> Round.zero - in - return ((shell_header.level, round), operation_stream, stream_stopper) - -let make_initial_state ?(monitor_node_operations = true) () = - let qc_event_stream = - let stream, push = Lwt_stream.create () in - {stream; push} - in - let canceler = Lwt_canceler.create () in - let operation_pool = Operation_pool.empty in - let lock = Lwt_mutex.create () in - { - operation_pool; - canceler; - proposal_watched = None; - qc_event_stream; - lock; - monitor_node_operations; - } - -let is_valid_consensus_content (candidate : candidate) consensus_content = - let {hash = _; round_watched; payload_hash_watched} = candidate in - Round.equal consensus_content.round round_watched - && Block_payload_hash.equal - consensus_content.block_payload_hash - payload_hash_watched - -let cancel_monitoring state = state.proposal_watched <- None - -let reset_monitoring state = - Lwt_mutex.with_lock state.lock @@ fun () -> - match state.proposal_watched with - | None -> Lwt.return_unit - | Some (Pqc_watch pqc_watched) -> - pqc_watched.current_voting_power <- 0 ; - pqc_watched.preendorsements_count <- 0 ; - pqc_watched.preendorsements_received <- Preendorsement_set.empty ; - Lwt.return_unit - | Some (Qc_watch qc_watched) -> - qc_watched.current_voting_power <- 0 ; - qc_watched.endorsements_count <- 0 ; - qc_watched.endorsements_received <- Endorsement_set.empty ; - Lwt.return_unit - -let update_monitoring ?(should_lock = true) state ops = - (if should_lock then Lwt_mutex.with_lock state.lock else fun f -> f ()) - @@ fun () -> - (* If no block is watched, don't do anything *) - match state.proposal_watched with - | None -> Lwt.return_unit - | Some - (Pqc_watch - ({ - candidate_watched; - get_slot_voting_power; - consensus_threshold; - preendorsements_received; - _; - } as proposal_watched)) -> - let preendorsements = Operation_pool.filter_preendorsements ops in - let preendorsements = - List.filter - (fun new_preendo -> - not (Preendorsement_set.mem new_preendo preendorsements_received)) - preendorsements - in - let preendorsements_count, voting_power = - List.fold_left - (fun (count, power) (op : Kind.preendorsement Operation.t) -> - let { - shell = _; - protocol_data = - {contents = Single (Preendorsement consensus_content); _}; - _; - } = - op - in - if is_valid_consensus_content candidate_watched consensus_content - then - match get_slot_voting_power ~slot:consensus_content.slot with - | Some op_power -> - proposal_watched.preendorsements_received <- - Preendorsement_set.add - op - proposal_watched.preendorsements_received ; - (succ count, power + op_power) - | None -> - (* preendorsements that do not use the first slot of a - delegate are not added to the quorum *) - (count, power) - else (count, power)) - (0, 0) - preendorsements - in - proposal_watched.current_voting_power <- - proposal_watched.current_voting_power + voting_power ; - proposal_watched.preendorsements_count <- - proposal_watched.preendorsements_count + preendorsements_count ; - if proposal_watched.current_voting_power >= consensus_threshold then ( - Events.( - emit - pqc_reached - ( proposal_watched.current_voting_power, - proposal_watched.preendorsements_count )) - >>= fun () -> - state.qc_event_stream.push - (Some - (Prequorum_reached - ( candidate_watched, - Preendorsement_set.elements - proposal_watched.preendorsements_received ))) ; - (* Once the event has been emitted, we cancel the monitoring *) - cancel_monitoring state ; - Lwt.return_unit) - else - Events.( - emit - preendorsements_received - ( preendorsements_count, - voting_power, - proposal_watched.current_voting_power, - proposal_watched.preendorsements_count )) - | Some - (Qc_watch - ({ - candidate_watched; - get_slot_voting_power; - consensus_threshold; - endorsements_received; - _; - } as proposal_watched)) -> - let endorsements = Operation_pool.filter_endorsements ops in - let endorsements = - List.filter - (fun new_endo -> - not (Endorsement_set.mem new_endo endorsements_received)) - endorsements - in - let endorsements_count, voting_power = - List.fold_left - (fun (count, power) (op : Kind.endorsement Operation.t) -> - let { - shell = _; - protocol_data = - {contents = Single (Endorsement consensus_content); _}; - _; - } = - op - in - if is_valid_consensus_content candidate_watched consensus_content - then - match get_slot_voting_power ~slot:consensus_content.slot with - | Some op_power -> - proposal_watched.endorsements_received <- - Endorsement_set.add - op - proposal_watched.endorsements_received ; - (succ count, power + op_power) - | None -> - (* endorsements that do not use the first slot of a delegate - are not added to the quorum *) - (count, power) - else (count, power)) - (0, 0) - endorsements - in - proposal_watched.current_voting_power <- - proposal_watched.current_voting_power + voting_power ; - proposal_watched.endorsements_count <- - proposal_watched.endorsements_count + endorsements_count ; - if proposal_watched.current_voting_power >= consensus_threshold then ( - Events.( - emit - qc_reached - ( proposal_watched.current_voting_power, - proposal_watched.endorsements_count )) - >>= fun () -> - state.qc_event_stream.push - (Some - (Quorum_reached - ( candidate_watched, - Endorsement_set.elements - proposal_watched.endorsements_received ))) ; - (* Once the event has been emitted, we cancel the monitoring *) - cancel_monitoring state ; - Lwt.return_unit) - else - Events.( - emit - endorsements_received - ( endorsements_count, - voting_power, - proposal_watched.current_voting_power, - proposal_watched.endorsements_count )) - -let monitor_quorum state new_proposal_watched = - Lwt_mutex.with_lock state.lock @@ fun () -> - (* if a previous monitoring was registered, we cancel it *) - if state.proposal_watched <> None then cancel_monitoring state ; - state.proposal_watched <- new_proposal_watched ; - let current_consensus_operations = - Operation_pool.Operation_set.elements state.operation_pool.consensus - in - (* initialize with the currently present consensus operations *) - update_monitoring ~should_lock:false state current_consensus_operations - -let monitor_preendorsement_quorum state ~consensus_threshold - ~get_slot_voting_power candidate_watched = - let new_proposal = - Some - (Pqc_watch - { - candidate_watched; - get_slot_voting_power; - consensus_threshold; - current_voting_power = 0; - preendorsements_received = Preendorsement_set.empty; - preendorsements_count = 0; - }) - in - monitor_quorum state new_proposal - -let monitor_endorsement_quorum state ~consensus_threshold ~get_slot_voting_power - candidate_watched = - let new_proposal = - Some - (Qc_watch - { - candidate_watched; - get_slot_voting_power; - consensus_threshold; - current_voting_power = 0; - endorsements_received = Endorsement_set.empty; - endorsements_count = 0; - }) - in - monitor_quorum state new_proposal - -let shutdown_worker state = - Events.(emit shutting_down ()) >>= fun () -> - Lwt_canceler.cancel state.canceler - -(* Each time a new head is received, the operation_pool field of the state is - cleaned/reset by this function. Instead of emptying it completely, we keep - the endorsements of at most 5 rounds and 1 level in the past, to be able to - include as much endorsements as possible in the next block if this baker is - the proposer. This allows to handle the following situations: - - - The baker observes an EQC for (L, R), but a proposal arrived for (L, R+1). - After the flush, extra endorsements on top of (L, R) are 'Branch_refused', - and are not re-sent by the node. If the baker proposes at (L+1, 1), he should - be able to include these extra endorsements. Hence the cache for old rounds. - - - The baker receives a head at (L+1, 0) on top of (L, 0), but this head - didn't reach consensus. If the baker who proposes at (L+1, 1) observed some - extra endorsements for (L, 0) that are not included in (L+1, 0), he may want - to add them. But these endorsements become 'Outdated' in the mempool once - (L+1, 0) is received. Hence the cache for previous level. -*) -let update_operations_pool state (head_level, head_round) = - let endorsements = - let head_round_i32 = Round.to_int32 head_round in - let head_level_i32 = head_level in - Operation_pool.Operation_set.filter - (function - | { - protocol_data = - Operation_data - {contents = Single (Endorsement {round; level; _}); _}; - _; - } -> - let round_i32 = Round.to_int32 round in - let level_i32 = Raw_level.to_int32 level in - let delta_round = Int32.sub head_round_i32 round_i32 in - let delta_level = Int32.sub head_level_i32 level_i32 in - (* Only retain endorsements that are maximum 5 rounds old and - 1 level in the last *) - Compare.Int32.(delta_round <= 5l && delta_level <= 1l) - | _ -> false) - state.operation_pool.consensus - in - let operation_pool = {Operation_pool.empty with consensus = endorsements} in - state.operation_pool <- operation_pool - -let create ?(monitor_node_operations = true) - (cctxt : #Protocol_client_context.full) = - let state = make_initial_state ~monitor_node_operations () in - (* TODO should we continue forever ? *) - let rec worker_loop () = - monitor_operations cctxt >>= function - | Error err -> Events.(emit loop_failed err) - | Ok (head, operation_stream, op_stream_stopper) -> - Events.(emit starting_new_monitoring ()) >>= fun () -> - state.canceler <- Lwt_canceler.create () ; - Lwt_canceler.on_cancel state.canceler (fun () -> - op_stream_stopper () ; - cancel_monitoring state ; - Lwt.return_unit) ; - update_operations_pool state head ; - let rec loop () = - Lwt_stream.get operation_stream >>= function - | None -> - (* When the stream closes, it means a new head has been set, - we reset the monitoring and flush current operations *) - Events.(emit end_of_stream ()) >>= fun () -> - op_stream_stopper () ; - reset_monitoring state >>= fun () -> worker_loop () - | Some ops -> - state.operation_pool <- - Operation_pool.add_operations state.operation_pool ops ; - update_monitoring state ops >>= fun () -> loop () - in - loop () - in - Lwt.dont_wait - (fun () -> - Lwt.finalize - (fun () -> - if state.monitor_node_operations then worker_loop () - else Lwt.return_unit) - (fun () -> shutdown_worker state >>= fun _ -> Lwt.return_unit)) - (fun exn -> - Events.(emit__dont_wait__use_with_care ended (Printexc.to_string exn))) ; - Lwt.return state - -let retrieve_pending_operations cctxt state = - let open Protocol_client_context in - Alpha_block_services.Mempool.pending_operations - cctxt - ~chain:cctxt#chain - ~validated:true - ~branch_delayed:true - ~branch_refused:false - ~refused:false - ~outdated:false - () - >>=? fun pending_mempool -> - state.operation_pool <- - Operation_pool.add_operations state.operation_pool - @@ List.rev_map snd pending_mempool.validated ; - state.operation_pool <- - Operation_pool.add_operations - state.operation_pool - (List.rev_map - (fun (_, (op, _)) -> op) - (Operation_hash.Map.bindings pending_mempool.branch_delayed)) ; - return_unit - -let get_current_operations state = state.operation_pool - -let get_quorum_event_stream state = state.qc_event_stream.stream diff --git a/src/proto_017_PtNairob/lib_delegate/operation_worker.mli b/src/proto_017_PtNairob/lib_delegate/operation_worker.mli deleted file mode 100644 index b62caa996da2472930610566d64081fecb754b8c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/operation_worker.mli +++ /dev/null @@ -1,88 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Launch processes to gather operations from the mempool and make them - available for the baker. *) - -open Protocol -open Alpha_context - -(** {1 Datatypes}*) - -type t - -type candidate = { - hash : Block_hash.t; - round_watched : Round.t; - payload_hash_watched : Block_payload_hash.t; -} - -val candidate_encoding : candidate Data_encoding.t - -type event = - | Prequorum_reached of candidate * Kind.preendorsement operation list - | Quorum_reached of candidate * Kind.endorsement operation list - -(** {1 Constructors}*) - -(** [create ?monitor_node_operations cctxt] creates a monitoring process to - fetch operations for the baker to process. - - @param monitor_node_operations monitor operations on the node (defaults: - [true]). Set [monitor_node_operations] to [false] to only consider - externally provided (non-node) operations. *) -val create : - ?monitor_node_operations:bool -> #Protocol_client_context.full -> t Lwt.t - -(** {1 Utilities} *) - -val retrieve_pending_operations : - #Protocol_client_context.full -> t -> unit tzresult Lwt.t - -(** {1 Accessors}*) - -val get_current_operations : t -> Operation_pool.pool - -val get_quorum_event_stream : t -> event Lwt_stream.t - -(** {1 Observers} *) - -val monitor_preendorsement_quorum : - t -> - consensus_threshold:int -> - get_slot_voting_power:(slot:Slot.t -> int option) -> - candidate -> - unit Lwt.t - -val monitor_endorsement_quorum : - t -> - consensus_threshold:int -> - get_slot_voting_power:(slot:Slot.t -> int option) -> - candidate -> - unit Lwt.t - -val cancel_monitoring : t -> unit - -val shutdown_worker : t -> (unit, exn list) result Lwt.t diff --git a/src/proto_017_PtNairob/lib_delegate/state_transitions.ml b/src/proto_017_PtNairob/lib_delegate/state_transitions.ml deleted file mode 100644 index f617795f9b91fa1670ad43c81748401cc6cea96e..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/state_transitions.ml +++ /dev/null @@ -1,979 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context -open Baking_state -open Baking_actions -module Events = Baking_events.State_transitions - -let do_nothing state = Lwt.return (state, Do_nothing) - -type proposal_acceptance = Invalid | Outdated_proposal | Valid_proposal - -let is_acceptable_proposal_for_current_level state - (proposal : Baking_state.proposal) = - let current_round = state.round_state.current_round in - if Round.(current_round < proposal.block.round) then - Events.( - emit unexpected_proposal_round (current_round, proposal.block.round)) - >>= fun () -> Lwt.return Invalid - else if Round.(current_round > proposal.block.round) then - Lwt.return Outdated_proposal - else - (* current_round = proposal.round *) - let previous_proposal = state.level_state.latest_proposal in - if - Round.(proposal.block.round = previous_proposal.block.round) - && Block_hash.(proposal.block.hash <> previous_proposal.block.hash) - && Block_hash.( - proposal.predecessor.hash = previous_proposal.predecessor.hash) - then - (* An existing proposal was found at the same round: the - proposal is bad and should be punished by the accuser *) - Events.( - emit - proposal_for_round_already_seen - (proposal.block.hash, current_round, previous_proposal.block.hash)) - >>= fun () -> Lwt.return Invalid - else - (* current_round = proposal.block.round ∧ - proposal.block.round <> previous_proposal.block.round - => - proposal.block.round > previous_proposal.block.round - - The proposal has the expected round and the previous proposal - is a predecessor therefore the proposal is valid *) - Lwt.return Valid_proposal - -let make_consensus_list state proposal = - (* TODO efficiently iterate on the slot map instead of removing - duplicate endorsements *) - let level = - Raw_level.of_int32 state.level_state.current_level |> function - | Ok l -> l - | _ -> assert false - in - let round = proposal.block.round in - let block_payload_hash = proposal.block.payload_hash in - SlotMap.fold - (fun _slot (consensus_key_and_delegate, slots) acc -> - ( consensus_key_and_delegate, - {slot = slots.first_slot; level; round; block_payload_hash} ) - :: acc) - state.level_state.delegate_slots.own_delegate_slots - [] - |> List.sort_uniq compare - -(* If we do not have any slots, we won't inject any operation but we - will still participate to determine an elected block *) -let make_preendorse_action state proposal = - let preendorsements : (consensus_key_and_delegate * consensus_content) list = - make_consensus_list state proposal - in - Inject_preendorsements {preendorsements} - -let update_proposal ~is_proposal_applied state proposal = - Events.(emit updating_latest_proposal proposal.block.hash) >>= fun () -> - let prev_proposal = state.level_state.latest_proposal in - let is_latest_proposal_applied = - (* mark as applied if it is indeed applied or if this specific proposal was - already marked as applied *) - is_proposal_applied - || prev_proposal.block.hash = proposal.block.hash - && state.level_state.is_latest_proposal_applied - in - let new_level_state = - { - state.level_state with - is_latest_proposal_applied; - latest_proposal = proposal; - } - in - Lwt.return {state with level_state = new_level_state} - -let may_update_proposal ~is_proposal_applied state (proposal : proposal) = - assert ( - Compare.Int32.( - state.level_state.latest_proposal.block.shell.level - = proposal.block.shell.level)) ; - if - Round.(state.level_state.latest_proposal.block.round < proposal.block.round) - then update_proposal ~is_proposal_applied state proposal - else Lwt.return state - -let preendorse state proposal = - if Baking_state.is_first_block_in_protocol proposal then - (* We do not preendorse the first transition block *) - let new_state = update_current_phase state Idle in - Lwt.return (new_state, Do_nothing) - else - Events.(emit attempting_preendorse_proposal proposal.block.hash) - >>= fun () -> - let new_state = - (* We have detected a new proposal that needs to be preattested. - We switch to the `Awaiting_preendorsements` phase. *) - update_current_phase state Awaiting_preendorsements - in - Lwt.return (new_state, make_preendorse_action state proposal) - -let extract_pqc state (new_proposal : proposal) = - match new_proposal.block.prequorum with - | None -> None - | Some pqc -> - let add_voting_power acc (op : Kind.preendorsement Operation.t) = - let open Protocol.Alpha_context.Operation in - let { - shell = _; - protocol_data = {contents = Single (Preendorsement {slot; _}); _}; - _; - } = - op - in - match - SlotMap.find slot state.level_state.delegate_slots.all_delegate_slots - with - | None -> - (* cannot happen if the map is correctly populated *) - acc - | Some {endorsing_power; _} -> acc + endorsing_power - in - let voting_power = - List.fold_left add_voting_power 0 pqc.preendorsements - in - let consensus_threshold = - state.global_state.constants.parametric.consensus_threshold - in - if Compare.Int.(voting_power >= consensus_threshold) then - Some (pqc.preendorsements, pqc.round) - else None - -let may_update_endorsable_payload_with_internal_pqc state - (new_proposal : proposal) = - match - (new_proposal.block.prequorum, state.level_state.endorsable_payload) - with - | None, _ -> - (* The proposal does not contain a PQC: no need to update *) - state - | Some {round = new_round; _}, Some {prequorum = {round = old_round; _}; _} - when Round.(new_round < old_round) -> - (* The proposal pqc is outdated, do not update *) - state - | Some better_prequorum, _ -> - assert ( - Block_payload_hash.( - better_prequorum.block_payload_hash = new_proposal.block.payload_hash)) ; - assert ( - Compare.Int32.(better_prequorum.level = new_proposal.block.shell.level)) ; - let new_endorsable_payload = - Some {proposal = new_proposal; prequorum = better_prequorum} - in - let new_level_state = - {state.level_state with endorsable_payload = new_endorsable_payload} - in - {state with level_state = new_level_state} - -let may_update_is_latest_proposal_applied ~is_proposal_applied state - new_proposal = - let current_proposal = state.level_state.latest_proposal in - if - is_proposal_applied - && Block_hash.(current_proposal.block.hash = new_proposal.block.hash) - then - let new_level_state = - {state.level_state with is_latest_proposal_applied = true} - in - let new_state = {state with level_state = new_level_state} in - new_state - else state - -let has_already_been_handled state new_proposal = - let current_proposal = state.level_state.latest_proposal in - Block_hash.(current_proposal.block.hash = new_proposal.block.hash) - && state.level_state.is_latest_proposal_applied - -let rec handle_proposal ~is_proposal_applied state (new_proposal : proposal) = - (* TODO: https://gitlab.com/tezos/tezos/-/issues/6648 - Do not handle proposals that have been applied already. - *) - (* We need to avoid to send preendorsements, if we are in phases were - preendorsements have been sent already. This is needed to avoid switching - back from Awaiting_endorsements to Awaiting_preendorsements. *) - let may_preendorse state proposal = - match state.round_state.current_phase with - | Idle -> preendorse state proposal - | _ -> do_nothing state - in - - let current_level = state.level_state.current_level in - let new_proposal_level = new_proposal.block.shell.level in - let current_proposal = state.level_state.latest_proposal in - let state = - may_update_is_latest_proposal_applied - ~is_proposal_applied - state - new_proposal - in - if Compare.Int32.(current_level > new_proposal_level) then - (* The baker is ahead, a reorg may have happened. Do nothing: - wait for the node to send us the branch's head. This new head - should have a fitness that is greater than our current - proposal and thus, its level should be at least the same as - our current proposal's level. *) - Events.(emit baker_is_ahead_of_node (current_level, new_proposal_level)) - >>= fun () -> do_nothing state - else if Compare.Int32.(current_level = new_proposal_level) then - if - (* The received head is a new proposal for the current level: - let's check if it's a valid one for us. *) - Block_hash.( - current_proposal.predecessor.hash <> new_proposal.predecessor.hash) - then - Events.( - emit - new_proposal_is_on_another_branch - (current_proposal.predecessor.hash, new_proposal.predecessor.hash)) - >>= fun () -> may_switch_branch ~is_proposal_applied state new_proposal - else - is_acceptable_proposal_for_current_level state new_proposal >>= function - | Invalid -> - (* The proposal is invalid: we ignore it *) - Events.(emit skipping_invalid_proposal ()) >>= fun () -> - do_nothing state - | Outdated_proposal -> - (* Check whether we need to update our endorsable payload *) - let state = - may_update_endorsable_payload_with_internal_pqc state new_proposal - in - (* The proposal is outdated: we update to be able to extract - its included endorsements but we do not endorse it *) - Events.(emit outdated_proposal new_proposal.block.hash) >>= fun () -> - may_update_proposal ~is_proposal_applied state new_proposal - >>= fun state -> do_nothing state - | Valid_proposal -> ( - (* Valid_proposal => proposal.round = current_round *) - (* Check whether we need to update our endorsable payload *) - let new_state = - may_update_endorsable_payload_with_internal_pqc state new_proposal - in - may_update_proposal ~is_proposal_applied new_state new_proposal - >>= fun new_state -> - (* The proposal is valid but maybe we already locked on a payload *) - match new_state.level_state.locked_round with - | Some locked_round -> ( - if - Block_payload_hash.( - locked_round.payload_hash = new_proposal.block.payload_hash) - then - (* when the new head has the same payload as our - [locked_round], we accept it and preendorse *) - may_preendorse new_state new_proposal - else - (* The payload is different *) - match new_proposal.block.prequorum with - | Some {round; _} when Round.(locked_round.round < round) -> - (* This PQC is above our locked_round, we can preendorse it *) - may_preendorse new_state new_proposal - | _ -> - (* We shouldn't preendorse this proposal, but we - should at least watch (pre)quorums events on it - but only when it is applied otherwise we await - for the proposal to be applied. *) - let new_state = - update_current_phase new_state Awaiting_preendorsements - in - Lwt.return (new_state, Watch_proposal)) - | None -> - (* Otherwise, we did not lock on any payload, thus we can - preendorse it *) - may_preendorse new_state new_proposal) - else - (* Last case: new_proposal_level > current_level *) - (* Possible scenarios: - - we received a block for a next level - - we received our own block - This is where we update our [level_state] (and our [round_state]) *) - Events.(emit new_head_with_increasing_level ()) >>= fun () -> - let new_level = new_proposal.block.shell.level in - let compute_new_state ~current_round ~delegate_slots - ~next_level_delegate_slots = - let round_state = - {current_round; current_phase = Idle; delayed_quorum = None} - in - let level_state = - { - current_level = new_level; - latest_proposal = new_proposal; - is_latest_proposal_applied = is_proposal_applied; - (* Unlock values *) - locked_round = None; - endorsable_payload = None; - elected_block = None; - delegate_slots; - next_level_delegate_slots; - next_level_proposed_round = None; - next_forged_block = None; - } - in - (* recursive call with the up-to-date state to handle the new - level proposals *) - handle_proposal - ~is_proposal_applied - {state with level_state; round_state} - new_proposal - in - let action = - Update_to_level {new_level_proposal = new_proposal; compute_new_state} - in - Lwt.return (state, action) - -and may_switch_branch ~is_proposal_applied state new_proposal = - let switch_branch state = - Events.(emit switching_branch ()) >>= fun () -> - (* If we are on a different branch, we also need to update our - [round_state] accordingly. - The recursive call to [handle_proposal] cannot end up - with an invalid proposal as it's on a different branch, thus - there is no need to backtrack to the former state as the new - proposal must end up being the new [latest_proposal]. That's - why we update it here. *) - let round_update = - { - Baking_actions.new_round_proposal = new_proposal; - handle_proposal = - (fun state -> handle_proposal ~is_proposal_applied state new_proposal); - } - in - update_proposal ~is_proposal_applied state new_proposal >>= fun new_state -> - (* TODO if the branch proposal is outdated, we should - trigger an [End_of_round] to participate *) - Lwt.return (new_state, Synchronize_round round_update) - in - let current_endorsable_payload = state.level_state.endorsable_payload in - match (current_endorsable_payload, new_proposal.block.prequorum) with - | None, Some _ | None, None -> - Events.(emit branch_proposal_has_better_fitness ()) >>= fun () -> - (* The new branch contains a PQC (and we do not) or a better - fitness, we switch. *) - switch_branch state - | Some _, None -> - (* We have a better PQC, we don't switch as we are able to - propose a better chain if we stay on our current one. *) - Events.(emit branch_proposal_has_no_prequorum ()) >>= fun () -> - do_nothing state - | Some {prequorum = current_pqc; _}, Some new_pqc -> - if Round.(current_pqc.round > new_pqc.round) then - Events.(emit branch_proposal_has_lower_prequorum ()) >>= fun () -> - (* The other's branch PQC is lower than ours, do not - switch *) - do_nothing state - else if Round.(current_pqc.round < new_pqc.round) then - Events.(emit branch_proposal_has_better_prequorum ()) >>= fun () -> - (* Their PQC is better than ours: we switch *) - switch_branch state - else - (* current_pqc.round = new_pqc *) - (* There is a PQC on two branches with the same round and - the same level but not the same predecessor : it's - impossible unless if there was some double-baking. This - shouldn't happen but do nothing anyway. *) - Events.(emit branch_proposal_has_same_prequorum ()) >>= fun () -> - do_nothing state - -(** In the association map [delegate_slots], the function returns an - optional pair ([delegate], [endorsing_slot]) if for the current - [round], the validator [delegate] has a endorsing slot. *) -let round_proposer state delegate_slots round = - (* TODO: make sure that for each slots all rounds in the map are filled *) - (* !FIXME! Endorsers and proposer are differents sets *) - (* !FIXME! the slotmap may be inconsistent & may sure to document - the invariants *) - let round_mod = - Int32.to_int (Round.to_int32 round) - mod state.global_state.constants.parametric.consensus_committee_size - in - SlotMap.find - state.level_state.delegate_slots.all_slots_by_round.(round_mod) - delegate_slots - -(* Create a fresh block proposal containing the current operations of - the mempool in [state] and the additional [attestations] and - [dal_attestations] for [delegate] at round [round]. *) -let prepare_block_to_bake ~endorsements ~dal_attestations ?last_proposal - ~(predecessor : block_info) state delegate round = - (* The block to bake embeds the operations gathered by the - worker. However, consensus operations that are not relevant for - this block are filtered out. In the case of proposing a new fresh - block, the block is supposed to carry only attestations for the - previous level. *) - let operation_pool = - (* 1. Fetch operations from the mempool. *) - let current_mempool = - let pool = - Operation_worker.get_current_operations - state.global_state.operation_worker - in - (* Considered the operations in the previous proposal as well *) - match last_proposal with - | Some proposal -> - let { - Operation_pool.votes_payload; - anonymous_payload; - managers_payload; - } = - proposal.payload - in - List.fold_left - Operation_pool.add_operations - pool - [votes_payload; anonymous_payload; managers_payload] - | None -> pool - in - (* 2. Filter and only retain relevant endorsements. *) - let relevant_consensus_operations = - let endorsement_filter = - { - Operation_pool.level = predecessor.shell.level; - round = predecessor.round; - payload_hash = predecessor.payload_hash; - } - in - Operation_pool.filter_with_relevant_consensus_ops - ~endorsement_filter - ~preendorsement_filter:None - current_mempool.consensus - in - let filtered_mempool = - {current_mempool with consensus = relevant_consensus_operations} - in - (* 3. Add the additional given [endorsements] and [dal_attestations]. - N.b. this is a set: there won't be duplicates *) - let pool = - Operation_pool.add_operations - filtered_mempool - (List.map Operation.pack endorsements) - in - Operation_pool.add_operations - pool - (List.map Operation.pack dal_attestations) - in - let kind = Fresh operation_pool in - Events.(emit preparing_fresh_block (delegate, round)) >>= fun () -> - let force_apply = - state.global_state.config.force_apply || Round.(round <> zero) - (* This is used as a safety net by applying blocks on round > 0, in case - validation-only did not produce a correct round-0 block. *) - in - Lwt.return {predecessor; round; delegate; kind; force_apply} - -let forge_fresh_block_action ~endorsements ~dal_attestations ?last_proposal - ~(predecessor : block_info) state delegate = - prepare_block_to_bake - ~endorsements - ~dal_attestations - ?last_proposal - ~predecessor - state - delegate - Round.zero - >>= fun block_to_bake -> - let updated_state = update_current_phase state Idle in - Lwt.return @@ Forge_block {block_to_bake; updated_state} - -(** Create an inject action that will inject either a fresh block or the pre-emptively - forged block if it exists. *) -let propose_fresh_block_action ~endorsements ~dal_attestations ?last_proposal - ~(predecessor : block_info) state delegate round = - (* TODO check if there is a trace where we could not have updated the level *) - (* let+ kind, updated_state = *) - (match state.level_state.next_forged_block with - | Some ({delegate; round; block_header = _; operations = _} as signed_block) - -> - Events.(emit no_need_forge_block (delegate, round)) >|= fun () -> - let updated_state = - { - state with - level_state = {state.level_state with next_forged_block = None}; - } - in - (Inject_only signed_block, updated_state) - | None -> - prepare_block_to_bake - ~endorsements - ~dal_attestations - ?last_proposal - ~predecessor - state - delegate - round - >|= fun block_to_bake -> (Forge_and_inject block_to_bake, state)) - >|= fun (kind, updated_state) -> - let updated_state = update_current_phase updated_state Idle in - Inject_block {kind; updated_state} - -let propose_block_action state delegate round (proposal : proposal) = - (* Possible cases: - 1. There was a proposal but the PQC was not reached. - 2. There was a proposal and the PQC was reached. We repropose the - [endorsable_payload] if it exists, not the [locked_round] as it - may be older. *) - match state.level_state.endorsable_payload with - | None -> - Events.(emit no_endorsable_payload_fresh_block ()) >>= fun () -> - (* For case 1, we may re-inject with the same payload or a fresh - one. We make the choice of baking a fresh one: the previous - proposal may have been rejected because the block may have been - valid but may be considered "bad" (censored operations, empty - block, etc.) by the other validators. *) - (* Invariant: there is no locked round if there is no endorsable - payload *) - assert (state.level_state.locked_round = None) ; - let endorsements_in_last_proposal = proposal.block.quorum in - (* Also insert the DAL attestations from the proposal, because the mempool - may not contain them anymore *) - (* TODO: https://gitlab.com/tezos/tezos/-/issues/4671 - The block may therefore contain multiple attestations for the same delegate. *) - let dal_attestations_in_last_proposal = proposal.block.dal_attestations in - propose_fresh_block_action - ~endorsements:endorsements_in_last_proposal - ~dal_attestations:dal_attestations_in_last_proposal - state - ~last_proposal:proposal.block - ~predecessor:proposal.predecessor - delegate - round - | Some {proposal; prequorum} -> - Events.(emit repropose_block proposal.block.payload_hash) >>= fun () -> - (* For case 2, we re-inject the same block as [endorsable_round] - but we may add some left-overs endorsements. Therefore, the - operations we need to include are: - - the proposal's included endorsements - - the potential missing new endorsements for the - previous block - - the PQC of the endorsable payload *) - let consensus_operations = - (* Fetch preendorsements and endorsements from the mempool - (that could be missing from the proposal), filter, then add - consensus operations of the proposal itself, and convert - into [packed_operation trace]. *) - let mempool_consensus_operations = - (Operation_worker.get_current_operations - state.global_state.operation_worker) - .consensus - in - let all_consensus_operations = - (* Add the proposal and pqc consensus operations to the - mempool *) - List.fold_left - (fun set op -> Operation_pool.Operation_set.add op set) - mempool_consensus_operations - (List.map Operation.pack proposal.block.quorum - @ List.map Operation.pack prequorum.preendorsements) - in - let endorsement_filter = - { - Operation_pool.level = proposal.predecessor.shell.level; - round = proposal.predecessor.round; - payload_hash = proposal.predecessor.payload_hash; - } - in - let preendorsement_filter = - Some - { - Operation_pool.level = prequorum.level; - round = prequorum.round; - payload_hash = prequorum.block_payload_hash; - } - in - Operation_pool.( - filter_with_relevant_consensus_ops - ~endorsement_filter - ~preendorsement_filter - all_consensus_operations - |> Operation_set.elements) - in - let payload_hash = proposal.block.payload_hash in - let payload_round = proposal.block.payload_round in - let payload = proposal.block.payload in - let kind = - Reproposal {consensus_operations; payload_hash; payload_round; payload} - in - let force_apply = - true - (* This is used as a safety net by applying blocks on round > 0, in case - validation-only did not produce a correct round-0 block. *) - in - let block_to_bake = - {predecessor = proposal.predecessor; round; delegate; kind; force_apply} - in - let updated_state = update_current_phase state Idle in - Lwt.return - @@ Inject_block {kind = Forge_and_inject block_to_bake; updated_state} - -let end_of_round state current_round = - let new_round = Round.succ current_round in - let new_round_state = {state.round_state with current_round = new_round} in - let new_state = {state with round_state = new_round_state} in - (* we need to check if we need to bake for this round or not *) - match - round_proposer - new_state - new_state.level_state.delegate_slots.own_delegate_slots - new_state.round_state.current_round - with - | None -> - Events.( - emit - no_proposal_slot - (current_round, state.level_state.current_level, new_round)) - >>= fun () -> - (* We don't have any delegate that may propose a new block for - this round -- We will wait for preendorsements when the next - level block arrive. Meanwhile, we are idle *) - let new_state = update_current_phase new_state Idle in - do_nothing new_state - | Some (delegate, _) -> - let latest_proposal = state.level_state.latest_proposal in - if Baking_state.is_first_block_in_protocol latest_proposal then - (* Do not inject a block for the previous protocol! (Let the - baker of the previous protocol do it.) *) - do_nothing new_state - else - Events.( - emit - proposal_slot - (current_round, state.level_state.current_level, new_round, delegate)) - >>= fun () -> - (* We have a delegate, we need to determine what to inject *) - propose_block_action - new_state - delegate - new_round - state.level_state.latest_proposal - >>= fun action -> Lwt.return (new_state, action) - -let time_to_forge_block state = - let at_round = Round.zero in - let round_proposer_opt = - round_proposer - state - state.level_state.next_level_delegate_slots.own_delegate_slots - at_round - in - match (state.level_state.elected_block, round_proposer_opt) with - | None, _ | _, None -> - (* Unreachable: the [Time_to_forge_Block] event can only be - triggered when we have a slot and an elected block *) - assert false - | Some elected_block, Some (delegate, _) -> - let endorsements = elected_block.endorsement_qc in - let dal_attestations = - (* Unlike proposal attestations, we don't watch and store DAL attestations for - each proposal, we'll retrieve them from the mempool *) - [] - in - forge_fresh_block_action - ~endorsements - ~dal_attestations - ~predecessor:elected_block.proposal.block - state - delegate - >|= fun action -> (state, action) - -let time_to_bake_at_next_level state at_round = - (* It is now time to update the state level *) - (* We need to keep track for which block we have 2f+1 *endorsements*, that is, - which will become the new predecessor_block *) - (* Invariant: endorsable_round >= round(elected block) >= locked_round *) - let round_proposer_opt = - round_proposer - state - state.level_state.next_level_delegate_slots.own_delegate_slots - at_round - in - match (state.level_state.elected_block, round_proposer_opt) with - | None, _ | _, None -> - (* Unreachable: the [Time_to_bake_next_level] event can only be - triggered when we have a slot and an elected block *) - assert false - | Some elected_block, Some (delegate, _) -> - let endorsements = elected_block.endorsement_qc in - let dal_attestations = - (* Unlike endorsements, we don't watch and store DAL attestations for - each proposal, we'll retrieve them from the mempool *) - [] - in - let new_level_state = - {state.level_state with next_level_proposed_round = Some at_round} - in - let new_state = {state with level_state = new_level_state} in - propose_fresh_block_action - ~endorsements - ~dal_attestations - ~predecessor:elected_block.proposal.block - new_state - delegate - at_round - >>= fun action -> Lwt.return (new_state, action) - -let update_locked_round state round payload_hash = - let locked_round = Some {payload_hash; round} in - let new_level_state = {state.level_state with locked_round} in - {state with level_state = new_level_state} - -let make_endorse_action state proposal = - let endorsements : (consensus_key_and_delegate * consensus_content) list = - make_consensus_list state proposal - in - Inject_endorsements {endorsements} - -let prequorum_reached_when_awaiting_preendorsements state candidate - preendorsements = - let latest_proposal = state.level_state.latest_proposal in - if Block_hash.(candidate.Operation_worker.hash <> latest_proposal.block.hash) - then - Events.( - emit - unexpected_prequorum_received - (candidate.hash, latest_proposal.block.hash)) - >>= fun () -> do_nothing state - else - let prequorum = - { - level = latest_proposal.block.shell.level; - round = latest_proposal.block.round; - block_payload_hash = latest_proposal.block.payload_hash; - preendorsements - (* preendorsements may be nil when [consensus_threshold] is 0 *); - } - in - let new_endorsable_payload = {proposal = latest_proposal; prequorum} in - let new_level_state = - let level_state_with_new_payload = - { - state.level_state with - endorsable_payload = Some new_endorsable_payload; - } - in - match state.level_state.endorsable_payload with - | None -> level_state_with_new_payload - | Some endorsable_payload -> - if - Round.( - endorsable_payload.prequorum.round - < new_endorsable_payload.prequorum.round) - then level_state_with_new_payload - else state.level_state - in - let new_state = {state with level_state = new_level_state} in - let new_state = - update_locked_round - new_state - latest_proposal.block.round - latest_proposal.block.payload_hash - in - let new_state = update_current_phase new_state Awaiting_endorsements in - Lwt.return (new_state, make_endorse_action new_state latest_proposal) - -let quorum_reached_when_waiting_endorsements state candidate endorsement_qc = - let latest_proposal = state.level_state.latest_proposal in - let is_latest_proposal_applied = - state.level_state.is_latest_proposal_applied - in - if Block_hash.(candidate.Operation_worker.hash <> latest_proposal.block.hash) - then - Events.( - emit - unexpected_quorum_received - (candidate.hash, latest_proposal.block.hash)) - >>= fun () -> do_nothing state - else - let new_round_state, new_level_state = - match state.level_state.elected_block with - | None when is_latest_proposal_applied -> - (* The elected proposal has been applied. Record the elected block - and transition to the Idle phase, as there is nothing left to do. - *) - let elected_block = - Some {proposal = latest_proposal; endorsement_qc} - in - let new_level_state = {state.level_state with elected_block} in - let new_round_state = {state.round_state with current_phase = Idle} in - (new_round_state, new_level_state) - | None -> - (* A quorum has been reached, but the elected proposal has not been - applied yet by the node. Transition in the `Awaiting_application` - phase, and do not save the elected block in the state. Instead, - keep track that an early quorum has been reached at this round. - This avoids the proposer of a block at the next level to inject a - proposal before the node has been applied the proposal elected at - the current level. *) - let new_round_state = - { - state.round_state with - current_phase = Awaiting_application; - delayed_quorum = Some endorsement_qc; - } - in - (new_round_state, state.level_state) - | Some _ -> - (* If we already have an elected block, do not update it: the - earlier, the better. We do not need to record the quorum either, - as this won't be used to elect a new block. *) - (state.round_state, state.level_state) - in - let new_state = - {state with round_state = new_round_state; level_state = new_level_state} - in - do_nothing new_state - -let handle_expected_applied_proposal (state : Baking_state.t) = - (* This code is triggered only when in the `Awaiting_application`phase, which - in turn is reached only if a quorum has been met but the - block has not been applied by the node. As a consequence, the only - thing that is left to do at this stage is to update the elected block - and transition to the Idle phase, as there is nothing left to do. *) - let new_level_state = - {state.level_state with is_latest_proposal_applied = true} - in - let new_state = {state with level_state = new_level_state} in - let new_state = - match new_state.level_state.elected_block with - | None -> - (* We do not have an elected block for this level. We need to update it. *) - let latest_proposal = state.level_state.latest_proposal in - let endorsement_qc = - match state.round_state.delayed_quorum with - | None -> assert false - | Some endorsement_qc -> endorsement_qc - in - let elected_block = Some {proposal = latest_proposal; endorsement_qc} in - let new_level_state = {state.level_state with elected_block} in - (* The application arrived before the prequorum: just wait for the prequorum. *) - {state with level_state = new_level_state} - | Some _ -> - (* We already have an elected block at this level. We do not need to update - it. The earlier, the better. *) - new_state - in - let new_state = update_current_phase new_state Idle in - do_nothing new_state - -(* Hypothesis: - - The state is not to be modified outside this module - (NB: there are exceptions in Baking_actions: the corner cases - [update_to_level] and [synchronize_round] and - the hack used by [inject_block]) - - - new_proposal's received blocks are expected to belong to our current - round - - - [Prequorum_reached] can only be received when we've seen a new head - - - [Quorum_reached] can only be received when we've seen a - [Prequorum_reached] *) -let step (state : Baking_state.t) (event : Baking_state.event) : - (Baking_state.t * Baking_actions.t) Lwt.t = - let phase = state.round_state.current_phase in - Events.(emit step_current_phase (phase, event)) >>= fun () -> - match (phase, event) with - (* Handle timeouts *) - | _, Timeout (End_of_round {ending_round}) -> - (* If the round is ending, stop everything currently going on and - increment the round. *) - end_of_round state ending_round - | _, Timeout (Time_to_bake_next_level {at_round}) -> - (* If it is time to bake the next level, stop everything currently - going on and propose the next level block *) - time_to_bake_at_next_level state at_round - | _, Timeout Time_to_forge_block -> time_to_forge_block state - | Idle, New_head_proposal proposal -> - Events.( - emit - new_head - (proposal.block.hash, proposal.block.shell.level, proposal.block.round)) - >>= fun () -> handle_proposal ~is_proposal_applied:true state proposal - | Awaiting_application, New_head_proposal proposal -> - if - Block_hash.( - state.level_state.latest_proposal.block.hash <> proposal.block.hash) - then - Events.( - emit - new_head - ( proposal.block.hash, - proposal.block.shell.level, - proposal.block.round )) - >>= fun () -> - Events.(emit unexpected_new_head_while_waiting_for_application ()) - >>= fun () -> handle_proposal ~is_proposal_applied:true state proposal - else - Events.(emit applied_expected_proposal_received proposal.block.hash) - >>= fun () -> handle_expected_applied_proposal state - | Awaiting_endorsements, New_head_proposal proposal - | Awaiting_preendorsements, New_head_proposal proposal -> - Events.( - emit - new_head - (proposal.block.hash, proposal.block.shell.level, proposal.block.round)) - >>= fun () -> - Events.(emit new_head_while_waiting_for_qc ()) >>= fun () -> - handle_proposal ~is_proposal_applied:true state proposal - | Idle, New_valid_proposal proposal -> - Events.( - emit - new_valid_proposal - (proposal.block.hash, proposal.block.shell.level, proposal.block.round)) - >>= fun () -> handle_proposal ~is_proposal_applied:false state proposal - | Awaiting_application, New_valid_proposal proposal - | Awaiting_endorsements, New_valid_proposal proposal - | Awaiting_preendorsements, New_valid_proposal proposal -> - Events.( - emit - new_valid_proposal - (proposal.block.hash, proposal.block.shell.level, proposal.block.round)) - >>= fun () -> - if has_already_been_handled state proposal then - Events.(emit valid_proposal_received_after_application ()) >>= fun () -> - do_nothing state - else - Events.(emit new_valid_proposal_while_waiting_for_qc ()) >>= fun () -> - handle_proposal ~is_proposal_applied:false state proposal - | Awaiting_preendorsements, Prequorum_reached (candidate, preendorsement_qc) - -> - prequorum_reached_when_awaiting_preendorsements - state - candidate - preendorsement_qc - | Awaiting_endorsements, Quorum_reached (candidate, endorsement_qc) -> - quorum_reached_when_waiting_endorsements state candidate endorsement_qc - (* Unreachable cases *) - | Idle, (Prequorum_reached _ | Quorum_reached _) - | Awaiting_preendorsements, Quorum_reached _ - | (Awaiting_application | Awaiting_endorsements), Prequorum_reached _ - | Awaiting_application, Quorum_reached _ -> - (* This cannot/should not happen *) - do_nothing state diff --git a/src/proto_017_PtNairob/lib_delegate/state_transitions.mli b/src/proto_017_PtNairob/lib_delegate/state_transitions.mli deleted file mode 100644 index 1ea303458ca984face9b5b299d35cf952cb132fd..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/state_transitions.mli +++ /dev/null @@ -1,97 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 module, and in particular the {!step} function, modifies the automaton - state, while {!Baking_actions} performs potentially failing side-effects. *) - -open Protocol -open Alpha_context -open Baking_state -open Baking_actions - -val do_nothing : state -> (state * action) Lwt.t - -type proposal_acceptance = Invalid | Outdated_proposal | Valid_proposal - -val is_acceptable_proposal_for_current_level : - state -> proposal -> proposal_acceptance Lwt.t - -val make_consensus_list : - state -> proposal -> (consensus_key_and_delegate * consensus_content) list - -val may_update_proposal : - is_proposal_applied:bool -> state -> proposal -> state Lwt.t - -val preendorse : state -> proposal -> (state * action) Lwt.t - -val extract_pqc : - state -> proposal -> (Kind.preendorsement operation list * Round.t) option - -val handle_proposal : - is_proposal_applied:bool -> state -> proposal -> (state * action) Lwt.t - -val round_proposer : - state -> - (consensus_key_and_delegate * endorsing_slot) SlotMap.t -> - Round.t -> - (consensus_key_and_delegate * endorsing_slot) option - -val propose_fresh_block_action : - endorsements:Kind.endorsement Operation.t list -> - dal_attestations:Kind.dal_attestation Operation.t list -> - ?last_proposal:block_info -> - predecessor:block_info -> - state -> - consensus_key_and_delegate -> - Round.t -> - action Lwt.t - -val propose_block_action : - state -> consensus_key_and_delegate -> Round.t -> proposal -> action Lwt.t - -(** Increase the current round and propose at the new round (same - level), if the baker has a proposer slot. *) -val end_of_round : state -> Round.t -> (state * action) Lwt.t - -(** Propose (if possible) for the first time at a new level. *) -val time_to_bake_at_next_level : state -> Round.t -> (state * action) Lwt.t - -val update_locked_round : state -> Round.t -> Block_payload_hash.t -> state - -val make_endorse_action : state -> proposal -> action - -val prequorum_reached_when_awaiting_preendorsements : - state -> - Operation_worker.candidate -> - Kind.preendorsement operation list -> - (state * action) Lwt.t - -val quorum_reached_when_waiting_endorsements : - state -> - Operation_worker.candidate -> - Kind.endorsement operation list -> - (state * action) Lwt.t - -val step : state -> event -> (state * action) Lwt.t diff --git a/src/proto_017_PtNairob/lib_delegate/test/README.md b/src/proto_017_PtNairob/lib_delegate/test/README.md deleted file mode 100644 index 6b745df188f983d82cec8fbbad7840884f6a4eb9..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/test/README.md +++ /dev/null @@ -1,127 +0,0 @@ -# Testing Tenderbake via mockup-based simulations - -This test suite contains tests that check the baker. A notable feature that -distinguishes these tests from simple unit tests is that the baker is -examined as a whole with all its components working together. We do not run -a node, instead, we run a mockup node that allows us to create an illusion -for the baker that it talks to a real node. Thus, we have full control of -how the mockup node behaves, how the proposals and operations propagate, and -what the baker sees when it calls RPCs. - -Pros: - -* Integrates naturally with the existing testing setup and CI. No external - binaries or setup needed. -* Fast. The round time is currently constant and equal to 3 seconds. 2 - second was also tried, but that resulted in deviations from expected - behavior in about 10% of cases. Upon closer inspection it was found out - that round timeouts happen before a key event in the scenario. Supposedly, - this depends on the time the test is started as all other parameters are - set and deterministic. Switching 3 seconds solved the issue. -* Uses the same code as the baker, so people who are familiar with the - existing Tezos will benefit from their knowledge. -* Various assertions and checks can be expressed to ensure that the scenario - in question progresses exactly as it supposed to. -* Many details of how the baker sees the world can be tightly controlled. - -Cons: - -* Hard to see the logic of the scenario because it has to be written as a - collection of hooks. - -## Running the tests - -The tests can be run like this from the `src/proto_alpha/lib_delegate/test`: - -``` -$ dune exec ./main.exe -- -v -``` - -## Writing a test - -See the examples in `test_scenario.ml` for inspiration. Start writing a -scenario by deciding how many bakers you need and how many delegates each of -them will have (see the docs for `Mockup_simulator.run`): - -```ocaml - let open Mockup_simulator in - run [(3, (module Default_hooks)); (2, (module Default_hooks))] -``` - -* Set `debug` to `true` in `Mockup_simulator.default_config` and pass it to - `Mockup_simulator.run`. When `debug` is enabled baker logs will be printed. - This is the main instrument for observing what happens in the scenario. -* Consider setting `timeout` to an appropriate value. By default it is 10 - seconds, which should be fine for short scenarios, but may be insufficient - for longer ones. Timeout is a safety mechanism that prevents scenarios - from hanging and non-termination. -* It is also possible to control round durations, but it recommended to - use at least 3 seconds (the default). -* Finally, proposal slots can be controlled with the `delegate_selection` - field. The nested lists specify slot owners per level and - round. Note that if not provided, a seed nonce will be bruteforced - to obtain the desired delegate selection. - - -```ocaml - let open Mockup_simulator in - let config = - { - default_config with - debug = true; - delegate_selection = - [ - ( 1l, - [ - (0l, bootstrap3); - (1l, bootstrap4); - (2l, bootstrap2); - (3l, bootstrap1); - ] ); - ( 2l, - [ - (0l, bootstrap1); - (1l, bootstrap2); - (2l, bootstrap3); - (3l, bootstrap4); - ] ); - ]; - timeout = 15; - } - in - run ~config [(3, (module Default_hooks)); (2, (module Default_hooks))] -``` - -Note that delegate selection affects both (pre-)endorsing and voting power. -Delegates that do not have proposer slots will not be able to (pre-)endorse. -Voting power of delegates who have proposer slots will be proportional to -the number of slots they have. - -Next step is writing hook modules per baker that control its mockup mode and -execute assertions. In most cases there is no need to implement all hooks, -so the `Default_hooks` module can be reused, e.g.: - -```ocaml - let module Hooks : Mockup_simulator.Hooks = struct - include Mockup_simulator.Default_hooks - - let stop_on_event = function - | Baking_state.New_proposal {block; _} -> - (* Stop the node as soon as we receive a proposal with a level - higher than 5. *) - block.shell.level > 5l - | _ -> false - end in -``` - -Other hooks can be used to implement assertions using `failwith` and to set -mutable variable to track progress of a scenario. - -### Termination - -A scenario runs till all bakers terminate or till the scenario times out. A -baker can terminate successfully or unsuccessfully. Successful termination -happens when `stop_on_event` returns `true`. Unsuccessful termination occurs -when any of the hooks executes `failwith`. If at least one baker fails its -error message propagates and is displayed by the testing framework -(Alcotest). diff --git a/src/proto_017_PtNairob/lib_delegate/test/dune b/src/proto_017_PtNairob/lib_delegate/test/dune deleted file mode 100644 index 035a946a0ce5e2bb94dc32e348d0f865ead0e172..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/test/dune +++ /dev/null @@ -1,57 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name src_proto_017_PtNairob_lib_delegate_test_tezt_lib) - (instrumentation (backend bisect_ppx)) - (libraries - tezt.core - octez-libs.base - octez-libs.test-helpers - octez-libs.micheline - octez-protocol-017-PtNairob-libs.client - tezos-protocol-017-PtNairob.protocol - octez-libs.base-test-helpers - octez-protocol-017-PtNairob-libs.bakings.mockup-simulator - octez-protocol-017-PtNairob-libs.baking - tezos-protocol-017-PtNairob.parameters - octez-libs.crypto - octez-libs.event-logging-test-helpers - uri) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezt_core - -open Tezt_core.Base - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_test_helpers - -open Tezos_micheline - -open Tezos_client_017_PtNairob - -open Tezos_protocol_017_PtNairob - -open Tezos_base_test_helpers - -open Tezos_017_PtNairob_mockup_simulator - -open Tezos_baking_017_PtNairob - -open Tezos_event_logging_test_helpers) - (modules test_scenario)) - -(executable - (name main) - (instrumentation (backend bisect_ppx --bisect-sigterm)) - (libraries - src_proto_017_PtNairob_lib_delegate_test_tezt_lib - tezt) - (link_flags - (:standard) - (:include %{workspace_root}/macos-link-flags.sexp)) - (modules main)) - -(rule - (alias runtest) - (package octez-protocol-017-PtNairob-libs) - (enabled_if (<> false %{env:RUNTEZTALIAS=true})) - (action (run %{dep:./main.exe}))) - -(rule - (targets main.ml) - (action (with-stdout-to %{targets} (echo "let () = Tezt.Test.run ()")))) diff --git a/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/broadcast_services.ml b/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/broadcast_services.ml deleted file mode 100644 index 1a8c0a3ad8f3425bf6ab07a782d283fa26d6578a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/broadcast_services.ml +++ /dev/null @@ -1,85 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 S = struct - open Data_encoding - - let path = Tezos_rpc.Path.(root / "broadcast") - - let dests_query = - let open Tezos_rpc.Query in - query (fun dests -> - object - method dests = dests - end) - |+ multi_field "dests" Tezos_rpc.Arg.int (fun t -> t#dests) - |> seal - - (* copied from lib_shell_services/injection_services.ml *) - let block_param = - obj2 - (req "block" (dynamic_size Block_header.encoding)) - (req - "operations" - (list (dynamic_size (list (dynamic_size Operation.encoding))))) - - let block = - Tezos_rpc.Service.post_service - ~description:"Broadcast a block." - ~query:dests_query - ~input:block_param - ~output:unit - Tezos_rpc.Path.(path / "block") - - let operation = - Tezos_rpc.Service.post_service - ~description:"Broadcast an operation." - ~query:dests_query - ~input:Alpha_context.Operation.encoding - ~output:unit - Tezos_rpc.Path.(path / "operation") -end - -open Tezos_rpc.Context - -let block ctxt ?(dests = []) raw operations = - make_call - S.block - ctxt - () - (object - method dests = dests - end) - (raw, operations) - -let operation ctxt ?(dests = []) operation = - make_call - S.operation - ctxt - () - (object - method dests = dests - end) - operation diff --git a/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/dune b/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/dune deleted file mode 100644 index 30f183d8f5a039adeb11490f0f063788d4c694eb..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/dune +++ /dev/null @@ -1,34 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name tezos_017_PtNairob_mockup_simulator) - (public_name octez-protocol-017-PtNairob-libs.bakings.mockup-simulator) - (libraries - octez-libs.base - tezos-protocol-017-PtNairob.protocol - octez-protocol-017-PtNairob-libs.client - octez-shell-libs.client-commands - octez-protocol-017-PtNairob-libs.baking - octez-libs.stdlib-unix - octez-shell-libs.client-base-unix - tezos-protocol-017-PtNairob.parameters - octez-shell-libs.mockup - octez-shell-libs.mockup-proxy - octez-shell-libs.mockup-commands - octez-protocol-017-PtNairob-libs.baking.tenderbrute - tezt.core) - (flags - (:standard) - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_protocol_017_PtNairob - -open Tezos_protocol_017_PtNairob.Protocol - -open Tezos_client_017_PtNairob - -open Tezos_client_commands - -open Tezos_baking_017_PtNairob - -open Tezos_stdlib_unix - -open Tezos_client_base_unix - -open Tezos_protocol_017_PtNairob_parameters - -open Tenderbrute_017_PtNairob - -open Tezt_core)) diff --git a/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/faked_client_context.ml b/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/faked_client_context.ml deleted file mode 100644 index ededa688a755bef410018cb3c96f8e08f2959627..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/faked_client_context.ml +++ /dev/null @@ -1,174 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 Tezos_client_base - -let logger = - let log _channel msg = Lwt_fmt.printf "%s@." msg in - new Client_context.simple_printer log - -class dummy_prompter : Client_context.prompter = - object - method prompt : type a. (a, string tzresult) Client_context.lwt_format -> a - = - fun _msg -> assert false - - method prompt_password : type a. - (a, Bytes.t tzresult) Client_context.lwt_format -> a = - fun _msg -> assert false - - method multiple_password_retries = false - end - -let log _channel msg = - print_endline msg ; - Lwt.return_unit - -class faked_ctxt (hooks : Faked_services.hooks) (chain_id : Chain_id.t) : - Tezos_rpc.Context.generic = - let local_ctxt = - let module Services = Faked_services.Make ((val hooks)) in - Tezos_mockup_proxy.RPC_client.local_ctxt (Services.directory chain_id) - in - object - method base = local_ctxt#base - - method generic_media_type_call meth ?body uri = - local_ctxt#generic_media_type_call meth ?body uri - - method call_service - : 'm 'p 'q 'i 'o. - (([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) Tezos_rpc.Service.t -> - 'p -> - 'q -> - 'i -> - 'o tzresult Lwt.t = - fun service params query body -> - local_ctxt#call_service service params query body - - method call_streamed_service - : 'm 'p 'q 'i 'o. - (([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) Tezos_rpc.Service.t -> - on_chunk:('o -> unit) -> - on_close:(unit -> unit) -> - 'p -> - 'q -> - 'i -> - (unit -> unit) tzresult Lwt.t = - fun service ~on_chunk ~on_close params query body -> - local_ctxt#call_streamed_service - service - ~on_chunk - ~on_close - params - query - body - end - -class faked_wallet ~base_dir ~filesystem : Client_context.wallet = - object (self) - method load_passwords = None - - method read_file fname = - match String.Hashtbl.find filesystem fname with - | None -> failwith "faked_wallet: cannot read file (%s)" fname - | Some (content, _mtime) -> return content - - method private filename alias_name = - Filename.concat - base_dir - (String.map (function ' ' -> '_' | c -> c) alias_name ^ "s") - - val lock_mutex = Lwt_mutex.create () - - method with_lock : type a. (unit -> a Lwt.t) -> a Lwt.t = - fun f -> Lwt_mutex.with_lock lock_mutex f - - method get_base_dir = base_dir - - method load : type a. - string -> default:a -> a Data_encoding.encoding -> a tzresult Lwt.t = - fun alias_name ~default encoding -> - let filename = self#filename alias_name in - if not (String.Hashtbl.mem filesystem filename) then return default - else - self#read_file filename >>=? fun content -> - let json = (Ezjsonm.from_string content :> Data_encoding.json) in - match Data_encoding.Json.destruct encoding json with - | exception e -> - failwith - "did not understand the %s alias file %s : %s" - alias_name - filename - (Printexc.to_string e) - | data -> return data - - method write : type a. - string -> a -> a Data_encoding.encoding -> unit tzresult Lwt.t = - fun alias_name list encoding -> - let filename = self#filename alias_name in - let json = Data_encoding.Json.construct encoding list in - let str = Ezjsonm.value_to_string (json :> Ezjsonm.value) in - String.Hashtbl.replace - filesystem - filename - (str, Some (Ptime.to_float_s (Ptime_clock.now ()))) ; - return_unit - - method last_modification_time : string -> float option tzresult Lwt.t = - let open Lwt_result_syntax in - fun alias_name -> - let filename = self#filename alias_name in - let file = String.Hashtbl.find_opt filesystem filename in - match file with - | None -> return_none - | Some (_content, mtime) -> return mtime - end - -class faked_io_wallet ~base_dir ~filesystem : Client_context.io_wallet = - object - inherit Client_context.simple_printer log - - inherit dummy_prompter - - inherit faked_wallet ~base_dir ~filesystem - end - -class unix_faked ~base_dir ~filesystem ~chain_id ~hooks : Client_context.full = - object - inherit faked_io_wallet ~base_dir ~filesystem - - inherit faked_ctxt hooks chain_id - - inherit Client_context_unix.unix_ui - - method chain = `Hash chain_id - - method block = `Head 0 - - method confirmations = None - - method verbose_rpc_error_diagnostics = false - end diff --git a/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/faked_daemon.ml b/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/faked_daemon.ml deleted file mode 100644 index a6122acc33831293d5ec6e43ca04d5a8fa05cc60..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/faked_daemon.ml +++ /dev/null @@ -1,30 +0,0 @@ -module Baker = struct - let run ~(cctxt : #Protocol_client_context.full) ~stop_on_event ~chain_id - ~(context_index : Abstract_context_index.t) ~delegates = - let chain = `Hash chain_id in - let baking_configuration = - let open Baking_configuration in - { - default_config with - validation = ContextIndex context_index; - state_recorder = Memory; - } - in - (* By default errors are simply printed but the baker won't stop - because of them. This is not what we want for testing. Here we force - the baker to terminate unsuccessfully if an error occurs. *) - let canceler = Lwt_canceler.create () in - let on_error (err : error trace) = - Lwt_canceler.cancel canceler >>= fun _ -> - Format.printf "%a" Error_monad.pp_print_trace err ; - Lwt_exit.exit_and_raise 1 - in - Baking_scheduling.run - cctxt - ~canceler - ~stop_on_event - ~on_error - ~chain - baking_configuration - delegates -end diff --git a/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/faked_services.ml b/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/faked_services.ml deleted file mode 100644 index 533c0d99036e80fc157e656c867b732e9cc40bc9..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/faked_services.ml +++ /dev/null @@ -1,357 +0,0 @@ -open Tezos_shell_services -module Directory = Tezos_rpc.Directory -module Chain_services = Tezos_shell_services.Chain_services -module Block_services = Tezos_shell_services.Block_services -module Block_services_alpha = Protocol_client_context.Alpha_block_services - -module type Mocked_services_hooks = sig - type mempool = Mockup.M.Block_services.Mempool.t - - (** The baker and endorser rely on this stream to be notified of new - valid blocks. *) - val monitor_validated_blocks : - unit -> - (Chain_id.t * Block_hash.t * Block_header.t * Operation.t list list) - Tezos_rpc.Answer.stream - - (** The baker and endorser rely on this stream to be notified of new - heads. *) - val monitor_heads : - unit -> (Block_hash.t * Block_header.t) Tezos_rpc.Answer.stream - - (** Returns current and next protocol for a block. *) - val protocols : - Block_services.block -> Block_services.protocols tzresult Lwt.t - - (** [raw_header] returns the byte encoded block header of the block - associated to the given block specification. *) - val raw_header : Block_services.block -> bytes tzresult Lwt.t - - (** [header] returns the block header of the block associated to the given - block specification. *) - val header : - Block_services.block -> Mockup.M.Block_services.block_header tzresult Lwt.t - - (** [resulting_context_hash] returns the context resulting hash of the given block. *) - val resulting_context_hash : - Block_services.block -> Context_hash.t tzresult Lwt.t - - (** [operations] returns all operations included in the block. *) - val operations : - Block_services.block -> - Mockup.M.Block_services.operation list list tzresult Lwt.t - - (** [inject_block_callback] is called when an RPC is performed on - [Tezos_shell_services.Injection_services.S.block], after checking that - the block header can be deserialized. *) - val inject_block : - Block_hash.t -> - Block_header.t -> - Operation.t trace trace -> - unit tzresult Lwt.t - - (** [inject_operation] is used by the endorser (or the client) to inject - operations, including endorsements. *) - val inject_operation : Operation.t -> Operation_hash.t tzresult Lwt.t - - (** [pending_operations] returns the current contents of the mempool. It - is used by the baker to fetch operations to potentially include in the - block being baked. These operations might include endorsements. If - there aren't enough endorsements, the baker waits on - [monitor_operations]. *) - val pending_operations : unit -> mempool Lwt.t - - (** Return a stream of list of operations. Used by the baker to wait on - endorsements. Invariant: the stream becomes empty when the node changes - head. *) - val monitor_operations : - version:Block_services.version -> - validated:bool -> - branch_delayed:bool -> - branch_refused:bool -> - refused:bool -> - (Block_services.version - * ((Operation_hash.t * Mockup.M.Protocol.operation) * error trace option) - list) - Tezos_rpc.Answer.stream - - (** Lists block hashes from the chain, up to the last checkpoint, sorted - with decreasing fitness. Without arguments it returns the head of the - chain. Optional arguments allow to return the list of predecessors of a - given block or of a set of blocks. *) - val list_blocks : - heads:Block_hash.t list -> - length:int option -> - min_date:Time.Protocol.t option -> - Block_hash.t list list tzresult Lwt.t - - (** List the ancestors of the given block which, if referred to as - the branch in an operation header, are recent enough for that - operation to be included in the current block. *) - val live_blocks : Block_services.block -> Block_hash.Set.t tzresult Lwt.t - - (** [rpc_context_callback] is used in the implementations of several - RPCs (see local_services.ml). It should correspond to the - rpc_context constructed from the context at the requested block. *) - val rpc_context_callback : - Block_services.block -> - Tezos_protocol_environment.rpc_context tzresult Lwt.t - - (** Return raw protocol data as a block. *) - val raw_protocol_data : Block_services.block -> Bytes.t tzresult Lwt.t - - (** Broadcast block manually to nodes [dests] (given by their - number, starting from 0). If [dests] is not provided, broadcast - to all nodes. *) - val broadcast_block : - ?dests:int list -> - Block_hash.t -> - Block_header.t -> - Operation.t trace trace -> - unit tzresult Lwt.t - - (** Broadcast operation manually to nodes [dests] (given by their - number, starting from 0). If [dests] is not provided, broadcast - to all nodes. *) - val broadcast_operation : - ?dests:int list -> Alpha_context.packed_operation -> unit tzresult Lwt.t - - (** Simulate waiting for the node to be bootstrapped. Because the - simulated node is already bootstrapped, returns the current head - immediately. *) - val monitor_bootstrapped : - unit -> (Block_hash.t * Time.Protocol.t) Tezos_rpc.Answer.stream -end - -type hooks = (module Mocked_services_hooks) - -module Make (Hooks : Mocked_services_hooks) = struct - let monitor_validated_blocks = - Directory.gen_register0 - Directory.empty - Monitor_services.S.validated_blocks - (fun _next_protocol _ -> - Tezos_rpc.Answer.return_stream (Hooks.monitor_validated_blocks ())) - - let monitor_heads = - Directory.gen_register1 - Directory.empty - Monitor_services.S.heads - (fun _chain _next_protocol () -> - Tezos_rpc.Answer.return_stream (Hooks.monitor_heads ())) - - let monitor_bootstrapped = - Directory.gen_register0 - Directory.empty - Monitor_services.S.bootstrapped - (fun () () -> - Tezos_rpc.Answer.return_stream (Hooks.monitor_bootstrapped ())) - - let protocols = - let path = - let open Tezos_rpc.Path in - prefix Block_services.chain_path Block_services.path - in - let service = - Tezos_rpc.Service.prefix path Block_services.Empty.S.protocols - in - Directory.register Directory.empty service (fun (_, block) () () -> - Hooks.protocols block) - - let raw_header = - Directory.prefix - (Tezos_rpc.Path.prefix Chain_services.path Block_services.path) - @@ Directory.register - Directory.empty - Mockup.M.Block_services.S.raw_header - (fun (((), _chain), block) _ _ -> Hooks.raw_header block) - - let header = - Directory.prefix - (Tezos_rpc.Path.prefix Chain_services.path Block_services.path) - @@ Directory.register - Directory.empty - Mockup.M.Block_services.S.header - (fun (((), _chain), block) _ _ -> Hooks.header block) - - let resulting_context_hash = - Directory.prefix - (Tezos_rpc.Path.prefix Chain_services.path Block_services.path) - @@ Directory.register - Directory.empty - Mockup.M.Block_services.S.resulting_context_hash - (fun (((), _chain), block) _ _ -> Hooks.resulting_context_hash block) - - let operations = - Directory.prefix - (Tezos_rpc.Path.prefix Chain_services.path Block_services.path) - @@ Directory.register - Directory.empty - Mockup.M.Block_services.S.Operations.operations - (fun (((), _chain), block) q () -> - let open Lwt_result_syntax in - let* ops = Hooks.operations block in - return (q#version, ops)) - - let hash = - Directory.prefix - (Tezos_rpc.Path.prefix Chain_services.path Block_services.path) - @@ Directory.register - Directory.empty - Block_services.Empty.S.hash - (fun (((), _chain), block) () () -> - Hooks.header block >>=? fun x -> return x.hash) - - let shell_header = - Directory.prefix - (Tezos_rpc.Path.prefix Chain_services.path Block_services.path) - @@ Directory.register - Directory.empty - Mockup.M.Block_services.S.Header.shell_header - (fun (((), _chain), block) _ _ -> - Hooks.header block >>=? fun x -> return x.shell) - - let chain chain_id = - Directory.prefix - Chain_services.path - (Directory.register - Directory.empty - Chain_services.S.chain_id - (fun _chain () () -> return chain_id)) - - let inject_block = - Directory.register - Directory.empty - Injection_services.S.block - (fun () _chain (bytes, operations) -> - match Block_header.of_bytes bytes with - | None -> failwith "faked_services.inject_block: can't deserialize" - | Some block_header -> - let block_hash = Block_hash.hash_bytes [bytes] in - Hooks.inject_block block_hash block_header operations >>=? fun () -> - return block_hash) - - let inject_operation = - Directory.register - Directory.empty - Injection_services.S.operation - (fun () _chain bytes -> - match Data_encoding.Binary.of_bytes_opt Operation.encoding bytes with - | None -> failwith "faked_services.inject_operation: can't deserialize" - | Some operation -> Hooks.inject_operation operation) - - let broadcast_block = - Directory.register - Directory.empty - Broadcast_services.S.block - (fun () dests (block_header, operations) -> - let bytes = Block_header.to_bytes block_header in - let block_hash = Block_hash.hash_bytes [bytes] in - let dests = match dests#dests with [] -> None | dests -> Some dests in - Hooks.broadcast_block ?dests block_hash block_header operations) - - let broadcast_operation = - Directory.register - Directory.empty - Broadcast_services.S.operation - (fun () dests operation -> - let dests = match dests#dests with [] -> None | dests -> Some dests in - Hooks.broadcast_operation ?dests operation) - - let pending_operations = - Directory.gen_register - Directory.empty - (Mockup.M.Block_services.S.Mempool.pending_operations - @@ Block_services.mempool_path Block_services.chain_path) - (fun ((), _chain) params () -> - Hooks.pending_operations () >>= fun mempool -> - Tezos_rpc.Answer.return (params#version, mempool)) - - let monitor_operations = - Directory.gen_register - Directory.empty - (Block_services_alpha.S.Mempool.monitor_operations - @@ Block_services.mempool_path Block_services.chain_path) - (fun ((), _chain) flags () -> - let stream = - Hooks.monitor_operations - ~version:flags#version - ~validated:flags#validated - ~branch_delayed:flags#branch_delayed - ~branch_refused:flags#branch_refused - ~refused:flags#refused - in - Tezos_rpc.Answer.return_stream stream) - - let list_blocks = - Directory.prefix - Chain_services.path - (Directory.register - Directory.empty - Chain_services.S.Blocks.list - (fun ((), _chain) flags () -> - Hooks.list_blocks - ~heads:flags#heads - ~length:flags#length - ~min_date:flags#min_date)) - - let live_blocks = - Directory.prefix - (Tezos_rpc.Path.prefix Chain_services.path Block_services.path) - @@ Directory.register - Directory.empty - Block_services.Empty.S.live_blocks - (fun (_, block) _ () -> Hooks.live_blocks block) - - let raw_protocol_data = - Directory.prefix - (Tezos_rpc.Path.prefix Chain_services.path Block_services.path) - @@ Directory.register - Directory.empty - Block_services.Empty.S.Header.raw_protocol_data - (fun (_, block) () () -> Hooks.raw_protocol_data block) - - let shell_directory chain_id = - List.fold_left - Directory.merge - Directory.empty - [ - monitor_validated_blocks; - monitor_heads; - protocols; - raw_header; - header; - operations; - hash; - shell_header; - resulting_context_hash; - chain chain_id; - inject_block; - inject_operation; - monitor_operations; - list_blocks; - live_blocks; - raw_protocol_data; - broadcast_block; - broadcast_operation; - monitor_bootstrapped; - ] - - let directory chain_id = - let proto_directory = - Directory.prefix - Chain_services.path - (Directory.prefix - Block_services.path - (Directory.map - (fun (((), _chain), block) -> - Hooks.rpc_context_callback block >>= function - | Error _ -> assert false - | Ok rpc_context -> Lwt.return rpc_context) - Mockup.M.directory)) - in - let base = Directory.merge (shell_directory chain_id) proto_directory in - Tezos_rpc.Directory.register_describe_directory_service - base - Tezos_rpc.Service.description_service -end diff --git a/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/mockup_simulator.ml b/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/mockup_simulator.ml deleted file mode 100644 index ae0542b2e0976dc556990f4eea700486440b1909..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/mockup_simulator.ml +++ /dev/null @@ -1,1464 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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 block = { - rpc_context : Tezos_protocol_environment.rpc_context; - protocol_data : Protocol.Alpha_context.Block_header.protocol_data; - raw_protocol_data : Bytes.t; - operations : Mockup.M.Block_services.operation list list; - resulting_context_hash : Context_hash.t; -} - -type chain = block list - -(** As new blocks and operations are received they are pushed to an Lwt_pipe - wrapped into this type. *) -type broadcast = - | Broadcast_block of Block_hash.t * Block_header.t * Operation.t list list - | Broadcast_op of Operation_hash.t * Alpha_context.packed_operation - -(** The state of a mockup node. *) -type state = { - instance_index : int; - (** Index of this node. Indices go from 0 to N-1 where N is the total - number of bakers in the simulation. *) - live_depth : int; - (** How many blocks (counting from the head into the past) are considered live? *) - mutable chain : chain; (** The chain as seen by this fake "node". *) - mutable mempool : (Operation_hash.t * Mockup.M.Protocol.operation) list; - (** Mempool of this fake "node". *) - chain_table : chain Block_hash.Table.t; - (** The chain table of this fake "node". It maps from block hashes to - blocks. *) - global_chain_table : block Block_hash.Table.t; - (** The global chain table that allows us to look up blocks that may be - missing in [chain_table], i.e. not known to this particular node. This - is used to find unknown predecessors. The real node can ask about an - unknown block and receive it on request, this is supposed to emulate - that functionality. *) - ctxt_table : Tezos_protocol_environment.rpc_context Context_hash.Table.t; - (** The context table allows us to look up rpc_context by its hash. *) - validated_blocks_pipe : - (Block_hash.t * Block_header.t * Operation.t list list) Lwt_pipe.Unbounded.t; - (** [validated_blocks_pipe] is used to implement the - [monitor_validated_blocks] RPC. *) - heads_pipe : (Block_hash.t * Block_header.t) Lwt_pipe.Unbounded.t; - (** [heads_pipe] is used to implement the [monitor_heads] - RPC. *) - mutable operations_stream : - (Operation_hash.t * Mockup.M.Protocol.operation) list Lwt_stream.t; - mutable operations_stream_push : - (Operation_hash.t * Mockup.M.Protocol.operation) list option -> unit; - (** [operations_pipe] is used to implement the [operations_pipe] RPC. *) - mutable streaming_operations : bool; - (** A helper flag used to implement the monitor operations RPC. *) - broadcast_pipes : broadcast Lwt_pipe.Unbounded.t list; - (** Broadcast pipes per node. *) - genesis_block_true_hash : Block_hash.t; - (** True hash of the genesis - block as calculated by the - [Block_header.hash] function. *) -} - -let accounts = Mockup.Protocol_parameters.default_value.bootstrap_accounts - -let chain_id = Chain_id.of_string_exn "main" - -let genesis_block_hash = - Block_hash.of_b58check_exn - "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU" - -let genesis_predecessor_block_hash = Block_hash.zero - -type propagation = Block | Pass | Delay of float - -type propagation_vector = propagation list - -module type Hooks = sig - val on_inject_block : - level:int32 -> - round:int32 -> - block_hash:Block_hash.t -> - block_header:Block_header.t -> - operations:Operation.t list list -> - protocol_data:Alpha_context.Block_header.protocol_data -> - (Block_hash.t * Block_header.t * Operation.t list list * propagation_vector) - tzresult - Lwt.t - - val on_inject_operation : - op_hash:Operation_hash.t -> - op:Alpha_context.packed_operation -> - (Operation_hash.t * Alpha_context.packed_operation * propagation_vector) - tzresult - Lwt.t - - val on_new_validated_block : - block_hash:Block_hash.t -> - block_header:Block_header.t -> - operations:Operation.t list list -> - (Block_hash.t * Block_header.t * Operation.t list list) option Lwt.t - - val on_new_head : - block_hash:Block_hash.t -> - block_header:Block_header.t -> - (Block_hash.t * Block_header.t) option Lwt.t - - val on_new_operation : - Operation_hash.t * Alpha_context.packed_operation -> - (Operation_hash.t * Alpha_context.packed_operation) option Lwt.t - - val check_block_before_processing : - level:int32 -> - round:int32 -> - block_hash:Block_hash.t -> - block_header:Block_header.t -> - protocol_data:Alpha_context.Block_header.protocol_data -> - unit tzresult Lwt.t - - val check_chain_after_processing : - level:int32 -> round:int32 -> chain:chain -> unit tzresult Lwt.t - - val check_mempool_after_processing : - mempool:(Operation_hash.t * Mockup.M.Protocol.operation) list -> - unit tzresult Lwt.t - - val stop_on_event : Baking_state.event -> bool - - val on_start_baker : - baker_position:int -> - delegates:Baking_state.consensus_key list -> - cctxt:Protocol_client_context.full -> - unit Lwt.t - - val check_chain_on_success : chain:chain -> unit tzresult Lwt.t -end - -(** Return a series of blocks starting from the block with the given - identifier. *) -let locate_blocks (state : state) - (block : Tezos_shell_services.Block_services.block) : - block list tzresult Lwt.t = - match block with - | `Hash (hash, rel) -> ( - match Block_hash.Table.find state.chain_table hash with - | None -> - failwith "locate_blocks: can't find the block %a" Block_hash.pp hash - | Some chain0 -> - let _, chain = List.split_n rel chain0 in - return chain) - | `Head rel -> - let _, chain = List.split_n rel state.chain in - return chain - | `Level _ -> failwith "locate_blocks: `Level block spec not handled" - | `Genesis -> failwith "locate_blocks: `Genesis block spec net handled" - | `Alias _ -> failwith "locate_blocks: `Alias block spec not handled" - -(** Similar to [locate_blocks], but only returns the first block. *) -let locate_block (state : state) - (block : Tezos_shell_services.Block_services.block) : block tzresult Lwt.t = - locate_blocks state block >>=? function - | [] -> failwith "locate_block: can't find the block" - | x :: _ -> return x - -(** Return the collection of live blocks for a given block identifier. *) -let live_blocks (state : state) block = - locate_blocks state block >>=? fun chain -> - let segment, _ = List.split_n state.live_depth chain in - return - (List.fold_left - (fun set ({rpc_context; _} : block) -> - let hash = rpc_context.Tezos_protocol_environment.block_hash in - Block_hash.Set.add hash set) - (Block_hash.Set.of_list - [state.genesis_block_true_hash; genesis_predecessor_block_hash]) - segment) - -(** Extract the round number from raw fitness. *) -let round_from_raw_fitness raw_fitness = - match Protocol.Alpha_context.Fitness.from_raw raw_fitness with - | Ok fitness -> - return - (Alpha_context.Round.to_int32 - (Protocol.Alpha_context.Fitness.round fitness)) - | Error _ -> failwith "round_from_raw_fitness: cannot parse fitness" - -(** Extract level from a block header. *) -let get_block_level (block_header : Block_header.t) = - return block_header.shell.level - -(** Extract round from a block header. *) -let get_block_round (block_header : Block_header.t) = - round_from_raw_fitness block_header.shell.fitness - -(** Parse protocol data. *) -let parse_protocol_data (protocol_data : Bytes.t) = - match - Data_encoding.Binary.of_bytes_opt - Protocol.Alpha_context.Block_header.protocol_data_encoding - protocol_data - with - | None -> failwith "can't parse protocol data of a block" - | Some parsed_protocol_data -> return parsed_protocol_data - -(** Broadcast an operation or block according to the given propagation - vector. *) -let handle_propagation msg propagation_vector broadcast_pipes = - List.iter_s - (fun (propagation, pipe) -> - match propagation with - | Block -> Lwt.return () - | Pass -> - Lwt_pipe.Unbounded.push pipe msg ; - Lwt.return_unit - | Delay s -> - Lwt.dont_wait - (fun () -> - Lwt_unix.sleep s >>= fun () -> - Lwt_pipe.Unbounded.push pipe msg ; - Lwt.return_unit) - (fun _exn -> ()) ; - Lwt.return ()) - (List.combine_drop propagation_vector broadcast_pipes) - >>= fun () -> return () - -(** Use the [user_hooks] to produce a module of functions that will perform - the heavy lifting for the RPC implementations. *) -let make_mocked_services_hooks (state : state) (user_hooks : (module Hooks)) : - Faked_services.hooks = - let module User_hooks = (val user_hooks : Hooks) in - let module Impl : Faked_services.Mocked_services_hooks = struct - type mempool = Mockup.M.Block_services.Mempool.t - - let monitor_validated_blocks () = - let next () = - let rec pop_until_ok () = - Lwt_pipe.Unbounded.pop state.validated_blocks_pipe - >>= fun (block_hash, block_header, operations) -> - User_hooks.on_new_validated_block - ~block_hash - ~block_header - ~operations - >>= function - | None -> pop_until_ok () - | Some (hash, head, operations) -> - Lwt.return_some (chain_id, hash, head, operations) - in - pop_until_ok () - in - let shutdown () = () in - Tezos_rpc.Answer.{next; shutdown} - - let monitor_heads () = - let next () = - let rec pop_until_ok () = - Lwt_pipe.Unbounded.pop state.heads_pipe - >>= fun (block_hash, block_header) -> - (* Sleep a 0.1s to simulate a block application delay *) - Lwt_unix.sleep 0.1 >>= fun () -> - User_hooks.on_new_head ~block_hash ~block_header >>= function - | None -> pop_until_ok () - | Some head -> Lwt.return_some head - in - pop_until_ok () - in - let shutdown () = () in - Tezos_rpc.Answer.{next; shutdown} - - let monitor_bootstrapped () = - let first_run = ref true in - let next () = - if !first_run then ( - first_run := false ; - let b = match state.chain with [] -> assert false | b :: _ -> b in - let head_hash = b.rpc_context.block_hash in - let timestamp = b.rpc_context.block_header.timestamp in - Lwt.return_some (head_hash, timestamp)) - else Lwt.return_none - in - let shutdown () = () in - Tezos_rpc.Answer.{next; shutdown} - - let protocols (block : Tezos_shell_services.Block_services.block) = - locate_block state block >>=? fun x -> - let hash = x.rpc_context.block_hash in - let is_predecessor_of_genesis = - match block with - | `Hash (requested_hash, rel) -> - Int.equal rel 0 - && Block_hash.equal requested_hash genesis_predecessor_block_hash - | _ -> false - in - (* It is important to tell the baker that the genesis block is not in - the alpha protocol (we use Protocol_hash.zero). This will make the - baker not try to propose alternatives to that block and just accept - it as final in that Protocol_hash.zero protocol. The same for - predecessor of genesis, it should be in Protocol_hash.zero. *) - return - Tezos_shell_services.Block_services. - { - current_protocol = - (if - Block_hash.equal hash genesis_block_hash - || is_predecessor_of_genesis - then Protocol_hash.zero - else Protocol.hash); - next_protocol = - (if is_predecessor_of_genesis then Protocol_hash.zero - else Protocol.hash); - } - - let may_lie_on_proto_level block x = - (* As for ../protocols, the baker distinguishes activation - blocks from "normal" blocks by comparing the [proto_level] of - the shell header and its predecessor. If the predecessor's - one is different, it must mean that we are considering an - activation block and must not endorse. Here, we do a bit of - hacking in order to return a different proto_level for the - predecessor of the genesis block which is considered as the - current protocol activation block. To perfectly mimic what is - supposed to happen, the first mocked up block created should - be made in the genesis protocol, however, it is not what's - done in the mockup mode. *) - let is_predecessor_of_genesis = - match block with - | `Hash (requested_hash, rel) -> - Int.equal rel 0 - && Block_hash.equal requested_hash genesis_predecessor_block_hash - | _ -> false - in - if is_predecessor_of_genesis then - { - x.rpc_context.block_header with - proto_level = pred x.rpc_context.block_header.proto_level; - } - else x.rpc_context.block_header - - let raw_header (block : Tezos_shell_services.Block_services.block) : - bytes tzresult Lwt.t = - locate_block state block >>=? fun x -> - let shell = may_lie_on_proto_level block x in - let protocol_data = - Data_encoding.Binary.to_bytes_exn - Protocol.block_header_data_encoding - x.protocol_data - in - return - (Data_encoding.Binary.to_bytes_exn - Tezos_base.Block_header.encoding - {shell; protocol_data}) - - let header (block : Tezos_shell_services.Block_services.block) : - Mockup.M.Block_services.block_header tzresult Lwt.t = - locate_block state block >>=? fun x -> - let shell = may_lie_on_proto_level block x in - return - { - Mockup.M.Block_services.hash = x.rpc_context.block_hash; - chain_id; - shell; - protocol_data = x.protocol_data; - } - - let resulting_context_hash - (block : Tezos_shell_services.Block_services.block) : - Context_hash.t tzresult Lwt.t = - locate_block state block >>=? fun x -> return x.resulting_context_hash - - let operations block = - locate_block state block >>=? fun x -> return x.operations - - let inject_block block_hash (block_header : Block_header.t) operations = - parse_protocol_data block_header.protocol_data >>=? fun protocol_data -> - get_block_level block_header >>=? fun level -> - get_block_round block_header >>=? fun round -> - User_hooks.on_inject_block - ~level - ~round - ~block_hash - ~block_header - ~operations - ~protocol_data - >>=? fun (block_hash1, block_header1, operations1, propagation_vector) -> - handle_propagation - (Broadcast_block (block_hash1, block_header1, operations1)) - propagation_vector - state.broadcast_pipes - - let all_pipes_or_select = function - | None -> return state.broadcast_pipes - | Some l -> - List.map_es - (fun n -> - match List.nth_opt state.broadcast_pipes n with - | None -> - failwith - "Node number %d is out of range (max is %d)" - n - (List.length state.broadcast_pipes - 1) - | Some pipe -> return pipe) - l - - let broadcast_block ?dests block_hash (block_header : Block_header.t) - operations = - all_pipes_or_select dests >>=? fun pipes -> - List.iter_s - (fun pipe -> - Lwt_pipe.Unbounded.push - pipe - (Broadcast_block (block_hash, block_header, operations)) ; - Lwt.return ()) - pipes - >>= return - - let inject_operation (Operation.{shell; proto} as op) = - let op_hash = Operation.hash op in - let proto_op_opt = - Data_encoding.Binary.of_bytes Protocol.operation_data_encoding proto - in - match proto_op_opt with - | Error _ -> failwith "inject_operation: cannot parse operation" - | Ok protocol_data -> - let op : Protocol.Alpha_context.packed_operation = - {shell; protocol_data} - in - User_hooks.on_inject_operation ~op_hash ~op - >>=? fun (op_hash1, op1, propagation_vector) -> - handle_propagation - (Broadcast_op (op_hash1, op1)) - propagation_vector - state.broadcast_pipes - >>=? fun () -> return op_hash1 - - let broadcast_operation ?dests - (op : Protocol.Alpha_context.packed_operation) = - all_pipes_or_select dests >>=? fun pipes -> - let op_hash = Alpha_context.Operation.hash_packed op in - List.iter_s - (fun pipe -> - Lwt_pipe.Unbounded.push pipe (Broadcast_op (op_hash, op)) ; - Lwt.return ()) - pipes - >>= return - - let pending_operations () = - let ops = state.mempool in - Lwt.return - Mockup.M.Block_services.Mempool. - { - validated = ops; - refused = Operation_hash.Map.empty; - outdated = Operation_hash.Map.empty; - branch_refused = Operation_hash.Map.empty; - branch_delayed = Operation_hash.Map.empty; - unprocessed = Operation_hash.Map.empty; - } - - let monitor_operations ~version ~validated ~branch_delayed ~branch_refused - ~refused = - ignore validated ; - ignore branch_delayed ; - ignore branch_refused ; - ignore refused ; - let streamed = ref false in - state.streaming_operations <- true ; - let next () = - let rec loop () = - Lwt_stream.get state.operations_stream >>= function - | None when !streamed -> Lwt.return None - | None -> - streamed := true ; - Lwt.return_some (version, []) - | Some ops -> ( - List.filter_map_s User_hooks.on_new_operation ops >>= function - | [] -> loop () - | l -> Lwt.return_some (version, List.map (fun x -> (x, None)) l)) - in - loop () - in - let shutdown () = () in - Tezos_rpc.Answer.{next; shutdown} - - let rpc_context_callback block = - locate_block state block >>=? fun x -> return x.rpc_context - - let list_blocks ~heads ~length ~min_date:_ = - let compare_block_fitnesses block0 block1 = - Fitness.compare - block0.rpc_context.block_header.fitness - block1.rpc_context.block_header.fitness - in - let hash_of_block block = block.rpc_context.block_hash in - let lookup_head head = - locate_blocks state (`Hash (head, 0)) >>=? fun xs -> - let segment = - match length with None -> xs | Some n -> List.take_n n xs - in - return - (List.map hash_of_block (List.sort compare_block_fitnesses segment)) - in - List.map_es lookup_head heads - - let live_blocks block = live_blocks state block - - let raw_protocol_data block = - locate_block state block >>=? fun x -> return x.raw_protocol_data - end in - (module Impl) - -(** Return the current head. *) -let head {chain; _} = - match List.hd chain with - | None -> failwith "mockup_simulator.ml: empty chain" - | Some hd -> return hd - -(** Clear from the mempool operations whose branch does not point to - a live block with respect to the current head. *) -let clear_mempool state = - head state >>=? fun head -> - let included_ops_hashes = - List.map - (fun (op : Mockup.M.Block_services.operation) -> op.hash) - (List.flatten head.operations) - in - live_blocks state (`Head 0) >>=? fun live_set -> - let mempool = - List.filter - (fun (_oph, (op : Mockup.M.Protocol.operation)) -> - let included_in_head = - List.mem - ~equal:Operation_hash.equal - (Alpha_context.Operation.hash_packed op) - included_ops_hashes - in - Block_hash.Set.mem op.shell.branch live_set && not included_in_head) - state.mempool - in - state.mempool <- mempool ; - return_unit - -let begin_validation_and_application ctxt chain_id mode ~predecessor ~cache = - let open Lwt_result_syntax in - let* validation_state = - Mockup.M.Protocol.begin_validation ctxt chain_id mode ~predecessor ~cache - in - let* application_state = - Mockup.M.Protocol.begin_application ctxt chain_id mode ~predecessor ~cache - in - return (validation_state, application_state) - -let validate_and_apply_operation (validation_state, application_state) oph op = - let open Lwt_result_syntax in - let* validation_state = - Mockup.M.Protocol.validate_operation validation_state oph op - in - let* application_state, receipt = - Mockup.M.Protocol.apply_operation application_state oph op - in - return ((validation_state, application_state), receipt) - -let finalize_validation_and_application (validation_state, application_state) - shell_header = - let open Lwt_result_syntax in - let* () = Mockup.M.Protocol.finalize_validation validation_state in - Mockup.M.Protocol.finalize_application application_state shell_header - -(** Apply a block to the given [rpc_context]. *) -let reconstruct_context (rpc_context : Tezos_protocol_environment.rpc_context) - (operations : Operation.t list list) (block_header : Block_header.t) = - let predecessor = rpc_context.block_header in - let predecessor_context = rpc_context.context in - parse_protocol_data block_header.protocol_data >>=? fun protocol_data -> - begin_validation_and_application - predecessor_context - chain_id - (Application {shell = block_header.shell; protocol_data}) - ~predecessor - ~cache:`Lazy - >>=? fun state -> - let i = ref 0 in - List.fold_left_es - (List.fold_left_es (fun (state, results) op -> - incr i ; - let oph = Operation.hash op in - let operation_data = - Data_encoding.Binary.of_bytes_exn - Mockup.M.Protocol.operation_data_encoding - op.Operation.proto - in - let op = - {Mockup.M.Protocol.shell = op.shell; protocol_data = operation_data} - in - validate_and_apply_operation state oph op >>=? fun (state, receipt) -> - return (state, receipt :: results))) - (state, []) - operations - >>=? fun (state, _) -> finalize_validation_and_application state None - -(** Process an incoming block. If validation succeeds: - - update the current head to this new block - - cleanup outdated operations - - cleanup listener table - Note that this implementation does not handle concurrent branches. *) -let rec process_block state block_hash (block_header : Block_header.t) - operations = - let get_predecessor () = - let predecessor_hash = block_header.Block_header.shell.predecessor in - head state >>=? fun head -> - match Block_hash.Table.find state.chain_table predecessor_hash with - | None | Some [] -> ( - (* Even if the predecessor is not known locally, it might be known by - some node in the network. The code below "requests" information - about the block by its hash. *) - match - Block_hash.Table.find state.global_chain_table predecessor_hash - with - | None -> failwith "get_predecessor: unknown predecessor block" - | Some predecessor -> - let predecessor_block_header = - Block_header. - { - shell = predecessor.rpc_context.block_header; - protocol_data = predecessor.raw_protocol_data; - } - in - let predecessor_ops = - List.map - (fun xs -> - List.map - (fun (op : Mockup.M.Block_services.operation) -> - Operation. - { - shell = op.shell; - proto = - Data_encoding.Binary.to_bytes_exn - Protocol.operation_data_encoding - op.protocol_data; - }) - xs) - predecessor.operations - in - (* If the block is found, apply it before proceeding. *) - process_block - state - predecessor.rpc_context.block_hash - predecessor_block_header - predecessor_ops - >>=? fun () -> return predecessor) - | Some (predecessor :: _) -> - if - Int32.sub - head.rpc_context.block_header.level - predecessor.rpc_context.block_header.level - <= 2l - then return predecessor - else failwith "get_predecessor: the predecessor block is too old" - in - match Block_hash.Table.find state.chain_table block_hash with - | Some _ -> - (* The block is already known. *) - return_unit - | None -> - get_predecessor () >>=? fun predecessor -> - head state >>=? fun head -> - reconstruct_context predecessor.rpc_context operations block_header - >>=? fun ({context; message; _}, _) -> - let resulting_context_hash = - Tezos_context_ops.Context_ops.hash - ~time:block_header.shell.timestamp - ?message - context - in - let rpc_context = - Tezos_protocol_environment. - {context; block_hash; block_header = block_header.shell} - in - let operations = - List.map - (fun pass -> - List.map - (fun (Operation.{shell; proto} as op) -> - let hash : Operation_hash.t = Operation.hash op in - let protocol_data : Alpha_context.packed_protocol_data = - Data_encoding.Binary.of_bytes_exn - Protocol.operation_data_encoding - proto - in - { - Mockup.M.Block_services.chain_id; - hash; - shell; - protocol_data; - receipt = Empty; - }) - pass) - operations - in - parse_protocol_data block_header.protocol_data >>=? fun protocol_data -> - let new_block = - { - rpc_context; - protocol_data; - raw_protocol_data = block_header.protocol_data; - operations; - resulting_context_hash; - } - in - let predecessor_hash = block_header.Block_header.shell.predecessor in - let tail = - Block_hash.Table.find state.chain_table predecessor_hash - |> WithExceptions.Option.get ~loc:__LOC__ - in - let new_chain = new_block :: tail in - Block_hash.Table.replace state.chain_table block_hash new_chain ; - Block_hash.Table.replace state.global_chain_table block_hash new_block ; - Context_hash.Table.replace - state.ctxt_table - resulting_context_hash - rpc_context ; - if - Fitness.( - block_header.shell.fitness > head.rpc_context.block_header.fitness) - then ( - state.chain <- new_chain ; - clear_mempool state >>=? fun () -> - (* The head changed: notify that the stream ended. *) - state.operations_stream_push None ; - state.streaming_operations <- false ; - (* Instanciate a new stream *) - let operations_stream, operations_stream_push = Lwt_stream.create () in - state.operations_stream <- operations_stream ; - state.operations_stream_push <- operations_stream_push ; - state.operations_stream_push (Some state.mempool) ; - return_unit) - else return_unit - -(** This process listens to broadcast block and operations and incorporates - them in the context of the fake node. *) -let rec listener ~(user_hooks : (module Hooks)) ~state ~broadcast_pipe = - let module User_hooks = (val user_hooks : Hooks) in - Lwt_pipe.Unbounded.pop broadcast_pipe >>= function - | Broadcast_op (operation_hash, packed_operation) -> - (if - List.mem_assoc ~equal:Operation_hash.equal operation_hash state.mempool - then return_unit - else ( - state.mempool <- (operation_hash, packed_operation) :: state.mempool ; - state.operations_stream_push (Some [(operation_hash, packed_operation)]) ; - User_hooks.check_mempool_after_processing ~mempool:state.mempool)) - >>=? fun () -> listener ~user_hooks ~state ~broadcast_pipe - | Broadcast_block (block_hash, block_header, operations) -> - get_block_level block_header >>=? fun level -> - get_block_round block_header >>=? fun round -> - parse_protocol_data block_header.protocol_data >>=? fun protocol_data -> - User_hooks.check_block_before_processing - ~level - ~round - ~block_hash - ~block_header - ~protocol_data - >>=? fun () -> - process_block state block_hash block_header operations >>=? fun () -> - User_hooks.check_chain_after_processing ~level ~round ~chain:state.chain - >>=? fun () -> - Lwt_pipe.Unbounded.push - state.validated_blocks_pipe - (block_hash, block_header, operations) ; - Lwt_pipe.Unbounded.push state.heads_pipe (block_hash, block_header) ; - listener ~user_hooks ~state ~broadcast_pipe - -(** Create a fake node state. *) -let create_fake_node_state ~i ~live_depth - ~(genesis_block : Block_header.t * Tezos_protocol_environment.rpc_context) - ~global_chain_table ~broadcast_pipes = - let block_header0, rpc_context0 = genesis_block in - parse_protocol_data block_header0.protocol_data >>=? fun protocol_data -> - let genesis0 = - { - rpc_context = rpc_context0; - protocol_data; - raw_protocol_data = block_header0.protocol_data; - operations = [[]; []; []; []]; - resulting_context_hash = block_header0.shell.context; - } - in - let chain0 = [genesis0] in - let validated_blocks_pipe = Lwt_pipe.Unbounded.create () in - let heads_pipe = Lwt_pipe.Unbounded.create () in - let operations_stream, operations_stream_push = Lwt_stream.create () in - let genesis_block_true_hash = - Block_header.hash - { - shell = rpc_context0.block_header; - protocol_data = block_header0.protocol_data; - } - in - (* Only push genesis block as a new head, not a valid block: it is - the shell's semantics to not advertise "transition" blocks. *) - Lwt_pipe.Unbounded.push heads_pipe (rpc_context0.block_hash, block_header0) ; - return - { - instance_index = i; - live_depth; - mempool = []; - chain = chain0; - chain_table = - Block_hash.Table.of_seq - (List.to_seq - [ - (rpc_context0.block_hash, chain0); - (genesis_block_true_hash, chain0); - (genesis_predecessor_block_hash, chain0); - ]); - global_chain_table; - ctxt_table = - Context_hash.Table.of_seq - (List.to_seq - [ - ( rpc_context0.Tezos_protocol_environment.block_header - .Block_header.context, - rpc_context0 ); - ]); - validated_blocks_pipe; - heads_pipe; - operations_stream; - operations_stream_push; - streaming_operations = false; - broadcast_pipes; - genesis_block_true_hash; - } - -class tezt_printer : Tezos_client_base.Client_context.printer = - let open Tezos_client_base in - let open Client_context in - let wrap_tezt_log : (_ format4 -> _) -> _ format4 -> _ = - fun f x -> - Format.kasprintf - (fun msg -> - f "%s" msg ; - Lwt.return_unit) - x - in - object - method error : type a b. (a, b) lwt_format -> a = - Format.kasprintf (fun msg -> Lwt.fail (Failure msg)) - - method warning : type a. (a, unit) lwt_format -> a = - wrap_tezt_log Tezt_core.Log.warn - - method message : type a. (a, unit) lwt_format -> a = - wrap_tezt_log (fun x -> Tezt_core.Log.info x) - - method answer : type a. (a, unit) lwt_format -> a = - wrap_tezt_log (fun x -> Tezt_core.Log.info x) - - method log : type a. string -> (a, unit) lwt_format -> a = - fun _log_output -> wrap_tezt_log (fun x -> Tezt_core.Log.info x) - end - -(** Start baker process. *) -let baker_process ~(delegates : Baking_state.consensus_key list) ~base_dir - ~(genesis_block : Block_header.t * Tezos_protocol_environment.rpc_context) - ~i ~global_chain_table ~broadcast_pipes ~(user_hooks : (module Hooks)) = - let broadcast_pipe = - List.nth broadcast_pipes i |> WithExceptions.Option.get ~loc:__LOC__ - in - create_fake_node_state - ~i - ~live_depth:60 - ~genesis_block - ~global_chain_table - ~broadcast_pipes - >>=? fun state -> - let filesystem = String.Hashtbl.create 10 in - let wallet = new Faked_client_context.faked_io_wallet ~base_dir ~filesystem in - let cctxt = - let hooks = make_mocked_services_hooks state user_hooks in - new Protocol_client_context.wrap_full - (new Faked_client_context.unix_faked - ~base_dir - ~filesystem - ~chain_id - ~hooks) - in - let module User_hooks = (val user_hooks : Hooks) in - User_hooks.on_start_baker ~baker_position:i ~delegates ~cctxt >>= fun () -> - List.iter_es - (fun ({alias; public_key; public_key_hash; secret_key_uri} : - Baking_state.consensus_key) -> - let open Tezos_client_base in - let name = alias |> WithExceptions.Option.get ~loc:__LOC__ in - Client_keys.neuterize secret_key_uri >>=? fun public_key_uri -> - Client_keys.register_key - wallet - ~force:false - (public_key_hash, public_key_uri, secret_key_uri) - ~public_key - name) - delegates - >>=? fun () -> - let context_index = - let open Abstract_context_index in - { - sync_fun = Lwt.return; - checkout_fun = - (fun hash -> - Context_hash.Table.find state.ctxt_table hash - |> Option.map (fun Tezos_protocol_environment.{context; _} -> context) - |> Lwt.return); - finalize_fun = Lwt.return; - } - in - let module User_hooks = (val user_hooks : Hooks) in - let listener_process () = listener ~user_hooks ~state ~broadcast_pipe in - let stop_on_event event = User_hooks.stop_on_event event in - let baker_process () = - Faked_daemon.Baker.run - ~cctxt - ~stop_on_event - ~chain_id - ~context_index - ~delegates - in - Lwt.pick [listener_process (); baker_process ()] >>=? fun () -> - User_hooks.check_chain_on_success ~chain:state.chain - -let genesis_protocol_data (baker_sk : Signature.secret_key) - (predecessor_hash : Block_hash.t) (block_header : Block_header.shell_header) - : Bytes.t = - let proof_of_work_nonce = - Bytes.create Protocol.Alpha_context.Constants.proof_of_work_nonce_size - in - let payload_hash = - Protocol.Alpha_context.Block_payload.hash - ~predecessor_hash - ~payload_round:Alpha_context.Round.zero - [] - in - let contents = - Protocol.Alpha_context.Block_header. - { - payload_hash; - payload_round = Alpha_context.Round.zero; - proof_of_work_nonce; - seed_nonce_hash = None; - liquidity_baking_toggle_vote = - Baking_configuration.default_liquidity_baking_config - .liquidity_baking_vote; - } - in - let unsigned_header = - Data_encoding.Binary.to_bytes_exn - Protocol.Alpha_context.Block_header.unsigned_encoding - (block_header, contents) - in - let signature = - Signature.sign - ~watermark: - Alpha_context.Block_header.(to_watermark (Block_header chain_id)) - baker_sk - unsigned_header - in - Data_encoding.Binary.to_bytes_exn - Protocol.Alpha_context.Block_header.protocol_data_encoding - {contents; signature} - -(** Figure out who should be the signer for the genesis block. *) -let deduce_baker_sk - (accounts_with_secrets : - (Protocol.Alpha_context.Parameters.bootstrap_account - * Tezos_mockup_commands.Mockup_wallet.bootstrap_secret) - list) (total_accounts : int) (level : int) : - Signature.secret_key tzresult Lwt.t = - (match (total_accounts, level) with - | _, 0 -> return 0 (* apparently this doesn't really matter *) - | _ -> - failwith - "cannot deduce baker for a genesis block, total accounts = %d, level = \ - %d" - total_accounts - level) - >>=? fun baker_index -> - let _, secret = - List.nth accounts_with_secrets baker_index - |> WithExceptions.Option.get ~loc:__LOC__ - in - let secret_key = - Signature.Secret_key.of_b58check_exn (Uri.path (secret.sk_uri :> Uri.t)) - in - return secret_key - -(** Generate the two initial genesis blocks. *) -let make_genesis_context ~delegate_selection ~initial_seed ~round0 ~round1 - ~consensus_committee_size ~consensus_threshold accounts_with_secrets - (total_accounts : int) = - let default_constants = Mockup.Protocol_parameters.default_value.constants in - let round_durations = - let open Alpha_context in - Stdlib.Option.get - (Round.Durations.create_opt - ~first_round_duration:(Period.of_seconds_exn round0) - ~delay_increment_per_round: - (Period.of_seconds_exn (Int64.sub round1 round0))) - in - let constants = - { - default_constants with - initial_seed; - consensus_committee_size; - consensus_threshold; - minimal_block_delay = Alpha_context.Period.of_seconds_exn (max 1L round0); - delay_increment_per_round = - Alpha_context.Period.of_seconds_exn Int64.(max 1L (sub round1 round0)); - } - in - let from_bootstrap_account i - ( (account : Protocol.Alpha_context.Parameters.bootstrap_account), - (secret : Tezos_mockup_commands.Mockup_wallet.bootstrap_secret) ) : - Mockup.Parsed_account.t = - { - name = Format.sprintf "bootstrap%d" (i + 1); - sk_uri = secret.sk_uri; - amount = account.amount; - } - in - let bootstrap_accounts = - Data_encoding.Json.construct - (Data_encoding.list Mockup.Parsed_account.encoding) - (List.mapi from_bootstrap_account accounts_with_secrets) - in - let cctxt = new tezt_printer in - List.map_e - (fun (level, round_delegates) -> - Raw_level_repr.of_int32 level >>? fun level -> - List.map_e - (fun (round, delegate) -> - Round_repr.of_int32 round >|? fun round -> (round, delegate)) - round_delegates - >|? fun round_delegates -> (level, round_delegates)) - delegate_selection - |> Environment.wrap_tzresult - >>?= fun delegate_selection -> - (match (delegate_selection, constants.initial_seed) with - | [], seed_opt -> return seed_opt - | selection, (Some _ as seed) -> ( - cctxt#message "Checking provided seed." >>= fun () -> - Tenderbrute.check_seed - ~bootstrap_accounts_json:bootstrap_accounts - ~parameters:Mockup.Protocol_parameters.{default_value with constants} - ~seed - selection - >>=? function - | true -> return seed - | false -> - failwith "Provided initial seed does not match delegate selection") - | _, None -> - cctxt#message "No initial seed provided, bruteforcing." >>= fun () -> - Tenderbrute.bruteforce - ~max:100_000_000_000 - ~bootstrap_accounts_json:bootstrap_accounts - ~parameters:Mockup.Protocol_parameters.{default_value with constants} - delegate_selection) - >>=? fun initial_seed -> - (match initial_seed with - | None -> Lwt.return_unit - | _ when initial_seed = constants.initial_seed -> Lwt.return_unit - | Some seed -> - cctxt#warning - "Bruteforced seed is %a, please save into your test." - State_hash.pp - seed) - >>= fun () -> - let constants = {constants with initial_seed} in - let common_parameters = - Mockup.Protocol_parameters.{default_value with constants} - in - let make_block0 initial_timestamp = - let parameters = {common_parameters with initial_timestamp} in - let reencoded_parameters = - Data_encoding.Binary.of_bytes_exn Mockup.M.parameters_encoding - @@ Data_encoding.Binary.to_bytes_exn - Mockup.Protocol_parameters.encoding - parameters - in - Mockup.M.init - ~cctxt - ~parameters:reencoded_parameters - ~constants_overrides_json:None - ~bootstrap_accounts_json:(Some bootstrap_accounts) - >>=? fun {chain = _; rpc_context = rpc_context0; protocol_data = _} -> - let block_header0 = - { - rpc_context0.block_header with - predecessor = genesis_predecessor_block_hash; - } - in - let rpc_context = {rpc_context0 with block_header = block_header0} in - deduce_baker_sk accounts_with_secrets total_accounts 0 >>=? fun baker_sk -> - let protocol_data = - genesis_protocol_data - baker_sk - genesis_predecessor_block_hash - rpc_context.block_header - in - let block_header = - Block_header.{shell = rpc_context.block_header; protocol_data} - in - return (block_header, rpc_context) - in - let level0_round0_duration = - Protocol.Alpha_context.Round.round_duration - round_durations - Alpha_context.Round.zero - in - let timestamp0 = - Time.Protocol.of_seconds - Int64.( - sub - (of_float (Unix.time ())) - (Alpha_context.Period.to_seconds level0_round0_duration)) - in - make_block0 timestamp0 - -(** By default, propagate every message everywhere. *) -let default_propagation_vector = List.repeat 5 Pass - -module Default_hooks : Hooks = struct - let on_inject_block ~level:_ ~round:_ ~block_hash ~block_header ~operations - ~protocol_data:_ = - return (block_hash, block_header, operations, default_propagation_vector) - - let on_inject_operation ~op_hash ~op = - return (op_hash, op, default_propagation_vector) - - let on_new_validated_block ~block_hash ~block_header ~operations = - Lwt.return (Some (block_hash, block_header, operations)) - - let on_new_head ~block_hash ~block_header = - Lwt.return (Some (block_hash, block_header)) - - let on_new_operation x = Lwt.return_some x - - let check_block_before_processing ~level:_ ~round:_ ~block_hash:_ - ~block_header:_ ~protocol_data:_ = - return_unit - - let check_chain_after_processing ~level:_ ~round:_ ~chain:_ = return_unit - - let check_mempool_after_processing ~mempool:_ = return_unit - - let stop_on_event _ = false - - let on_start_baker ~baker_position:_ ~delegates:_ ~cctxt:_ = Lwt.return_unit - - let check_chain_on_success ~chain:_ = return_unit -end - -type config = { - round0 : int64; - round1 : int64; - timeout : int; - delegate_selection : (int32 * (int32 * Signature.public_key_hash) list) list; - initial_seed : State_hash.t option; - consensus_committee_size : int; - consensus_threshold : int; -} - -let default_config = - { - round0 = 2L; - (* Rounds should be long enough for the bakers to - exchange all the necessary messages. *) - round1 = 3L (* No real need to increase round durations. *); - timeout = 30; - delegate_selection = []; - initial_seed = None; - consensus_committee_size = - Default_parameters.constants_mainnet.consensus_committee_size; - consensus_threshold = - Default_parameters.constants_mainnet.consensus_threshold; - } - -let make_baking_delegate - ( (account : Alpha_context.Parameters.bootstrap_account), - (secret : Tezos_mockup_commands.Mockup_wallet.bootstrap_secret) ) : - Baking_state.consensus_key = - Baking_state. - { - alias = Some secret.name; - public_key = account.public_key |> WithExceptions.Option.get ~loc:__LOC__; - public_key_hash = account.public_key_hash; - secret_key_uri = secret.sk_uri; - } - -let run ?(config = default_config) bakers_spec = - Tezos_client_base.Client_keys.register_signer - (module Tezos_signer_backends.Unencrypted) ; - let total_accounts = - List.fold_left (fun acc (n, _) -> acc + n) 0 bakers_spec - in - if total_accounts = 0 then - failwith "the simulation should use at least one delegate" - else if total_accounts > 5 then - failwith "only up to 5 bootstrap accounts are available" - else - let total_bakers = List.length bakers_spec in - (List.init ~when_negative_length:() total_bakers (fun _ -> - Lwt_pipe.Unbounded.create ()) - |> function - | Error () -> failwith "impossible: negative length of the baker spec" - | Ok xs -> return xs) - >>=? fun broadcast_pipes -> - let global_chain_table = Block_hash.Table.create 10 in - Tezos_mockup_commands.Mockup_wallet.default_bootstrap_accounts - >>=? fun bootstrap_secrets -> - let accounts_with_secrets = - List.combine_drop (List.take_n total_accounts accounts) bootstrap_secrets - in - let all_delegates = List.map make_baking_delegate accounts_with_secrets in - make_genesis_context - ~delegate_selection:config.delegate_selection - ~initial_seed:config.initial_seed - ~round0:config.round0 - ~round1:config.round1 - ~consensus_committee_size:config.consensus_committee_size - ~consensus_threshold:config.consensus_threshold - accounts_with_secrets - total_accounts - >>=? fun genesis_block -> - let take_third (_, _, x) = x in - let timeout_process () = - Lwt_unix.sleep (Float.of_int config.timeout) >>= fun () -> - failwith "the test is taking longer than %d seconds@." config.timeout - in - Lwt.pick - [ - timeout_process (); - Lwt_result_syntax.tzjoin - (take_third - (List.fold_left - (fun (i, delegates_acc, ms) (n, user_hooks) -> - let delegates, leftover_delegates = - List.split_n n delegates_acc - in - let m = - baker_process - ~delegates - ~base_dir:"dummy" - ~genesis_block - ~i - ~global_chain_table - ~broadcast_pipes - ~user_hooks - in - (i + 1, leftover_delegates, m :: ms)) - (0, all_delegates, []) - bakers_spec)); - ] - -let get_account_pk i = - match List.nth accounts i with - | None -> assert false - | Some acc -> acc.public_key |> WithExceptions.Option.get ~loc:__LOC__ - -let bootstrap1 = get_account_pk 0 - -let bootstrap2 = get_account_pk 1 - -let bootstrap3 = get_account_pk 2 - -let bootstrap4 = get_account_pk 3 - -let bootstrap5 = get_account_pk 4 - -let check_block_signature ~block_hash ~(block_header : Block_header.t) - ~public_key = - let (protocol_data : Protocol.Alpha_context.Block_header.protocol_data) = - Data_encoding.Binary.of_bytes_exn - Protocol.Alpha_context.Block_header.protocol_data_encoding - block_header.protocol_data - in - let unsigned_header = - Data_encoding.Binary.to_bytes_exn - Protocol.Alpha_context.Block_header.unsigned_encoding - (block_header.shell, protocol_data.contents) - in - if - Signature.check - ~watermark: - Alpha_context.Block_header.(to_watermark (Block_header chain_id)) - public_key - protocol_data.signature - unsigned_header - then return_unit - else - failwith - "unexpected signature for %a; tried with %a@." - Block_hash.pp - block_hash - Signature.Public_key.pp - public_key - -type op_predicate = - Operation_hash.t -> Alpha_context.packed_operation -> bool tzresult Lwt.t - -let mempool_count_ops ~mempool ~predicate = - List.map_es (fun (op_hash, op) -> predicate op_hash op) mempool - >>=? fun results -> - return - (List.fold_left - (fun acc result -> if result then acc + 1 else acc) - 0 - results) - -let mempool_has_op ~mempool ~predicate = - mempool_count_ops ~mempool ~predicate >>=? fun n -> return (n > 0) - -let mempool_has_op_ref ~mempool ~predicate ~var = - mempool_has_op ~mempool ~predicate >>=? fun result -> - if result then var := true ; - return_unit - -let op_is_signed_by ~public_key (op_hash : Operation_hash.t) - (op : Alpha_context.packed_operation) = - match op.protocol_data with - | Operation_data d -> ( - (match d.contents with - | Single op_contents -> - return - (match op_contents with - | Endorsement _ -> - Alpha_context.Operation.to_watermark (Endorsement chain_id) - | Preendorsement _ -> - Alpha_context.Operation.to_watermark (Preendorsement chain_id) - | _ -> Signature.Generic_operation) - | _ -> failwith "unexpected contents in %a@." Operation_hash.pp op_hash) - >>=? fun watermark -> - match d.signature with - | None -> - failwith - "did not find a signature for op %a@." - Operation_hash.pp - op_hash - | Some signature -> - let unsigned_operation_bytes = - Data_encoding.Binary.to_bytes_exn - Protocol.Alpha_context.Operation.unsigned_encoding - (op.shell, Contents_list d.contents) - in - return - (Signature.check - ~watermark - public_key - signature - unsigned_operation_bytes)) - -let op_is_preendorsement ?level ?round (op_hash : Operation_hash.t) - (op : Alpha_context.packed_operation) = - match op.protocol_data with - | Operation_data d -> ( - match d.contents with - | Single op_contents -> ( - match op_contents with - | Preendorsement consensus_content -> - let right_level = - match level with - | None -> true - | Some expected_level -> - Int32.equal - (Alpha_context.Raw_level.to_int32 consensus_content.level) - expected_level - in - let right_round = - match round with - | None -> true - | Some expected_round -> - Int32.equal - (Alpha_context.Round.to_int32 consensus_content.round) - expected_round - in - return (right_level && right_round) - | _ -> return false) - | _ -> failwith "unexpected contents in %a@." Operation_hash.pp op_hash) - -let op_is_endorsement ?level ?round (op_hash : Operation_hash.t) - (op : Alpha_context.packed_operation) = - match op.protocol_data with - | Operation_data d -> ( - match d.contents with - | Single op_contents -> ( - match op_contents with - | Endorsement consensus_content -> - let right_level = - match level with - | None -> true - | Some expected_level -> - Int32.equal - (Alpha_context.Raw_level.to_int32 consensus_content.level) - expected_level - in - let right_round = - match round with - | None -> true - | Some expected_round -> - Int32.equal - (Alpha_context.Round.to_int32 consensus_content.round) - expected_round - in - return (right_level && right_round) - | _ -> return false) - | _ -> failwith "unexpected contents in %a@." Operation_hash.pp op_hash) - -let op_is_both f g op_hash op = - f op_hash op >>=? fun f_result -> - if f_result then g op_hash op else return false - -let save_proposal_payload - ~(protocol_data : Alpha_context.Block_header.protocol_data) ~var = - var := - Some - (protocol_data.contents.payload_hash, protocol_data.contents.payload_round) ; - return_unit - -let verify_payload_hash - ~(protocol_data : Alpha_context.Block_header.protocol_data) - ~original_proposal ~message = - match !original_proposal with - | None -> - failwith - "verify_payload_hash: expected to have observed a proposal by now" - | Some (original_hash, original_round) -> - if - Protocol.Block_payload_hash.equal - original_hash - protocol_data.contents.payload_hash - && Protocol.Alpha_context.Round.equal - original_round - protocol_data.contents.payload_round - then return_unit - else failwith "verify_payload_hash: %s" message - -let get_block_round block = - round_from_raw_fitness block.rpc_context.block_header.fitness diff --git a/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/mockup_simulator.mli b/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/mockup_simulator.mli deleted file mode 100644 index aff3e8ee82d1d3659842347a5b5940e41aac6faf..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/test/mockup_simulator/mockup_simulator.mli +++ /dev/null @@ -1,253 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Representation of a block in the simulator. *) -type block = { - rpc_context : Tezos_protocol_environment.rpc_context; - protocol_data : Protocol.Alpha_context.Block_header.protocol_data; - raw_protocol_data : Bytes.t; - operations : Mockup.M.Block_services.operation list list; - resulting_context_hash : Context_hash.t; -} - -(** Chain is a list of blocks. *) -type chain = block list - -(** How an operation or block should propagate through the network. *) -type propagation = - | Block (** Block the operation/block, it'll never be delivered. *) - | Pass (** Pass the operation/block as is. *) - | Delay of float - (** Delay the operation/block for the given number of seconds. *) - -(** Values of this type specify to which bakers a block or operation should - be delivered. *) -type propagation_vector = propagation list - -(** The way to control behavior of a mockup node. *) -module type Hooks = sig - (** This function is called on injection of a block by a particular baker. - It allows us to inspect, change, or discard the block. Calling the - injection RPC and actually updating the state of the mockup node are - two different operations. Normally the first entails the latter, but - not always. In particular, the [propagation_vector] controls what - bakers will see and incorporate the block. *) - val on_inject_block : - level:int32 -> - round:int32 -> - block_hash:Block_hash.t -> - block_header:Block_header.t -> - operations:Operation.t list list -> - protocol_data:Alpha_context.Block_header.protocol_data -> - (Block_hash.t * Block_header.t * Operation.t list list * propagation_vector) - tzresult - Lwt.t - - (** This function is called on injection of an operation. It is similar - to [on_inject_block], which see. *) - val on_inject_operation : - op_hash:Operation_hash.t -> - op:Alpha_context.packed_operation -> - (Operation_hash.t * Alpha_context.packed_operation * propagation_vector) - tzresult - Lwt.t - - (** This is called when a new validated block is going to be sent as - the response to a "monitor validated blocks" RPC call. Returning - [None] here terminates the process for the baker. *) - val on_new_validated_block : - block_hash:Block_hash.t -> - block_header:Block_header.t -> - operations:Operation.t list list -> - (Block_hash.t * Block_header.t * Operation.t list list) option Lwt.t - - (** This is called when a new head is going to be sent as the response to - a "monitor heads" RPC call. Returning [None] here terminates the - process for the baker. *) - val on_new_head : - block_hash:Block_hash.t -> - block_header:Block_header.t -> - (Block_hash.t * Block_header.t) option Lwt.t - - (** This is called when a new operation is going to be sent as the - response to a "monitor operations" RPC call. Returning [None] here - indicates that the node has advanced to the next level. *) - val on_new_operation : - Operation_hash.t * Alpha_context.packed_operation -> - (Operation_hash.t * Alpha_context.packed_operation) option Lwt.t - - (** Check a block before processing it in the mockup. *) - val check_block_before_processing : - level:int32 -> - round:int32 -> - block_hash:Block_hash.t -> - block_header:Block_header.t -> - protocol_data:Alpha_context.Block_header.protocol_data -> - unit tzresult Lwt.t - - (** Check the chain after processing a proposal. *) - val check_chain_after_processing : - level:int32 -> round:int32 -> chain:chain -> unit tzresult Lwt.t - - (** Check operations in the mempool after injecting an operation. *) - val check_mempool_after_processing : - mempool:(Operation_hash.t * Mockup.M.Protocol.operation) list -> - unit tzresult Lwt.t - - (** This hook is used to decide when the baker is supposed to shut down. - It is triggered by receiving an event. *) - val stop_on_event : Baking_state.event -> bool - - (** This hook is used to gather information on the baker when it is - started (usually recording for later use). The first argument - [baker_position], is the position of the baker in the list of - bakers that were started for this run. *) - val on_start_baker : - baker_position:int -> - delegates:Baking_state.consensus_key list -> - cctxt:Protocol_client_context.full -> - unit Lwt.t - - (** Check to run on the chain upon successful termination. *) - val check_chain_on_success : chain:chain -> unit tzresult Lwt.t -end - -(** The default hook implementation. *) -module Default_hooks : Hooks - -(** Simulation configuration. *) -type config = { - round0 : int64; (** Duration of the round 0 in seconds. *) - round1 : int64; (** Duration of the round 1 in seconds. *) - timeout : int; - (** Maximal duration of the test. If the test takes - longer to terminate it'll be aborted with an - error. *) - delegate_selection : (int32 * (int32 * Signature.public_key_hash) list) list; - (** Desired selection of delegates per level/round *) - initial_seed : State_hash.t option; - (** Optional initial seed for protocol (used to control delegate selection) *) - consensus_committee_size : int; - (** Size of the committee for tenderbake in number of slots *) - consensus_threshold : int; - (** Threshold, in number of slots, for the quorum to be considered - reached. Should be [2 * consensus_committee_size / 3 + 1] in - usual setting for tenderbake. *) -} - -(** Default configuration. *) -val default_config : config - -(** [run spec] runs a simulation according to the [spec]. Elements of [spec] - describe bakers: how many delegate each baker has and how it behaves. The - total number of delegates cannot exceed 5 for now (it is easy to increase - this limit). The delegates are assigned in order, gradually exhausting - the standard bootstrap accounts. For example, if the first baker has 3 - delegates and the second one has 2 delegates, we have the following - distribution of bootstrap accounts: - - Baker no. 1: bootstrap1, bootstrap2, bootstrap3 - - Baker no. 2: bootstrap4, bootstrap5 - - A simulation continues till all nodes finish either with an error or - successfully. If at least one node finishes with an error, it propagates - to the final result. *) -val run : ?config:config -> (int * (module Hooks)) list -> unit tzresult Lwt.t - -val bootstrap1 : Signature.public_key - -val bootstrap2 : Signature.public_key - -val bootstrap3 : Signature.public_key - -val bootstrap4 : Signature.public_key - -val bootstrap5 : Signature.public_key - -(** Check if a block header is signed by a given delegate. *) -val check_block_signature : - block_hash:Block_hash.t -> - block_header:Block_header.t -> - public_key:Signature.public_key -> - unit tzresult Lwt.t - -(** A shortcut type for predicates on operations. *) -type op_predicate = - Operation_hash.t -> Alpha_context.packed_operation -> bool tzresult Lwt.t - -(** Count the number of operations in the mempool that satisfy the given - predicate. *) -val mempool_count_ops : - mempool:(Operation_hash.t * Mockup.M.Protocol.operation) list -> - predicate:op_predicate -> - int tzresult Lwt.t - -(** Check if the mempool has at least one operation that satisfies the given - predicate. *) -val mempool_has_op : - mempool:(Operation_hash.t * Mockup.M.Protocol.operation) list -> - predicate:op_predicate -> - bool tzresult Lwt.t - -(** Similar to [mempool_has_op] but instead of returning a [bool] it sets - the given [bool ref]. *) -val mempool_has_op_ref : - mempool:(Operation_hash.t * Mockup.M.Protocol.operation) list -> - predicate:op_predicate -> - var:bool ref -> - unit tzresult Lwt.t - -(** Check if an operation is signed by the given delegate. *) -val op_is_signed_by : public_key:Signature.public_key -> op_predicate - -(** Check that an operation is a preendorsement. *) -val op_is_preendorsement : ?level:int32 -> ?round:int32 -> op_predicate - -(** Check that an operation is an endorsement. *) -val op_is_endorsement : ?level:int32 -> ?round:int32 -> op_predicate - -(** Combine two predicates. *) -val op_is_both : op_predicate -> op_predicate -> op_predicate - -(** Set the given variable to save payload hash and payload round. *) -val save_proposal_payload : - protocol_data:Alpha_context.Block_header.protocol_data -> - var:(Block_payload_hash.t * Alpha_context.Round.t) option ref -> - unit tzresult Lwt.t - -(** Check that payload hashes match, fail if it is not the case. *) -val verify_payload_hash : - protocol_data:Alpha_context.Block_header.protocol_data -> - original_proposal:(Block_payload_hash.t * Alpha_context.Round.t) option ref -> - message:string -> - unit tzresult Lwt.t - -(** Parse protocol data. *) -val parse_protocol_data : - Bytes.t -> Alpha_context.Block_header.protocol_data tzresult Lwt.t - -(** Get round of a block. *) -val get_block_round : block -> int32 tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_delegate/test/tenderbrute/dune b/src/proto_017_PtNairob/lib_delegate/test/tenderbrute/dune deleted file mode 100644 index 3202475e1f7e019e575e4011cf5bc418360ec55c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/test/tenderbrute/dune +++ /dev/null @@ -1,24 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(executable - (name tenderbrute_main) - (libraries - octez-libs.base - octez-shell-libs.client-base - octez-protocol-017-PtNairob-libs.client - tezos-protocol-017-PtNairob.protocol - octez-protocol-017-PtNairob-libs.baking.tenderbrute) - (link_flags - (:standard) - (:include %{workspace_root}/macos-link-flags.sexp) - (-linkall)) - (flags - (:standard) - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_base - -open Tezos_client_base - -open Tezos_client_017_PtNairob - -open Tezos_protocol_017_PtNairob - -open Tenderbrute_017_PtNairob)) diff --git a/src/proto_017_PtNairob/lib_delegate/test/tenderbrute/lib/dune b/src/proto_017_PtNairob/lib_delegate/test/tenderbrute/lib/dune deleted file mode 100644 index 5955632c7b2cb84a7dd5afea7523ba6ac01e85c8..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/test/tenderbrute/lib/dune +++ /dev/null @@ -1,22 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name tenderbrute_017_PtNairob) - (public_name octez-protocol-017-PtNairob-libs.baking.tenderbrute) - (libraries - data-encoding - octez-libs.base - octez-libs.base.unix - tezos-protocol-017-PtNairob.protocol - octez-shell-libs.client-base - octez-protocol-017-PtNairob-libs.client) - (flags - (:standard) - -open Data_encoding - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_base - -open Tezos_protocol_017_PtNairob - -open Tezos_client_base - -open Tezos_client_017_PtNairob)) diff --git a/src/proto_017_PtNairob/lib_delegate/test/tenderbrute/lib/tenderbrute.ml b/src/proto_017_PtNairob/lib_delegate/test/tenderbrute/lib/tenderbrute.ml deleted file mode 100644 index dfa062d84ce273f5f9741563fa618e47a6bdeb6c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/test/tenderbrute/lib/tenderbrute.ml +++ /dev/null @@ -1,196 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 - -type delegate_selection = - (Raw_level_repr.t * (Round_repr.t * Signature.public_key_hash) list) list - -module LevelRoundMap = Map.Make (struct - type t = Level_repr.t * Round_repr.t - - let compare (l1, r1) (l2, r2) = - Stdlib.compare - (Raw_level_repr.to_int32 l1.Level_repr.level, Round_repr.to_int32 r1) - (Raw_level_repr.to_int32 l2.Level_repr.level, Round_repr.to_int32 r2) -end) - -let _ = Client_keys.register_signer (module Tezos_signer_backends.Unencrypted) - -(* Initialize a context in memory with the Mockup *) -let init_context ?constants_overrides_json ?bootstrap_accounts_json parameters = - let parameters = - Data_encoding.Binary.of_bytes_exn Mockup.M.parameters_encoding - @@ Data_encoding.Binary.to_bytes_exn - Mockup.Protocol_parameters.encoding - parameters - in - Mockup.M.init - ~cctxt:Client_context.null_printer - ~parameters - ~constants_overrides_json - ~bootstrap_accounts_json - >>=? fun mockup_init -> - let ctxt = mockup_init.rpc_context.context in - let timestamp = Time.Protocol.of_seconds 0L in - (* The timestamp is irrelevant for the rights *) - Raw_context.prepare ctxt ~level:1l ~predecessor_timestamp:timestamp ~timestamp - >|= Environment.wrap_tzresult - -(* Change the initial seed for the first preserved cycles. This suppose that the - seeds for these cycles are already set, which is the case because this - function is always called after {!init_context}. *) -let change_seed ?initial_seed ctxt = - let preserved = Constants_storage.preserved_cycles ctxt in - List.fold_left_es - (fun (c, ctxt) seed -> - let cycle = Cycle_repr.of_int32_exn (Int32.of_int c) in - Storage.Seed.For_cycle.remove_existing ctxt cycle >>=? fun ctxt -> - Storage.Seed.For_cycle.init ctxt cycle seed >|=? fun ctxt -> (c + 1, ctxt)) - (0, ctxt) - (Seed_repr.initial_seeds ?initial_seed (preserved + 2)) - >|=? snd - -let init ?constants_overrides_json ?bootstrap_accounts_json parameters = - init_context ?constants_overrides_json ?bootstrap_accounts_json parameters - >>=? fun ctxt -> - let blocks_per_cycle = Constants_storage.blocks_per_cycle ctxt in - let blocks_per_commitment = Constants_storage.blocks_per_commitment ctxt in - let cycle_eras = - [ - Level_repr. - { - first_level = Raw_level_repr.of_int32_exn 0l; - first_cycle = Cycle_repr.root; - blocks_per_cycle; - blocks_per_commitment; - }; - ] - in - Level_repr.create_cycle_eras cycle_eras |> Environment.wrap_tzresult - >>?= fun cycle_eras -> return (ctxt, cycle_eras) - -(* Check if the given selection correponds to the baking rights assigned by the - protocol (with the initial seeds registered in the context). Returns [true] - when the selection is the one of the protocol or [false] otherwise. *) -let check ctxt ~selection = - Lwt.catch - (fun () -> - LevelRoundMap.fold_es - (fun (level, round) delegate ctxt -> - Delegate_sampler.baking_rights_owner ctxt level ~round - >|= Environment.wrap_tzresult - >>=? fun (ctxt, _, pk) -> - if not (Signature.Public_key_hash.equal delegate pk.delegate) then - raise Exit - else return ctxt) - selection - ctxt - >>=? fun _ctxt -> return_true) - (function Exit -> return_false | e -> Lwt.reraise e) - -(* Create random 32 bytes *) -let rnd_bytes32 () = - let b1 = Random.int64 Int64.max_int in - let b2 = Random.int64 Int64.max_int in - let b3 = Random.int64 Int64.max_int in - let b4 = Random.int64 Int64.max_int in - let b = Bytes.make 32 '\000' in - TzEndian.set_int64 b 0 b1 ; - TzEndian.set_int64 b 8 b2 ; - TzEndian.set_int64 b 16 b3 ; - TzEndian.set_int64 b 24 b4 ; - b - -let mk_selection_map cycle_eras selection = - List.fold_left - (fun acc (level, round_delegates) -> - let level = Level_repr.level_from_raw ~cycle_eras level in - List.fold_left - (fun acc (round, delegate) -> - if LevelRoundMap.mem (level, round) acc then - Stdlib.failwith "Duplicate level/round" ; - LevelRoundMap.add (level, round) delegate acc) - acc - round_delegates) - LevelRoundMap.empty - selection - -(* Bruteforce an initial seed nonce for the desired delegate selection *) -let bruteforce ?(show_progress = false) ?(random_seed = 0) ?max - ?(parameters = Mockup.Protocol_parameters.default_value) - ?constants_overrides_json ?bootstrap_accounts_json selection = - Random.init random_seed ; - init ?constants_overrides_json ?bootstrap_accounts_json parameters - >>=? fun (ctxt, cycle_eras) -> - let selection = mk_selection_map cycle_eras selection in - let last_nb_chars = ref 0 in - let frames = - [| - "( â— )"; - "( â— )"; - "( â— )"; - "( â— )"; - "( â—)"; - "( â— )"; - "( â— )"; - "( â— )"; - "( â— )"; - "(â— )"; - |] - in - let nframes = Array.length frames in - let frame n = frames.(n mod nframes) in - let rec loop n = - if show_progress && n <> 0 && n mod 10_000 = 0 then ( - Format.eprintf "%s" (String.make !last_nb_chars '\b') ; - let s = frame (n / 10_000) ^ " " ^ string_of_int n in - last_nb_chars := String.length s ; - Format.eprintf "%s%!" s) ; - match max with - | Some max when n > max -> failwith "Did not find seed nonce" - | _ -> ( - let initial_seed = - if n = 0 then None - else Some (State_hash.of_bytes_exn (rnd_bytes32 ())) - in - change_seed ?initial_seed ctxt >|= Environment.wrap_tzresult - >>=? fun ctxt -> - check ctxt ~selection >>=? function - | true -> - Format.eprintf "%s%!" (String.make !last_nb_chars '\b') ; - return initial_seed - | false -> loop (n + 1)) - in - loop 0 - -(* Check that an initial seed corresonds to the desired delegate selection *) -let check_seed ?(parameters = Mockup.Protocol_parameters.default_value) - ?constants_overrides_json ?bootstrap_accounts_json ~seed selection = - init ?constants_overrides_json ?bootstrap_accounts_json parameters - >>=? fun (ctxt, cycle_eras) -> - let selection = mk_selection_map cycle_eras selection in - change_seed ?initial_seed:seed ctxt >|= Environment.wrap_tzresult - >>=? fun ctxt -> check ctxt ~selection diff --git a/src/proto_017_PtNairob/lib_delegate/test/tenderbrute/lib/tenderbrute.mli b/src/proto_017_PtNairob/lib_delegate/test/tenderbrute/lib/tenderbrute.mli deleted file mode 100644 index 7b6915d2cfd283a3fed1b2dd55a2e2be4b3194fb..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/test/tenderbrute/lib/tenderbrute.mli +++ /dev/null @@ -1,83 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 - -(** The type of desired delegate selection. For each level, and each round, - one can provide a public key hash that would be the proposer. All non- - specified level and rounds are not constrained. *) -type delegate_selection = - (Raw_level_repr.t * (Round_repr.t * Signature.public_key_hash) list) list - -(** Brute-force an initial seed nonce for the desired delegate selection. - When found, the seed nonce is returned as a byte sequence of size 32. If - no nonce is necessary to obtain the desired selection, [None] is returned - (there won't be any brute-forcing then). - - {b Note}: When using this function in your tests, take care of saving the - nonce once it is found locallty (in this case call {!check_seed_nonce} to - ensure it yields the desired selection) to avoid unnecessary computation - (in particular this function should not be called in the CI). - - @param show_progress if [true], display a spinner and the number of iterations - on the output (stderr) while [brutefore] is running. - @param random_seed initialize OCaml's random number generator with this seed - (by default [0]). This is useful to spawn multiple bruteforce in - parallel or on multiple machines. - @param constants_overrides_json JSON representation of some constants that are - to be overwritten for the in-memory context. The most useful change is to - set the size of cycles (which directly impacts the attribution of rights) or - the committee size with {i e.g.} - {[ { "blocks_per_cycle" : 8, "consensus_committee_size" : 25 } ]} - @param bootstrap_accounts_json JSON representation of bootstrap accounts of - the form: - {[ - [ { "name" : "bootstrap1" - "sk_uri": "unencrypted:edsk3gUfUPyBSfrS9CCgmCiQsTCHGkviBDusMxDJstFtojtc1zcpsh", - "amount": "3000000000000" }, - ...] - ]} - @param parameters parameters of the protocol (optional). - @param selection is the desired delegate selection. See {!delegate_selection}. - *) -val bruteforce : - ?show_progress:bool -> - ?random_seed:int -> - ?max:int -> - ?parameters:Mockup.Protocol_parameters.t -> - ?constants_overrides_json:json -> - ?bootstrap_accounts_json:json -> - delegate_selection -> - State_hash.t option tzresult Lwt.t - -(** Check that an initial seed nonce yields to the desired delegate selection. - See {!bruteforce} for the arguments. *) -val check_seed : - ?parameters:Mockup.Protocol_parameters.t -> - ?constants_overrides_json:json -> - ?bootstrap_accounts_json:json -> - seed:State_hash.t option -> - delegate_selection -> - bool tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_delegate/test/tenderbrute/tenderbrute_main.ml b/src/proto_017_PtNairob/lib_delegate/test/tenderbrute/tenderbrute_main.ml deleted file mode 100644 index f3558b1a198548993524bde2373b0a8f531d48ed..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/test/tenderbrute/tenderbrute_main.ml +++ /dev/null @@ -1,169 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 bootstrap_accounts = ref None - -let constants_overrides = ref None - -let selection = ref [] - -let max = ref None - -let random_seed = ref None - -let report_err res = - match res with - | Error e -> - Format.eprintf "\n%a@." Error_monad.pp_print_trace e ; - exit 2 - | Ok res -> res - -let delegate_encoding = - let open Data_encoding in - union - [ - case - ~title:"Public key hash" - (Tag 0) - Signature.Public_key_hash.encoding - (function `Pkh p -> Some p | _ -> None) - (fun p -> `Pkh p); - case - ~title:"Alias" - (Tag 1) - string - (function `Alias a -> Some a | _ -> None) - (fun a -> `Alias a); - ] - -let selection_encoding = - let open Data_encoding in - list - (tup2 - Raw_level_repr.encoding - (list (tup2 Round_repr.encoding delegate_encoding))) - -let mk_bootstrap_aliases bootstrap_accounts_json = - let parameters = Mockup.Protocol_parameters.default_value in - let open Alpha_context.Parameters in - match bootstrap_accounts_json with - | None -> - List.mapi - (fun i a -> (Format.sprintf "bootstrap%d" i, a.public_key_hash)) - parameters.bootstrap_accounts - |> return - | Some j -> - let open Data_encoding in - let accounts = Json.destruct (list Mockup.Parsed_account.encoding) j in - List.map_ep - (fun a -> - Mockup.Parsed_account.to_bootstrap_account a >|=? fun acc -> - (a.name, acc.public_key_hash)) - accounts - -let selection_to_pkhs bootstrap_accounts_json selection = - mk_bootstrap_aliases bootstrap_accounts_json >|=? fun bootstrap_aliases -> - List.map - (fun (level, l) -> - ( level, - List.map - (fun (round, d) -> - ( round, - match d with - | `Pkh d -> d - | `Alias a -> ( - match List.assoc ~equal:String.equal a bootstrap_aliases with - | None -> Stdlib.failwith @@ "Unknown alias " ^ a - | Some d -> d) )) - l )) - selection - -let parse_json_or_file s = - Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file s >|= function - | Ok json -> Ok json - | Error errs -> ( - match Data_encoding.Json.from_string s with - | Ok json -> Ok json - | Error e -> Error (Exn (Failure e) :: errs)) - -let set_selection s = - Lwt_main.run - ( parse_json_or_file s >|= report_err >|= fun json -> - selection := Data_encoding.Json.destruct selection_encoding json ) - -let main () = - let thread = - (match !bootstrap_accounts with - | None -> return_none - | Some read -> read >|=? Option.some) - >>=? fun bootstrap_accounts_json -> - (match !constants_overrides with - | None -> return_none - | Some read -> read >|=? Option.some) - >>=? fun constants_overrides_json -> - selection_to_pkhs bootstrap_accounts_json !selection >>=? fun selection -> - Tenderbrute.bruteforce - ~show_progress:true - ?max:!max - ?random_seed:!random_seed - ?bootstrap_accounts_json - ?constants_overrides_json - selection - in - Lwt_main.run - ( thread >|= report_err >|= fun seed -> - let seed_str = - match seed with None -> "None" | Some s -> State_hash.to_b58check s - in - Format.printf "%s@." seed_str ) - -let specs = - [ - ( "--max", - Arg.Int (fun m -> max := Some m), - " set maximum number of tries to " ); - ( "--random-seed", - Arg.Int (fun i -> random_seed := Some i), - " initialize the random generator with (useful to spawn mutliple \ - instances)" ); - ( "--constants-overrides", - Arg.String (fun s -> constants_overrides := Some (parse_json_or_file s)), - " set overrides for constants in protocol parameters (e.g. \ - blocks_per_cycle)" ); - ( "--bootstrap-accounts", - Arg.String (fun s -> bootstrap_accounts := Some (parse_json_or_file s)), - " set bootstrap accounts of protocol" ); - ] - -let usage = - Format.sprintf - {|usage: %s '[[1, [[0, "tz1..."], [1, "tz1..."]]], [2, [[0, "tz1..."]]]]'|} - Sys.argv.(0) - -let () = - Arg.parse (Arg.align specs) set_selection usage ; - main () diff --git a/src/proto_017_PtNairob/lib_delegate/test/test_scenario.ml b/src/proto_017_PtNairob/lib_delegate/test/test_scenario.ml deleted file mode 100644 index e6bf774cc6946c1d2f92bf84339d2d90cda9069a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/test/test_scenario.ml +++ /dev/null @@ -1,1895 +0,0 @@ -(* Testing - ------- - Component: Protocol, delegate - Invocation: dune exec src/proto_017_PtNairob/lib_delegate/test/main.exe \ - -- --file test_scenario.ml - Subject: Test different scenario for delegate -*) - -open Mockup_simulator - -let bootstrap1 = Signature.Public_key.hash bootstrap1 - -let bootstrap2 = Signature.Public_key.hash bootstrap2 - -let bootstrap3 = Signature.Public_key.hash bootstrap3 - -let bootstrap4 = Signature.Public_key.hash bootstrap4 - -let bootstrap5 = Signature.Public_key.hash bootstrap5 - -let some_seed s = Some (Protocol.State_hash.of_b58check_exn s) - -(* - -Test that the chain reaches the 5th level. - -*) - -let test_level_5 () = - let level_to_reach = 5l in - let module Hooks : Hooks = struct - include Default_hooks - - let stop_on_event = function - | Baking_state.New_head_proposal {block; _} -> - (* Stop the node as soon as we receive a proposal with a level - higher than [level_to_reach]. *) - block.shell.level > level_to_reach - | _ -> false - - let check_chain_on_success ~chain = - (* Make sure that all decided blocks have been decided at round 0. *) - let round_is_zero block = - let level = block.rpc_context.block_header.level in - get_block_round block >>=? fun round -> - if Int32.equal round 0l then return () - else failwith "block at level %ld was selected at round %ld" level round - in - List.iter_es round_is_zero chain - end in - (* Here we start two bakers, one with 3 delegates (bootstrap1, bootstrap2, - bootstrap3) and the other with 2 delegates (bootstrap4, bootstrap5). - The simulation continues till both nodes stop, see [stop_on_event] - above. *) - let config = - { - default_config with - timeout = Int32.to_int level_to_reach * 3 * 2; - round0 = 2L; - round1 = 3L; - } - in - run ~config [(3, (module Hooks)); (2, (module Hooks))] - -let test_preendorse_on_valid () = - let level_to_reach = 2l in - let round_to_reach = 1l in - let module Hooks : Hooks = struct - include Default_hooks - - let on_new_head ~block_hash ~block_header = - (* Stop notifying heads on the level to reach, only notify that - it has been validated *) - if block_header.Block_header.shell.level < level_to_reach then - Lwt.return_some (block_hash, block_header) - else Lwt.return_none - - let seen_candidate = ref None - - let pqc_noticed = ref false - - let qc_noticed = ref false - - let stop_on_event = function - | Baking_state.Prequorum_reached (candidate, _) -> - (* Register the PQC notice. *) - (match !seen_candidate with - | Some seen_candidate - when Block_hash.(candidate.hash = seen_candidate) -> - pqc_noticed := true - | _ -> ()) ; - false - | Baking_state.Quorum_reached (candidate, _) -> - (* Because attestations are sent regardless of whether - a head has been applied, we can expect a quorum to - be received regardless of a head not being produced. *) - (match !seen_candidate with - | Some seen_candidate - when Block_hash.(candidate.hash = seen_candidate) -> - qc_noticed := true - | _ -> ()) ; - false - | New_head_proposal {block; _} -> - (* Ensure that we never notice a new head at the level where - we are not supposed to. *) - if block.shell.level = level_to_reach then - Stdlib.failwith "Unexpected new head event" - else false - | New_valid_proposal {block; _} -> - (* Register the seen valid proposal candidate. *) - if - block.shell.level = level_to_reach - && Protocol.Alpha_context.Round.to_int32 block.round = 0l - then seen_candidate := Some block.hash ; - (* Stop the node when we reach level 2 / round 2. *) - block.shell.level = level_to_reach - && Protocol.Alpha_context.Round.to_int32 block.round >= round_to_reach - | _ -> false - - let check_chain_on_success ~chain:_ = - assert (!seen_candidate <> None) ; - assert !pqc_noticed ; - assert !qc_noticed ; - return_unit - end in - let config = {default_config with timeout = 10} in - run ~config [(1, (module Hooks))] - -let test_reset_delayed_pqc () = - let module Hooks : Hooks = struct - include Default_hooks - - let should_wait = ref true - - let trigger = ref false - - let on_new_operation x = - (if !should_wait then Lwt_unix.sleep 0.5 else Lwt_unix.sleep 0.2) - >>= fun () -> - if !trigger then ( - trigger := false ; - Lwt.return_none) - else Lwt.return_some x - - let on_new_head ~block_hash ~(block_header : Block_header.t) = - let block_round = - match - Protocol.Alpha_context.Fitness.round_from_raw - block_header.shell.fitness - with - | Error _ -> assert false - | Ok x -> x - in - if - block_header.Block_header.shell.level = 1l - && Protocol.Alpha_context.Round.(block_round = zero) - then ( - Lwt_unix.sleep 1. >>= fun () -> - should_wait := false ; - trigger := true ; - Lwt.return_some (block_hash, block_header)) - else Lwt.return_some (block_hash, block_header) - - let stop_on_event = function - | Baking_state.New_valid_proposal {block; _} -> - let is_high_round = - let open Protocol.Alpha_context.Round in - match of_int 5 with - | Ok high_round -> block.round = high_round - | _ -> assert false - in - (block.shell.level = 1l && is_high_round) || block.shell.level > 1l - | _ -> false - - let check_chain_on_success ~chain = - let head = Stdlib.List.hd chain in - if head.rpc_context.block_header.level = 1l then failwith "baker is stuck" - else return_unit - end in - let config = {default_config with round0 = 2L; round1 = 3L; timeout = 50} in - run ~config [(1, (module Hooks))] - -(* - -Scenario T1 - -1. Node A proposes at the round 0. -2. Both node A and node B preendorse. -3. Node A stops. -4. Node B endorses in the round 0 and locks. No decision is taken at the - round 0 because A did not endorse. -5. We check that in round 1 (the next slot for B), B proposes the same - value as A proposed in the round 0, not a new proposal. -*) - -let test_scenario_t1 () = - let original_proposal = ref None in - let a_preendorsed = ref false in - let b_preendorsed = ref false in - let b_endorsed = ref false in - let b_reproposed = ref false in - (* Here we use custom hooks to make each node/baker behave according to - its role in the scenario. *) - let module Node_a_hooks : Hooks = struct - include Default_hooks - - let check_mempool_after_processing ~mempool = - mempool_has_op_ref - ~mempool - ~predicate: - (op_is_both - (op_is_signed_by ~public_key:Mockup_simulator.bootstrap1) - (op_is_preendorsement ~level:1l ~round:0l)) - ~var:a_preendorsed - - let stop_on_event _ = !a_preendorsed - end in - let module Node_b_hooks : Hooks = struct - include Default_hooks - - let check_block_before_processing ~level ~round ~block_hash ~block_header - ~(protocol_data : Protocol.Alpha_context.Block_header.protocol_data) = - (match (!b_endorsed, level, round) with - | false, 1l, 0l -> - (* If any of the checks fails the whole scenario will fail. *) - check_block_signature - ~block_hash - ~block_header - ~public_key:Mockup_simulator.bootstrap1 - >>=? fun () -> - save_proposal_payload ~protocol_data ~var:original_proposal - | true, 1l, 1l -> - check_block_signature - ~block_hash - ~block_header - ~public_key:Mockup_simulator.bootstrap2 - >>=? fun () -> - verify_payload_hash - ~protocol_data - ~original_proposal - ~message:"a new block proposed instead of reproposal" - >>=? fun () -> - b_reproposed := true ; - return_unit - | _ -> failwith "unexpected level = %ld / round = %ld" level round) - >>=? fun () -> return_unit - - let check_mempool_after_processing ~mempool = - mempool_has_op_ref - ~mempool - ~predicate: - (op_is_both - (op_is_signed_by ~public_key:Mockup_simulator.bootstrap2) - (op_is_preendorsement ~level:1l ~round:0l)) - ~var:b_preendorsed - >>=? fun () -> - mempool_has_op_ref - ~mempool - ~predicate: - (op_is_both - (op_is_signed_by ~public_key:Mockup_simulator.bootstrap2) - (op_is_preendorsement ~level:1l ~round:0l)) - ~var:b_endorsed - - let stop_on_event _ = !b_reproposed - end in - let config = - { - default_config with - initial_seed = None; - delegate_selection = [(1l, [(0l, bootstrap1); (1l, bootstrap2)])]; - } - in - run ~config [(1, (module Node_a_hooks)); (1, (module Node_b_hooks))] - -(* - -Scenario T2 - -1. Node A should propose at the round 0, but it is dead. -2. Node B waits til it has its proposal slot at round 1 and proposes then. - -*) - -let test_scenario_t2 () = - let b_proposed = ref false in - let module Node_a_hooks : Hooks = struct - include Default_hooks - - let stop_on_event _ = true (* Node A stops immediately. *) - end in - let module Node_b_hooks : Hooks = struct - include Default_hooks - - let check_block_before_processing ~level ~round ~block_hash ~block_header - ~protocol_data:_ = - (* Here we test that the only block that B observes is its own - proposal for level 1 at round 1. *) - match (level, round) with - | 1l, 1l -> - check_block_signature - ~block_hash - ~block_header - ~public_key:Mockup_simulator.bootstrap2 - >>=? fun () -> - b_proposed := true ; - return_unit - | _ -> failwith "unexpected level = %ld / round = %ld" level round - - let stop_on_event _ = - (* Stop as soon as B has proposed. This ends the test. *) - !b_proposed - end in - let config = - { - default_config with - initial_seed = None; - delegate_selection = [(1l, [(0l, bootstrap1); (1l, bootstrap2)])]; - } - in - run ~config [(1, (module Node_a_hooks)); (1, (module Node_b_hooks))] - -(* - -Scenario T3 - -1. There are four nodes: A, B, C, and D. -2. C is the proposer at the round 0. It sends the proposal, which is - received by all bakers except for D. -3. Due to how the messages propagate, only B sees 3 preendorsements. It - endorses and locks. Other nodes all see fewer than 3 preendorsements. - - A -> A and B - B -> B - C -> C and B - -4. D proposes at the round 1. Its message reaches 3 nodes, including B. - - D -> D, B, C - -5. B does not preendorse because it is locked. -6. No decision is taken at the round 1. -7. B proposes at the round 2. There are no more problems with propagation of - messages, so a decision is reached. - -*) - -let test_scenario_t3 () = - let b_observed_pqc = ref false in - let original_proposal = ref None in - let we_are_done = ref false in - let stop_on_event0 _ = !we_are_done in - let module Node_a_hooks : Hooks = struct - include Default_hooks - - let on_inject_operation ~op_hash ~op = - if !b_observed_pqc then return (op_hash, op, [Pass; Pass; Pass; Pass]) - else - op_is_preendorsement ~level:1l ~round:0l op_hash op - >>=? fun is_preendorsement -> - if is_preendorsement then - return (op_hash, op, [Pass; Pass; Block; Block]) - else failwith "unexpected operation from the node D" - - let stop_on_event = stop_on_event0 - end in - let module Node_b_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level ~round ~block_hash ~block_header ~operations - ~(protocol_data : Protocol.Alpha_context.Block_header.protocol_data) = - match (level, round) with - | 1l, 2l -> - check_block_signature - ~block_hash - ~block_header - ~public_key:Mockup_simulator.bootstrap2 - >>=? fun () -> - we_are_done := true ; - verify_payload_hash - ~protocol_data - ~original_proposal - ~message:"a new block proposed instead of reproposal" - >>=? fun () -> - return (block_hash, block_header, operations, [Pass; Pass; Pass; Pass]) - | _ -> - failwith - "unexpected injection on the node B, level = %ld / round = %ld" - level - round - - let on_inject_operation ~op_hash ~op = - if !b_observed_pqc then return (op_hash, op, [Pass; Pass; Pass; Pass]) - else - op_is_preendorsement ~level:1l ~round:0l op_hash op - >>=? fun is_preendorsement -> - if is_preendorsement then - return (op_hash, op, [Block; Pass; Block; Block]) - else failwith "unexpected operation from the node B" - - let check_mempool_after_processing ~mempool = - let predicate op_hash op = - op_is_preendorsement ~level:1l ~round:0l op_hash op - in - mempool_count_ops ~mempool ~predicate >>=? fun n -> - if n > 3 then - failwith "B received too many preendorsements, expected to see only 3" - else if n = 3 then ( - b_observed_pqc := true ; - return_unit) - else return_unit - - let stop_on_event = stop_on_event0 - end in - let module Node_c_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level ~round ~block_hash ~block_header ~operations - ~(protocol_data : Protocol.Alpha_context.Block_header.protocol_data) = - match (level, round) with - | 1l, 0l -> - check_block_signature - ~block_hash - ~block_header - ~public_key:Mockup_simulator.bootstrap3 - >>=? fun () -> - save_proposal_payload ~protocol_data ~var:original_proposal - >>=? fun () -> - return - (block_hash, block_header, operations, [Pass; Pass; Pass; Block]) - | _ -> - failwith - "unexpected injection on the node C, level = %ld / round = %ld" - level - round - - let on_inject_operation ~op_hash ~op = - if !b_observed_pqc then return (op_hash, op, [Pass; Pass; Pass; Pass]) - else - op_is_preendorsement ~level:1l ~round:0l op_hash op - >>=? fun is_preendorsement -> - if is_preendorsement then - return (op_hash, op, [Block; Pass; Pass; Block]) - else failwith "unexpected operation from the node C" - - let stop_on_event = stop_on_event0 - end in - let module Node_d_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level ~round ~block_hash ~block_header ~operations - ~protocol_data:_ = - match (level, round) with - | 1l, 1l -> - return - (block_hash, block_header, operations, [Block; Pass; Pass; Pass]) - | _ -> - failwith - "unexpected injection on the node D, level = %ld / round = %ld" - level - round - - let on_inject_operation ~op_hash ~op = - if !b_observed_pqc then return (op_hash, op, [Pass; Pass; Pass; Pass]) - else return (op_hash, op, [Block; Block; Block; Block]) - - let stop_on_event = stop_on_event0 - end in - let config = - { - default_config with - initial_seed = - some_seed "rngFtAUcm1EneHCCrxxSWAaxSukwEhSPvpTnFjVdKLEjgkapUy1pP"; - delegate_selection = - [ - ( 1l, - [ - (0l, bootstrap3); - (1l, bootstrap4); - (2l, bootstrap2); - (3l, bootstrap1); - ] ); - ( 2l, - [ - (0l, bootstrap1); - (1l, bootstrap2); - (2l, bootstrap3); - (3l, bootstrap4); - ] ); - ]; - } - in - run - ~config - [ - (1, (module Node_a_hooks)); - (1, (module Node_b_hooks)); - (1, (module Node_c_hooks)); - (1, (module Node_d_hooks)); - ] - -(* Scenario T4 - - 1. There are two nodes A B: - A can propose at level 1, round 0 and level 2, round 1 - B can propose at level 1, round 1 and level 2, round 0 - 4. Node A proposes at level 1, round 0, - 5. Both nodes preattest the proposal at level 1, round 0, - 6. Both nodes attest the proposal at level 1, round 0, - 7. Only A receives the block application at level 1, round 0, - 8. B does not propose at level 2, round 0, - 9. A proposes at level 2, round 1. - Predecessor hash is block at level 1, round 0. -*) - -let test_scenario_t4 () = - let open Lwt_result_syntax in - let level_to_reach = 4l in - let a_proposal_level_1 = ref None in - let a_proposal_level_2_predecessor = ref None in - let b_endorsed_level_1 = ref false in - let b_proposed_level_2 = ref false in - - let stop_on_event0 = function - | Baking_state.New_head_proposal {block; _} -> - block.shell.level >= level_to_reach - | _ -> false - in - let module Node_a_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level ~round ~block_hash ~block_header ~operations - ~protocol_data:_ = - let () = - match (level, round) with - | 1l, 0l -> a_proposal_level_1 := Some block_hash - | 2l, 1l -> - a_proposal_level_2_predecessor := - Some block_header.Block_header.shell.predecessor - | _ -> () - in - return (block_hash, block_header, operations, [Pass; Pass]) - - let stop_on_event = stop_on_event0 - end in - let module Node_b_hooks : Hooks = struct - include Default_hooks - - let on_new_head ~block_hash ~block_header = - (* Stop notifying heads to node B for block proposed at level 1, round 0. *) - match !a_proposal_level_1 with - | Some a_proposal_level_1 - when Block_hash.(a_proposal_level_1 = block_hash) -> - Lwt.return_none - | _ -> Lwt.return_some (block_hash, block_header) - - let on_inject_block ~level ~round ~block_hash ~block_header ~operations - ~protocol_data:_ = - let () = - match (level, round) with - | 2l, 0l -> b_proposed_level_2 := true - | _ -> () - in - return (block_hash, block_header, operations, [Pass; Pass]) - - let on_inject_operation ~op_hash ~op = - let* is_endorsement = op_is_endorsement ~level:1l ~round:0l op_hash op in - if is_endorsement then b_endorsed_level_1 := true ; - return (op_hash, op, [Pass; Pass]) - - let check_chain_on_success ~chain:_ = - if not !b_endorsed_level_1 then - failwith "Node B did not endorse proposal at level 1, round 0" - else if - not - @@ Option.equal - Block_hash.equal - !a_proposal_level_2_predecessor - !a_proposal_level_1 - then - failwith - "Invalid predecessor block for A's proposal at level 2: proposal had \ - predecessor %a, expected %a\n" - (Format.pp_print_option Block_hash.pp_short) - !a_proposal_level_1 - (Format.pp_print_option Block_hash.pp_short) - !a_proposal_level_2_predecessor - else return_unit - - let stop_on_event = stop_on_event0 - end in - let config = - { - default_config with - initial_seed = - some_seed "rngG9pS9mbDWnz6YLUFrd8sbb9KMUzfAUMpSpnxNHY9BFnSB8L3zq"; - delegate_selection = - [ - (1l, [(0l, bootstrap1); (1l, bootstrap2)]); - (2l, [(0l, bootstrap2); (1l, bootstrap1)]); - ]; - } - in - run ~config [(1, (module Node_a_hooks)); (1, (module Node_b_hooks))] - -(* - -Scenario F1 - -1. Node C (bootstrap3) proposes at level 1 round 0, its proposal reaches all - nodes. -2. Propagation of preendorsements happens in such a way that only Node A - (bootstrap1) observes PQC: - - A -> A - B -> B and A - C -> C and A - D -> D and A - - Node A locks. - -3. At the level 1 round 1 node D (bootstrap4) proposes. Propagation of - messages is normal. - -4. Node A (bootstrap1) should propose at level 2 round 0. - -*) - -let test_scenario_f1 () = - let c_proposed_l1_r0 = ref false in - let d_proposed_l1_r1 = ref false in - let a_proposed_l2_r0 = ref false in - let stop_on_event0 _ = !a_proposed_l2_r0 in - let pass = - (* This is to be sure that the proposal for round r arrives while - the baker is in round r, and not in round r-1. (See related - issue: - https://gitlab.com/tezos/tezos/-/issues/4143). Otherwise, the - test does not perform as expected. *) - Delay 0.5 - in - let module Node_a_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level ~round ~block_hash ~block_header ~operations - ~protocol_data:_ = - match (!c_proposed_l1_r0, !d_proposed_l1_r1, level, round) with - | true, true, 2l, 0l -> - check_block_signature - ~block_hash - ~block_header - ~public_key:Mockup_simulator.bootstrap1 - >>=? fun () -> - (a_proposed_l2_r0 := true ; - return_unit) - >>=? fun () -> - return (block_hash, block_header, operations, [pass; pass; pass; pass]) - | _ -> - failwith - "unexpected injection on the node A, level = %ld / round = %ld" - level - round - - let on_inject_operation ~op_hash ~op = - match (!c_proposed_l1_r0, !d_proposed_l1_r1) with - | true, false -> return (op_hash, op, [Pass; Block; Block; Block]) - | _ -> return (op_hash, op, [Pass; Pass; Pass; Pass]) - - let stop_on_event = stop_on_event0 - end in - let module Node_b_hooks : Hooks = struct - include Default_hooks - - let on_inject_operation ~op_hash ~op = - match (!c_proposed_l1_r0, !d_proposed_l1_r1) with - | true, false -> return (op_hash, op, [Pass; Pass; Block; Block]) - | _ -> return (op_hash, op, [Pass; Pass; Pass; Pass]) - - let stop_on_event = stop_on_event0 - end in - let module Node_c_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level ~round ~block_hash ~block_header ~operations - ~protocol_data:_ = - match (!c_proposed_l1_r0, !d_proposed_l1_r1, level, round) with - | false, false, 1l, 0l -> - check_block_signature - ~block_hash - ~block_header - ~public_key:Mockup_simulator.bootstrap3 - >>=? fun () -> - (c_proposed_l1_r0 := true ; - return_unit) - >>=? fun () -> - return (block_hash, block_header, operations, [pass; pass; pass; pass]) - | _ -> - failwith - "unexpected injection on the node C, level = %ld / round = %ld" - level - round - - let on_inject_operation ~op_hash ~op = - match (!c_proposed_l1_r0, !d_proposed_l1_r1) with - | true, false -> return (op_hash, op, [Pass; Block; Pass; Block]) - | _ -> return (op_hash, op, [Pass; Pass; Pass; Pass]) - - let stop_on_event = stop_on_event0 - end in - let module Node_d_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level ~round ~block_hash ~block_header ~operations - ~protocol_data:_ = - match (!d_proposed_l1_r1, level, round) with - | false, 1l, 1l -> - check_block_signature - ~block_hash - ~block_header - ~public_key:Mockup_simulator.bootstrap4 - >>=? fun () -> - (d_proposed_l1_r1 := true ; - return_unit) - >>=? fun () -> - return (block_hash, block_header, operations, [pass; pass; pass; pass]) - | _ -> - failwith - "unexpected injection on the node D, level = %ld / round = %ld" - level - round - - let on_inject_operation ~op_hash ~op = - match (!c_proposed_l1_r0, !d_proposed_l1_r1) with - | true, false -> return (op_hash, op, [Pass; Block; Block; Pass]) - | _ -> return (op_hash, op, [Pass; Pass; Pass; Pass]) - - let stop_on_event = stop_on_event0 - end in - let config = - { - default_config with - initial_seed = - some_seed "rngGohKUZjXzv69sxvDqAYRd4XPDQSxDoEpP72znu2jduBuhcYiSE"; - delegate_selection = - [ - ( 1l, - [ - (0l, bootstrap3); - (1l, bootstrap4); - (2l, bootstrap1); - (3l, bootstrap2); - ] ); - ( 2l, - [ - (0l, bootstrap1); - (1l, bootstrap4); - (2l, bootstrap2); - (3l, bootstrap3); - ] ); - ]; - timeout = 30; - } - in - run - ~config - [ - (1, (module Node_a_hooks)); - (1, (module Node_b_hooks)); - (1, (module Node_c_hooks)); - (1, (module Node_d_hooks)); - ] - -(* - -Scenario F2 - -1. There are four nodes: A, B, C, and D. -2. A proposes at 1.0 and observes EQC. -3. A has the slot at 2.0 but somehow it doesn't propose or its proposal is lost. -4. B, C, and D have the rounds 1, 2, and 3 respectively, but they also do not propose. -5. A should still propose at 2.4. - -*) - -let test_scenario_f2 () = - let proposal_2_4_observed = ref false in - let module Hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level ~round ~block_hash ~block_header ~operations - ~protocol_data:_ = - let propagation_vector = - match (level, round) with - | 1l, 0l -> [Pass; Pass; Pass; Pass] - | 2l, 0l -> [Pass; Block; Block; Block] - | 2l, 4l -> - proposal_2_4_observed := true ; - [Pass; Pass; Pass; Pass] - | _ -> [Block; Block; Block; Block] - in - return (block_hash, block_header, operations, propagation_vector) - - let stop_on_event _ = !proposal_2_4_observed - end in - let config = - { - default_config with - initial_seed = - some_seed "rngGPSm87ZqWxJmZu7rewiLiyKY72ffCQQvxDuWmFBw59dWAL5VTB"; - delegate_selection = - [ - (1l, [(0l, bootstrap1)]); - ( 2l, - [ - (0l, bootstrap1); - (1l, bootstrap2); - (2l, bootstrap3); - (3l, bootstrap4); - (4l, bootstrap1); - ] ); - ]; - timeout = 60; - round0 = 2L; - round1 = 3L; - } - in - run - ~config - [ - (1, (module Hooks)); - (1, (module Hooks)); - (1, (module Hooks)); - (1, (module Hooks)); - ] - -(* - -Scenario M1 - -1. Four nodes start, each with 1 delegate. -2. As soon as 2nd level is proposed all communication between nodes becomes - impossible. -3. The situation continues for 5 seconds. -4. After communication is resumed the bakers must continue making progress. - -*) - -let test_scenario_m1 () = - let observed_level2_timestamp = ref None in - let network_down_sec = 5. in - let module Hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level ~round:_ ~block_hash ~block_header ~operations - ~protocol_data:_ = - let propagation_vector = - match !observed_level2_timestamp with - | None -> - if Compare.Int32.(level >= 2l) then ( - observed_level2_timestamp := Some (Unix.time ()) ; - [Pass; Pass; Pass; Pass]) - else [Pass; Pass; Pass; Pass] - | Some level2_observed -> - if Unix.time () -. level2_observed < network_down_sec then - [Block; Block; Block; Block] - else [Pass; Pass; Pass; Pass] - in - return (block_hash, block_header, operations, propagation_vector) - - let on_inject_operation ~op_hash ~op = - let propagation_vector = - match !observed_level2_timestamp with - | None -> [Pass; Pass; Pass; Pass] - | Some level2_observed -> - if Unix.time () -. level2_observed < network_down_sec then - [Block; Block; Block; Block] - else [Pass; Pass; Pass; Pass] - in - return (op_hash, op, propagation_vector) - - let stop_on_event = function - | Baking_state.New_head_proposal {block; _} -> block.shell.level > 4l - | _ -> false - end in - let config = {default_config with timeout = 60} in - run - ~config - [ - (1, (module Hooks)); - (1, (module Hooks)); - (1, (module Hooks)); - (1, (module Hooks)); - ] - -(* - -Scenario M2 - -1. Five nodes start (single delegate per node). -2. They decide level 1. -3. However, the node that has the slot for level 2 round 0 is not there - to participate. -4. We check that the chain continues advancing despite that. - -*) - -let test_scenario_m2 () = - let module Normal_node : Hooks = struct - include Default_hooks - - let stop_on_event = function - | Baking_state.New_head_proposal {block; _} -> block.shell.level > 5l - | _ -> false - end in - let module Missing_node : Hooks = struct - include Default_hooks - - let stop_on_event _ = true (* stop immediately *) - end in - let config = - { - default_config with - initial_seed = - some_seed "rngGo77zNC59bYiQMk2M14aDZZu4KXG8BV1C8pi7afjJ7cXyqB3M1"; - delegate_selection = - [ - ( 1l, - [ - (0l, bootstrap1); - (1l, bootstrap2); - (2l, bootstrap3); - (3l, bootstrap4); - ] ); - ( 2l, - [ - (0l, bootstrap5); - (1l, bootstrap1); - (2l, bootstrap2); - (3l, bootstrap3); - (4l, bootstrap4); - ] ); - ]; - round0 = 2L; - round1 = 3L; - timeout = 60; - } - in - run - ~config - [ - (1, (module Normal_node)); - (1, (module Normal_node)); - (1, (module Normal_node)); - (1, (module Normal_node)); - (1, (module Missing_node)); - ] - -(* - -Scenario M3 - -1. There are four nodes: A, B, C, and D. -2. A and B propose in turns. Messages from A reach every node, but messages - from other nodes only go to A. -3. The chain should not make progress. Since we have both bootstrap1 and - bootstrap2 in delegate selection they have equal voting power. Therefore - it is necessary to have 2 votes for prequorums (which is achieved when A - is proposing) and 2 votes for quorums (impossible because B has no way to - obtain PQC and thus cannot send endorsements). - -*) - -let test_scenario_m3 () = - let stop_on_event0 = function - | Baking_state.New_head_proposal {block; _} -> - block.shell.level = 1l - && Protocol.Alpha_context.Round.to_int32 block.round = 6l - | _ -> false - in - - let module Node_a_hooks : Hooks = struct - include Default_hooks - - let stop_on_event = stop_on_event0 - end in - let module Other_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level:_ ~round:_ ~block_hash ~block_header ~operations - ~protocol_data:_ = - return (block_hash, block_header, operations, [Pass; Block; Block; Block]) - - let on_inject_operation ~op_hash ~op = - return (op_hash, op, [Pass; Block; Block; Block]) - - let stop_on_event = stop_on_event0 - end in - let config = - { - default_config with - initial_seed = - some_seed "rngGaxNJcwEVJLgQXmnN8KN5skn6fhU4Awtu8zVDKViTd5gsfT51M"; - delegate_selection = - [ - ( 1l, - [ - (0l, bootstrap1); - (1l, bootstrap2); - (2l, bootstrap1); - (3l, bootstrap2); - (4l, bootstrap1); - (5l, bootstrap2); - (6l, bootstrap1); - ] ); - ]; - round0 = 2L; - round1 = 3L; - timeout = 60; - } - in - run - ~config - [ - (1, (module Node_a_hooks)); - (1, (module Other_hooks)); - (1, (module Other_hooks)); - (1, (module Other_hooks)); - ] - -(* - -Scenario M4 - -1. There are four bakers: A, B, C, and D. -2. A proposes at level 1 round 0. Its proposal reaches A, B, C, and D, but - with a delay of 0.5 seconds. -3. 3 votes are enough for consensus, because voting powers of all delegates - are equal. Preendorsements propagate freely, however endorsements from C - are blocked. -4. Check that at level 1 round 0 quorum is reached (from the point of view - of A). This means that D sends an endorsement despite receiving - preendorsements before the proposal. - -*) - -let test_scenario_m4 () = - let a_observed_qc = ref false in - let stop_on_event0 _ = !a_observed_qc in - let module Node_a_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level ~round ~block_hash ~block_header ~operations - ~protocol_data:_ = - match (level, round) with - | 1l, 0l -> - check_block_signature - ~block_hash - ~block_header - ~public_key:Mockup_simulator.bootstrap1 - >>=? fun () -> - return - (block_hash, block_header, operations, [Pass; Pass; Pass; Delay 0.5]) - | _ -> - failwith - "unexpected injection on the node A, level = %ld / round = %ld" - level - round - - let check_mempool_after_processing ~mempool = - let predicate op_hash op = - op_is_endorsement ~level:1l ~round:0l op_hash op - in - mempool_count_ops ~mempool ~predicate >>=? fun n -> - if n > 3 then - failwith "A received too many endorsements, expected to see only 3" - else if n = 3 then ( - a_observed_qc := true ; - return_unit) - else return_unit - - let stop_on_event = stop_on_event0 - end in - let module Node_b_hooks : Hooks = struct - include Default_hooks - - let stop_on_event = stop_on_event0 - end in - let module Node_c_hooks : Hooks = struct - include Default_hooks - - let on_inject_operation ~op_hash ~op = - op_is_endorsement ~level:1l ~round:0l op_hash op - >>=? fun is_endorsement -> - return - ( op_hash, - op, - if is_endorsement then [Block; Block; Block; Block] - else [Pass; Pass; Pass; Pass] ) - - let stop_on_event = stop_on_event0 - end in - let module Node_d_hooks : Hooks = struct - include Default_hooks - - let stop_on_event = stop_on_event0 - end in - let config = - { - default_config with - initial_seed = - some_seed "rngGJmwLi7kPvGwV2LR3kjNQ6xamGPCZ9ooep9QcafbqRXZhYEciT"; - delegate_selection = - [ - ( 1l, - [ - (0l, bootstrap1); - (1l, bootstrap2); - (2l, bootstrap3); - (3l, bootstrap4); - ] ); - ]; - } - in - run - ~config - [ - (1, (module Node_a_hooks)); - (1, (module Node_b_hooks)); - (1, (module Node_c_hooks)); - (1, (module Node_d_hooks)); - ] - -(* - -Scenario M5 - -1. There are four bakers: A, B, C, and D. -2. A proposes at level 1 round 0. Its proposal reaches A, B, C, and D, but with - a delay of 1 second. There are no problems with propagation of - preendorsements and endorsements. -3. At the level 1 all four bakers have proposer slots, however we block possible - proposals from B and C at higher rounds. -4. Check that D proposes at the level 2 round 0, which means that it has - observed QC. - -*) - -let test_scenario_m5 () = - let stop_on_event0 = function - | Baking_state.New_head_proposal {block; _} -> block.shell.level >= 2l - | _ -> false - in - let module Node_a_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level ~round ~block_hash ~block_header ~operations - ~protocol_data:_ = - match (level, round) with - | 1l, 0l -> - check_block_signature - ~block_hash - ~block_header - ~public_key:Mockup_simulator.bootstrap1 - >>=? fun () -> - return - (block_hash, block_header, operations, [Pass; Pass; Pass; Delay 1.0]) - | _ -> - failwith - "unexpected injection on the node A, level = %ld / round = %ld" - level - round - - let stop_on_event = stop_on_event0 - end in - let module Other_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level:_ ~round:_ ~block_hash ~block_header ~operations - ~protocol_data:_ = - return (block_hash, block_header, operations, [Block; Block; Block; Block]) - - let stop_on_event = stop_on_event0 - end in - let module Node_d_hooks : Hooks = struct - include Default_hooks - - let stop_on_event = stop_on_event0 - end in - let config = - { - default_config with - initial_seed = - some_seed "rngGJmwLi7kPvGwV2LR3kjNQ6xamGPCZ9ooep9QcafbqRXZhYEciT"; - delegate_selection = - [ - ( 1l, - [ - (0l, bootstrap1); - (1l, bootstrap2); - (2l, bootstrap3); - (3l, bootstrap4); - ] ); - ]; - round0 = 3L; - round1 = 4L; - } - in - run - ~config - [ - (1, (module Node_a_hooks)); - (1, (module Other_hooks)); - (1, (module Other_hooks)); - (1, (module Node_d_hooks)); - ] - -(* - -Scenario M6 - -1. There are four bakers: A, B, C, and D. -2. A proposes at level 1 round 0. Its proposal reaches all nodes, and they - observe PQC. Only A observes a QC. -3. At level 1 round 1 it is B's turn to propose. Since it has observed the - PQC, it reproposes A's proposal. A does not see it. -4. B observes PQC and QC for its proposal. -5. A proposes at level 2 round 0. No one sees the proposal. -6. B proposes at level 2 round 1. A sees B's proposal and switches its branch. -7. We wait 2 more levels before checking A's chain to verify that it has - adopted B's proposal. - -*) - -let test_scenario_m6 () = - let b_proposal_2_1 = ref None in - let stop_on_event0 = function - | Baking_state.New_head_proposal {block; _} -> block.shell.level > 4l - | _ -> false - in - let module Node_a_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level ~round ~block_hash ~block_header ~operations - ~protocol_data:_ = - let propagation_vector = - match (level, round) with - | 2l, 0l -> [Pass; Block; Block; Block] - | _ -> [Pass; Pass; Pass; Pass] - in - return (block_hash, block_header, operations, propagation_vector) - - let on_inject_operation ~op_hash ~op = - op_is_endorsement ~level:1l ~round:0l op_hash op - >>=? fun is_a10_endorsement -> - return - ( op_hash, - op, - if is_a10_endorsement then [Pass; Block; Block; Block] - else [Pass; Pass; Pass; Pass] ) - - let stop_on_event = stop_on_event0 - - let check_chain_on_success ~chain = - match List.nth (List.rev chain) 2 with - | None -> failwith "Node A has empty chain" - | Some (block : block) -> - verify_payload_hash - ~protocol_data:block.protocol_data - ~original_proposal:b_proposal_2_1 - ~message:"A did not switch to B's proposal (level 2, round 1)" - end in - let module Node_b_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level ~round ~block_hash ~block_header ~operations - ~protocol_data = - (match (level, round) with - | 1l, 1l -> return [Block; Delay 0.1; Delay 0.1; Delay 0.1] - | 2l, 1l -> - save_proposal_payload ~protocol_data ~var:b_proposal_2_1 - >>=? fun () -> return [Pass; Pass; Pass; Pass] - | _ -> return [Pass; Pass; Pass; Pass]) - >>=? fun propagation_vector -> - return (block_hash, block_header, operations, propagation_vector) - - let on_inject_operation ~op_hash ~op = - op_is_endorsement ~level:1l ~round:0l op_hash op - >>=? fun is_a10_endorsement -> - return - ( op_hash, - op, - if is_a10_endorsement then [Pass; Block; Block; Block] - else [Pass; Pass; Pass; Pass] ) - - let stop_on_event = stop_on_event0 - end in - let module Other_node : Hooks = struct - include Default_hooks - - let on_inject_block ~level:_ ~round:_ ~block_hash ~block_header ~operations - ~protocol_data:_ = - return (block_hash, block_header, operations, [Pass; Pass; Pass; Pass]) - - let on_inject_operation ~op_hash ~op = - op_is_endorsement ~level:1l ~round:0l op_hash op - >>=? fun is_a10_endorsement -> - return - ( op_hash, - op, - if is_a10_endorsement then [Pass; Block; Block; Block] - else [Pass; Pass; Pass; Pass] ) - - let stop_on_event = stop_on_event0 - end in - let config = - { - default_config with - initial_seed = - some_seed "rngGnwG2gApiRzo1kdbCgQheqtZroUsAjsJzyw2RBbtg3gtTeMQ9F"; - delegate_selection = - [ - ( 1l, - [ - (0l, bootstrap1); - (1l, bootstrap2); - (2l, bootstrap3); - (3l, bootstrap4); - ] ); - ( 2l, - [ - (0l, bootstrap1); - (1l, bootstrap2); - (2l, bootstrap3); - (3l, bootstrap4); - ] ); - ]; - timeout = 60; - } - in - run - ~config - [ - (1, (module Node_a_hooks)); - (1, (module Node_b_hooks)); - (1, (module Other_node)); - (1, (module Other_node)); - ] - -(* - -Scenario M7 - -The same as M6, but: - -5. B proposes at level 2 round 0 (A does not see the proposal). -6. A proposes at 2.1. B switches to A's branch when it receives 2.1. -7. We wait 2 more levels before checking everyone's chain to verify that - A's proposal has been selected. - -*) - -let test_scenario_m7 () = - let a_proposal_2_1 = ref None in - let c_received_2_1 = ref false in - let d_received_2_1 = ref false in - let stop_on_event0 = function - | Baking_state.New_head_proposal {block; _} -> block.shell.level > 4l - | _ -> false - in - let check_chain_on_success0 node_label ~chain = - match List.nth (List.rev chain) 2 with - | None -> failwith "Node %s has empty chain" node_label - | Some (block : block) -> - verify_payload_hash - ~protocol_data:block.protocol_data - ~original_proposal:a_proposal_2_1 - ~message: - (Format.sprintf - "%s did not switch to A's proposal (level 2, round 1)" - node_label) - in - let module Node_a_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level ~round ~block_hash ~block_header ~operations - ~protocol_data = - (match (level, round) with - | 2l, 1l -> save_proposal_payload ~protocol_data ~var:a_proposal_2_1 - | _ -> return_unit) - >>=? fun () -> - return (block_hash, block_header, operations, [Pass; Pass; Pass; Pass]) - - let on_inject_operation ~op_hash ~op = - op_is_endorsement ~level:1l ~round:0l op_hash op - >>=? fun is_a10_endorsement -> - return - ( op_hash, - op, - if is_a10_endorsement then [Pass; Block; Block; Block] - else [Pass; Pass; Pass; Pass] ) - - let stop_on_event = stop_on_event0 - - let check_chain_on_success = check_chain_on_success0 "A" - end in - let module Node_b_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level ~round ~block_hash ~block_header ~operations - ~protocol_data:_ = - (match (level, round) with - | 1l, 1l -> return [Block; Delay 0.1; Delay 0.1; Delay 0.1] - | 2l, 0l -> return [Block; Pass; Pass; Pass] - | _ -> return [Pass; Pass; Pass; Pass]) - >>=? fun propagation_vector -> - return (block_hash, block_header, operations, propagation_vector) - - let on_inject_operation ~op_hash ~op = - op_is_endorsement ~level:1l ~round:0l op_hash op - >>=? fun is_a10_endorsement -> - op_is_preendorsement ~level:2l op_hash op - >>=? fun level2_preendorsement -> - op_is_endorsement ~level:2l op_hash op >>=? fun level2_endorsement -> - let propagation_vector = - match - (is_a10_endorsement, level2_preendorsement, level2_endorsement) - with - | true, _, _ -> [Pass; Block; Block; Block] - | _, true, _ | _, _, true -> [Block; Block; Block; Block] - | _, _, _ -> [Pass; Pass; Pass; Pass] - in - return (op_hash, op, propagation_vector) - - let stop_on_event = stop_on_event0 - - let check_chain_on_success = check_chain_on_success0 "B" - end in - let module Node_c_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level:_ ~round:_ ~block_hash ~block_header ~operations - ~protocol_data:_ = - let propagation_vector = - if !c_received_2_1 then [Pass; Pass; Pass; Pass] - else [Block; Block; Block; Block] - in - return (block_hash, block_header, operations, propagation_vector) - - let check_chain_after_processing ~level ~round ~chain:_ = - match (level, round) with - | 2l, 1l -> - c_received_2_1 := true ; - return_unit - | _ -> return_unit - - let on_inject_operation ~op_hash ~op = - op_is_endorsement ~level:1l ~round:0l op_hash op - >>=? fun is_a10_endorsement -> - op_is_preendorsement ~level:2l op_hash op - >>=? fun level2_preendorsement -> - op_is_endorsement ~level:2l op_hash op >>=? fun level2_endorsement -> - let propagation_vector = - match - ( is_a10_endorsement, - !c_received_2_1, - level2_preendorsement, - level2_endorsement ) - with - | true, _, _, _ -> [Pass; Block; Block; Block] - | _, false, true, _ | _, false, _, true -> [Block; Block; Block; Block] - | _, _, _, _ -> [Pass; Pass; Pass; Pass] - in - return (op_hash, op, propagation_vector) - - let stop_on_event = stop_on_event0 - - let check_chain_on_success = check_chain_on_success0 "C" - end in - let module Node_d_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level:_ ~round:_ ~block_hash ~block_header ~operations - ~protocol_data:_ = - let propagation_vector = - if !d_received_2_1 then [Pass; Pass; Pass; Pass] - else [Block; Block; Block; Block] - in - return (block_hash, block_header, operations, propagation_vector) - - let check_chain_after_processing ~level ~round ~chain:_ = - match (level, round) with - | 2l, 1l -> - d_received_2_1 := true ; - return_unit - | _ -> return_unit - - let on_inject_operation ~op_hash ~op = - op_is_endorsement ~level:1l ~round:0l op_hash op - >>=? fun is_a10_endorsement -> - op_is_preendorsement ~level:2l op_hash op - >>=? fun level2_preendorsement -> - op_is_endorsement ~level:2l op_hash op >>=? fun level2_endorsement -> - let propagation_vector = - match - ( is_a10_endorsement, - !d_received_2_1, - level2_preendorsement, - level2_endorsement ) - with - | true, _, _, _ -> [Pass; Block; Block; Block] - | _, false, true, _ | _, false, _, true -> [Block; Block; Block; Block] - | _, _, _, _ -> [Pass; Pass; Pass; Pass] - in - return (op_hash, op, propagation_vector) - - let stop_on_event = stop_on_event0 - - let check_chain_on_success = check_chain_on_success0 "D" - end in - let config = - { - default_config with - initial_seed = - some_seed "rngGJ7ReXwsjWuzpeqCgHAjudFwJtxdYz44Genz1FnyJ8R226hoKh"; - delegate_selection = - [ - ( 1l, - [ - (0l, bootstrap1); - (1l, bootstrap2); - (2l, bootstrap3); - (3l, bootstrap4); - ] ); - ( 2l, - [ - (0l, bootstrap2); - (1l, bootstrap1); - (2l, bootstrap3); - (3l, bootstrap4); - ] ); - ]; - timeout = 60; - } - in - run - ~config - [ - (1, (module Node_a_hooks)); - (1, (module Node_b_hooks)); - (1, (module Node_c_hooks)); - (1, (module Node_d_hooks)); - ] - -(* - -Scenario M8 - -5. B proposes at 2.0 and observes PQC but not QC. -6. C re-proposes at 2.1 and similarly observes PQC but not QC. -7. A proposes at 2.2. B, C, and D do not switch to A's branch; moreover A - switches to their branch when it receives the next proposal (2.3). This - happens because B, C, and D have PQC despite A having a higher round (2 > 1). -8. We wait 2 more levels before checking everyone's chain to verify that - B's proposal has been selected. - -*) - -let test_scenario_m8 () = - let b_proposal_2_0 = ref None in - let stop_on_event0 = function - | Baking_state.New_head_proposal {block; _} -> block.shell.level > 4l - | _ -> false - in - let on_inject_operation0 ~op_hash ~op = - op_is_endorsement ~level:1l ~round:0l op_hash op - >>=? fun is_a10_endorsement -> - op_is_endorsement ~level:2l ~round:0l op_hash op - >>=? fun is_b20_endorsement -> - op_is_endorsement ~level:2l ~round:1l op_hash op - >>=? fun is_c21_endorsement -> - let propagation_vector = - if is_a10_endorsement then [Pass; Block; Block; Block] - else if is_b20_endorsement || is_c21_endorsement then - [Block; Block; Block; Block] - else [Pass; Pass; Pass; Pass] - in - return (op_hash, op, propagation_vector) - in - let check_chain_on_success0 node_label ~chain = - match List.nth (List.rev chain) 2 with - | None -> failwith "Node %s has empty chain" node_label - | Some (block : block) -> - verify_payload_hash - ~protocol_data:block.protocol_data - ~original_proposal:b_proposal_2_0 - ~message: - (Format.sprintf - "%s did not switch to B's proposal (level 2, round 0)" - node_label) - in - let module Node_a_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level:_ ~round:_ ~block_hash ~block_header ~operations - ~protocol_data:_ = - return (block_hash, block_header, operations, [Pass; Pass; Pass; Pass]) - - let on_inject_operation = on_inject_operation0 - - let stop_on_event = stop_on_event0 - - let check_chain_on_success = check_chain_on_success0 "A" - end in - let module Node_b_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level ~round ~block_hash ~block_header ~operations - ~protocol_data = - (match (level, round) with - | 1l, 1l -> return [Block; Delay 0.1; Delay 0.1; Delay 0.1] - | 2l, 0l -> - save_proposal_payload ~protocol_data ~var:b_proposal_2_0 - >>=? fun () -> return [Block; Pass; Pass; Pass] - | _ -> return [Pass; Pass; Pass; Pass]) - >>=? fun propagation_vector -> - return (block_hash, block_header, operations, propagation_vector) - - let on_inject_operation = on_inject_operation0 - - let stop_on_event = stop_on_event0 - - let check_chain_on_success = check_chain_on_success0 "B" - end in - let module Node_c_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level ~round ~block_hash ~block_header ~operations - ~protocol_data:_ = - let propagation_vector = - match (level, round) with - | 2l, 1l -> [Block; Pass; Pass; Pass] - | _ -> [Pass; Pass; Pass; Pass] - in - return (block_hash, block_header, operations, propagation_vector) - - let on_inject_operation = on_inject_operation0 - - let stop_on_event = stop_on_event0 - - let check_chain_on_success = check_chain_on_success0 "C" - end in - let module Node_d_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level:_ ~round:_ ~block_hash ~block_header ~operations - ~protocol_data:_ = - return (block_hash, block_header, operations, [Pass; Pass; Pass; Pass]) - - let on_inject_operation = on_inject_operation0 - - let stop_on_event = stop_on_event0 - - let check_chain_on_success = check_chain_on_success0 "D" - end in - let config = - { - default_config with - initial_seed = - some_seed "rngFy2zFmgg25SXrE6aawqQVhD1kdw9eCCRxc843RLQjz5MZ6MGER"; - delegate_selection = - [ - ( 1l, - [ - (0l, bootstrap1); - (1l, bootstrap2); - (2l, bootstrap3); - (3l, bootstrap4); - ] ); - ( 2l, - [ - (0l, bootstrap2); - (1l, bootstrap3); - (2l, bootstrap1); - (3l, bootstrap4); - ] ); - ]; - timeout = 60; - } - in - run - ~config - [ - (1, (module Node_a_hooks)); - (1, (module Node_b_hooks)); - (1, (module Node_c_hooks)); - (1, (module Node_d_hooks)); - ] - -(* - Scenario M9 - - Two nodes: A, B - - 1. L1 - A proposes and reaches QC. - 2. L1 - When QC is reached, observe that B emits time to forge event. Shortly after, observe - that B emits time to bake event. - 3. L2 - A observes the block from B and ends. - -*) -let test_scenario_m9 () = - let stop_level = Int32.of_int 2 in - let node_b_qc = ref false in - let node_b_ttf = ref false in - let node_b_level = ref Int32.zero in - let bh : Block_hash.t option ref = ref None in - let stop_on_event0 = function - | Baking_state.New_head_proposal {block; _} -> - block.shell.level >= stop_level - | _ -> false - in - let module Node_a_hooks : Hooks = struct - include Default_hooks - - let raise_error : string option ref = ref None - - let block_round block_header = - let open Block_header in - match - Protocol.Alpha_context.Fitness.round_from_raw block_header.shell.fitness - with - | Error _ -> assert false - | Ok x -> x - - let on_new_head ~block_hash ~block_header = - let open Block_header in - let block_round = block_round block_header in - let level = block_header.shell.level in - let is_round0 = - Protocol.Alpha_context.Round.equal - block_round - Protocol.Alpha_context.Round.zero - in - match level with - | 2l -> - raise_error := - if - is_round0 - && not (Block_hash.equal block_hash (Stdlib.Option.get !bh)) - then Some "Block hash was not equal" - else if not is_round0 then - Some "Level 2 expected to have a block at round 0" - else None ; - Lwt.return @@ Some (block_hash, block_header) - | _ -> Lwt.return @@ Some (block_hash, block_header) - - let stop_on_event = stop_on_event0 - - let check_chain_on_success ~chain:_ = - match !raise_error with - | Some err -> Stdlib.failwith err - | _ -> return_unit - end in - let module Node_b_hooks : Hooks = struct - include Default_hooks - - let on_inject_block ~level:_ ~round:_ ~block_hash ~block_header ~operations - ~protocol_data:_ = - bh := Some block_hash ; - return (block_hash, block_header, operations, [Pass; Pass]) - - let stop_on_event = function - | Baking_state.Quorum_reached _ when !node_b_level = 1l -> - node_b_qc := true ; - false - | Baking_state.Timeout timeout when !node_b_level = 1l -> ( - match timeout with - | Time_to_forge_block -> - if !node_b_qc then ( - node_b_ttf := true ; - false) - else - Stdlib.failwith - "time to forge emitted without observing qc event" - | Time_to_bake_next_level _ -> - if !node_b_qc && !node_b_ttf then false - else - Stdlib.failwith - "time to bake emitted without observing qc or time to forge \ - event" - | End_of_round _ -> - Stdlib.failwith "End of round timeout not expected") - | Baking_state.New_valid_proposal {block; _} -> - node_b_level := block.shell.level ; - false - | event -> stop_on_event0 event - end in - let config = - { - default_config with - delegate_selection = [(1l, [(0l, bootstrap1)]); (2l, [(0l, bootstrap2)])]; - round0 = 3L; - round1 = 4L; - } - in - run ~config [(1, (module Node_a_hooks)); (1, (module Node_b_hooks))] - -(* - Scenario M10 - - Two nodes : A, B - - 1. Node A is the proposer at level 1, round 0, but is dead - 2. Node B proposes at level 1, round 1, therefore the - Time_to_forge_block was not called. -*) -let test_scenario_m10 () = - let stop_level = 1l in - let stop_round = Protocol.Alpha_context.Round.(succ zero) in - let node_b_ttf = ref false in - let module Node_a_hooks : Hooks = struct - include Default_hooks - - let stop_on_event _ = true (* Node A stops immediately. *) - end in - let module Node_b_hooks : Hooks = struct - include Default_hooks - - let stop_on_event = function - | Baking_state.Timeout Time_to_forge_block -> - node_b_ttf := true ; - false - (* When we get to level = 1, round = 1, the time to forge timeout should - not have been called *) - | Baking_state.New_head_proposal {block; _} -> - let block_round = block.round in - if block.shell.level >= stop_level && block_round = stop_round then ( - assert (not !node_b_ttf) ; - true) - else false - | _ -> false - end in - let config = - { - default_config with - round0 = 3L; - round1 = 4L; - delegate_selection = [(1l, [(0l, bootstrap1); (1l, bootstrap2)])]; - } - in - run ~config [(1, (module Node_a_hooks)); (1, (module Node_b_hooks))] - -let () = - let open Lwt_result_syntax in - (* Activate a sink to record baker's events *) - let t = lazy (Tezt_sink.activate ()) in - let proto_name = - String.lowercase_ascii Protocol.name - |> String.map (function '-' -> '_' | x -> x) - in - let register_test (title, test) = - Test.register - ~__FILE__ - ~title - ~tags:[proto_name; "baker"; "mockup"; Tag.time_sensitive] - @@ fun () -> - let*! () = Lazy.force t in - let*! r = test () in - match r with - | Ok () -> unit - | Error errs -> Test.fail ~__LOC__ "%a" pp_print_trace errs - in - List.iter - register_test - [ - (Protocol.name ^ ": reaches level 5", test_level_5); - ( Protocol.name ^ ": cannot progress without new head", - test_preendorse_on_valid ); - (Protocol.name ^ ": reset delayed pqc", test_reset_delayed_pqc); - (Protocol.name ^ ": scenario t1", test_scenario_t1); - (Protocol.name ^ ": scenario t2", test_scenario_t2); - (Protocol.name ^ ": scenario t3", test_scenario_t3); - (Protocol.name ^ ": scenario t4", test_scenario_t4); - (Protocol.name ^ ": scenario f1", test_scenario_f1); - (Protocol.name ^ ": scenario f2", test_scenario_f2); - (Protocol.name ^ ": scenario m1", test_scenario_m1); - (Protocol.name ^ ": scenario m2", test_scenario_m2); - (Protocol.name ^ ": scenario m3", test_scenario_m3); - (Protocol.name ^ ": scenario m4", test_scenario_m4); - (Protocol.name ^ ": scenario m5", test_scenario_m5); - (Protocol.name ^ ": scenario m6", test_scenario_m6); - (Protocol.name ^ ": scenario m7", test_scenario_m7); - (Protocol.name ^ ": scenario m8", test_scenario_m8); - (Protocol.name ^ ": scenario m9", test_scenario_m9); - (Protocol.name ^ ": scenario m10", test_scenario_m10); - ] diff --git a/src/proto_017_PtNairob/lib_delegate/vdf_helpers.ml b/src/proto_017_PtNairob/lib_delegate/vdf_helpers.ml deleted file mode 100644 index b3fe451bc1d59ff5af42115f0fe43efa7b7db03f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/vdf_helpers.ml +++ /dev/null @@ -1,31 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs *) -(* *) -(* 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.Alpha_context - -let is_in_nonce_revelation_stage ~nonce_revelation_threshold ~(level : Level.t) - = - let cycle_position = level.cycle_position in - Int32.compare cycle_position nonce_revelation_threshold < 0 diff --git a/src/proto_017_PtNairob/lib_delegate/vdf_helpers.mli b/src/proto_017_PtNairob/lib_delegate/vdf_helpers.mli deleted file mode 100644 index 1000c59bece0520432e5cd0a2678d6722e924320..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_delegate/vdf_helpers.mli +++ /dev/null @@ -1,35 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs *) -(* *) -(* 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.Alpha_context - -(** [is_in_nonce_revelation_stage ~nonce_revelation_threshold ~level] checks - whether [level] is part of the nonce revelation stage of its cycle, which - is defined as the first [nonce_revelation_threshold] blocks of every cycle. - It is used to avoid calling the [Seed_computation] RPC on blocks which are - part of the nonce revelation stage. - *) -val is_in_nonce_revelation_stage : - nonce_revelation_threshold:int32 -> level:Level.t -> bool diff --git a/src/proto_017_PtNairob/lib_plugin/index.mld b/src/proto_017_PtNairob/lib_plugin/index.mld index af32ce587bd0750b4148bf3d76f11516e90794a1..87bafb1fe363238cd53acb4ceefe0f57d1c82566 100644 --- a/src/proto_017_PtNairob/lib_plugin/index.mld +++ b/src/proto_017_PtNairob/lib_plugin/index.mld @@ -4,12 +4,7 @@ This is a package containing some libraries related to the Tezos 017-PtNairob pr It contains the following libraries: -- {{!module-Tezos_017_PtNairob_test_helpers}Tezos_017_PtNairob_test_helpers}: Protocol testing framework -- {{!module-Tezos_baking_017_PtNairob}Tezos_baking_017_PtNairob}: Base library for `tezos-baker/accuser` -- {{!module-Tezos_baking_017_PtNairob_commands}Tezos_baking_017_PtNairob_commands}: Protocol-specific commands for baking - {{!module-Tezos_client_017_PtNairob}Tezos_client_017_PtNairob}: Protocol specific library for `octez-client` -- {{!module-Tezos_dac_017_PtNairob}Tezos_dac_017_PtNairob}: Protocol specific library for the Data availability Committee -- {{!module-Tezos_dal_017_PtNairob}Tezos_dal_017_PtNairob}: Protocol specific library for the Data availability Layer - {{!module-Tezos_layer2_utils_017_PtNairob}Tezos_layer2_utils_017_PtNairob}: Protocol specific library for Layer 2 utils - {{!module-Tezos_protocol_plugin_017_PtNairob}Tezos_protocol_plugin_017_PtNairob}: Protocol plugin - {{!module-Tezos_protocol_plugin_017_PtNairob_registerer}Tezos_protocol_plugin_017_PtNairob_registerer}: Protocol plugin registerer diff --git a/src/proto_017_PtNairob/lib_plugin/test/dune b/src/proto_017_PtNairob/lib_plugin/test/dune deleted file mode 100644 index 8912cb97b70734f872ac5f0bf122ce68298ccfb6..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_plugin/test/dune +++ /dev/null @@ -1,63 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name src_proto_017_PtNairob_lib_plugin_test_tezt_lib) - (instrumentation (backend bisect_ppx)) - (libraries - tezt.core - octez-libs.base - octez-libs.base-test-helpers - octez-libs.base.unix - octez-alcotezt - octez-libs.test-helpers - qcheck-alcotest - octez-libs.stdlib-unix - octez-libs.micheline - octez-protocol-017-PtNairob-libs.plugin - tezos-protocol-017-PtNairob.protocol - tezos-protocol-017-PtNairob.parameters - octez-protocol-017-PtNairob-libs.test-helpers) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezt_core - -open Tezt_core.Base - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_base_test_helpers - -open Octez_alcotezt - -open Tezos_test_helpers - -open Tezos_micheline - -open Tezos_protocol_plugin_017_PtNairob - -open Tezos_protocol_017_PtNairob - -open Tezos_protocol_017_PtNairob.Protocol - -open Tezos_protocol_017_PtNairob_parameters - -open Tezos_017_PtNairob_test_helpers) - (modules - helpers - test_conflict_handler - test_consensus_filter - test_fee_needed_to_overtake - test_fee_needed_to_replace_by_fee)) - -(executable - (name main) - (instrumentation (backend bisect_ppx --bisect-sigterm)) - (libraries - src_proto_017_PtNairob_lib_plugin_test_tezt_lib - tezt) - (link_flags - (:standard) - (:include %{workspace_root}/macos-link-flags.sexp)) - (modules main)) - -(rule - (alias runtest) - (package octez-protocol-017-PtNairob-libs) - (enabled_if (<> false %{env:RUNTEZTALIAS=true})) - (action (run %{dep:./main.exe}))) - -(rule - (targets main.ml) - (action (with-stdout-to %{targets} (echo "let () = Tezt.Test.run ()")))) diff --git a/src/proto_017_PtNairob/lib_plugin/test/helpers.ml b/src/proto_017_PtNairob/lib_plugin/test/helpers.ml deleted file mode 100644 index cb44f4007624e1602872bbdc8f11fc0c83f3d50b..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_plugin/test/helpers.ml +++ /dev/null @@ -1,172 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** One-element list containing the Tezt tag of the local protocol, - e.g. "alpha", "nairobi", "mumbai", etc. *) -let proto_tags = Alcotezt_utils.is_proto_test __FILE__ - -(** Register a plugin test, with file-specific tags and prefix in title. *) -let register_test ~__FILE__ ~file_title ~file_tags ~title ~additional_tags = - Test.register - ~__FILE__ - ~title:(sf "%s/plugin: %s: %s" Protocol.name file_title title) - ~tags:(proto_tags @ ("plugin" :: (file_tags @ additional_tags))) - -(** Generator for a packed operation preceded by its hash. *) -let oph_and_op_gen = QCheck2.Gen.map snd Operation_generator.generate_operation - -(** Generator for a packed non-manager operation. *) -let non_manager_operation_gen = - Operation_generator.generate_non_manager_operation - -(** Generator for a packed manager operation. *) -let manager_operation_gen = - let open QCheck2.Gen in - let* batch_size = int_range 1 Operation_generator.max_batch_size in - Operation_generator.generate_manager_operation batch_size - -(** Generator for a packed manager operation with the specified - total fee and gas limit. *) -let manager_op_with_fee_and_gas_gen ~fee_in_mutez ~gas = - let open Alpha_context in - let open QCheck2.Gen in - let rec set_fee_and_gas : - type kind. _ -> _ -> kind contents_list -> kind contents_list t = - fun desired_total_fee desired_total_gas -> function - | Single (Manager_operation data) -> - let fee = Tez.of_mutez_exn (Int64.of_int desired_total_fee) in - let gas_limit = Gas.Arith.integral_of_int_exn desired_total_gas in - return (Single (Manager_operation {data with fee; gas_limit})) - | Cons (Manager_operation data, tail) -> - let* local_fee = - (* We generate some corner cases where some individual - operations in the batch have zero fees. *) - let* r = frequencyl [(7, `Random); (2, `Zero); (1, `All)] in - match r with - | `Random -> int_range 0 desired_total_fee - | `Zero -> return 0 - | `All -> return desired_total_fee - in - let* local_gas = int_range 0 desired_total_gas in - let fee = Tez.of_mutez_exn (Int64.of_int local_fee) in - let gas_limit = Gas.Arith.integral_of_int_exn local_gas in - let* tail = - set_fee_and_gas - (desired_total_fee - local_fee) - (desired_total_gas - local_gas) - tail - in - return (Cons (Manager_operation {data with fee; gas_limit}, tail)) - | Single _ -> - (* This function is only called on a manager operation. *) assert false - in - (* Generate a random manager operation. *) - let* batch_size = int_range 1 Operation_generator.max_batch_size in - let* op = Operation_generator.generate_manager_operation batch_size in - (* Modify its fee and gas to match the [fee_in_mutez] and [gas] inputs. *) - let {shell = _; protocol_data = Operation_data protocol_data} = op in - let* contents = set_fee_and_gas fee_in_mutez gas protocol_data.contents in - let protocol_data = {protocol_data with contents} in - let op = {op with protocol_data = Operation_data protocol_data} in - return (Operation.hash_packed op, op) - -(** Generate a packed manager operation with the specified total fee - and gas limit. *) -let generate_manager_op_with_fee_and_gas ~fee_in_mutez ~gas = - QCheck2.Gen.generate1 (manager_op_with_fee_and_gas_gen ~fee_in_mutez ~gas) - -(** Change the total fee of the packed operation [op] to [fee] (in mutez). - Also change its source to [source] if the argument is provided. - - Precondition: [op] must be a manager operation. *) -let set_fee_and_source fee ?source op = - let open Alpha_context in - let open QCheck2.Gen in - let rec set_fee_contents_list_gen : - type kind. int64 -> kind contents_list -> kind contents_list t = - fun desired_total_fee (* in mutez *) -> function - | Single (Manager_operation data) -> - let fee = Tez.of_mutez_exn desired_total_fee in - let contents = - match source with - | Some source -> Manager_operation {data with fee; source} - | None -> Manager_operation {data with fee} - in - return (Single contents) - | Cons (Manager_operation data, tail) -> - let* local_fee = - (* We generate some corner cases where some individual - operations in the batch have zero fees. *) - let* r = frequencyl [(7, `Random); (2, `Zero); (1, `All)] in - match r with - | `Random -> - let* n = int_range 0 (Int64.to_int desired_total_fee) in - return (Int64.of_int n) - | `Zero -> return 0L - | `All -> return desired_total_fee - in - let fee = Tez.of_mutez_exn local_fee in - let contents = - match source with - | Some source -> Manager_operation {data with fee; source} - | None -> Manager_operation {data with fee} - in - let* tail = - set_fee_contents_list_gen (Int64.sub desired_total_fee local_fee) tail - in - return (Cons (contents, tail)) - | Single _ -> (* see precondition: manager operation *) assert false - in - let {shell = _; protocol_data = Operation_data data} = op in - let contents = generate1 (set_fee_contents_list_gen fee data.contents) in - {op with protocol_data = Operation_data {data with contents}} - -let set_fee fee op = set_fee_and_source fee op - -(** Return an [Operation_hash.t] that is distinct from [different_from]. *) -let different_oph ~different_from = - if Operation_hash.(different_from = zero) then ( - let new_hash = Operation_hash.hash_string ["1"] in - assert (Operation_hash.(new_hash <> zero)) ; - new_hash) - else Operation_hash.zero - -(** List helpers *) - -let rec iter_neighbors f = function - | [] | [_] -> () - | x :: (y :: _ as l) -> - f x y ; - iter_neighbors f l - -let iter2_exn f l1 l2 = - match List.iter2 ~when_different_lengths:() f l1 l2 with - | Ok () -> () - | Error () -> - Test.fail - ~__LOC__ - "Lists have respective lengths %d and %d." - (List.length l1) - (List.length l2) diff --git a/src/proto_017_PtNairob/lib_plugin/test/test_conflict_handler.ml b/src/proto_017_PtNairob/lib_plugin/test/test_conflict_handler.ml deleted file mode 100644 index 3091894dd8e1e862752d398199d1e6ca895a0049..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_plugin/test/test_conflict_handler.ml +++ /dev/null @@ -1,226 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Plugin.Mempool - Invocation: dune exec src/proto_017_PtNairob/lib_plugin/test/main.exe \ - -- --file test_conflict_handler.ml - Subject: Unit tests the Mempool.conflict_handler function of the plugin -*) - -let register_test = - Helpers.register_test - ~__FILE__ - ~file_title:"conflict_handler" - ~file_tags:["mempool"; "conflict_handler"] - -let pp_answer fmt = function - | `Keep -> Format.fprintf fmt "Keep" - | `Replace -> Format.fprintf fmt "Replace" - -let check_answer ?__LOC__ expected actual = - assert - (Qcheck2_helpers.qcheck_eq ~pp:pp_answer ?__LOC__ expected actual : bool) - -let is_manager_op ((_ : Operation_hash.t), op) = - (* This is implemented differently from - [Plugin.Mempool.is_manager_operation] (which relies on - [Alpha_context.Operation.acceptable_pass]), used in - [Plugin.Mempool.conflict_handler], to avoid the test being just a - copy of the code. *) - let {Alpha_context.protocol_data = Operation_data proto_data; _} = op in - match proto_data.contents with - | Single (Manager_operation _) | Cons (Manager_operation _, _) -> true - | _ -> false - -(** Test that when the operations are not both manager operations, the - conflict handler picks the higher operation according to - [Operation.compare]. *) -let () = - register_test - ~title:"non-manager operations" - ~additional_tags:["nonmanager"; "random"] - @@ fun () -> - let ops = - QCheck2.Gen.( - generate ~n:100 (pair Helpers.oph_and_op_gen Helpers.oph_and_op_gen)) - in - List.iter - (fun (op1, op2) -> - let answer = - Plugin.Mempool.conflict_handler - Plugin.Mempool.default_config - ~existing_operation:op1 - ~new_operation:op2 - in - if is_manager_op op1 && is_manager_op op2 then - (* When both operations are manager operations, the result is - complicated and depends on the [config]. Testing it here - would mean basically reimplementing - [conflict_handler]. Instead, we test this case in the - "manager operations" test below. *) - () - else if - (* When there is at least one non-manager operation, the - conflict handler defers to [Operation.compare]: the higher - operation is selected. *) - Alpha_context.Operation.compare op1 op2 >= 0 - then check_answer ~__LOC__ `Keep answer - else check_answer ~__LOC__ `Replace answer) - ops ; - unit - -let check_conflict_handler ~__LOC__ config ~old ~nw expected = - let answer = - Plugin.Mempool.conflict_handler - config - ~existing_operation:old - ~new_operation:nw - in - check_answer ~__LOC__ expected answer - -(** Test the semantics of the conflict handler on manager operations, - with either hand-picked or carefully generated fee and gas. *) -let () = - register_test - ~title:"manager operations" - ~additional_tags:["manager"; "random"] - @@ fun () -> - let make_op = Helpers.generate_manager_op_with_fee_and_gas in - - (* Test operations with specific fee and gas, using the default - configuration. This configuration replaces the old operation when - the new one is at least 5% better, in terms of both fees and - fee/gas ratios. *) - let default = Plugin.Mempool.default_config in - let ref_fee = 10_000_000 in - let ref_gas = 2100 in - (* Reference operation arbitrarily has 10 tez of fees and 2100 - gas. The gas is chosen to still give an integer when multiplied - by 100/105. *) - let old = make_op ~fee_in_mutez:ref_fee ~gas:ref_gas in - (* Operation with same fee and ratio. *) - let op_same = make_op ~fee_in_mutez:ref_fee ~gas:ref_gas in - check_conflict_handler ~__LOC__ default ~old ~nw:op_same `Keep ; - (* 5% better fee but same ratio (because gas is also 5% more). *) - let more5 = Q.make (Z.of_int 105) (Z.of_int 100) in - let fee_more5 = Q.(to_int (mul more5 (of_int ref_fee))) in - let gas_more5 = Q.(to_int (mul more5 (of_int ref_gas))) in - let op_fee5 = make_op ~fee_in_mutez:fee_more5 ~gas:gas_more5 in - check_conflict_handler ~__LOC__ default ~old ~nw:op_fee5 `Keep ; - (* 5% better ratio but same fee (because gas is multiplied by 100/105). *) - let less5 = Q.make (Z.of_int 100) (Z.of_int 105) in - let gas_less5 = Q.(to_int (mul less5 (of_int ref_gas))) in - let op_ratio5 = make_op ~fee_in_mutez:ref_fee ~gas:gas_less5 in - check_conflict_handler ~__LOC__ default ~old ~nw:op_ratio5 `Keep ; - (* Both 5% better fee and 5% better ratio. *) - let op_both5 = make_op ~fee_in_mutez:fee_more5 ~gas:ref_gas in - check_conflict_handler ~__LOC__ default ~old ~nw:op_both5 `Replace ; - - (* Config that requires 10% better fee and ratio to replace. *) - let config10 = - Plugin.Mempool.Internal_for_tests.default_config_with_replace_factor - (Q.make (Z.of_int 11) (Z.of_int 10)) - in - - check_conflict_handler ~__LOC__ config10 ~old ~nw:op_same `Keep ; - check_conflict_handler ~__LOC__ config10 ~old ~nw:op_fee5 `Keep ; - check_conflict_handler ~__LOC__ config10 ~old ~nw:op_ratio5 `Keep ; - check_conflict_handler ~__LOC__ config10 ~old ~nw:op_both5 `Keep ; - (* Config that replaces when the new op has at least as much fee and ratio. *) - let config0 = - Plugin.Mempool.Internal_for_tests.default_config_with_replace_factor Q.one - in - check_conflict_handler ~__LOC__ config0 ~old ~nw:op_same `Replace ; - check_conflict_handler ~__LOC__ config0 ~old ~nw:op_fee5 `Replace ; - check_conflict_handler ~__LOC__ config0 ~old ~nw:op_ratio5 `Replace ; - check_conflict_handler ~__LOC__ config0 ~old ~nw:op_both5 `Replace ; - (* This config does not replace when the new operation has worse - fees (even when the ratio is higher). *) - let op_less_fee = make_op ~fee_in_mutez:(ref_fee - 1) ~gas:(ref_gas - 1) in - check_conflict_handler ~__LOC__ default ~old ~nw:op_less_fee `Keep ; - (* This config does not replace either when the ratio is smaller. *) - let op_worse_ratio = make_op ~fee_in_mutez:ref_fee ~gas:(ref_gas + 1) in - check_conflict_handler ~__LOC__ default ~old ~nw:op_worse_ratio `Keep ; - - (* Generate random operations which do not have 5% better fees than - the reference [op]: they should not replace [op] when using the - default config. *) - let open QCheck2.Gen in - let repeat = 30 in - let max_gas = 5 * ref_gas in - let generator_not_5more_fee = - let* fee_in_mutez = int_range 0 (fee_more5 - 1) in - let* gas = int_range 0 max_gas in - Format.eprintf "op_not_fee5: fee = %d; gas = %d@." fee_in_mutez gas ; - Helpers.manager_op_with_fee_and_gas_gen ~fee_in_mutez ~gas - in - let ops_not_5more_fee = generate ~n:repeat generator_not_5more_fee in - List.iter - (fun nw -> check_conflict_handler ~__LOC__ default ~old ~nw `Keep) - ops_not_5more_fee ; - (* Generate random operations which do not have 5% better ratio than - the reference [op]: they should not replace [op] when using the - default config. *) - let ratio_5more = - Q.(mul more5 (make (Z.of_int ref_fee) (Z.of_int ref_gas))) - in - let generator_not_5more_ratio = - let* gas = int_range 0 max_gas in - let fee_for_5more_ratio = Q.(mul (of_int gas) ratio_5more) in - let fee_upper_bound = Q.to_int fee_for_5more_ratio - 1 in - let* fee_in_mutez = int_range 0 (max 0 fee_upper_bound) in - Format.eprintf "op_not_ratio5: fee = %d; gas = %d@." fee_in_mutez gas ; - Helpers.manager_op_with_fee_and_gas_gen ~fee_in_mutez ~gas - in - let ops_not_5more_ratio = generate ~n:repeat generator_not_5more_ratio in - List.iter - (fun nw -> check_conflict_handler ~__LOC__ default ~old ~nw `Keep) - ops_not_5more_ratio ; - (* Generate random operations which have both 5% higher fees and 5% - better ratio than the reference [op]: they should replace [op] - when using the default config. *) - let max_fee = - (* We use a significantly higher factor to define [max_fee] from - [ref_fee] than [max_gas] from [ref_gas]. Therefore, even if we - generate a gas equal to [max_gas], we can still generate a fee - that makes the ratio at least 5% better than the reference - operation's. *) - 10 * ref_fee - in - let generator_both_5more = - let* gas = int_range 0 max_gas in - let fee_for_5more_ratio = Q.(mul (of_int gas) ratio_5more) in - let fee_lower_bound = max fee_more5 (Q.to_int fee_for_5more_ratio + 1) in - let* fee_in_mutez = int_range fee_lower_bound max_fee in - Format.eprintf "op_both_better: fee = %d; gas = %d@." fee_in_mutez gas ; - Helpers.manager_op_with_fee_and_gas_gen ~fee_in_mutez ~gas - in - let ops_both_5more = generate ~n:repeat generator_both_5more in - List.iter - (fun nw -> check_conflict_handler ~__LOC__ default ~old ~nw `Replace) - ops_both_5more ; - Lwt.return_unit diff --git a/src/proto_017_PtNairob/lib_plugin/test/test_consensus_filter.ml b/src/proto_017_PtNairob/lib_plugin/test/test_consensus_filter.ml deleted file mode 100644 index ae09c8356c23df30fb6d9f40e4e2affd4740a691..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_plugin/test/test_consensus_filter.ml +++ /dev/null @@ -1,461 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Plugin.Mempool - Invocation: dune exec src/proto_017_PtNairob/lib_plugin/test/main.exe \ - -- --file test_consensus_filter.ml - Subject: Unit tests the Mempool consensus filter -*) - -open Qcheck2_helpers -open Alpha_context -open Plugin.Mempool.Internal_for_tests - -(** {2. Conversion helpers} *) - -let timestamp_of_int32 ts = Timestamp.of_seconds (Int64.of_int32 ts) - -(** Data Generators *) -module Generator = struct - open QCheck2.Gen - - let decorate ?(prefix = "") ?(suffix = "") printer d = - prefix ^ printer d ^ suffix - - let config = - let* drift_int_opt = opt small_nat in - let clock_drift = - Option.map - (fun drift_int -> Period.of_seconds_exn (Int64.of_int drift_int)) - drift_int_opt - in - return (default_config_with_clock_drift clock_drift) - - let print_config = - decorate ~prefix:"clock_drift " (fun config -> - Option.fold - ~none:"round_0 duration" - ~some:(fun drift -> Int64.to_string @@ Period.to_seconds drift) - (get_clock_drift config)) - - let of_result = Result.value_f ~default:(fun _ -> assert false) - - let small_nat_32 = - let+ small_nat in - Int32.of_int small_nat - - let small_signed_32 = - let+ small_signed_int in - Int32.of_int small_signed_int - - let dup gen = - let+ x = gen in - (x, x) - - let round = - let+ x = map (fun i32 -> Round.of_int32 i32) small_nat_32 in - of_result x - - let print_round = Format.asprintf "%a" Round.pp - - let same_rounds = dup round - - let level = - let+ x = map Raw_level.of_int32 small_nat_32 in - of_result x - - let print_level = Format.asprintf "%a" Raw_level.pp - - let same_levels = dup level - - let timestamp = - let+ i32 = int32 in - timestamp_of_int32 i32 - - let print_timestamp = Timestamp.to_notation - - let near_timestamps = - let+ i, diff = pair int32 small_signed_32 in - timestamp_of_int32 i |> fun ts1 -> - timestamp_of_int32 Int32.(add i diff) |> fun ts2 -> (ts1, ts2) - - let successive_timestamp = - let+ ts, (diff : int) = pair timestamp small_nat in - let x = - Period.of_seconds (Int64.of_int diff) >>? fun diff -> - Timestamp.(ts +? diff) >>? fun ts2 -> Ok (ts, ts2) - in - of_result x - - let param_acceptable ?(rounds = pair round round) ?(levels = pair level level) - ?(timestamps = near_timestamps) () = - pair config (pair (pair rounds levels) timestamps) - - let print_param_acceptable = - let open QCheck2.Print in - let print_levels = pair print_level print_level in - let print_timestamps = pair print_timestamp print_timestamp in - let print_rounds = pair print_round print_round in - pair print_config (pair (pair print_rounds print_levels) print_timestamps) -end - -let assert_no_error d = match d with Error _ -> assert false | Ok d -> d - -(** Constants : - This could be generated but it would largely increase the search space. *) -let round_durations : Round.round_durations = - assert_no_error - @@ Round.Durations.create - ~first_round_duration:Period.(of_seconds_exn 4L) - ~delay_increment_per_round:Period.(of_seconds_exn 10L) - -let round_zero_duration = Round.round_duration round_durations Round.zero - -(** Don't allow test to fail *) -let no_error = function - | Ok b -> b - | Error errs -> - Format.printf - "test fail due to error : %a@." - Error_monad.pp_print_trace - (Environment.wrap_tztrace errs) ; - false - -(** Helper to compute *) -let durations round_durations start stop = - List.map_e - (fun round -> - Round.of_int round >|? fun round -> - Round.round_duration round_durations round |> Period.to_seconds) - Tezos_stdlib.Utils.Infix.(start -- stop) - -(** Expected timestamp for the begining of a round at same level that - the proposal. - - It has been developped before the Round.timestamp_of_round_same_level and has a - different implementation. - -*) -let timestamp_of_round round_durations ~proposal_timestamp ~proposal_round - ~round = - (let iproposal_round = Int32.to_int @@ Round.to_int32 proposal_round in - let iround = Int32.to_int @@ Round.to_int32 round in - if Round.(proposal_round = round) then ok (Period.zero, proposal_timestamp) - else if Round.(proposal_round < round) then - durations round_durations iproposal_round (iround - 1) >>? fun durations -> - Period.of_seconds @@ List.fold_left Int64.add Int64.zero durations - >>? fun rounds_duration -> - Timestamp.(proposal_timestamp +? rounds_duration) >|? fun ts -> - (rounds_duration, ts) - else - durations round_durations iround (iproposal_round - 1) >>? fun durations -> - List.fold_left Int64.add Int64.zero durations |> fun rounds_duration -> - Timestamp.of_seconds - @@ Int64.sub (Timestamp.to_seconds proposal_timestamp) rounds_duration - |> fun ts -> - Period.of_seconds rounds_duration >|? fun rounds_duration -> - (rounds_duration, ts)) - >>? fun (_rnd_dur, exp_ts) -> ok exp_ts - -let drift_of = - let r0_dur = Round.round_duration round_durations Round.zero in - fun clock_drift -> Option.value ~default:r0_dur clock_drift - -(** [max_ts] computes the upper bound on future timestamps given the - accepted round drift. -*) -let max_ts clock_drift prop_ts now = - Timestamp.(max prop_ts now +? drift_of clock_drift) - -let predecessor_start proposal_timestamp proposal_round grandparent_round = - assert_no_error - @@ ( Round.level_offset_of_round - round_durations - ~round:Round.(succ grandparent_round) - >>? fun proposal_level_offset -> - Round.level_offset_of_round round_durations ~round:proposal_round - >>? fun proposal_round_offset -> - Period.(add proposal_level_offset proposal_round_offset) - >>? fun proposal_offset -> - Ok Timestamp.(proposal_timestamp - proposal_offset) ) - -(** {2. Tests} *) - -(** Test past operations that are accepted whatever the current timestamp is: - strictly before the predecessor level or at the current level and with a - strictly lower round than the head. *) - -let test_acceptable_past_level = - let open QCheck2 in - Test.make - ~print:Generator.print_param_acceptable - ~name:"acceptable past op " - (Generator.param_acceptable ()) - (fun - ( config, - ( ((proposal_round, op_round), (proposal_level, op_level)), - (proposal_timestamp, now_timestamp) ) ) - -> - Raw_level.( - proposal_level > succ op_level - || (proposal_level = op_level && Round.(proposal_round > op_round))) - ==> no_error - @@ acceptable_op - ~config - ~round_durations - ~round_zero_duration - ~proposal_level - ~proposal_round - ~proposal_timestamp - ~proposal_predecessor_level_start: - (predecessor_start - proposal_timestamp - proposal_round - Round.zero) - ~op_level - ~op_round - ~now_timestamp) - -(** Test acceptable operations at current level, current round, i.e. on the - currently considered proposal *) -let test_acceptable_current_level_current_round = - let open QCheck2 in - Test.make - ~print:Generator.print_param_acceptable - ~name:"same round, same level " - Generator.(param_acceptable ~rounds:same_rounds ~levels:same_levels ()) - (fun ( config, - (((op_round, _), (_, op_level)), (proposal_timestamp, now_timestamp)) - ) -> - let proposal_level = op_level in - let proposal_round = op_round in - no_error - @@ acceptable_op - ~config - ~round_durations - ~round_zero_duration - ~proposal_level - ~proposal_round - ~proposal_timestamp - ~proposal_predecessor_level_start: - (predecessor_start proposal_timestamp proposal_round Round.zero) - ~op_level - ~op_round - ~now_timestamp) - -(** Test operations at same level, different round, with an acceptable expected - timestamp for the operation. *) -let test_acceptable_current_level = - let open QCheck2 in - Test.make - ~print:Generator.print_param_acceptable - ~name:"same level, different round, acceptable op" - Generator.(param_acceptable ~levels:same_levels ()) - (fun ( config, - ( ((proposal_round, op_round), (_, op_level)), - (proposal_timestamp, now_timestamp) ) ) -> - let proposal_level = op_level in - no_error - ( timestamp_of_round - round_durations - ~proposal_timestamp - ~proposal_round - ~round:op_round - >>? fun expected_time -> - max_ts (get_clock_drift config) proposal_timestamp now_timestamp - >>? fun max_timestamp -> ok Timestamp.(expected_time <= max_timestamp) - ) - ==> no_error - @@ acceptable_op - ~config - ~round_durations - ~round_zero_duration - ~proposal_level - ~proposal_round - ~proposal_timestamp - ~proposal_predecessor_level_start: - (predecessor_start - proposal_timestamp - proposal_round - Round.zero) - ~op_level - ~op_round - ~now_timestamp) - -(** Test operations at same level, different round, with a too high expected - timestamp for the operation, and not at current round (which is always accepted). *) -let test_not_acceptable_current_level = - let open QCheck2 in - Test.make - ~print:Generator.print_param_acceptable - ~name:"same level, different round, too far" - Generator.(param_acceptable ~levels:same_levels ()) - (fun ( config, - ( ((proposal_round, op_round), (_, op_level)), - (proposal_timestamp, now_timestamp) ) ) -> - let proposal_level = op_level in - no_error - ( timestamp_of_round - round_durations - ~proposal_timestamp - ~proposal_round - ~round:op_round - >>? fun expected_time -> - max_ts (get_clock_drift config) proposal_timestamp now_timestamp - >>? fun max_timestamp -> - ok - Timestamp.( - expected_time > max_timestamp - && Round.(proposal_round <> op_round)) ) - ==> no_error - (acceptable_op - ~config - ~round_durations - ~round_zero_duration - ~proposal_level - ~proposal_round - ~proposal_timestamp - ~proposal_predecessor_level_start: - (predecessor_start - proposal_timestamp - proposal_round - Round.zero) - ~op_level - ~op_round - ~now_timestamp - >|? not)) - -(** Test operations at next level, different round, with an acceptable timestamp for - the operation. *) -let test_acceptable_next_level = - let open QCheck2 in - Test.make - ~print:Generator.print_param_acceptable - ~name:"next level, acceptable op" - Generator.(param_acceptable ~levels:same_levels ()) - (fun ( config, - ( ((proposal_round, op_round), (proposal_level, _)), - (proposal_timestamp, now_timestamp) ) ) -> - let op_level = Raw_level.succ proposal_level in - no_error - ( timestamp_of_round - round_durations - ~proposal_timestamp - ~proposal_round - ~round:Round.zero - >>? fun current_level_start -> - Round.timestamp_of_round - round_durations - ~predecessor_timestamp:current_level_start - ~predecessor_round:Round.zero - ~round:op_round - >>? fun expected_time -> - max_ts (get_clock_drift config) proposal_timestamp now_timestamp - >>? fun max_timestamp -> ok Timestamp.(expected_time <= max_timestamp) - ) - ==> no_error - @@ acceptable_op - ~config - ~round_durations - ~round_zero_duration - ~proposal_level - ~proposal_round - ~proposal_timestamp - ~proposal_predecessor_level_start: - (predecessor_start - proposal_timestamp - proposal_round - Round.zero) - ~op_level - ~op_round - ~now_timestamp) - -(** Test operations at next level, different round, with a too high timestamp - for the operation. *) -let test_not_acceptable_next_level = - let open QCheck2 in - Test.make - ~print:Generator.print_param_acceptable - ~name:"next level, too far" - Generator.( - param_acceptable ~levels:same_levels ~timestamps:successive_timestamp ()) - (fun ( config, - ( ((proposal_round, op_round), (proposal_level, _)), - (proposal_timestamp, now_timestamp) ) ) -> - let op_level = Raw_level.succ proposal_level in - QCheck2.assume - @@ no_error - ( timestamp_of_round - round_durations - ~proposal_timestamp - ~proposal_round - ~round:Round.zero - >>? fun current_level_start -> - Round.timestamp_of_round - round_durations - ~predecessor_timestamp:current_level_start - ~predecessor_round:Round.zero - ~round:op_round - >>? fun expected_time -> - Timestamp.( - proposal_timestamp - +? Round.round_duration round_durations proposal_round) - >>? fun next_level_ts -> - max_ts (get_clock_drift config) next_level_ts now_timestamp - >>? fun max_timestamp -> - ok Timestamp.(expected_time > max_timestamp) ) ; - no_error - @@ (acceptable_op - ~config - ~round_durations - ~round_zero_duration - ~proposal_level - ~proposal_round - ~proposal_timestamp - ~proposal_predecessor_level_start: - (predecessor_start proposal_timestamp proposal_round Round.zero) - ~op_level - ~op_round - ~now_timestamp - >|? not)) - -let () = - Alcotest.run - ~__FILE__ - Protocol.name - [ - ( "pre_filter", - qcheck_wrap - [ - test_acceptable_past_level; - test_acceptable_current_level_current_round; - test_acceptable_current_level; - test_not_acceptable_current_level; - test_acceptable_next_level; - test_not_acceptable_next_level; - ] ); - ] diff --git a/src/proto_017_PtNairob/lib_plugin/test/test_fee_needed_to_overtake.ml b/src/proto_017_PtNairob/lib_plugin/test/test_fee_needed_to_overtake.ml deleted file mode 100644 index 1606f5dd21bcd8e8e3d56a989c5fcbddfe348f29..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_plugin/test/test_fee_needed_to_overtake.ml +++ /dev/null @@ -1,178 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Plugin.Mempool - Invocation: dune exec src/proto_017_PtNairob/lib_plugin/test/main.exe \ - -- --file test_fee_needed_to_overtake.ml - Subject: Unit tests the Mempool.fee_needed_to_overtake - function of the plugin -*) - -let register_test = - Helpers.register_test - ~__FILE__ - ~file_title:"fee_needed_to_overtake" - ~file_tags:["mempool"; "fee_needed_to_overtake"] - -(** Test that [fee_needed_to_overtake] returns [None] when at least - one argument is a non-manager operation. *) -let () = - register_test - ~title:"non-manager operations" - ~additional_tags:["nonmanager"; "random"] - @@ fun () -> - let n = (* Number of non-manager operations to generate *) 30 in - let non_manager_ops = - QCheck2.Gen.generate ~n Helpers.non_manager_operation_gen - in - (* Test with two non-manager operations. *) - let test op_to_overtake candidate_op = - assert ( - Option.is_none - (Plugin.Mempool.fee_needed_to_overtake ~op_to_overtake ~candidate_op)) - in - Helpers.iter_neighbors test non_manager_ops ; - (* Test with one non-manager and one manager operation. *) - let manager_ops = QCheck2.Gen.generate ~n Helpers.manager_operation_gen in - let test_both op1 op2 = - test op1 op2 ; - test op2 op1 - in - Helpers.iter2_exn test_both non_manager_ops manager_ops ; - unit - -(** Check that {!Plugin.Mempool.fee_needed_to_overtake} correctly - returns the minimal fee with which [candidate_op] would be - guaranteed to be greater than [op_to_overtake]. - - Precondition: both operations are manager operations with respective - total fee and gas limit [fee_o], [gas_o] and [fee_c], [gas_c]. *) -let test_manager_ops (op_to_overtake, fee_o, gas_o) (candidate_op, fee_c, gas_c) - = - Log.debug - "Test op_to_overtake: {fee=%dmutez; gas=%d} and candidate_op: \ - {fee=%dmutez; gas=%d}" - fee_o - gas_o - fee_c - gas_c ; - let fee_needed = - WithExceptions.Option.get ~loc:__LOC__ - @@ Plugin.Mempool.fee_needed_to_overtake - ~op_to_overtake:(snd op_to_overtake) - ~candidate_op:(snd candidate_op) - in - Log.debug " --> fee_needed: %Ld" fee_needed ; - (* We need to ensure that in the operation comparisons below, the - hashes provided as first elements of the pairs are distinct. - Indeed, {!Alpha_context.Operation.compare} always returns 0 when - these hashes are equal, regardless of the operations themselves. *) - let fake_oph = Helpers.different_oph ~different_from:(fst op_to_overtake) in - (* We also set the source to {!Signature.Public_key_hash.zero} in - the operation that will be compared to [op_to_overtake], so that - if their weights (fee/gas ratio) are equal, then the former is - smaller (see [Operation_repr.compare_manager_weight]). *) - let source = Signature.Public_key_hash.zero in - let with_fee fee = - (fake_oph, Helpers.set_fee_and_source fee ~source (snd candidate_op)) - in - let fee_smaller = Int64.sub fee_needed 1L in - if Alpha_context.Operation.compare (with_fee fee_smaller) op_to_overtake > 0 - then - Test.fail - ~__LOC__ - "Adjusted candidate_op: {fee=%Ldmutez; gas=%d} with fee smaller than \ - fee_needed should be smaller than or equal to op_to_overtake: \ - {fee=%dmutez; gas=%d}" - fee_smaller - gas_c - fee_o - gas_o ; - if Alpha_context.Operation.compare (with_fee fee_needed) op_to_overtake <= 0 - then - Test.fail - ~__LOC__ - "Adjusted candidate_op: {fee=%Ldmutez; gas=%d} with fee_needed should be \ - greater than op_to_overtake: {fee=%dmutez; gas=%d}" - fee_needed - gas_c - fee_o - gas_o - -(** Test manager operations with hand-picked fee and gas. *) -let () = - register_test - ~title:"hand-picked fee and gas" - ~additional_tags:["manager"; "handpicked"] - @@ fun () -> - (* Various relative gas limits and fees: equal, off by one, - multiple/divisor, high ppcm, coprime, zero, one, much higher/lower, etc. *) - let fee_in_mutez_and_gas_list = - [ - (1000, 1000); - (500, 1000); - (1000, 1001); - (1000, 999); - (1000, 500); - (1000, 4000); - (1000, 1200); - (333, 777); - (11, 7); - (1000, 31); - (1000, 1); - (1, 100_000); - (1_000_000, 100_001); - (0, 10); - ] - in - let ops = - List.map - (fun (fee_in_mutez, gas) -> - let op = - Helpers.generate_manager_op_with_fee_and_gas ~fee_in_mutez ~gas - in - (op, fee_in_mutez, gas)) - fee_in_mutez_and_gas_list - in - List.iter (fun op -> List.iter (test_manager_ops op) ops) ops ; - unit - -(** Test manager operations with random fee and gas. *) -let () = - register_test - ~title:"random fee and gas" - ~additional_tags:["manager"; "random"] - @@ fun () -> - let gen = - let open QCheck2.Gen in - let* fee_in_mutez = int_range 0 100_000_000 in - let* gas = int_range 1 50_000_000 in - let* op = Helpers.manager_op_with_fee_and_gas_gen ~fee_in_mutez ~gas in - return (op, fee_in_mutez, gas) - in - Helpers.iter_neighbors test_manager_ops (QCheck2.Gen.generate ~n:100 gen) ; - unit diff --git a/src/proto_017_PtNairob/lib_plugin/test/test_fee_needed_to_replace_by_fee.ml b/src/proto_017_PtNairob/lib_plugin/test/test_fee_needed_to_replace_by_fee.ml deleted file mode 100644 index f4604296f2230382f9cd1cc35b6f74d7a5b8bdbc..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_plugin/test/test_fee_needed_to_replace_by_fee.ml +++ /dev/null @@ -1,210 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Plugin.Mempool - Invocation: dune exec src/proto_017_PtNairob/lib_plugin/test/main.exe \ - -- --file test_fee_needed_to_replace_by_fee.ml - Subject: Unit tests the fee_needed_to_replace_by_fee function - of the mempool plugin -*) - -let register_test = - Helpers.register_test - ~__FILE__ - ~file_title:"fee_needed_to_replace_by_fee" - ~file_tags:["mempool"; "fee_needed_to_replace_by_fee"] - -(** Test that [fee_needed_to_replace_by_fee] returns [None] when at least - one argument is a non-manager operation. *) -let () = - register_test - ~title:"non-manager operations" - ~additional_tags:["nonmanager"; "random"] - @@ fun () -> - let n = (* Number of non-manager operations to generate *) 30 in - let non_manager_ops = - QCheck2.Gen.generate ~n Helpers.non_manager_operation_gen - in - (* Test with two non-manager operations. *) - let test op_to_replace candidate_op = - assert ( - Option.is_none - (Plugin.Mempool.Internal_for_tests.fee_needed_to_replace_by_fee - Plugin.Mempool.default_config - ~op_to_replace - ~candidate_op)) - in - Helpers.iter_neighbors test non_manager_ops ; - (* Test with one non-manager and one manager operation. *) - let manager_ops = QCheck2.Gen.generate ~n Helpers.manager_operation_gen in - let test_both op1 op2 = - test op1 op2 ; - test op2 op1 - in - Helpers.iter2_exn test_both non_manager_ops manager_ops ; - unit - -(** Check that {!Plugin.Mempool.fee_needed_to_replace_by_fee} - correctly returns the minimal fee that [candidate_op] would need to - replace [op_to_replace] through {!Plugin.Mempool.conflict_handler}. - - Precondition: both operations are manager operations with respective - total fee and gas limit [fee_r], [gas_r] and [fee_c], [gas_c]. *) -let test_manager_ops config (op_to_replace, fee_r, gas_r) - (candidate_op, fee_c, gas_c) = - Log.debug - "Test op_to_replace: {fee=%dmutez; gas=%d} and candidate_op: {fee=%dmutez; \ - gas=%d}" - fee_r - gas_r - fee_c - gas_c ; - let fee_needed = - WithExceptions.Option.get ~loc:__LOC__ - @@ Plugin.Mempool.Internal_for_tests.fee_needed_to_replace_by_fee - config - ~op_to_replace:(snd op_to_replace) - ~candidate_op:(snd candidate_op) - in - Log.debug " --> fee_needed: %Ld" fee_needed ; - let with_fee fee = - (fst candidate_op, Helpers.set_fee fee (snd candidate_op)) - in - (if fee_needed > 0L then - let fee_smaller = Int64.pred fee_needed in - match - Plugin.Mempool.conflict_handler - config - ~existing_operation:op_to_replace - ~new_operation:(with_fee fee_smaller) - with - | `Keep -> () - | `Replace -> - Test.fail - ~__LOC__ - "Adjusted candidate_op: {fee=%Ldmutez; gas=%d} with fee smaller than \ - fee_needed should not be allowed to replace op_to_replace: \ - {fee=%dmutez; gas=%d}" - fee_smaller - gas_c - fee_r - gas_r) ; - match - Plugin.Mempool.conflict_handler - config - ~existing_operation:op_to_replace - ~new_operation:(with_fee fee_needed) - with - | `Keep -> - Test.fail - ~__LOC__ - "Adjusted candidate_op: {fee=%Ldmutez; gas=%d} with fee_needed should \ - replace op_to_replace: {fee=%dmutez; gas=%d}" - fee_needed - gas_c - fee_r - gas_r - | `Replace -> () - -(** Test manager operations with hand-picked fee and gas. *) -let () = - register_test - ~title:"hand-picked fee and gas" - ~additional_tags:["manager"; "handpicked"] - @@ fun () -> - let fee_in_mutez_and_gas_list = - [ - (* Various relative gas limits and fees: equal, off by one, - multiple/divisor, high ppcm, coprime, zero, one, much - higher/lower etc. *) - (1000, 1000); - (500, 1000); - (1000, 1001); - (1000, 999); - (1000, 500); - (1000, 4000); - (1000, 1200); - (333, 777); - (11, 7); - (1000, 31); - (1000, 1); - (1, 100_000); - (1_000_000, 100_001); - (0, 10); - (* Values such that fee or fee/gas, relative to (1000, 1000) that - appears above in the list, is close to the default - [replace_by_fee_factor] of 105/100 or its inverse. *) - (1050, 1000); - (1051, 1000); - (1049, 1000); - (1050, 1001); - (1050, 999); - (1000, 1050); - (1000, 1051); - (1000, 1049); - ] - in - let ops = - List.map - (fun (fee_in_mutez, gas) -> - let op = - Helpers.generate_manager_op_with_fee_and_gas ~fee_in_mutez ~gas - in - (op, fee_in_mutez, gas)) - fee_in_mutez_and_gas_list - in - List.iter - (fun op -> - List.iter (test_manager_ops Plugin.Mempool.default_config op) ops) - ops ; - unit - -(** Test manager operations with random fee and gas, and random config. *) -let () = - register_test - ~title:"random fee, gas, and config" - ~additional_tags:["manager"; "random"] - @@ fun () -> - let open QCheck2.Gen in - let gen = - let* fee_in_mutez = int_range 0 100_000_000 in - let* gas = int_range 1 50_000_000 in - let* op = Helpers.manager_op_with_fee_and_gas_gen ~fee_in_mutez ~gas in - return (op, fee_in_mutez, gas) - in - let gen_config = - let* num = int_range 0 1000 in - let* den = int_range 1 1000 in - return - (Plugin.Mempool.Internal_for_tests.default_config_with_replace_factor - (Q.of_ints num den)) - in - let test_manager_ops op_fee_gas1 op_fee_gas2 = - test_manager_ops (generate1 gen_config) op_fee_gas1 op_fee_gas2 - in - Helpers.iter_neighbors test_manager_ops (generate ~n:100 gen) ; - Lwt.return_unit diff --git a/src/proto_017_PtNairob/lib_protocol/test/README.md b/src/proto_017_PtNairob/lib_protocol/test/README.md deleted file mode 100644 index b0ec6d5b04644236e347a1aec12fb83aa5aaccaa..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/README.md +++ /dev/null @@ -1,30 +0,0 @@ -# lib_protocol tests - -This folder contains unit, integration and property-based tests for -the economic protocol definition. The tests are organized in -sub-folders: first by type of test, and for integration, a further -subdivision by theme: - -- `unit`: tests that sit below `Alpha_context`. -- `integration`: tests that require passing around a context. - - `michelson`: tests that involve Micheline expressions. - - `consensus`: tests for consensus: baking, endorsement, etc. - - `gas`: tests for gas. - - `operations`: test for operations. -- `pbt`: for property-based tests using `qcheck`. - -Finally, `helpers/` contains common definitions for writing tests. - -There might not be a clear-cut location for new tests. For new -integration tests, either add them directly to `integration/` or -create a new sub-folder corresponding to the theme of the test. - -# Running - -To run all the tests, run: - -``` -dune runtest src/proto_alpha/lib_protocol/ -``` - -To run an individual test file, consult its `Invocation` header. diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/README.md b/src/proto_017_PtNairob/lib_protocol/test/helpers/README.md deleted file mode 100644 index b071cfb4ec038daa53226eb6a5742579144e4598..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/README.md +++ /dev/null @@ -1,3 +0,0 @@ -## Helpers to build unit/integration tests for the protocol - -The OPAM package `tezos-alpha-test-helpers` contains helpers to build unit/integration tests, like forging a block, a context, nonces, operations, etc. diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/account.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/account.ml deleted file mode 100644 index 7f0144c194548826e89204ea7e84f75aabfb7d96..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/account.ml +++ /dev/null @@ -1,146 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 -open Alpha_context - -type t = { - pkh : Signature.Public_key_hash.t; - pk : Signature.Public_key.t; - sk : Signature.Secret_key.t; -} - -type account = t - -let known_accounts = Signature.Public_key_hash.Table.create 17 - -let random_seed ~rng_state = - Bytes.init Tezos_crypto.Hacl.Ed25519.sk_size (fun _i -> - Char.chr (Random.State.int rng_state 256)) - -let random_algo ~rng_state : Signature.algo = - match Random.State.int rng_state 3 with - | 0 -> Ed25519 - | 1 -> Secp256k1 - | 2 -> P256 - | 3 -> Bls - | _ -> assert false - -let new_account ?(rng_state = Random.State.make_self_init ()) - ?(seed = random_seed ~rng_state) ?(algo = random_algo ~rng_state) () = - let pkh, pk, sk = Signature.generate_key ~algo ~seed () in - let account = {pkh; pk; sk} in - Signature.Public_key_hash.Table.add known_accounts pkh account ; - account - -let add_account ({pkh; _} as account) = - Signature.Public_key_hash.Table.add known_accounts pkh account - -let activator_account = - let seed = random_seed ~rng_state:(Random.State.make [|0x1337533D|]) in - new_account ~seed () - -let find pkh = - match Signature.Public_key_hash.Table.find known_accounts pkh with - | Some k -> return k - | None -> failwith "Missing account: %a" Signature.Public_key_hash.pp pkh - -let find_alternate pkh = - let exception Found of t in - try - Signature.Public_key_hash.Table.iter - (fun pkh' account -> - if not (Signature.Public_key_hash.equal pkh pkh') then - raise (Found account)) - known_accounts ; - raise Not_found - with Found account -> account - -let dummy_account = - let seed = - random_seed ~rng_state:(Random.State.make [|0x1337533D; 0x1337533D|]) - in - new_account ~seed () - -let default_initial_balance = Tez.of_mutez_exn 4_000_000_000_000L - -let generate_accounts ?rng_state n : t list tzresult = - Signature.Public_key_hash.Table.clear known_accounts ; - List.init ~when_negative_length:[] n (fun _i -> new_account ?rng_state ()) - -let commitment_secret = - Blinded_public_key_hash.activation_code_of_hex - "aaaaaaaaaaaaaaaaaaaabbbbbbbbbbbbbbbbbbbb" - |> WithExceptions.Option.get ~loc:__LOC__ - -let new_commitment ?seed () = - let pkh, pk, sk = Signature.generate_key ?seed ~algo:Ed25519 () in - let unactivated_account = {pkh; pk; sk} in - let open Commitment in - let pkh = match pkh with Ed25519 pkh -> pkh | _ -> assert false in - let bpkh = Blinded_public_key_hash.of_ed25519_pkh commitment_secret pkh in - Lwt.return - ( (Environment.wrap_tzresult @@ Tez.(one *? 4_000L)) >|? fun amount -> - (unactivated_account, {blinded_public_key_hash = bpkh; amount}) ) - -let pkh_of_contract_exn = function - | Contract.Implicit pkh -> pkh - | Originated _ -> assert false - -let make_bootstrap_account ?(balance = default_initial_balance) - ?(delegate_to = None) ?(consensus_key = None) account = - Parameters. - { - public_key_hash = account.pkh; - public_key = Some account.pk; - amount = balance; - delegate_to; - consensus_key; - } - -let rec make_bootstrap_accounts ?(bootstrap_balances = []) - ?(bootstrap_delegations = []) ?(bootstrap_consensus_keys = []) accounts = - let decons_of_opt = function x :: xs -> (x, xs) | [] -> (None, []) in - let decons = function x :: xs -> (Some x, xs) | [] -> (None, []) in - match accounts with - | account :: accounts -> - let balance, bootstrap_balances = decons bootstrap_balances in - let delegate_to, bootstrap_delegations = - decons_of_opt bootstrap_delegations - in - let consensus_key, bootstrap_consensus_keys = - decons_of_opt bootstrap_consensus_keys - in - make_bootstrap_account - ?balance:(Option.map Tez.of_mutez_exn balance) - ~delegate_to - ~consensus_key - account - :: make_bootstrap_accounts - ~bootstrap_balances - ~bootstrap_delegations - ~bootstrap_consensus_keys - accounts - | [] -> [] diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/account.mli b/src/proto_017_PtNairob/lib_protocol/test/helpers/account.mli deleted file mode 100644 index 62ae056b2e6ab784dd512b3edd9598f14b09662c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/account.mli +++ /dev/null @@ -1,100 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 -open Alpha_context - -type t = { - pkh : Signature.Public_key_hash.t; - pk : Signature.Public_key.t; - sk : Signature.Secret_key.t; -} - -type account = t - -val known_accounts : t Signature.Public_key_hash.Table.t - -val activator_account : account - -val dummy_account : account - -(** [new_account ?rng_state ?seed ?algo ()] creates a new account with curve - [algo] with the given [seed] (or [rng_state] to generate the seed) and add - it to the global account state. -*) -val new_account : - ?rng_state:Random.State.t -> - ?seed:Bytes.t -> - ?algo:Signature.algo -> - unit -> - account - -val add_account : t -> unit - -val find : Signature.Public_key_hash.t -> t tzresult Lwt.t - -val find_alternate : Signature.Public_key_hash.t -> t - -(** 4.000.000.000 tez *) -val default_initial_balance : Tez.t - -(** [generate_accounts ?rng_state n] first frees the global account state then - generates [n] random accounts with [rng_state] to generate the seed and adds - them to the global account state. -*) -val generate_accounts : ?rng_state:Random.State.t -> int -> t list tzresult - -val commitment_secret : Blinded_public_key_hash.activation_code - -val new_commitment : - ?seed:Bytes.t -> unit -> (account * Commitment.t) tzresult Lwt.t - -(** Fails if the contract is not an implicit one *) -val pkh_of_contract_exn : Contract.t -> Signature.Public_key_hash.t - -(** [make_bootstrap_account ~initial_balance ~delegate_to account] creates a - {!Parameters.bootstrap_account} from an account with the default or set - values. default [initial_balance] is [default_initial_balance], - [delegate_to] is [None] and [consensus_key] is [None]. -*) -val make_bootstrap_account : - ?balance:Tez.t -> - ?delegate_to:Signature.public_key_hash option -> - ?consensus_key:Signature.public_key option -> - t -> - Parameters.bootstrap_account - -(** [make_bootstrap_accounts ~bootstrap_balances ~bootstrap_delegations - ~bootstrap_consensus_keys accounts] combines the lists [accounts], - [bootstrap_balances], [bootstrap_delegations] and [bootstrap_consensus_keys] - to create a list of {!Parameters.bootstrap_account} using - [make_bootstrap_account]. -*) -val make_bootstrap_accounts : - ?bootstrap_balances:int64 list -> - ?bootstrap_delegations:Signature.public_key_hash option list -> - ?bootstrap_consensus_keys:Signature.public_key option list -> - t list -> - Parameters.bootstrap_account list diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/assert.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/assert.ml deleted file mode 100644 index 4e491c3b294741829e0c40583ddcc4c50954858c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/assert.ml +++ /dev/null @@ -1,298 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2021-2022 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Protocol - -let error ~loc v f = - match v with - | Error err when List.exists f err -> return_unit - | Ok _ -> failwith "Unexpected successful result (%s)" loc - | Error err -> failwith "@[Unexpected error (%s): %a@]" loc pp_print_trace err - -let test_error_encodings e = - let module E = Environment.Error_monad in - ignore (E.pp Format.str_formatter e) ; - let e' = E.json_of_error e |> E.error_of_json in - assert (e = e') - -let proto_error ~loc v f = - error ~loc v (function - | Environment.Ecoproto_error err -> - test_error_encodings err ; - f err - | _ -> false) - -let proto_error_with_info ?(error_info_field = `Title) ~loc v - expected_error_info = - let info err = - let i = Error_monad.find_info_of_error (Environment.wrap_tzerror err) in - match error_info_field with - | `Title -> i.title - | `Id -> i.id - | `Description -> i.description - | `Message -> Format.asprintf "%a" Environment.Error_monad.pp err - in - proto_error ~loc v (function err -> - Format.printf - "@[THE ERROR IS: %s@,EXPECTED: %s@]@." - (info err) - expected_error_info ; - let info = info err in - String.equal info expected_error_info) - -let equal ~loc (cmp : 'a -> 'a -> bool) msg pp a b = - if not (cmp a b) then - failwith "@[@[[%s]@] - @[%s : %a is not equal to %a@]@]" loc msg pp a pp b - else return_unit - -let leq ~loc (cmp : 'a -> 'a -> int) msg pp a b = - if cmp a b > 0 then - failwith - "@[@[[%s]@] - @[%s : %a is not less or equal to %a@]@]" - loc - msg - pp - a - pp - b - else return_unit - -let lt ~loc (cmp : 'a -> 'a -> int) msg pp a b = - if cmp a b >= 0 then - failwith "@[@[[%s]@] - @[%s : %a is not less than %a@]@]" loc msg pp a pp b - else return_unit - -let not_equal ~loc (cmp : 'a -> 'a -> bool) msg pp a b = - if cmp a b then - failwith "@[@[[%s]@] - @[%s : %a is equal to %a@]@]" loc msg pp a pp b - else return_unit - -module Int32 = struct - include Int32 - - let pp pp v = Format.pp_print_int pp (Int32.to_int v) -end - -module Int64 = struct - include Int64 - - let pp pp v = Format.pp_print_int pp (Int64.to_int v) -end - -(* char *) -let equal_char ~loc a b = - equal ~loc Char.equal "Characters aren't equal" Format.pp_print_char a b - -(* int *) -let equal_int ~loc (a : int) (b : int) = - equal ~loc Int.equal "Integers aren't equal" Format.pp_print_int a b - -let not_equal_int ~loc (a : int) (b : int) = - not_equal ~loc Int.equal "Integers are equal" Format.pp_print_int a b - -let leq_int ~loc (a : int) (b : int) = - leq ~loc Compare.Int.compare "Integer comparison" Format.pp_print_int a b - -(* int32 *) -let equal_int32 ~loc (a : int32) (b : int32) = - equal ~loc Int32.equal "Int32 aren't equal" Int32.pp a b - -let leq_int32 ~loc (a : int32) (b : int32) = - leq ~loc Compare.Int32.compare "Int32 comparison" Int32.pp a b - -let lt_int32 ~loc (a : int32) (b : int32) = - lt ~loc Compare.Int32.compare "Int32 comparison" Int32.pp a b - -(* int64 *) -let equal_int64 ~loc (a : int64) (b : int64) = - equal ~loc Compare.Int64.( = ) "Int64 aren't equal" Int64.pp a b - -let not_equal_int64 ~loc (a : int64) (b : int64) = - not_equal ~loc Int64.equal "Int64 are equal" Int64.pp a b - -let leq_int64 ~loc (a : int64) (b : int64) = - leq ~loc Compare.Int64.compare "Int64 comparison" Int64.pp a b - -let equal_z ~loc (a : Z.t) (b : Z.t) = - equal ~loc Compare.Z.( = ) "Z are not equal" Z.pp_print a b - -(* bool *) -let equal_bool ~loc (a : bool) (b : bool) = - equal ~loc Bool.equal "Booleans aren't equal" Format.pp_print_bool a b - -let not_equal_bool ~loc (a : bool) (b : bool) = - not_equal ~loc Bool.equal "Booleans are equal" Format.pp_print_bool a b - -(* string *) -let equal_string ~loc (a : string) (b : string) = - equal ~loc String.equal "Strings aren't equal" Format.pp_print_string a b - -let not_equal_string ~loc (a : string) (b : string) = - not_equal ~loc String.equal "Strings are equal" Format.pp_print_string a b - -(* tez *) -let equal_tez ~loc (a : Alpha_context.Tez.t) (b : Alpha_context.Tez.t) = - let open Alpha_context in - equal ~loc Tez.( = ) "Tez aren't equal" Tez.pp a b - -let not_equal_tez ~loc (a : Alpha_context.Tez.t) (b : Alpha_context.Tez.t) = - let open Alpha_context in - not_equal ~loc Tez.( = ) "Tez are equal" Tez.pp a b - -(* pkh *) -let equal_pkh ~loc (a : Signature.Public_key_hash.t) - (b : Signature.Public_key_hash.t) = - let module PKH = Signature.Public_key_hash in - equal ~loc PKH.equal "Public key hashes aren't equal" PKH.pp a b - -let not_equal_pkh ~loc (a : Signature.Public_key_hash.t) - (b : Signature.Public_key_hash.t) = - let module PKH = Signature.Public_key_hash in - not_equal ~loc PKH.equal "Public key hashes are equal" PKH.pp a b - -(* protocol hash *) -let equal_protocol_hash ~loc (a : Protocol_hash.t) (b : Protocol_hash.t) = - equal - ~loc - Protocol_hash.equal - "Protocol hashes aren't equal" - Protocol_hash.pp - a - b - -let not_equal_protocol_hash ~loc (a : Protocol_hash.t) (b : Protocol_hash.t) = - not_equal - ~loc - Protocol_hash.equal - "Protocol hashes are equal" - Protocol_hash.pp - a - b - -let get_some ~loc = function - | Some x -> return x - | None -> failwith "Unexpected None (%s)" loc - -let is_none ~loc ~pp = function - | Some x -> failwith "Unexpected (Some %a) (%s)" pp x loc - | None -> return_unit - -let equal_result ~loc ~pp_ok ~pp_error eq_ok eq_error a b = - equal - ~loc - (Result.equal ~ok:eq_ok ~error:eq_error) - "Results are not equal" - (Format.pp_print_result ~ok:pp_ok ~error:pp_error) - a - b - -let is_error ~loc ~pp = function - | Ok x -> failwith "Unexpected (Ok %a) (%s)" pp x loc - | Error _ -> return_unit - -let get_ok ~__LOC__ = function - | Ok r -> return r - | Error err -> - failwith "@[Unexpected error (%s): %a@]" __LOC__ pp_print_trace err - -open Context - -(* Some asserts for account operations *) - -let contract_property_is property ~loc b contract expected = - property b contract >>=? fun balance -> equal_tez ~loc balance expected - -(** [balance_is b c amount] checks that the current balance [b] of contract [c] - is [amount]. -*) -let balance_is = contract_property_is Contract.balance - -(** [frozen_bonds_is b c amount] checks that the current frozen bonds of - contract [c] is [amount]. -*) -let frozen_bonds_is = contract_property_is Contract.frozen_bonds - -let balance_or_frozen_bonds_was_operated ~is_balance ~operand ~loc b contract - old_balance amount = - operand old_balance amount |> Environment.wrap_tzresult >>?= fun expected -> - let f = if is_balance then balance_is else frozen_bonds_is in - f ~loc b contract expected - -(** [balance_was_credited ~loc ctxt contract old_balance amount] checks - that [contract]'s balance was credited [amount] tez in comparison to - [old_balance]. -*) -let balance_was_credited = - balance_or_frozen_bonds_was_operated - ~is_balance:true - ~operand:Alpha_context.Tez.( +? ) - -(** [balance_was_credited ~loc ctxt contract old_balance amount] checks - that [contract]'s balance was debited [amount] tez in comparison to - [old_balance]. -*) -let balance_was_debited = - balance_or_frozen_bonds_was_operated - ~is_balance:true - ~operand:Alpha_context.Tez.( -? ) - -(** [frozen_bonds_was_credited ~loc ctxt contract old_balance amount] checks - that [contract]'s frozen bonds was credited [amount] tez in comparison to - [old_balance]. -*) -let frozen_bonds_was_credited = - balance_or_frozen_bonds_was_operated - ~is_balance:false - ~operand:Alpha_context.Tez.( +? ) - -(** [frozen_bonds_was_credited ~loc ctxt contract old_balance amount] checks - that [contract]'s frozen bonds was credited [amount] tez in comparison to - [old_balance]. -*) -let frozen_bonds_was_debited = - balance_or_frozen_bonds_was_operated - ~is_balance:false - ~operand:Alpha_context.Tez.( -? ) - -let pp_print_list pp out xs = - let list_pp fmt = - Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@.") fmt - in - Format.fprintf out "[%a]" (list_pp pp) xs - -let assert_equal_list ~loc eq msg pp = - equal ~loc (List.equal eq) msg (pp_print_list pp) - -let to_json_string encoding x = - x - |> Data_encoding.Json.construct encoding - |> Format.asprintf "\n%a\n" Data_encoding.Json.pp - -let equal_with_encoding ~loc encoding a b = - equal_string ~loc (to_json_string encoding a) (to_json_string encoding b) - -let not_equal_with_encoding ~loc encoding a b = - not_equal_string ~loc (to_json_string encoding a) (to_json_string encoding b) diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/big_map_helpers.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/big_map_helpers.ml deleted file mode 100644 index 46827683863ce5a3d2f71e96fa5f806fcf966033..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/big_map_helpers.ml +++ /dev/null @@ -1,71 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Protocol -open Alpha_context - -let make_big_map block ~source ~key_type ~value_type key_values = - let open Lwt_result_wrap_syntax in - let key_type = Expr.from_string key_type in - let value_type = Expr.from_string value_type in - let* operation, originated = - Op.contract_origination_hash (B block) source ~script:Op.dummy_script - in - let* block = Block.bake ~operation block in - let* incr = Incremental.begin_construction block in - let ctxt = Incremental.alpha_ctxt incr in - let*@ ctxt, big_map_id = Big_map.fresh ~temporary:false ctxt in - let* updates, ctxt = - List.fold_left_es - (fun (kvs, ctxt) (key, value) -> - let key_hash = - match - Data_encoding.Binary.to_bytes_opt Script_repr.expr_encoding key - with - | Some bytes -> Script_expr_hash.hash_bytes [bytes] - | None -> assert false - in - return ({Big_map.key; key_hash; value = Some value} :: kvs, ctxt)) - ([], ctxt) - key_values - in - let*@ ctxt = - Contract.update_script_storage - ctxt - originated - key_type - (Some - [ - Lazy_storage.make - Lazy_storage.Kind.Big_map - big_map_id - (Update - { - init = Lazy_storage.Alloc Big_map.{key_type; value_type}; - updates; - }); - ]) - in - return (big_map_id, ctxt) diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/big_map_helpers.mli b/src/proto_017_PtNairob/lib_protocol/test/helpers/big_map_helpers.mli deleted file mode 100644 index eca8c1dbd083b9cd5f639af9bf5327612eb01361..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/big_map_helpers.mli +++ /dev/null @@ -1,40 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Protocol - -(** [make_big_map block ~source ~key_type ~value_type key_values] constructs a - new big-map with the given key-type [key_type] and value type [value_type]. - - The big-map is owned by a new contract that is originated from [source], - with script {!Op.dummy_script}, and consists of a list of key-value pairs - according to the given [key_values] list of Micheline expressions. *) -val make_big_map : - Block.t -> - source:Alpha_context.Contract.t -> - key_type:string -> - value_type:string -> - (Script_repr.expr * Script_repr.expr) list -> - (Lazy_storage_kind.Big_map.Id.t * Alpha_context.context) tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/block.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/block.ml deleted file mode 100644 index 0bb605ac6941d7d5e392336b6d5db8b49bd30101..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/block.ml +++ /dev/null @@ -1,983 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2020 Metastate AG *) -(* Copyright (c) 2022 Trili Tech *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Protocol -module Proto_Nonce = Nonce (* Renamed otherwise is masked by Alpha_context *) -open Alpha_context - -(* This type collects a block and the context that results from its application *) -type t = { - hash : Block_hash.t; - header : Block_header.t; - operations : Operation.packed list; - context : Tezos_protocol_environment.Context.t; -} - -type block = t - -let rpc_context block = - { - Environment.Updater.block_hash = block.hash; - block_header = block.header.shell; - context = block.context; - } - -let rpc_ctxt = - new Environment.proto_rpc_context_of_directory - rpc_context - Plugin.RPC.rpc_services - -(******** Policies ***********) - -(* Policies are functions that take a block and return a tuple - [(account, level, timestamp)] for the [forge_header] function. *) - -(* This type is used only to provide a simpler interface to the exterior. *) -type baker_policy = - | By_round of int - | By_account of public_key_hash - | Excluding of public_key_hash list - -type baking_mode = Application | Baking - -let get_next_baker_by_round round block = - Plugin.RPC.Baking_rights.get rpc_ctxt ~all:true ~max_round:(round + 1) block - >|=? fun bakers -> - let {Plugin.RPC.Baking_rights.delegate = pkh; consensus_key; timestamp; _} = - WithExceptions.Option.get ~loc:__LOC__ - @@ List.find - (fun {Plugin.RPC.Baking_rights.round = r; _} -> - Round.to_int32 r = Int32.of_int round) - bakers - in - ( pkh, - consensus_key, - round, - WithExceptions.Option.to_exn ~none:(Failure "") timestamp ) - -let get_next_baker_by_account pkh block = - Plugin.RPC.Baking_rights.get rpc_ctxt ~delegates:[pkh] block - >>=? fun bakers -> - (match List.hd bakers with - | Some b -> return b - | None -> failwith "No slots found for %a" Signature.Public_key_hash.pp pkh) - >>=? fun { - Plugin.RPC.Baking_rights.delegate = pkh; - consensus_key; - timestamp; - round; - _; - } -> - Environment.wrap_tzresult (Round.to_int round) >>?= fun round -> - return - ( pkh, - consensus_key, - round, - WithExceptions.Option.to_exn ~none:(Failure __LOC__) timestamp ) - -let get_next_baker_excluding excludes block = - Plugin.RPC.Baking_rights.get rpc_ctxt block >>=? fun bakers -> - let { - Plugin.RPC.Baking_rights.delegate = pkh; - consensus_key; - timestamp; - round; - _; - } = - WithExceptions.Option.get ~loc:__LOC__ - @@ List.find - (fun {Plugin.RPC.Baking_rights.consensus_key; _} -> - not - (List.mem - ~equal:Signature.Public_key_hash.equal - consensus_key - excludes)) - bakers - in - Environment.wrap_tzresult (Round.to_int round) >>?= fun round -> - return - ( pkh, - consensus_key, - round, - WithExceptions.Option.to_exn ~none:(Failure "") timestamp ) - -let dispatch_policy = function - | By_round r -> get_next_baker_by_round r - | By_account a -> get_next_baker_by_account a - | Excluding al -> get_next_baker_excluding al - -let get_next_baker ?(policy = By_round 0) = dispatch_policy policy - -let get_round (b : t) = - let fitness = b.header.shell.fitness in - Fitness.(from_raw fitness >|? round) |> Environment.wrap_tzresult - -module Forge = struct - type header = { - baker : public_key_hash; - consensus_key : public_key_hash; - (* the signer of the block *) - shell : Block_header.shell_header; - contents : Block_header.contents; - } - - let default_proof_of_work_nonce = - Bytes.create Constants.proof_of_work_nonce_size - - let make_contents ?(proof_of_work_nonce = default_proof_of_work_nonce) - ~payload_hash ~payload_round - ?(liquidity_baking_toggle_vote = Liquidity_baking.LB_pass) - ~seed_nonce_hash () = - Block_header. - { - payload_hash; - payload_round; - proof_of_work_nonce; - seed_nonce_hash; - liquidity_baking_toggle_vote; - } - - 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 = Context_hash.zero; - } - - let set_seed_nonce_hash seed_nonce_hash - {baker; consensus_key; shell; contents} = - {baker; consensus_key; shell; contents = {contents with seed_nonce_hash}} - - let set_baker baker ?(consensus_key = baker) header = - {header with baker; consensus_key} - - let sign_header {consensus_key; shell; contents; _} = - Account.find consensus_key >|=? fun signer_account -> - let unsigned_bytes = - Data_encoding.Binary.to_bytes_exn - Block_header.unsigned_encoding - (shell, contents) - in - let signature = - Signature.sign - ~watermark:Block_header.(to_watermark (Block_header Chain_id.zero)) - signer_account.sk - unsigned_bytes - in - Block_header.{shell; protocol_data = {contents; signature}} - - let classify_operations operations = - let validation_passes_len = List.length Main.validation_passes in - let t = Array.make validation_passes_len [] in - List.iter - (fun (op : packed_operation) -> - match Main.acceptable_pass op with - | None -> () - | Some pass -> t.(pass) <- op :: t.(pass)) - operations ; - let t = Array.map List.rev t in - Array.to_list t - - let forge_header ?(locked_round = None) ?(payload_round = None) - ?(policy = By_round 0) ?timestamp ?(operations = []) - ?liquidity_baking_toggle_vote pred = - let pred_fitness = - match Fitness.from_raw pred.header.shell.fitness with - | Ok pred_fitness -> pred_fitness - | _ -> assert false - in - let predecessor_round = Fitness.round pred_fitness in - dispatch_policy policy pred - >>=? fun (delegate, consensus_key, round, expected_timestamp) -> - let timestamp = Option.value ~default:expected_timestamp timestamp in - let level = Int32.succ pred.header.shell.level in - Raw_level.of_int32 level |> Environment.wrap_tzresult >>?= fun raw_level -> - Round.of_int round |> Environment.wrap_tzresult >>?= fun round -> - Fitness.create ~level:raw_level ~predecessor_round ~round ~locked_round - >|? Fitness.to_raw |> Environment.wrap_tzresult - >>?= fun fitness -> - (Plugin.RPC.current_level ~offset:1l rpc_ctxt pred >|=? function - | {expected_commitment = true; _} -> Some (fst (Proto_Nonce.generate ())) - | {expected_commitment = false; _} -> None) - >|=? fun seed_nonce_hash -> - let hashes = List.map Operation.hash_packed operations in - let operations_hash = - Operation_list_list_hash.compute [Operation_list_hash.compute hashes] - in - let shell = - make_shell - ~level - ~predecessor:pred.hash - ~timestamp - ~fitness - ~operations_hash - in - let operations = classify_operations operations in - let non_consensus_operations = - List.concat (match List.tl operations with None -> [] | Some l -> l) - in - let hashes = List.map Operation.hash_packed non_consensus_operations in - let payload_round = - match payload_round with None -> round | Some r -> r - in - let payload_hash = - Block_payload.hash - ~predecessor_hash:shell.predecessor - ~payload_round - hashes - in - let contents = - make_contents - ~seed_nonce_hash - ?liquidity_baking_toggle_vote - ~payload_hash - ~payload_round - () - in - {baker = delegate; consensus_key; shell; contents} - - (* compatibility only, needed by incremental *) - let contents ?(proof_of_work_nonce = default_proof_of_work_nonce) - ?seed_nonce_hash - ?(liquidity_baking_toggle_vote = Liquidity_baking.LB_pass) ~payload_hash - ~payload_round () = - { - Block_header.proof_of_work_nonce; - seed_nonce_hash; - liquidity_baking_toggle_vote; - payload_hash; - payload_round; - } -end - -(********* Genesis creation *************) - -(* Hard-coded context key *) -let protocol_param_key = ["protocol_parameters"] - -let check_constants_consistency constants = - let open Constants.Parametric in - let { - blocks_per_cycle; - blocks_per_commitment; - nonce_revelation_threshold; - blocks_per_stake_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 (nonce_revelation_threshold <= blocks_per_cycle) (fun () -> - failwith - "Inconsistent constants : nonce_revelation_threshold must be less than \ - blocks_per_cycle") - >>=? fun () -> - Error_monad.unless (blocks_per_cycle >= blocks_per_stake_snapshot) (fun () -> - failwith - "Inconsistent constants : blocks_per_cycle must be superior than \ - blocks_per_stake_snapshot") - -let prepare_main_init_params ?bootstrap_contracts commitments constants - bootstrap_accounts = - let open Tezos_protocol_017_PtNairob_parameters in - let parameters = - Default_parameters.parameters_of_constants - ~bootstrap_accounts - ?bootstrap_contracts - ~commitments - constants - in - let json = Default_parameters.json_of_parameters parameters in - let proto_params = - Data_encoding.Binary.to_bytes_exn Data_encoding.json json - in - Tezos_protocol_environment.Context.( - let empty = Tezos_protocol_environment.Memory_context.empty in - add empty ["version"] (Bytes.of_string "genesis") >>= fun ctxt -> - add ctxt protocol_param_key proto_params) - -let initial_context ?(commitments = []) ?bootstrap_contracts chain_id constants - header bootstrap_accounts = - prepare_main_init_params - ?bootstrap_contracts - commitments - constants - bootstrap_accounts - >>= fun ctxt -> - Main.init chain_id ctxt header >|= Environment.wrap_tzresult - >|=? fun {context; _} -> context - -let initial_alpha_context ?(commitments = []) constants - (block_header : Block_header.shell_header) bootstrap_accounts = - prepare_main_init_params commitments constants bootstrap_accounts - >>= fun ctxt -> - let level = block_header.level in - let timestamp = block_header.timestamp in - let predecessor = block_header.predecessor in - let typecheck (ctxt : Alpha_context.context) (script : Alpha_context.Script.t) - = - let allow_forged_in_storage = - false - (* There should be no forged value in bootstrap contracts. *) - in - Script_ir_translator.parse_script - ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) - ~allow_forged_in_storage - script - >>=? fun (Ex_script (Script parsed_script), ctxt) -> - Script_ir_translator.extract_lazy_storage_diff - ctxt - Optimized - parsed_script.storage_type - parsed_script.storage - ~to_duplicate:Script_ir_translator.no_lazy_storage_id - ~to_update:Script_ir_translator.no_lazy_storage_id - ~temporary:false - >>=? fun (storage, lazy_storage_diff, ctxt) -> - Script_ir_translator.unparse_data - ctxt - Optimized - parsed_script.storage_type - storage - >|=? fun (storage, ctxt) -> - let storage = Alpha_context.Script.lazy_expr storage in - (({script with storage}, lazy_storage_diff), ctxt) - in - Alpha_context.prepare_first_block - ~typecheck - ~level - ~timestamp - ~predecessor - Chain_id.zero - ctxt - >|= Environment.wrap_tzresult - -let genesis_with_parameters parameters = - let hash = - Block_hash.of_b58check_exn - "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU" - in - let fitness = - Fitness_repr.create_without_locked_round - ~level:(Protocol.Raw_level_repr.of_int32_exn 0l) - ~predecessor_round:Round_repr.zero - ~round:Round_repr.zero - |> Fitness_repr.to_raw - in - let shell = - Forge.make_shell - ~level:0l - ~predecessor:hash - ~timestamp:Time.Protocol.epoch - ~fitness - ~operations_hash:Operation_list_list_hash.zero - in - let contents = - Forge.make_contents - ~payload_hash:Block_payload_hash.zero - ~payload_round:Round.zero - ~seed_nonce_hash:None - () - in - let open Tezos_protocol_017_PtNairob_parameters in - let json = Default_parameters.json_of_parameters parameters in - let proto_params = - Data_encoding.Binary.to_bytes_exn Data_encoding.json json - in - Tezos_protocol_environment.Context.( - let empty = Tezos_protocol_environment.Memory_context.empty in - add empty ["version"] (Bytes.of_string "genesis") >>= fun ctxt -> - add ctxt protocol_param_key proto_params) - >>= fun ctxt -> - let chain_id = Chain_id.of_block_hash hash in - Main.init chain_id ctxt shell >|= Environment.wrap_tzresult - >|=? fun {context; _} -> - { - hash; - header = {shell; protocol_data = {contents; signature = Signature.zero}}; - operations = []; - context; - } - -let validate_bootstrap_accounts - (bootstrap_accounts : Parameters.bootstrap_account list) minimal_stake = - if bootstrap_accounts = [] then - Stdlib.failwith "Must have one account with minimal_stake to bake" ; - (* Check there are at least minimal_stake tokens *) - Lwt.catch - (fun () -> - List.fold_left_es - (fun acc (Parameters.{amount; _} : Parameters.bootstrap_account) -> - Environment.wrap_tzresult @@ Tez.( +? ) acc amount >>?= fun acc -> - if acc >= minimal_stake then raise Exit else return acc) - Tez.zero - bootstrap_accounts - >>=? fun (_ : Tez.t) -> - failwith - "Insufficient tokens in initial accounts: the amount should be at \ - least minimal_stake") - (function Exit -> return_unit | exc -> Lwt.reraise exc) - -let prepare_initial_context_params ?consensus_threshold ?min_proposal_quorum - ?level ?cost_per_byte ?liquidity_baking_subsidy ?endorsing_reward_per_slot - ?baking_reward_bonus_per_slot ?baking_reward_fixed_portion ?origination_size - ?blocks_per_cycle ?cycles_per_voting_period ?sc_rollup_enable - ?sc_rollup_arith_pvm_enable ?dal_enable ?zk_rollup_enable - ?hard_gas_limit_per_block ?nonce_revelation_threshold () = - let open Tezos_protocol_017_PtNairob_parameters in - let constants = Default_parameters.constants_test in - let min_proposal_quorum = - Option.value ~default:constants.min_proposal_quorum min_proposal_quorum - in - let cost_per_byte = - Option.value ~default:constants.cost_per_byte cost_per_byte - in - let liquidity_baking_subsidy = - Option.value - ~default:constants.liquidity_baking_subsidy - liquidity_baking_subsidy - in - let endorsing_reward_per_slot = - Option.value - ~default:constants.endorsing_reward_per_slot - endorsing_reward_per_slot - in - let baking_reward_bonus_per_slot = - Option.value - ~default:constants.baking_reward_bonus_per_slot - baking_reward_bonus_per_slot - in - let baking_reward_fixed_portion = - Option.value - ~default:constants.baking_reward_fixed_portion - baking_reward_fixed_portion - in - let origination_size = - Option.value ~default:constants.origination_size origination_size - in - let blocks_per_cycle = - Option.value ~default:constants.blocks_per_cycle blocks_per_cycle - in - let cycles_per_voting_period = - Option.value - ~default:constants.cycles_per_voting_period - cycles_per_voting_period - in - let consensus_threshold = - Option.value ~default:constants.consensus_threshold consensus_threshold - in - let sc_rollup_enable = - Option.value ~default:constants.sc_rollup.enable sc_rollup_enable - in - let sc_rollup_arith_pvm_enable = - Option.value ~default:constants.sc_rollup.enable sc_rollup_arith_pvm_enable - in - let dal_enable = - Option.value ~default:constants.dal.feature_enable dal_enable - in - let zk_rollup_enable = - Option.value ~default:constants.zk_rollup.enable zk_rollup_enable - in - let hard_gas_limit_per_block = - Option.value - ~default:constants.hard_gas_limit_per_block - hard_gas_limit_per_block - in - let nonce_revelation_threshold = - Option.value - ~default:constants.nonce_revelation_threshold - nonce_revelation_threshold - in - let constants = - { - constants with - endorsing_reward_per_slot; - baking_reward_bonus_per_slot; - baking_reward_fixed_portion; - origination_size; - blocks_per_cycle; - cycles_per_voting_period; - min_proposal_quorum; - cost_per_byte; - liquidity_baking_subsidy; - consensus_threshold; - tx_rollup = constants.tx_rollup; - sc_rollup = - { - constants.sc_rollup with - enable = sc_rollup_enable; - arith_pvm_enable = sc_rollup_arith_pvm_enable; - }; - dal = {constants.dal with feature_enable = dal_enable}; - zk_rollup = {constants.zk_rollup with enable = zk_rollup_enable}; - hard_gas_limit_per_block; - nonce_revelation_threshold; - } - in - check_constants_consistency constants >>=? fun () -> - let hash = - Block_hash.of_b58check_exn - "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU" - in - let level = Option.value ~default:0l level in - let fitness = - Fitness_repr.create_without_locked_round - ~level:(Protocol.Raw_level_repr.of_int32_exn level) - ~predecessor_round:Round_repr.zero - ~round:Round_repr.zero - |> Fitness_repr.to_raw - in - let shell = - Forge.make_shell - ~level - ~predecessor:hash - ~timestamp:Time.Protocol.epoch - ~fitness - ~operations_hash:Operation_list_list_hash.zero - in - return (constants, shell, hash) - -(* if no parameter file is passed we check in the current directory - where the test is run *) -let genesis ?commitments ?consensus_threshold ?min_proposal_quorum - ?bootstrap_contracts ?level ?cost_per_byte ?liquidity_baking_subsidy - ?endorsing_reward_per_slot ?baking_reward_bonus_per_slot - ?baking_reward_fixed_portion ?origination_size ?blocks_per_cycle - ?cycles_per_voting_period ?sc_rollup_enable ?sc_rollup_arith_pvm_enable - ?dal_enable ?zk_rollup_enable ?hard_gas_limit_per_block - ?nonce_revelation_threshold - (bootstrap_accounts : Parameters.bootstrap_account list) = - prepare_initial_context_params - ?consensus_threshold - ?min_proposal_quorum - ?level - ?cost_per_byte - ?liquidity_baking_subsidy - ?endorsing_reward_per_slot - ?baking_reward_bonus_per_slot - ?baking_reward_fixed_portion - ?origination_size - ?blocks_per_cycle - ?cycles_per_voting_period - ?sc_rollup_enable - ?sc_rollup_arith_pvm_enable - ?dal_enable - ?zk_rollup_enable - ?hard_gas_limit_per_block - ?nonce_revelation_threshold - () - >>=? fun (constants, shell, hash) -> - validate_bootstrap_accounts bootstrap_accounts constants.minimal_stake - >>=? fun () -> - initial_context - ?commitments - ?bootstrap_contracts - (Chain_id.of_block_hash hash) - constants - shell - bootstrap_accounts - >|=? fun context -> - let contents = - Forge.make_contents - ~payload_hash:Block_payload_hash.zero - ~payload_round:Round.zero - ~seed_nonce_hash:None - () - in - { - hash; - header = {shell; protocol_data = {contents; signature = Signature.zero}}; - operations = []; - context; - } - -let alpha_context ?commitments ?min_proposal_quorum - (bootstrap_accounts : Parameters.bootstrap_account list) = - prepare_initial_context_params ?min_proposal_quorum () - >>=? fun (constants, shell, _hash) -> - validate_bootstrap_accounts bootstrap_accounts constants.minimal_stake - >>=? fun () -> - initial_alpha_context ?commitments constants shell bootstrap_accounts - -(********* Baking *************) - -let begin_validation_and_application ctxt chain_id mode ~predecessor = - let open Lwt_result_syntax in - let* validation_state = begin_validation ctxt chain_id mode ~predecessor in - let* application_state = begin_application ctxt chain_id mode ~predecessor in - return (validation_state, application_state) - -let get_application_vstate (pred : t) (operations : Protocol.operation trace) = - Forge.forge_header pred ~operations >>=? fun header -> - Forge.sign_header header >>=? fun header -> - let open Environment.Error_monad in - begin_validation_and_application - pred.context - Chain_id.zero - (Application header) - ~predecessor:pred.header.shell - >|= Environment.wrap_tzresult - -(* Note that by calling this function without [protocol_data], we - force the mode to be partial construction. *) -let get_construction_vstate ?(policy = By_round 0) ?timestamp - ?(protocol_data = None) (pred : t) = - let open Protocol in - dispatch_policy policy pred - >>=? fun (_pkh, _ck, _round, expected_timestamp) -> - let timestamp = Option.value ~default:expected_timestamp timestamp in - let mode = - match protocol_data with - | None -> Partial_construction {predecessor_hash = pred.hash; timestamp} - | Some block_header_data -> - Construction - {predecessor_hash = pred.hash; timestamp; block_header_data} - in - begin_validation_and_application - pred.context - Chain_id.zero - mode - ~predecessor:pred.header.shell - >|= Environment.wrap_tzresult - -let validate_and_apply_operation (validation_state, application_state) op = - let open Lwt_result_syntax in - let oph = Operation.hash_packed op in - let* validation_state = validate_operation validation_state oph op in - let* application_state, receipt = apply_operation application_state oph op in - return ((validation_state, application_state), receipt) - -let finalize_validation_and_application (validation_state, application_state) - shell_header = - let open Lwt_result_syntax in - let* () = finalize_validation validation_state in - finalize_application application_state shell_header - -let detect_manager_failure : - type kind. kind Apply_results.operation_metadata -> _ = - let rec detect_manager_failure : - type kind. kind Apply_results.contents_result_list -> _ = - let open Apply_results in - let open Apply_operation_result in - let open Apply_internal_results in - let detect_manager_failure_single (type kind) - (Manager_operation_result - {operation_result; internal_operation_results; _} : - kind Kind.manager Apply_results.contents_result) = - let detect_manager_failure (type kind) - (result : (kind, _, _) operation_result) = - match result with - | Applied _ -> Ok () - | Skipped _ -> assert false - | Backtracked (_, None) -> - (* there must be another error for this to happen *) - Ok () - | Backtracked (_, Some errs) -> Error errs - | Failed (_, errs) -> Error errs - in - detect_manager_failure operation_result >>? fun () -> - List.iter_e - (fun (Internal_operation_result (_, r)) -> detect_manager_failure r) - internal_operation_results - in - function - | Single_result (Manager_operation_result _ as res) -> - detect_manager_failure_single res - | Single_result _ -> Ok () - | Cons_result (res, rest) -> - detect_manager_failure_single res >>? fun () -> - detect_manager_failure rest - in - fun {contents} -> detect_manager_failure contents - -let apply_with_metadata ?(policy = By_round 0) ?(check_size = true) ~baking_mode - ~allow_manager_failures header ?(operations = []) pred = - let open Environment.Error_monad in - ( (match baking_mode with - | Application -> - begin_validation_and_application - pred.context - Chain_id.zero - (Application header) - ~predecessor:pred.header.shell - >|= Environment.wrap_tzresult - | Baking -> - get_construction_vstate - ~policy - ~protocol_data:(Some header.protocol_data) - (pred : t)) - >>=? fun vstate -> - List.fold_left_es - (fun vstate op -> - (if check_size then - let operation_size = - Data_encoding.Binary.length Operation.encoding op - in - if operation_size > Constants_repr.max_operation_data_length then - raise - (invalid_arg - (Format.sprintf - "The operation size is %d, it exceeds the constant maximum \ - size %d" - operation_size - Constants_repr.max_operation_data_length))) ; - validate_and_apply_operation vstate op >>=? fun (state, result) -> - if allow_manager_failures then return state - else - match result with - | No_operation_metadata -> return state - | Operation_metadata metadata -> - detect_manager_failure metadata >>?= fun () -> return state) - vstate - operations - >|= Environment.wrap_tzresult - >>=? fun vstate -> - finalize_validation_and_application vstate (Some header.shell) - >|= Environment.wrap_tzresult - >|=? fun (validation, result) -> (validation.context, result) ) - >|=? fun (context, result) -> - let hash = Block_header.hash header in - ({hash; header; operations; context}, result) - -let apply header ?(operations = []) ?(allow_manager_failures = false) pred = - apply_with_metadata - header - ~operations - pred - ~baking_mode:Application - ~allow_manager_failures - >>=? fun (t, _metadata) -> return t - -let bake_with_metadata ?locked_round ?policy ?timestamp ?operation ?operations - ?payload_round ?check_size ~baking_mode ?(allow_manager_failures = false) - ?liquidity_baking_toggle_vote pred = - let operations = - match (operation, operations) with - | Some op, Some ops -> Some (op :: ops) - | Some op, None -> Some [op] - | None, Some ops -> Some ops - | None, None -> None - in - Forge.forge_header - ?payload_round - ?locked_round - ?timestamp - ?policy - ?operations - ?liquidity_baking_toggle_vote - pred - >>=? fun header -> - Forge.sign_header header >>=? fun header -> - apply_with_metadata - ?policy - ?check_size - ~baking_mode - ~allow_manager_failures - header - ?operations - pred - -let bake ?(baking_mode = Application) ?(allow_manager_failures = false) - ?payload_round ?locked_round ?policy ?timestamp ?operation ?operations - ?liquidity_baking_toggle_vote ?check_size pred = - bake_with_metadata - ?payload_round - ~baking_mode - ~allow_manager_failures - ?locked_round - ?policy - ?timestamp - ?operation - ?operations - ?liquidity_baking_toggle_vote - ?check_size - pred - >>=? fun (t, (_metadata : block_header_metadata)) -> return t - -(********** Cycles ****************) - -(* This function is duplicated from Context to avoid a cyclic dependency *) -let get_constants b = Alpha_services.Constants.all rpc_ctxt b - -let bake_n ?(baking_mode = Application) ?policy ?liquidity_baking_toggle_vote n - b = - List.fold_left_es - (fun b _ -> bake ~baking_mode ?policy ?liquidity_baking_toggle_vote b) - b - (1 -- n) - -let rec bake_while ?(baking_mode = Application) ?policy - ?liquidity_baking_toggle_vote predicate b = - let open Lwt_result_syntax in - let* new_block = bake ~baking_mode ?policy ?liquidity_baking_toggle_vote b in - if predicate new_block then - (bake_while [@ocaml.tailcall]) - ~baking_mode - ?policy - ?liquidity_baking_toggle_vote - predicate - new_block - else return b - -let bake_until_level ?(baking_mode = Application) ?policy - ?liquidity_baking_toggle_vote level b = - bake_while - ~baking_mode - ?policy - ?liquidity_baking_toggle_vote - (fun b -> b.header.shell.level <= Raw_level.to_int32 level) - b - -let bake_n_with_all_balance_updates ?(baking_mode = Application) ?policy - ?liquidity_baking_toggle_vote n b = - List.fold_left_es - (fun (b, balance_updates_rev) _ -> - bake_with_metadata ~baking_mode ?policy ?liquidity_baking_toggle_vote b - >>=? fun (b, metadata) -> - let balance_updates_rev = - List.rev_append metadata.balance_updates balance_updates_rev - in - let balance_updates_rev = - List.fold_left - (fun balance_updates_rev -> - let open Apply_results in - fun (Successful_manager_result r) -> - match r with - | Transaction_result (Transaction_to_sc_rollup_result _) - | Reveal_result _ | Delegation_result _ - | Update_consensus_key_result _ | Set_deposits_limit_result _ - | Transfer_ticket_result _ | Dal_publish_slot_header_result _ - | Sc_rollup_originate_result _ | Sc_rollup_add_messages_result _ - | Sc_rollup_cement_result _ | Sc_rollup_publish_result _ - | Sc_rollup_refute_result _ | Sc_rollup_timeout_result _ - | Sc_rollup_execute_outbox_message_result _ - | Sc_rollup_recover_bond_result _ | Zk_rollup_origination_result _ - | Zk_rollup_publish_result _ | Zk_rollup_update_result _ -> - balance_updates_rev - | Transaction_result - ( Transaction_to_contract_result {balance_updates; _} - | Transaction_to_tx_rollup_result {balance_updates; _} - | Transaction_to_zk_rollup_result {balance_updates; _} ) - | Origination_result {balance_updates; _} - | Register_global_constant_result {balance_updates; _} - | Increase_paid_storage_result {balance_updates; _} -> - List.rev_append balance_updates balance_updates_rev) - balance_updates_rev - metadata.implicit_operations_results - in - return (b, balance_updates_rev)) - (b, []) - (1 -- n) - >|=? fun (b, balance_updates_rev) -> (b, List.rev balance_updates_rev) - -let bake_n_with_origination_results ?(baking_mode = Application) ?policy n b = - List.fold_left_es - (fun (b, origination_results_rev) _ -> - bake_with_metadata ~baking_mode ?policy b >>=? fun (b, metadata) -> - let origination_results_rev = - List.fold_left - (fun origination_results_rev -> - let open Apply_results in - function - | Successful_manager_result (Reveal_result _) - | Successful_manager_result (Delegation_result _) - | Successful_manager_result (Update_consensus_key_result _) - | Successful_manager_result (Transaction_result _) - | Successful_manager_result (Register_global_constant_result _) - | Successful_manager_result (Set_deposits_limit_result _) - | Successful_manager_result (Increase_paid_storage_result _) - | Successful_manager_result (Transfer_ticket_result _) - | Successful_manager_result (Dal_publish_slot_header_result _) - | Successful_manager_result (Sc_rollup_originate_result _) - | Successful_manager_result (Sc_rollup_add_messages_result _) - | Successful_manager_result (Sc_rollup_cement_result _) - | Successful_manager_result (Sc_rollup_publish_result _) - | Successful_manager_result (Sc_rollup_refute_result _) - | Successful_manager_result (Sc_rollup_timeout_result _) - | Successful_manager_result - (Sc_rollup_execute_outbox_message_result _) - | Successful_manager_result (Sc_rollup_recover_bond_result _) - | Successful_manager_result (Zk_rollup_origination_result _) - | Successful_manager_result (Zk_rollup_publish_result _) - | Successful_manager_result (Zk_rollup_update_result _) -> - origination_results_rev - | Successful_manager_result (Origination_result x) -> - Origination_result x :: origination_results_rev) - origination_results_rev - metadata.implicit_operations_results - in - return (b, origination_results_rev)) - (b, []) - (1 -- n) - >|=? fun (b, origination_results_rev) -> (b, List.rev origination_results_rev) - -let bake_n_with_liquidity_baking_toggle_ema ?(baking_mode = Application) ?policy - ?liquidity_baking_toggle_vote n b = - let initial_ema = Liquidity_baking.Toggle_EMA.zero in - List.fold_left_es - (fun (b, _toggle_ema) _ -> - bake_with_metadata ~baking_mode ?policy ?liquidity_baking_toggle_vote b - >|=? fun (b, metadata) -> (b, metadata.liquidity_baking_toggle_ema)) - (b, initial_ema) - (1 -- n) - -let bake_until_cycle_end ?policy b = - get_constants b >>=? fun Constants.{parametric = {blocks_per_cycle; _}; _} -> - let current_level = b.header.shell.level in - let current_level = Int32.rem current_level blocks_per_cycle in - let delta = Int32.sub blocks_per_cycle current_level in - bake_n ?policy (Int32.to_int delta) b - -let bake_until_n_cycle_end ?policy n b = - List.fold_left_es (fun b _ -> bake_until_cycle_end ?policy b) b (1 -- n) - -let current_cycle b = - get_constants b >>=? fun Constants.{parametric = {blocks_per_cycle; _}; _} -> - let current_level = b.header.shell.level in - let current_cycle = Int32.div current_level blocks_per_cycle in - let current_cycle = Cycle.add Cycle.root (Int32.to_int current_cycle) in - return current_cycle - -let bake_until_cycle ?policy cycle (b : t) = - let rec loop (b : t) = - current_cycle b >>=? fun current_cycle -> - if Cycle.equal cycle current_cycle then return b - else bake_until_cycle_end ?policy b >>=? fun b -> loop b - in - loop b diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/block.mli b/src/proto_017_PtNairob/lib_protocol/test/helpers/block.mli deleted file mode 100644 index 4fdf2a4d1f9baee146ecc95041a8dd78fecafcdb..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/block.mli +++ /dev/null @@ -1,301 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2020 Metastate AG *) -(* Copyright (c) 2022 Trili Tech *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Protocol -open Alpha_context - -type t = { - hash : Block_hash.t; - header : Block_header.t; - operations : Operation.packed list; - context : Tezos_protocol_environment.Context.t; (** Resulting context *) -} - -type block = t - -val rpc_ctxt : t Environment.RPC_context.simple - -(** Policies to select the next baker: - - [By_round r] selects the baker at round [r] - - [By_account pkh] selects the first slot for baker [pkh] - - [Excluding pkhs] selects the first baker that doesn't belong to [pkhs] - - Note that bakers can have active consensus keys different from - their regular delegate keys. For the [By_account pkh] policy, [pkh] - refers to the baker's delegate key. However, for the [Excluding pkhs] - policy, [pkhs] refer to the baker's active consensus key. *) -type baker_policy = - | By_round of int - | By_account of public_key_hash - | Excluding of public_key_hash list - -(** - The default baking functions below is to use (blocks) [Application] mode. - Setting [baking_mode] allows to switch to [Full_construction] mode. -*) -type baking_mode = Application | Baking - -(** Returns (account, round, timestamp) of the next baker given - a policy, defaults to By_round 0. *) -val get_next_baker : - ?policy:baker_policy -> - t -> - (public_key_hash * public_key_hash * int * Time.Protocol.t) tzresult Lwt.t - -val get_round : block -> Round.t tzresult - -module Forge : sig - val contents : - ?proof_of_work_nonce:Bytes.t -> - ?seed_nonce_hash:Nonce_hash.t -> - ?liquidity_baking_toggle_vote:Liquidity_baking.liquidity_baking_toggle_vote -> - payload_hash:Block_payload_hash.t -> - payload_round:Round.t -> - unit -> - Block_header.contents - - type header - - val classify_operations : packed_operation list -> packed_operation list list - - (** Forges a correct header following the policy. - The header can then be modified and applied with [apply]. *) - val forge_header : - ?locked_round:Alpha_context.Round.t option -> - ?payload_round:Round.t option -> - ?policy:baker_policy -> - ?timestamp:Timestamp.time -> - ?operations:Operation.packed list -> - ?liquidity_baking_toggle_vote:Liquidity_baking.liquidity_baking_toggle_vote -> - t -> - header tzresult Lwt.t - - (** Sets uniquely seed_nonce_hash of a header *) - val set_seed_nonce_hash : Nonce_hash.t option -> header -> header - - (** Sets the baker that will sign the header to an arbitrary pkh *) - val set_baker : - public_key_hash -> - ?consensus_key:Signature.public_key_hash -> - header -> - header - - (** Signs the header with the key of the baker configured in the header. - The header can no longer be modified, only applied. *) - val sign_header : header -> Block_header.block_header tzresult Lwt.t -end - -val check_constants_consistency : Constants.Parametric.t -> unit tzresult Lwt.t - -(** [genesis accounts] : generates an initial block with the - given constants [] and initializes [accounts] with their - associated amounts. -*) -val genesis : - ?commitments:Commitment.t list -> - ?consensus_threshold:int -> - ?min_proposal_quorum:int32 -> - ?bootstrap_contracts:Parameters.bootstrap_contract list -> - ?level:int32 -> - ?cost_per_byte:Tez.t -> - ?liquidity_baking_subsidy:Tez.t -> - ?endorsing_reward_per_slot:Tez.t -> - ?baking_reward_bonus_per_slot:Tez.t -> - ?baking_reward_fixed_portion:Tez.t -> - ?origination_size:int -> - ?blocks_per_cycle:int32 -> - ?cycles_per_voting_period:int32 -> - ?sc_rollup_enable:bool -> - ?sc_rollup_arith_pvm_enable:bool -> - ?dal_enable:bool -> - ?zk_rollup_enable:bool -> - ?hard_gas_limit_per_block:Gas.Arith.integral -> - ?nonce_revelation_threshold:int32 -> - Parameters.bootstrap_account list -> - block tzresult Lwt.t - -val genesis_with_parameters : Parameters.t -> block tzresult Lwt.t - -(** [alpha_context accounts] : instantiates an alpha_context with the - given constants [] and initializes [accounts] with their - associated amounts. -*) -val alpha_context : - ?commitments:Commitment.t list -> - ?min_proposal_quorum:int32 -> - Parameters.bootstrap_account list -> - Alpha_context.t tzresult Lwt.t - -(** - [get_application_vstate pred operations] constructs a protocol validation - environment for operations in application mode on top of the given block - with the given operations. It's a shortcut for [begin_application] -*) -val get_application_vstate : - t -> - Protocol.operation list -> - (validation_state * application_state) tzresult Lwt.t - -(** - [get_construction_vstate ?policy ?timestamp ?protocol_data pred] - constructs a protocol validation environment for operations in - construction mode on top of the given block. The mode is - full(baking)/partial(mempool) if [protocol_data] given/absent. It's a - shortcut for [begin_construction] - *) -val get_construction_vstate : - ?policy:baker_policy -> - ?timestamp:Timestamp.time -> - ?protocol_data:block_header_data option -> - block -> - (validation_state * application_state) tzresult Lwt.t - -(** applies a signed header and its operations to a block and - obtains a new block *) -val apply : - Block_header.block_header -> - ?operations:Operation.packed list -> - ?allow_manager_failures:bool -> - t -> - t tzresult Lwt.t - -(** [bake b] returns a block [b'] which has as predecessor block [b]. - Optional parameter [policy] allows to pick the next baker in - several ways. If [check_size] is [true] (the default case), then - the function checks that the operations passed as arguments satisfy - the size limit of Tezos operations, as defined in the protocol. - This function bundles together [forge_header], [sign_header] and - [apply]. These functions should be used instead of bake to craft - unusual blocks for testing together with setters for properties of - the headers. Setting [allow_manager_failures] (default=false), - allows baking blocks with manager operation(s) that are valid but - that could fail during their application. If this is not set, the - block is correctly baked but the operations' application will fail - silently. For examples see seed.ml or double_baking.ml -*) -val bake : - ?baking_mode:baking_mode -> - ?allow_manager_failures:bool -> - ?payload_round:Round.t option -> - ?locked_round:Alpha_context.Round.t option -> - ?policy:baker_policy -> - ?timestamp:Timestamp.time -> - ?operation:Operation.packed -> - ?operations:Operation.packed list -> - ?liquidity_baking_toggle_vote:Liquidity_baking.liquidity_baking_toggle_vote -> - ?check_size:bool -> - t -> - t tzresult Lwt.t - -(** Bakes [n] blocks. *) -val bake_n : - ?baking_mode:baking_mode -> - ?policy:baker_policy -> - ?liquidity_baking_toggle_vote:Liquidity_baking.liquidity_baking_toggle_vote -> - int -> - t -> - block tzresult Lwt.t - -(** Bakes until the given level is reached. *) -val bake_until_level : - ?baking_mode:baking_mode -> - ?policy:baker_policy -> - ?liquidity_baking_toggle_vote:Liquidity_baking.liquidity_baking_toggle_vote -> - Raw_level.t -> - t -> - block tzresult Lwt.t - -(** Version of bake_n that returns a list of all balance updates included - in the metadata of baked blocks. **) -val bake_n_with_all_balance_updates : - ?baking_mode:baking_mode -> - ?policy:baker_policy -> - ?liquidity_baking_toggle_vote:Liquidity_baking.liquidity_baking_toggle_vote -> - int -> - t -> - (block * Alpha_context.Receipt.balance_updates) tzresult Lwt.t - -(** Version of bake_n that returns a list of all origination results - in the metadata of baked blocks. **) -val bake_n_with_origination_results : - ?baking_mode:baking_mode -> - ?policy:baker_policy -> - int -> - t -> - (block - * Alpha_context.Kind.origination - Apply_results.successful_manager_operation_result - list) - tzresult - Lwt.t - -(** Version of bake_n that returns the liquidity baking toggle EMA after [n] blocks. **) -val bake_n_with_liquidity_baking_toggle_ema : - ?baking_mode:baking_mode -> - ?policy:baker_policy -> - ?liquidity_baking_toggle_vote:Liquidity_baking.liquidity_baking_toggle_vote -> - int -> - t -> - (block * Alpha_context.Liquidity_baking.Toggle_EMA.t) tzresult Lwt.t - -val current_cycle : t -> Cycle.t tzresult Lwt.t - -(** Given a block [b] at level [l] bakes enough blocks to complete a cycle, - that is [blocks_per_cycle - (l % blocks_per_cycle)]. *) -val bake_until_cycle_end : ?policy:baker_policy -> t -> t tzresult Lwt.t - -(** Bakes enough blocks to end [n] cycles. *) -val bake_until_n_cycle_end : - ?policy:baker_policy -> int -> t -> t tzresult Lwt.t - -(** Bakes enough blocks to reach the cycle. *) -val bake_until_cycle : ?policy:baker_policy -> Cycle.t -> t -> t tzresult Lwt.t - -(** Common util function to create parameters for [initial_context] function *) -val prepare_initial_context_params : - ?consensus_threshold:int -> - ?min_proposal_quorum:int32 -> - ?level:int32 -> - ?cost_per_byte:Tez.t -> - ?liquidity_baking_subsidy:Tez.t -> - ?endorsing_reward_per_slot:Tez.t -> - ?baking_reward_bonus_per_slot:Tez.t -> - ?baking_reward_fixed_portion:Tez.t -> - ?origination_size:int -> - ?blocks_per_cycle:int32 -> - ?cycles_per_voting_period:int32 -> - ?sc_rollup_enable:bool -> - ?sc_rollup_arith_pvm_enable:bool -> - ?dal_enable:bool -> - ?zk_rollup_enable:bool -> - ?hard_gas_limit_per_block:Gas.Arith.integral -> - ?nonce_revelation_threshold:int32 -> - unit -> - ( Constants.Parametric.t * Block_header.shell_header * Block_hash.t, - tztrace ) - result - Lwt.t diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/consensus_helpers.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/consensus_helpers.ml deleted file mode 100644 index 56dce872e73d52899150c8612fa9d0a38cc7f74d..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/consensus_helpers.ml +++ /dev/null @@ -1,182 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context - -type mode = Application | Construction | Mempool - -let show_mode = function - | Application -> "Application" - | Construction -> "Construction" - | Mempool -> "Mempool" - -type kind = Preendorsement | Endorsement - -(** Craft an endorsement or preendorsement, and bake a block - containing it (in application or construction modes) or inject it - into a mempool. When [error] is [None], check that it succeeds, - otherwise check that it fails as specified by [error]. - - By default, the (pre)endorsement is for the first slot and is - signed by the delegate that owns this slot. Moreover, the operation - points to the given [endorsed_block]: in other words, it has that - block's level, round, payload hash, and its branch is the - predecessor of that block. Optional arguments allow to override - these default parameters. - - The [predecessor] is used as the predecessor of the baked block or - the head of the mempool. When it is not provided, we use the - [endorsed_block] for this. *) -let test_consensus_operation ?delegate ?slot ?level ?round ?block_payload_hash - ?branch ~endorsed_block ?(predecessor = endorsed_block) ?error ~loc kind - mode = - let open Lwt_result_syntax in - let* operation = - match kind with - | Preendorsement -> - Op.preendorsement - ?delegate - ?slot - ?level - ?round - ?block_payload_hash - ?branch - endorsed_block - | Endorsement -> - Op.endorsement - ?delegate - ?slot - ?level - ?round - ?block_payload_hash - ?branch - endorsed_block - in - let check_error res = - match error with - | Some error -> Assert.proto_error ~loc res error - | None -> - let*? _ = res in - return_unit - in - match mode with - | Application -> - Block.bake ~baking_mode:Application ~operation predecessor >>= check_error - | Construction -> - Block.bake ~baking_mode:Baking ~operation predecessor >>= check_error - | Mempool -> - let*! res = - let* inc = - Incremental.begin_construction ~mempool_mode:true predecessor - in - let* inc = Incremental.add_operation inc operation in - (* Finalization doesn't do much in mempool mode, but some RPCs - still call it, so we check that it doesn't fail unexpectedly. *) - Incremental.finalize_block inc - in - check_error res - -let test_consensus_operation_all_modes_different_outcomes ?delegate ?slot ?level - ?round ?block_payload_hash ?branch ~endorsed_block ?predecessor ~loc - ?application_error ?construction_error ?mempool_error kind = - List.iter_es - (fun (mode, error) -> - test_consensus_operation - ?delegate - ?slot - ?level - ?round - ?block_payload_hash - ?branch - ~endorsed_block - ?predecessor - ?error - ~loc:(Format.sprintf "%s (%s mode)" loc (show_mode mode)) - kind - mode) - [ - (Application, application_error); - (Construction, construction_error); - (Mempool, mempool_error); - ] - -let test_consensus_operation_all_modes ?delegate ?slot ?level ?round - ?block_payload_hash ?branch ~endorsed_block ?predecessor ?error ~loc kind = - test_consensus_operation_all_modes_different_outcomes - ?delegate - ?slot - ?level - ?round - ?block_payload_hash - ?branch - ~endorsed_block - ?predecessor - ~loc - ?application_error:error - ?construction_error:error - ?mempool_error:error - kind - -let delegate_of_first_slot b = - let module V = Plugin.RPC.Validators in - Context.get_endorsers b >|=? function - | {V.consensus_key; slots = s :: _; _} :: _ -> (consensus_key, s) - | _ -> assert false - -let delegate_of_slot ?(different_slot = false) slot b = - let module V = Plugin.RPC.Validators in - Context.get_endorsers b >|=? fun endorsers -> - List.find_map - (function - | {V.consensus_key; slots = s :: _; _} - when if different_slot then not (Slot.equal s slot) - else Slot.equal s slot -> - Some consensus_key - | _ -> None) - endorsers - |> function - | None -> assert false - | Some d -> d - -let test_consensus_op_for_next ~genesis ~kind ~next = - let dorsement ~endorsed_block ~delegate = - match kind with - | `Preendorsement -> Op.preendorsement ~delegate endorsed_block - | `Endorsement -> Op.endorsement ~delegate endorsed_block - in - Block.bake genesis >>=? fun b1 -> - (match next with - | `Level -> Block.bake b1 - | `Round -> Block.bake ~policy:(By_round 1) genesis) - >>=? fun b2 -> - Incremental.begin_construction ~mempool_mode:true b1 >>=? fun inc -> - delegate_of_first_slot (B b1) >>=? fun (delegate, slot) -> - dorsement ~endorsed_block:b1 ~delegate >>=? fun operation -> - Incremental.add_operation inc operation >>=? fun inc -> - delegate_of_slot ~different_slot:true slot (B b2) >>=? fun delegate -> - dorsement ~endorsed_block:b2 ~delegate >>=? fun operation -> - Incremental.add_operation inc operation >>=? fun (_ : Incremental.t) -> - return_unit diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/context.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/context.ml deleted file mode 100644 index 823ac96b2c1f80bdb982a222c02466ecfdc7f6cf..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/context.ml +++ /dev/null @@ -1,586 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2022 Trili Tech *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Protocol -open Alpha_context - -type t = B of Block.t | I of Incremental.t - -let branch = function B b -> b.hash | I i -> (Incremental.predecessor i).hash - -let pred_branch = function - | B b -> b.header.shell.predecessor - | I i -> (Incremental.predecessor i).hash - -let level = function B b -> b.header.shell.level | I i -> Incremental.level i - -let get_level ctxt = - level ctxt |> Raw_level.of_int32 |> Environment.wrap_tzresult - -let rpc_ctxt = - object - method call_proto_service0 - : 'm 'q 'i 'o. - ( ([< Tezos_rpc.Service.meth] as 'm), - Environment.RPC_context.t, - Environment.RPC_context.t, - 'q, - 'i, - 'o ) - Tezos_rpc.Service.t -> - t -> - 'q -> - 'i -> - 'o tzresult Lwt.t = - fun s pr q i -> - match pr with - | B b -> Block.rpc_ctxt#call_proto_service0 s b q i - | I b -> Incremental.rpc_ctxt#call_proto_service0 s b q i - - method call_proto_service1 - : 'm 'a 'q 'i 'o. - ( ([< Tezos_rpc.Service.meth] as 'm), - Environment.RPC_context.t, - Environment.RPC_context.t * 'a, - 'q, - 'i, - 'o ) - Tezos_rpc.Service.t -> - t -> - 'a -> - 'q -> - 'i -> - 'o tzresult Lwt.t = - fun s pr a q i -> - match pr with - | B bl -> Block.rpc_ctxt#call_proto_service1 s bl a q i - | I bl -> Incremental.rpc_ctxt#call_proto_service1 s bl a q i - - method call_proto_service2 - : 'm 'a 'b 'q 'i 'o. - ( ([< Tezos_rpc.Service.meth] as 'm), - Environment.RPC_context.t, - (Environment.RPC_context.t * 'a) * 'b, - 'q, - 'i, - 'o ) - Tezos_rpc.Service.t -> - t -> - 'a -> - 'b -> - 'q -> - 'i -> - 'o tzresult Lwt.t = - fun s pr a b q i -> - match pr with - | B bl -> Block.rpc_ctxt#call_proto_service2 s bl a b q i - | I bl -> Incremental.rpc_ctxt#call_proto_service2 s bl a b q i - - method call_proto_service3 - : 'm 'a 'b 'c 'q 'i 'o. - ( ([< Tezos_rpc.Service.meth] as 'm), - Environment.RPC_context.t, - ((Environment.RPC_context.t * 'a) * 'b) * 'c, - 'q, - 'i, - 'o ) - Tezos_rpc.Service.t -> - t -> - 'a -> - 'b -> - 'c -> - 'q -> - 'i -> - 'o tzresult Lwt.t = - fun s pr a b c q i -> - match pr with - | B bl -> Block.rpc_ctxt#call_proto_service3 s bl a b c q i - | I bl -> Incremental.rpc_ctxt#call_proto_service3 s bl a b c q i - end - -let get_endorsers ctxt = Plugin.RPC.Validators.get rpc_ctxt ctxt - -let get_first_different_endorsers ctxt = - get_endorsers ctxt >|=? function x :: y :: _ -> (x, y) | _ -> assert false - -let get_endorser ctxt = - get_endorsers ctxt >|=? fun endorsers -> - let endorser = WithExceptions.Option.get ~loc:__LOC__ @@ List.hd endorsers in - (endorser.consensus_key, endorser.slots) - -let get_endorser_slot ctxt pkh = - get_endorsers ctxt >|=? fun endorsers -> - List.find_map - (function - | {Plugin.RPC.Validators.consensus_key; slots; _} -> - if Signature.Public_key_hash.(consensus_key = pkh) then Some slots - else None) - endorsers - -let get_endorser_n ctxt n = - Plugin.RPC.Validators.get rpc_ctxt ctxt >|=? fun endorsers -> - let endorser = - WithExceptions.Option.get ~loc:__LOC__ @@ List.nth endorsers n - in - (endorser.consensus_key, endorser.slots) - -let get_endorsing_power_for_delegate ctxt ?levels pkh = - Plugin.RPC.Validators.get rpc_ctxt ?levels ctxt >>=? fun endorsers -> - let rec find_slots_for_delegate = function - | [] -> return 0 - | {Plugin.RPC.Validators.delegate; slots; _} :: t -> - if Signature.Public_key_hash.equal delegate pkh then - return (List.length slots) - else find_slots_for_delegate t - in - find_slots_for_delegate endorsers - -let get_voting_power = Delegate_services.voting_power rpc_ctxt - -let get_total_voting_power = Alpha_services.Voting.total_voting_power rpc_ctxt - -let get_bakers ?filter ?cycle ctxt = - Plugin.RPC.Baking_rights.get rpc_ctxt ?cycle ctxt >|=? fun bakers -> - (match filter with None -> bakers | Some f -> List.filter f bakers) - |> List.map (fun p -> p.Plugin.RPC.Baking_rights.delegate) - -let get_baker ctxt ~round = - get_bakers ~filter:(fun x -> x.round = round) ctxt >>=? fun bakers -> - (* there is only one baker for a given round *) - match bakers with [baker] -> return baker | _ -> assert false - -let get_first_different_baker baker bakers = - WithExceptions.Option.get ~loc:__LOC__ - @@ List.find - (fun baker' -> Signature.Public_key_hash.( <> ) baker baker') - bakers - -let get_first_different_bakers ctxt = - get_bakers ctxt >|=? function - | [] -> assert false - | baker_1 :: other_bakers -> - (baker_1, get_first_different_baker baker_1 other_bakers) - -let get_seed_nonce_hash ctxt = - let header = - match ctxt with B {header; _} -> header | I i -> Incremental.header i - in - match header.protocol_data.contents.seed_nonce_hash with - | None -> failwith "No committed nonce" - | Some hash -> return hash - -let get_seed ctxt = Alpha_services.Seed.get rpc_ctxt ctxt - -let get_seed_computation ctxt = - Alpha_services.Seed_computation.get rpc_ctxt ctxt - -let get_constants ctxt = Alpha_services.Constants.all rpc_ctxt ctxt - -let default_test_constants = - Tezos_protocol_017_PtNairob_parameters.Default_parameters.constants_test - -let get_baking_reward_fixed_portion ctxt = - get_constants ctxt - >>=? fun {Constants.parametric = {baking_reward_fixed_portion; _}; _} -> - return baking_reward_fixed_portion - -let get_bonus_reward ctxt ~endorsing_power = - get_constants ctxt - >>=? fun { - Constants.parametric = - {baking_reward_bonus_per_slot; consensus_threshold; _}; - _; - } -> - let multiplier = max 0 (endorsing_power - consensus_threshold) in - return Test_tez.(baking_reward_bonus_per_slot *! Int64.of_int multiplier) - -let get_endorsing_reward ctxt ~expected_endorsing_power = - get_constants ctxt - >>=? fun {Constants.parametric = {endorsing_reward_per_slot; _}; _} -> - Lwt.return - (Environment.wrap_tzresult - Tez.(endorsing_reward_per_slot *? Int64.of_int expected_endorsing_power)) - -let get_liquidity_baking_subsidy ctxt = - get_constants ctxt - >>=? fun {Constants.parametric = {liquidity_baking_subsidy; _}; _} -> - return liquidity_baking_subsidy - -let get_liquidity_baking_cpmm_address ctxt = - Alpha_services.Liquidity_baking.get_cpmm_address rpc_ctxt ctxt - -(* Voting *) - -module Vote = struct - let get_ballots ctxt = Alpha_services.Voting.ballots rpc_ctxt ctxt - - let get_ballot_list ctxt = Alpha_services.Voting.ballot_list rpc_ctxt ctxt - - let get_current_period ctxt = - Alpha_services.Voting.current_period rpc_ctxt ctxt - - let get_current_quorum ctxt = - Alpha_services.Voting.current_quorum rpc_ctxt ctxt - - let get_listings ctxt = Alpha_services.Voting.listings rpc_ctxt ctxt - - let get_proposals ctxt = Alpha_services.Voting.proposals rpc_ctxt ctxt - - let get_current_proposal ctxt = - Alpha_services.Voting.current_proposal rpc_ctxt ctxt - - let get_protocol (b : Block.t) = - Tezos_protocol_environment.Context.get_protocol b.context - - let get_delegate_proposal_count ctxt pkh = - Alpha_services.Voting.delegate_proposal_count rpc_ctxt ctxt pkh - - let get_participation_ema (b : Block.t) = - Environment.Context.find b.context ["votes"; "participation_ema"] - >|= function - | None -> assert false - | Some bytes -> ok (TzEndian.get_int32 bytes 0) - - let set_participation_ema (b : Block.t) ema = - let bytes = Bytes.make 4 '\000' in - TzEndian.set_int32 bytes 0 ema ; - Environment.Context.add b.context ["votes"; "participation_ema"] bytes - >|= fun context -> {b with context} - - type delegate_info = Alpha_context.Vote.delegate_info = { - voting_power : Int64.t option; - current_ballot : Alpha_context.Vote.ballot option; - current_proposals : Protocol_hash.t list; - remaining_proposals : int; - } -end - -module Contract = struct - let pp = Alpha_context.Contract.pp - - let equal a b = Alpha_context.Contract.compare a b = 0 - - let pkh = function - | Contract.Implicit p -> p - | Originated _ -> Stdlib.failwith "pkh: only for implicit contracts" - - let balance ctxt contract = - Alpha_services.Contract.balance rpc_ctxt ctxt contract - - let frozen_bonds ctxt contract = - Alpha_services.Contract.frozen_bonds rpc_ctxt ctxt contract - - let balance_and_frozen_bonds ctxt contract = - Alpha_services.Contract.balance_and_frozen_bonds rpc_ctxt ctxt contract - - let counter ctxt (contract : Contract.t) = - match contract with - | Originated _ -> invalid_arg "Helpers.Context.counter" - | Implicit mgr -> Alpha_services.Contract.counter rpc_ctxt ctxt mgr - - let manager _ (contract : Contract.t) = - match contract with - | Originated _ -> invalid_arg "Helpers.Context.manager" - | Implicit pkh -> Account.find pkh - - let is_manager_key_revealed ctxt (contract : Contract.t) = - match contract with - | Originated _ -> invalid_arg "Helpers.Context.is_manager_key_revealed" - | Implicit mgr -> - Alpha_services.Contract.manager_key rpc_ctxt ctxt mgr >|=? fun res -> - res <> None - - let delegate ctxt contract = - Alpha_services.Contract.delegate rpc_ctxt ctxt contract - - let delegate_opt ctxt contract = - Alpha_services.Contract.delegate_opt rpc_ctxt ctxt contract - - let storage ctxt contract = - Alpha_services.Contract.storage rpc_ctxt ctxt contract - - let script ctxt contract = - Alpha_services.Contract.script rpc_ctxt ctxt contract - >>=? fun {code; storage = _} -> - match Data_encoding.force_decode code with - | Some v -> return v - | None -> invalid_arg "Cannot force lazy script" - - let script_hash ctxt contract = - script ctxt contract >>=? fun script -> - let bytes = Data_encoding.Binary.to_bytes_exn Script.expr_encoding script in - return @@ Script_expr_hash.hash_bytes [bytes] -end - -module Delegate = struct - type info = Delegate_services.info = { - full_balance : Tez.t; - current_frozen_deposits : Tez.t; - frozen_deposits : Tez.t; - staking_balance : Tez.t; - frozen_deposits_limit : Tez.t option; - delegated_contracts : Alpha_context.Contract.t list; - delegated_balance : Tez.t; - deactivated : bool; - grace_period : Cycle.t; - voting_info : Alpha_context.Vote.delegate_info; - active_consensus_key : Signature.Public_key_hash.t; - pending_consensus_keys : (Cycle.t * Signature.Public_key_hash.t) list; - } - - let info ctxt pkh = Delegate_services.info rpc_ctxt ctxt pkh - - let full_balance ctxt pkh = Delegate_services.full_balance rpc_ctxt ctxt pkh - - let current_frozen_deposits ctxt pkh = - Delegate_services.current_frozen_deposits rpc_ctxt ctxt pkh - - let initial_frozen_deposits ctxt pkh = - Delegate_services.frozen_deposits rpc_ctxt ctxt pkh - - let staking_balance ctxt pkh = - Delegate_services.staking_balance rpc_ctxt ctxt pkh - - let frozen_deposits_limit ctxt pkh = - Delegate_services.frozen_deposits_limit rpc_ctxt ctxt pkh - - let deactivated ctxt pkh = Delegate_services.deactivated rpc_ctxt ctxt pkh - - let voting_info ctxt d = Alpha_services.Delegate.voting_info rpc_ctxt ctxt d - - let consensus_key ctxt pkh = Delegate_services.consensus_key rpc_ctxt ctxt pkh - - let participation ctxt pkh = Delegate_services.participation rpc_ctxt ctxt pkh -end - -module Sc_rollup = struct - let inbox ctxt = - Environment.RPC_context.make_call0 - Plugin.RPC.Sc_rollup.S.inbox - rpc_ctxt - ctxt - () - () - - let commitment ctxt sc_rollup hash = - Environment.RPC_context.make_call2 - Plugin.RPC.Sc_rollup.S.commitment - rpc_ctxt - ctxt - sc_rollup - hash - () - () - - let genesis_info ctxt sc_rollup = - Environment.RPC_context.make_call1 - Plugin.RPC.Sc_rollup.S.genesis_info - rpc_ctxt - ctxt - sc_rollup - () - () - - let timeout ctxt sc_rollup staker1 staker2 = - Environment.RPC_context.make_call3 - Plugin.RPC.Sc_rollup.S.timeout - rpc_ctxt - ctxt - sc_rollup - staker1 - staker2 - () - () - - let ongoing_games_for_staker ctxt sc_rollup staker = - Environment.RPC_context.make_call2 - Plugin.RPC.Sc_rollup.S.ongoing_refutation_games - rpc_ctxt - ctxt - sc_rollup - staker - () - () -end - -type (_, _) tup = - | T1 : ('a, 'a) tup - | T2 : ('a, 'a * 'a) tup - | T3 : ('a, 'a * 'a * 'a) tup - | TList : int -> ('a, 'a list) tup - -let tup_hd : type a r. (a, r) tup -> r -> a = - fun tup elts -> - match (tup, elts) with - | T1, v -> v - | T2, (v, _) -> v - | T3, (v, _, _) -> v - | TList _, v :: _ -> v - | TList _, [] -> assert false - -let tup_n : type a r. (a, r) tup -> int = function - | T1 -> 1 - | T2 -> 2 - | T3 -> 3 - | TList n -> n - -let tup_get : type a r. (a, r) tup -> a list -> r = - fun tup list -> - match (tup, list) with - | T1, [v] -> v - | T2, [v1; v2] -> (v1, v2) - | T3, [v1; v2; v3] -> (v1, v2, v3) - | TList _, l -> l - | _ -> assert false - -let init_gen tup ?rng_state ?commitments ?bootstrap_balances - ?bootstrap_delegations ?bootstrap_consensus_keys ?consensus_threshold - ?min_proposal_quorum ?bootstrap_contracts ?level ?cost_per_byte - ?liquidity_baking_subsidy ?endorsing_reward_per_slot - ?baking_reward_bonus_per_slot ?baking_reward_fixed_portion ?origination_size - ?blocks_per_cycle ?cycles_per_voting_period ?sc_rollup_enable - ?sc_rollup_arith_pvm_enable ?dal_enable ?zk_rollup_enable - ?hard_gas_limit_per_block ?nonce_revelation_threshold () = - let n = tup_n tup in - Account.generate_accounts ?rng_state n >>?= fun accounts -> - let contracts = - List.map (fun a -> Alpha_context.Contract.Implicit Account.(a.pkh)) accounts - in - let bootstrap_accounts = - Account.make_bootstrap_accounts - ?bootstrap_balances - ?bootstrap_delegations - ?bootstrap_consensus_keys - accounts - in - Block.genesis - ?commitments - ?consensus_threshold - ?min_proposal_quorum - ?bootstrap_contracts - ?level - ?cost_per_byte - ?liquidity_baking_subsidy - ?endorsing_reward_per_slot - ?baking_reward_bonus_per_slot - ?baking_reward_fixed_portion - ?origination_size - ?blocks_per_cycle - ?cycles_per_voting_period - ?sc_rollup_enable - ?sc_rollup_arith_pvm_enable - ?dal_enable - ?zk_rollup_enable - ?hard_gas_limit_per_block - ?nonce_revelation_threshold - bootstrap_accounts - >|=? fun blk -> (blk, tup_get tup contracts) - -let init_n n = init_gen (TList n) - -let init1 = init_gen T1 - -let init2 = init_gen T2 - -let init3 = init_gen T3 - -let create_bootstrap_accounts n = - let open Result_syntax in - let* accounts = Account.generate_accounts n in - let contracts = - List.map (fun a -> Alpha_context.Contract.Implicit Account.(a.pkh)) accounts - in - let bootstrap_accounts = Account.make_bootstrap_accounts accounts in - return (bootstrap_accounts, contracts) - -let init_with_constants_gen tup constants = - let open Lwt_result_syntax in - let n = tup_n tup in - let*? bootstrap_accounts, contracts = create_bootstrap_accounts n in - let parameters = - Tezos_protocol_017_PtNairob_parameters.Default_parameters - .parameters_of_constants - ~bootstrap_accounts - constants - in - let* blk = Block.genesis_with_parameters parameters in - return (blk, tup_get tup contracts) - -let init_with_constants_n constants n = - init_with_constants_gen (TList n) constants - -let init_with_constants1 = init_with_constants_gen T1 - -let init_with_constants2 = init_with_constants_gen T2 - -let init_with_parameters_gen tup parameters = - let open Lwt_result_syntax in - let n = tup_n tup in - let*? bootstrap_accounts, contracts = create_bootstrap_accounts n in - let parameters = Parameters.{parameters with bootstrap_accounts} in - let* blk = Block.genesis_with_parameters parameters in - return (blk, tup_get tup contracts) - -let init_with_parameters_n params n = init_with_parameters_gen (TList n) params - -let init_with_parameters1 = init_with_parameters_gen T1 - -let init_with_parameters2 = init_with_parameters_gen T2 - -let default_raw_context () = - let open Tezos_protocol_017_PtNairob_parameters in - let initial_account = Account.new_account () in - let bootstrap_accounts = - Account.make_bootstrap_account - ~balance:(Tez.of_mutez_exn 100_000_000_000L) - initial_account - in - Block.prepare_initial_context_params () >>=? fun (constants, _, _) -> - let parameters = - Default_parameters.parameters_of_constants - ~bootstrap_accounts:[bootstrap_accounts] - ~commitments:[] - constants - in - let json = Default_parameters.json_of_parameters parameters in - let proto_params = - Data_encoding.Binary.to_bytes_exn Data_encoding.json json - in - let protocol_param_key = ["protocol_parameters"] in - Tezos_protocol_environment.Context.( - let empty = Tezos_protocol_environment.Memory_context.empty in - add empty ["version"] (Bytes.of_string "genesis") >>= fun ctxt -> - add ctxt protocol_param_key proto_params) - >>= fun context -> - let typecheck ctxt script_repr = return ((script_repr, None), ctxt) in - Init_storage.prepare_first_block - Chain_id.zero - context - ~level:0l - ~timestamp:(Time.Protocol.of_seconds 1643125688L) - ~predecessor:Block_hash.zero - ~typecheck - >>= fun e -> Lwt.return @@ Environment.wrap_tzresult e diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/context.mli b/src/proto_017_PtNairob/lib_protocol/test/helpers/context.mli deleted file mode 100644 index d798566b30b4cfe1adb629e8a266aeee8ebf36a7..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/context.mli +++ /dev/null @@ -1,366 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2022 Trili Tech *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Protocol -open Alpha_context -open Environment - -type t = B of Block.t | I of Incremental.t - -val branch : t -> Block_hash.t - -val pred_branch : t -> Block_hash.t - -val get_level : t -> Raw_level.t tzresult - -(** Given a context, returns the list of endorsers charactized by - the [level], the public key hash of the [delegate], its [consensus_key] - and its assigned [slots]. - see {! Plugin.RPC.Validator.t}. *) -val get_endorsers : t -> Plugin.RPC.Validators.t list tzresult Lwt.t - -(** Return the two first elements of the list returns by [get_endorsers]. *) -val get_first_different_endorsers : - t -> (Plugin.RPC.Validators.t * Plugin.RPC.Validators.t) tzresult Lwt.t - -(** Return the first element [delegate,slot] of the list returns by - [get_endorsers], where [delegate] is the [consensus key] when - is set. *) -val get_endorser : t -> (public_key_hash * Slot.t list) tzresult Lwt.t - -(** Given a [delegate], and a context [ctxt], if [delegate] is in - [get_endorsers ctxt] returns the [slots] of [delegate] otherwise - return [None]. *) -val get_endorser_slot : - t -> public_key_hash -> Slot.t list option tzresult Lwt.t - -(** Return the [n]th element of the list returns by [get_endorsers]. *) -val get_endorser_n : t -> int -> (public_key_hash * Slot.t list) tzresult Lwt.t - -val get_endorsing_power_for_delegate : - t -> ?levels:Raw_level.t list -> public_key_hash -> int tzresult Lwt.t - -val get_voting_power : - t -> public_key_hash -> int64 Environment.Error_monad.shell_tzresult Lwt.t - -val get_total_voting_power : - t -> int64 Environment.Error_monad.shell_tzresult Lwt.t - -val get_bakers : - ?filter:(Plugin.RPC.Baking_rights.t -> bool) -> - ?cycle:Cycle.t -> - t -> - public_key_hash list tzresult Lwt.t - -val get_baker : t -> round:Round.t -> public_key_hash tzresult Lwt.t - -val get_first_different_baker : - public_key_hash -> public_key_hash trace -> public_key_hash - -val get_first_different_bakers : - t -> (public_key_hash * public_key_hash) tzresult Lwt.t - -val get_seed_nonce_hash : t -> Nonce_hash.t tzresult Lwt.t - -(** Returns the seed of the cycle to which the block belongs to. *) -val get_seed : t -> Seed.seed tzresult Lwt.t - -val get_seed_computation : t -> Seed.seed_computation_status tzresult Lwt.t - -(** Returns all the constants of the protocol *) -val get_constants : t -> Constants.t tzresult Lwt.t - -(** The default constants used in the test framework. To be used with - [init_with_constants]. *) -val default_test_constants : Constants.Parametric.t - -val get_baking_reward_fixed_portion : t -> Tez.t tzresult Lwt.t - -val get_bonus_reward : t -> endorsing_power:int -> Tez.t tzresult Lwt.t - -val get_endorsing_reward : - t -> expected_endorsing_power:int -> Tez.t tzresult Lwt.t - -val get_liquidity_baking_subsidy : t -> Tez.t tzresult Lwt.t - -val get_liquidity_baking_cpmm_address : t -> Contract_hash.t tzresult Lwt.t - -module Vote : sig - val get_ballots : t -> Vote.ballots tzresult Lwt.t - - val get_ballot_list : - t -> (Signature.Public_key_hash.t * Vote.ballot) list tzresult Lwt.t - - val get_current_period : t -> Voting_period.info tzresult Lwt.t - - val get_current_quorum : t -> int32 tzresult Lwt.t - - val get_participation_ema : Block.t -> int32 tzresult Lwt.t - - val get_listings : - t -> (Signature.Public_key_hash.t * int64) list tzresult Lwt.t - - val get_proposals : t -> int64 Protocol_hash.Map.t tzresult Lwt.t - - val get_current_proposal : t -> Protocol_hash.t option tzresult Lwt.t - - val get_protocol : Block.t -> Protocol_hash.t Lwt.t - - val set_participation_ema : Block.t -> int32 -> Block.t Lwt.t - - type delegate_info = Alpha_context.Vote.delegate_info = { - voting_power : Int64.t option; - current_ballot : Alpha_context.Vote.ballot option; - current_proposals : Protocol_hash.t list; - remaining_proposals : int; - } - - (** See {!Vote_storage.get_delegate_proposal_count}. - - Note that unlike most functions in the current module, this one - does not call an RPC. *) - val get_delegate_proposal_count : t -> public_key_hash -> int tzresult Lwt.t -end - -module Contract : sig - val pp : Format.formatter -> Contract.t -> unit - - val equal : Contract.t -> Contract.t -> bool - - val pkh : Contract.t -> public_key_hash - - (** Returns the balance of a contract, by default the main balance. - If the contract is implicit the frozen balances are available too: - deposit, fees or rewards. *) - val balance : t -> Contract.t -> Tez.t tzresult Lwt.t - - val frozen_bonds : t -> Contract.t -> Tez.t tzresult Lwt.t - - val balance_and_frozen_bonds : t -> Contract.t -> Tez.t tzresult Lwt.t - - val counter : t -> Contract.t -> Manager_counter.t tzresult Lwt.t - - val manager : t -> Contract.t -> Account.t tzresult Lwt.t - - val is_manager_key_revealed : t -> Contract.t -> bool tzresult Lwt.t - - val delegate : t -> Contract.t -> public_key_hash tzresult Lwt.t - - val delegate_opt : t -> Contract.t -> public_key_hash option tzresult Lwt.t - - val storage : t -> Contract_hash.t -> Script.expr tzresult Lwt.t - - val script : t -> Contract_hash.t -> Script.expr tzresult Lwt.t - - val script_hash : t -> Contract_hash.t -> Script_expr_hash.t tzresult Lwt.t -end - -module Delegate : sig - type info = Delegate_services.info = { - full_balance : Tez.t; - current_frozen_deposits : Tez.t; - frozen_deposits : Tez.t; - staking_balance : Tez.t; - frozen_deposits_limit : Tez.t option; - delegated_contracts : Alpha_context.Contract.t list; - delegated_balance : Tez.t; - deactivated : bool; - grace_period : Cycle.t; - voting_info : Vote.delegate_info; - active_consensus_key : Signature.Public_key_hash.t; - pending_consensus_keys : (Cycle.t * Signature.Public_key_hash.t) list; - } - - val info : t -> public_key_hash -> Delegate_services.info tzresult Lwt.t - - val full_balance : t -> public_key_hash -> Tez.t tzresult Lwt.t - - val current_frozen_deposits : t -> public_key_hash -> Tez.t tzresult Lwt.t - - (** calls the RPC [frozen_deposits]: we're using a different name to - be more easily distinguishable from [current_frozen_deposits] *) - val initial_frozen_deposits : t -> public_key_hash -> Tez.t tzresult Lwt.t - - val staking_balance : t -> public_key_hash -> Tez.t tzresult Lwt.t - - val frozen_deposits_limit : - t -> public_key_hash -> Tez.t option tzresult Lwt.t - - val deactivated : t -> public_key_hash -> bool tzresult Lwt.t - - val voting_info : t -> public_key_hash -> Vote.delegate_info tzresult Lwt.t - - val consensus_key : - t -> - public_key_hash -> - (public_key_hash * (Cycle.t * public_key_hash) list) tzresult Lwt.t - - val participation : - t -> public_key_hash -> Delegate.participation_info tzresult Lwt.t -end - -module Sc_rollup : sig - val inbox : t -> Sc_rollup.Inbox.t tzresult Lwt.t - - val commitment : - t -> - Sc_rollup.t -> - Sc_rollup.Commitment.Hash.t -> - Sc_rollup.Commitment.t tzresult Lwt.t - - val genesis_info : - t -> Sc_rollup.t -> Sc_rollup.Commitment.genesis_info tzresult Lwt.t - - val timeout : - t -> - Sc_rollup.t -> - Signature.Public_key_hash.t -> - Signature.Public_key_hash.t -> - Sc_rollup.Game.timeout option tzresult Lwt.t - - val ongoing_games_for_staker : - t -> - Sc_rollup.t -> - Signature.public_key_hash -> - (Sc_rollup.Game.t * Signature.public_key_hash * Signature.public_key_hash) - list - tzresult - Lwt.t -end - -type (_, _) tup = - | T1 : ('a, 'a) tup - | T2 : ('a, 'a * 'a) tup - | T3 : ('a, 'a * 'a * 'a) tup - | TList : int -> ('a, 'a list) tup - -val tup_hd : ('a, 'elts) tup -> 'elts -> 'a - -type 'accounts init := - ?rng_state:Random.State.t -> - ?commitments:Commitment.t list -> - ?bootstrap_balances:int64 list -> - ?bootstrap_delegations:Signature.Public_key_hash.t option list -> - ?bootstrap_consensus_keys:Signature.Public_key.t option list -> - ?consensus_threshold:int -> - ?min_proposal_quorum:int32 -> - ?bootstrap_contracts:Parameters.bootstrap_contract list -> - ?level:int32 -> - ?cost_per_byte:Tez.t -> - ?liquidity_baking_subsidy:Tez.t -> - ?endorsing_reward_per_slot:Tez.t -> - ?baking_reward_bonus_per_slot:Tez.t -> - ?baking_reward_fixed_portion:Tez.t -> - ?origination_size:int -> - ?blocks_per_cycle:int32 -> - ?cycles_per_voting_period:int32 -> - ?sc_rollup_enable:bool -> - ?sc_rollup_arith_pvm_enable:bool -> - ?dal_enable:bool -> - ?zk_rollup_enable:bool -> - ?hard_gas_limit_per_block:Gas.Arith.integral -> - ?nonce_revelation_threshold:int32 -> - unit -> - (Block.t * 'accounts) tzresult Lwt.t - -(** Returns an initial block and the implicit contracts corresponding - to its bootstrap accounts. The number of bootstrap accounts, and - the structure of the returned contracts, are specified by the [tup] - argument. *) -val init_gen : (Alpha_context.Contract.t, 'accounts) tup -> 'accounts init - -(** [init_n n] : returns an initial block with [n] initialized accounts - and the associated implicit contracts *) -val init_n : int -> Alpha_context.Contract.t list init - -(** [init1] : returns an initial block with 1 initialized bootstrap account - and the associated implicit contract *) -val init1 : Alpha_context.Contract.t init - -(** [init2] : returns an initial block with 2 initialized bootstrap accounts - and the associated implicit contracts *) -val init2 : (Alpha_context.Contract.t * Alpha_context.Contract.t) init - -(** [init3] : returns an initial block with 3 initialized bootstrap accounts - and the associated implicit contracts *) -val init3 : - (Alpha_context.Contract.t - * Alpha_context.Contract.t - * Alpha_context.Contract.t) - init - -val init_with_constants_gen : - (Alpha_context.Contract.t, 'contracts) tup -> - Constants.Parametric.t -> - (Block.t * 'contracts) tzresult Lwt.t - -val init_with_constants_n : - Constants.Parametric.t -> - int -> - (Block.t * Alpha_context.Contract.t list) tzresult Lwt.t - -val init_with_constants1 : - Constants.Parametric.t -> (Block.t * Alpha_context.Contract.t) tzresult Lwt.t - -val init_with_constants2 : - Constants.Parametric.t -> - (Block.t * (Alpha_context.Contract.t * Alpha_context.Contract.t)) tzresult - Lwt.t - -(** [init_with_parameters_gen tup params] returns an initial block parametrised - with [params] and the implicit contracts corresponding to its bootstrap - accounts. The number of bootstrap accounts, and the structure of the - returned contracts, are specified by the [tup] argument. *) -val init_with_parameters_gen : - (Alpha_context.Contract.t, 'contracts) tup -> - Parameters.t -> - (Block.t * 'contracts) tzresult Lwt.t - -(** [init_with_parameters_n params n] returns an initial block parametrized - with [params] with [n] initialized accounts and the associated implicit - contracts *) -val init_with_parameters_n : - Parameters.t -> - int -> - (Block.t * Alpha_context.Contract.t list) tzresult Lwt.t - -(** [init_with_parameters1 params] returns an initial block parametrized with - [params] with one initialized account and the associated implicit - contract. *) -val init_with_parameters1 : - Parameters.t -> (Block.t * Alpha_context.Contract.t) tzresult Lwt.t - -(** [init_with_parameters2 params] returns an initial block parametrized with - [params] with two initialized accounts and the associated implicit - contracts *) -val init_with_parameters2 : - Parameters.t -> - (Block.t * (Alpha_context.Contract.t * Alpha_context.Contract.t)) tzresult - Lwt.t - -(** [default_raw_context] returns a [Raw_context.t] for use in tests - below [Alpha_context] *) -val default_raw_context : unit -> Raw_context.t tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/contract_helpers.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/contract_helpers.ml deleted file mode 100644 index 3c3a8e44880f915d52afadf75f30b9b7185ae38b..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/contract_helpers.ml +++ /dev/null @@ -1,145 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020-2021 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context -open Error_monad_operators - -(** Initializes 2 addresses to do only operations plus one that will be - used to bake. *) -let init () = - Context.init3 ~consensus_threshold:0 () >|=? fun (b, (src0, src1, src2)) -> - let baker = - match src0 with Implicit v -> v | Originated _ -> assert false - in - (b, baker, src1, src2) - -(** Return contents of a given file as string. *) -let read_file f = - In_channel.with_open_text f (fun ic -> - really_input_string ic (in_channel_length ic)) - -(** Loads a script from file. *) -let load_script ~storage file = - let contract_string = read_file file in - let code = Expr.toplevel_from_string contract_string in - let storage = Expr.from_string storage in - Alpha_context.Script.{code = lazy_expr code; storage = lazy_expr storage} - -(** Returns a block in which the contract is originated. *) -let originate_contract_hash file storage src b baker = - let script = load_script ~storage file in - Op.contract_origination_hash (B b) src ~fee:(Test_tez.of_int 10) ~script - >>=? fun (operation, dst) -> - Incremental.begin_construction ~policy:Block.(By_account baker) b - >>=? fun incr -> - Incremental.add_operation incr operation >>=? fun incr -> - Incremental.finalize_block incr >|=? fun b -> (dst, b) - -let originate_contract file storage src b baker = - originate_contract_hash file storage src b baker >|=? fun (dst, b) -> - (Contract.Originated dst, b) - -let fake_KT1 = - Contract_hash.of_b58check_exn "KT1FAKEFAKEFAKEFAKEFAKEFAKEFAKGGSE2x" - -let default_self = fake_KT1 - -let default_payer = Signature.Public_key_hash.zero - -let default_source = Contract.Implicit default_payer - -let default_step_constants = - Script_interpreter. - { - source = Contract default_source; - payer = default_payer; - self = default_self; - amount = Tez.zero; - balance = Tez.zero; - chain_id = Chain_id.zero; - now = Script_timestamp.of_zint Z.zero; - level = Script_int.zero_n; - } - -(** Helper function that parses and typechecks a script, its initial storage and - parameters from strings. It then executes the typed script with the storage - and parameters and returns the result. - - The [step_constants] argument passes in some data which remains constant - throughout script's execution, hence the name. This includes addresses of - the sender and payer, the address of the smart contract, the amount of Tez - transferred to it and so on. - - An [internal] operation is an operation generated by smart contract's execution - rather than by an implicit account. *) -let run_script ctx ?logger ?(step_constants = default_step_constants) - ?(internal = false) contract ?(entrypoint = Entrypoint.default) ~storage - ~parameter () = - let contract_expr = Expr.from_string contract in - let storage_expr = Expr.from_string storage in - let parameter_expr = Expr.from_string parameter in - let script = - Script.{code = lazy_expr contract_expr; storage = lazy_expr storage_expr} - in - Script_interpreter.execute - ctx - Readable - step_constants - ?logger - ~script - ~cached_script:None - ~entrypoint - ~parameter:parameter_expr - ~internal - >>=?? fun res -> return res - -let originate_contract_from_string_hash ~script ~storage ~source_contract ~baker - block = - let code = Expr.toplevel_from_string script in - let storage = Expr.from_string storage in - let script = - Alpha_context.Script.{code = lazy_expr code; storage = lazy_expr storage} - in - Op.contract_origination_hash - (B block) - source_contract - ~fee:(Test_tez.of_int 10) - ~script - >>=? fun (operation, dst) -> - Incremental.begin_construction ~policy:Block.(By_account baker) block - >>=? fun incr -> - Incremental.add_operation incr operation >>=? fun incr -> - Incremental.finalize_block incr >|=? fun b -> (dst, script, b) - -let originate_contract_from_string ~script ~storage ~source_contract ~baker - block = - originate_contract_from_string_hash - ~script - ~storage - ~source_contract - ~baker - block - >|=? fun (dst, script, b) -> (Contract.Originated dst, script, b) diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/cpmm_logic.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/cpmm_logic.ml deleted file mode 100644 index a1d4d8027c5808afbd02a62372fede6e8adc33f9..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/cpmm_logic.ml +++ /dev/null @@ -1,102 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context - -(** This is a simulation of the CPMM contract, as implemented in mligo - in [src/proto_alpha/lib_protocol/contracts/cpmm.mligo]. The - interested reader should look for comments in this file to gain a - better understanding of the contract logic. *) -module Simulate_raw = struct - let mutez_to_natural t = Z.of_int64 (Tez.to_mutez t) - - let natural_to_mutez n = Tez.of_mutez_exn (Z.to_int64 n) - - let addLiquidity ~tokenPool ~xtzPool ~lqtTotal ~amount = - let xtzPool = mutez_to_natural xtzPool in - let nat_amount = mutez_to_natural amount in - let lqt_minted = Z.(nat_amount * lqtTotal / xtzPool) in - let tokens_deposited = Z.(cdiv (nat_amount * tokenPool) xtzPool) in - (lqt_minted, tokens_deposited) - - let removeLiquidity ~tokenPool ~xtzPool ~lqtTotal ~lqtBurned = - let xtz_withdrawn = - natural_to_mutez Z.(lqtBurned * mutez_to_natural xtzPool / lqtTotal) - in - let tokens_withdrawn = Z.(lqtBurned * tokenPool / lqtTotal) in - (xtz_withdrawn, tokens_withdrawn) - - let tokenToXtz ~tokenPool ~xtzPool ~tokensSold = - let fee = Z.of_int 999 in - let xtz_bought_nat = - Z.( - tokensSold * fee * mutez_to_natural xtzPool - / ((tokenPool * of_int 1000) + (tokensSold * fee))) - in - let bought = Z.(xtz_bought_nat * of_int 999 / of_int 1000) in - (natural_to_mutez bought, xtz_bought_nat) - - let xtzToToken ~tokenPool ~xtzPool ~amount = - let fee = Z.of_int 999 in - let xtzPool = mutez_to_natural xtzPool in - let nat_amount = mutez_to_natural amount in - let amount_net_burn = Z.(nat_amount * Z.of_int 999 / Z.of_int 1000) in - let tokens_bought = - Z.( - amount_net_burn * fee * tokenPool - / ((xtzPool * Z.of_int 1000) + (amount_net_burn * fee))) - in - (tokens_bought, amount_net_burn) - - let tokenToToken ~tokenPool ~xtzPool ~tokensSold = - let fee = Z.of_int 999 in - let xtz_bought_nat = - Z.( - tokensSold * fee * mutez_to_natural xtzPool - / ((tokenPool * of_int 1000) + (tokensSold * fee))) - in - let xtz_bought_net_burn = Z.(xtz_bought_nat * of_int 999 / of_int 1000) in - (natural_to_mutez xtz_bought_net_burn, xtz_bought_nat) -end - -module Simulate = struct - open Cpmm_repr.Storage - - let addLiquidity {tokenPool; xtzPool; lqtTotal; _} amount = - Simulate_raw.addLiquidity ~xtzPool ~tokenPool ~lqtTotal ~amount - - let removeLiquidity {tokenPool; xtzPool; lqtTotal; _} lqtBurned = - Simulate_raw.removeLiquidity ~tokenPool ~xtzPool ~lqtTotal ~lqtBurned - - let tokenToXtz {tokenPool; xtzPool; _} tokensSold = - Simulate_raw.tokenToXtz ~tokenPool ~xtzPool ~tokensSold - - let xtzToToken {tokenPool; xtzPool; _} amount = - Simulate_raw.xtzToToken ~tokenPool ~xtzPool ~amount - - let tokenToToken {tokenPool; xtzPool; _} tokensSold = - Simulate_raw.tokenToToken ~tokenPool ~xtzPool ~tokensSold -end diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/cpmm_repr.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/cpmm_repr.ml deleted file mode 100644 index 41c1c8c0543b939a4ea385cb5eee58d4e2557a6c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/cpmm_repr.ml +++ /dev/null @@ -1,384 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context -open Expr_common - -(* // ============================================================================= - * // Storage - * // ============================================================================= *) - -module Storage = struct - type t = { - tokenPool : Z.t; - xtzPool : Tez.t; - lqtTotal : Z.t; - tokenAddress : Contract_hash.t; - lqtAddress : Contract_hash.t; - } - - let zero : t = - { - tokenPool = Z.zero; - xtzPool = Tez.zero; - lqtTotal = Z.zero; - tokenAddress = Contract_hash.zero; - lqtAddress = Contract_hash.zero; - } - - let to_string {tokenPool; xtzPool; lqtTotal; tokenAddress; lqtAddress} = - Format.asprintf - "{tokenPool : %a; xtzPool : %s; lqtTotal : %a; tokenAddress : %s; \ - lqtAddress : %s;}" - Z.pp_print - tokenPool - (Int64.to_string @@ Tez.to_mutez xtzPool) - Z.pp_print - lqtTotal - (Contract_hash.to_b58check tokenAddress) - (Contract_hash.to_b58check lqtAddress) - - let pp fmt s = Format.fprintf fmt "%s" (to_string s) - - let eq s s' = s = s' - - let to_expr : - loc:'a -> - t -> - ('a, Michelson_v1_primitives.prim) Tezos_micheline.Micheline.node = - fun ~loc {tokenPool; xtzPool; lqtTotal; tokenAddress; lqtAddress} -> - comb - ~loc - [ - int ~loc tokenPool; - mutez ~loc xtzPool; - int ~loc lqtTotal; - address_string ~loc (Contract.Originated tokenAddress); - address_string ~loc (Contract.Originated lqtAddress); - ] - - let to_michelson_string e = - let e = to_expr ~loc:0 e in - Format.asprintf - "%a" - Michelson_v1_printer.print_expr - (Micheline.strip_locations e) - - type exn += Invalid_storage_expr of string - - (** Note: parses a storage unparsed in readable mode (as - e.g. returned by [Alpha_services.Contract.storage]), so that - contracts are represented by strings. *) - let of_expr_exn : - ('a, Michelson_v1_primitives.prim) Tezos_micheline.Micheline.node -> t = - function - | Tezos_micheline.Micheline.Prim - ( _, - Script.D_Pair, - [ - Tezos_micheline.Micheline.Int (_, tokenPool); - Tezos_micheline.Micheline.Int (_, xtzPool); - Tezos_micheline.Micheline.Int (_, lqtTotal); - Tezos_micheline.Micheline.String (_, tokenAddress); - Tezos_micheline.Micheline.String (_, lqtAddress); - ], - [] ) -> - let xtzPool = Tez.of_mutez_exn (Z.to_int64 xtzPool) in - let tokenAddress = originated_of_string_exn tokenAddress in - let lqtAddress = originated_of_string_exn lqtAddress in - {tokenPool; xtzPool; lqtTotal; tokenAddress; lqtAddress} - | e -> - let canonical = Micheline.strip_locations e in - let msg = - Format.asprintf - "Not a valid CPMM storage: %s /// %a" - (try - Michelson_v1_printer.micheline_string_of_expression - ~zero_loc:true - canonical - with Z.Overflow -> - "Cannot represent as micheline due to overflowing Z -> int") - Michelson_v1_printer.print_expr - canonical - in - raise (Invalid_storage_expr msg) - - let get (ctxt : Context.t) ~(contract : Contract.t) : t tzresult Lwt.t = - match contract with - | Implicit _ -> - invalid_arg "Cpmm_repr.Storage.get called on implicit account" - | Originated c -> - Context.Contract.storage ctxt c >|=? Micheline.root >|=? of_expr_exn - - let of_tuple (tokenPool, xtzPool, lqtTotal, tokenAddress, lqtAddress) = - {tokenPool; xtzPool; lqtTotal; tokenAddress; lqtAddress} - - let to_tuple {tokenPool; xtzPool; lqtTotal; tokenAddress; lqtAddress} = - (tokenPool, xtzPool, lqtTotal, tokenAddress, lqtAddress) - - let valid {tokenPool; xtzPool; lqtTotal; _} = - tokenPool > Z.zero && lqtTotal > Z.zero && Tez.(xtzPool > Tez.zero) -end - -module Parameter = struct - (* // ============================================================================= - * // Entrypoints - * // ============================================================================= *) - - type add_liquidity = { - owner : Contract.t; - minLqtMinted : Z.t; - maxTokensDeposited : Z.t; - deadline : Script_timestamp.t; - } - - type remove_liquidity = { - to_ : Contract.t; - (* recipient of the liquidity redemption *) - lqtBurned : Z.t; - (* amount of lqt owned by sender to burn *) - minXtzWithdrawn : Tez.t; - (* minimum amount of Tez.t to withdraw *) - minTokensWithdrawn : Z.t; - (* minimum amount of tokens to withdraw *) - deadline : Script_timestamp.t; - (* the time before which the request must be completed *) - } - - type token_to_token = { - outputDexterContract : Contract.t; - minTokensBought : Z.t; - to_ : Contract.t; - tokensSold : Z.t; - deadline : Script_timestamp.t; - } - - type token_to_xtz = { - to_ : Contract.t; - tokensSold : Z.t; - minXtzBought : Tez.t; - deadline : Script_timestamp.t; - } - - type xtz_to_token = { - to_ : Contract.t; - minTokensBought : Z.t; - deadline : Script_timestamp.t; - } - - type t = - | AddLiquidity of add_liquidity - | Default of unit - | RemoveLiquidity of remove_liquidity - | TokenToToken of token_to_token - | TokenToXtz of token_to_xtz - | XtzToToken of xtz_to_token - - let addLiquidity p = AddLiquidity p - - let default p = Default p - - let removeLiquidity p = RemoveLiquidity p - - let tokenToToken p = TokenToToken p - - let tokenToXtz p = TokenToXtz p - - let xtzToToken p = XtzToToken p - - let add_liquidity_to_string : add_liquidity -> string = - fun {owner; minLqtMinted; maxTokensDeposited; deadline} -> - Format.asprintf - "{owner : %s; minLqtMinted : %a; maxTokensDeposited : %a; deadline : %s }" - (Contract.to_b58check owner) - Z.pp_print - minLqtMinted - Z.pp_print - maxTokensDeposited - (Script_timestamp.to_string deadline) - - let remove_liquidity_to_string : remove_liquidity -> string = - fun {to_; lqtBurned; minXtzWithdrawn; minTokensWithdrawn; deadline} -> - Format.asprintf - "{owner : %s; lqtBurned : %a; minXtzWithdrawn : %s; minTokensWithdrawn : \ - %a; deadline : %s }" - (Contract.to_b58check to_) - Z.pp_print - lqtBurned - (Int64.to_string @@ Tez.to_mutez minXtzWithdrawn) - Z.pp_print - minTokensWithdrawn - (Script_timestamp.to_string deadline) - - let token_to_token_to_string : token_to_token -> string = - fun {outputDexterContract; minTokensBought; to_; tokensSold; deadline} -> - Format.asprintf - "{outputDexterContract : %s; minTokensBought : %a; to_ : %s; tokensSold \ - : %a; deadline : %s }" - (Contract.to_b58check outputDexterContract) - Z.pp_print - minTokensBought - (Contract.to_b58check to_) - Z.pp_print - tokensSold - (Script_timestamp.to_string deadline) - - let token_to_xtz_to_string : token_to_xtz -> string = - fun {to_; tokensSold; minXtzBought; deadline} -> - Format.asprintf - "{to_ : %s; tokensSold : %a; minXtzBought : %s; deadline : %s }" - (Contract.to_b58check to_) - Z.pp_print - tokensSold - (Int64.to_string @@ Tez.to_mutez minXtzBought) - (Script_timestamp.to_string deadline) - - let xtz_to_token_to_string : xtz_to_token -> string = - fun {to_; minTokensBought; deadline} -> - Format.asprintf - "{to_ : %s; minTokensBought : %a; deadline : %s }" - (Contract.to_b58check to_) - Z.pp_print - minTokensBought - (Script_timestamp.to_string deadline) - - let to_string : t -> string = function - | AddLiquidity p -> - Format.asprintf "AddLiquidity %s" (add_liquidity_to_string p) - | Default () -> "Default ()" - | RemoveLiquidity p -> - Format.asprintf "RemoveLiquidity %s" (remove_liquidity_to_string p) - | TokenToToken p -> - Format.asprintf "TokenToToken (%s)" (token_to_token_to_string p) - | TokenToXtz p -> - Format.asprintf "TokenToXtz (%s)" (token_to_xtz_to_string p) - | XtzToToken p -> - Format.asprintf "XtzToToken (%s)" (xtz_to_token_to_string p) - - let entrypoint_of_parameter : t -> Entrypoint.t = function - | AddLiquidity _ -> Entrypoint.of_string_strict_exn "addLiquidity" - | Default _ -> Entrypoint.default - | RemoveLiquidity _ -> Entrypoint.of_string_strict_exn "removeLiquidity" - | TokenToToken _ -> Entrypoint.of_string_strict_exn "tokenToToken" - | TokenToXtz _ -> Entrypoint.of_string_strict_exn "tokenToXtz" - | XtzToToken _ -> Entrypoint.of_string_strict_exn "xtzToToken" - - let pp fmt s = Format.fprintf fmt "%s" (to_string s) - - let eq s s' = s = s' - - let to_expr_rooted : - loc:'a -> - t -> - ('a, Michelson_v1_primitives.prim) Tezos_micheline.Micheline.node = - fun ~loc -> function - | AddLiquidity {owner; minLqtMinted; maxTokensDeposited; deadline} -> - comb - ~loc - [ - address_string ~loc owner; - int ~loc minLqtMinted; - int ~loc maxTokensDeposited; - timestamp ~loc deadline; - ] - | Default () -> unit ~loc () - | RemoveLiquidity - {to_; lqtBurned; minXtzWithdrawn; minTokensWithdrawn; deadline} -> - comb - ~loc - [ - address_string ~loc to_; - int ~loc lqtBurned; - mutez ~loc minXtzWithdrawn; - int ~loc minTokensWithdrawn; - timestamp ~loc deadline; - ] - | TokenToToken - {outputDexterContract; minTokensBought; to_; tokensSold; deadline} -> - comb - ~loc - [ - address_string ~loc outputDexterContract; - int ~loc minTokensBought; - address_string ~loc to_; - int ~loc tokensSold; - timestamp ~loc deadline; - ] - | TokenToXtz {to_; tokensSold; minXtzBought; deadline} -> - comb - ~loc - [ - address_string ~loc to_; - int ~loc tokensSold; - mutez ~loc minXtzBought; - timestamp ~loc deadline; - ] - | XtzToToken {to_; minTokensBought; deadline} -> - comb - ~loc - [ - address_string ~loc to_; - int ~loc minTokensBought; - timestamp ~loc deadline; - ] - - let to_expr : - loc:'a -> - t -> - ('a, Michelson_v1_primitives.prim) Tezos_micheline.Micheline.node = - fun ~loc p -> - let rooted = to_expr_rooted ~loc p in - match p with - | AddLiquidity _ -> left ~loc @@ left ~loc @@ left ~loc rooted - | Default () -> left ~loc @@ left ~loc @@ right ~loc rooted - | RemoveLiquidity _ -> left ~loc @@ right ~loc @@ left ~loc rooted - | TokenToToken _ -> left ~loc @@ right ~loc @@ right ~loc rooted - | TokenToXtz _ -> right ~loc @@ left ~loc rooted - | XtzToToken _ -> right ~loc @@ right ~loc rooted - - let to_michelson_string e = - let e = to_expr ~loc:0 e in - Format.asprintf - "%a" - Michelson_v1_printer.print_expr - (Micheline.strip_locations e) -end - -let transaction (ctxt : Context.t) ~(contract : Contract.t) ~(src : Contract.t) - ?(amount = Tez.zero) (parameters : Parameter.t) = - let entrypoint = Parameter.entrypoint_of_parameter parameters in - let rooted_param_lazy = - parameters - |> Parameter.to_expr_rooted ~loc:0 - |> Micheline.strip_locations |> Alpha_context.Script.lazy_expr - in - Op.transaction - ctxt - src - contract - amount - ~entrypoint - ~parameters:rooted_param_lazy diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/dal_helpers.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/dal_helpers.ml deleted file mode 100644 index bfda6f74de2a20f8009c7a929d4dd49581bcf6e9..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/dal_helpers.ml +++ /dev/null @@ -1,267 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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 -module S = Dal_slot_repr -module Slot_index = Dal_slot_index_repr -module P = S.Page -module Hist = S.History -module Ihist = Hist.Internal_for_tests - -(** Error used below for functions that don't return their failures in the monad - error. *) -type error += Test_failure of string - -let () = - let open Data_encoding in - register_error_kind - `Permanent - ~id:(Protocol.name ^ "_test_failure") - ~title:"Test failure" - ~description:"Test failure." - ~pp:(fun ppf e -> Format.fprintf ppf "Test failure: %s" e) - (obj1 (req "error" string)) - (function Test_failure e -> Some e | _ -> None) - (fun e -> Test_failure e) - -let mk_cryptobox dal_params = - let open Result_syntax in - let () = Cryptobox.Internal_for_tests.init_prover_dal () in - match Cryptobox.make dal_params with - | Ok dal -> return dal - | Error (`Fail s) -> fail [Test_failure s] - -let derive_dal_parameters (reference : Cryptobox.parameters) ~redundancy_factor - ~constants_divider = - { - S.redundancy_factor; - page_size = reference.page_size / constants_divider; - slot_size = reference.slot_size / constants_divider; - number_of_shards = reference.number_of_shards / constants_divider; - } - -module Make (Parameters : sig - val dal_parameters : Alpha_context.Constants.Parametric.dal - - val cryptobox : Cryptobox.t Lazy.t -end) = -struct - (* Some global constants. *) - - let params = Parameters.dal_parameters.cryptobox_parameters - - let cryptobox = Parameters.cryptobox - - let genesis_history = Hist.genesis - - let genesis_history_cache = Hist.History_cache.empty ~capacity:3000L - - let level_one = Raw_level_repr.(succ root) - - let level_ten = Raw_level_repr.(of_int32_exn 10l) - - (* Helper functions. *) - - let get_history cache h = Hist.History_cache.find h cache |> Lwt.return - - let dal_mk_polynomial_from_slot slot_data = - let open Result_syntax in - let cryptobox = Lazy.force cryptobox in - match Cryptobox.polynomial_from_slot cryptobox slot_data with - | Ok p -> return p - | Error (`Slot_wrong_size s) -> - fail - [ - Test_failure - (Format.sprintf "polynomial_from_slot: Slot_wrong_size (%s)" s); - ] - - let dal_commit cryptobox polynomial = - let open Result_syntax in - match Cryptobox.commit cryptobox polynomial with - | Ok cm -> return cm - | Error - ((`Invalid_degree_strictly_less_than_expected _ | `Prover_SRS_not_loaded) - as commit_error) -> - fail [Test_failure (Cryptobox.string_of_commit_error commit_error)] - - let dal_mk_prove_page polynomial page_id = - let open Result_syntax in - let cryptobox = Lazy.force cryptobox in - match Cryptobox.prove_page cryptobox polynomial page_id.P.page_index with - | Ok p -> return p - | Error `Page_index_out_of_range -> - fail [Test_failure "compute_proof_segment: Page_index_out_of_range"] - | Error - ((`Invalid_degree_strictly_less_than_expected _ | `Prover_SRS_not_loaded) - as commit_error) -> - fail [Test_failure (Cryptobox.string_of_commit_error commit_error)] - - let mk_slot ?(level = level_one) ?(index = Slot_index.zero) - ?(fill_function = fun _i -> 'x') () = - let open Result_syntax in - let slot_data = Bytes.init params.slot_size fill_function in - let* polynomial = dal_mk_polynomial_from_slot slot_data in - let cryptobox = Lazy.force cryptobox in - let* commitment = dal_commit cryptobox polynomial in - return - ( slot_data, - polynomial, - S.Header.{id = {published_level = level; index}; commitment} ) - - let mk_page_id published_level slot_index page_index = - P.{slot_id = {published_level; index = slot_index}; page_index} - - let no_data = Some (fun ~default_char:_ _ -> None) - - let mk_page_info ?(default_char = 'x') ?level ?(page_index = P.Index.zero) - ?(custom_data = None) (slot : S.Header.t) polynomial = - let open Result_syntax in - let level = - match level with None -> slot.id.published_level | Some level -> level - in - let page_id = mk_page_id level slot.id.index page_index in - let* page_proof = dal_mk_prove_page polynomial page_id in - match custom_data with - | None -> - let page_data = Bytes.make params.page_size default_char in - return (Some (page_data, page_proof), page_id) - | Some mk_data -> ( - match mk_data ~default_char params.page_size with - | None -> return (None, page_id) - | Some page_data -> return (Some (page_data, page_proof), page_id)) - - let succ_slot_index index = - Option.value_f - Slot_index.(of_int_opt (to_int index + 1)) - ~default:(fun () -> Slot_index.zero) - - let next_char c = Char.(chr ((code c + 1) mod 255)) - - (** Auxiliary test function used by both unit and PBT tests: This function - produces a proof from the given information and verifies the produced result, - if any. The result of each step is checked with [check_produce_result] and - [check_verify_result], respectively. *) - let produce_and_verify_proof ~check_produce ?check_verify ~get_history - skip_list ~page_info ~page_id = - let open Lwt_result_syntax in - let*! res = - Hist.produce_proof params ~page_info page_id ~get_history skip_list - |> Lwt.map Environment.wrap_tzresult - in - let* () = check_produce res page_info in - match check_verify with - | None -> return_unit - | Some check_verify -> - let*? proof, _input_opt = res in - let res = - Hist.verify_proof params page_id skip_list proof - |> Environment.wrap_tzresult - in - check_verify res page_info - - (* Some check functions. *) - - (** Check that/if the returned content is the expected one. *) - let assert_content_is ~__LOC__ ~expected returned = - Assert.equal - ~loc:__LOC__ - (Option.equal Bytes.equal) - "Returned %s doesn't match the expected one" - (fun fmt opt -> - match opt with - | None -> Format.fprintf fmt "" - | Some bs -> Format.fprintf fmt "" (Bytes.to_string bs)) - returned - expected - - let expected_data page_info proof_status = - match (page_info, proof_status) with - | Some (d, _p), `Confirmed -> Some d - | None, `Confirmed -> assert false - | _ -> None - - let proof_status_to_string = function - | `Confirmed -> "CONFIRMED" - | `Unconfirmed -> "UNCONFIRMED" - - let successful_check_produce_result ~__LOC__ proof_status res page_info = - let open Lwt_result_syntax in - let* proof, input_opt = Assert.get_ok ~__LOC__ res in - let* () = - if Hist.Internal_for_tests.proof_statement_is proof proof_status then - return_unit - else - failwith - "Expected to have a %s page proof. Got %a@." - (proof_status_to_string proof_status) - (Hist.pp_proof ~serialized:false) - proof - in - assert_content_is - ~__LOC__ - input_opt - ~expected:(expected_data page_info proof_status) - - let failing_check_produce_result ~__LOC__ ~expected_error res _page_info = - Assert.proto_error ~loc:__LOC__ res (fun e -> - match (e, expected_error) with - | Hist.Dal_proof_error s, Hist.Dal_proof_error expected -> - String.equal s expected - | ( Hist.Unexpected_page_size {expected_size = e1; page_size = p1}, - Hist.Unexpected_page_size {expected_size = e2; page_size = p2} ) -> - e1 = e2 && p1 = p2 - | _ -> false) - - let successful_check_verify_result ~__LOC__ proof_status res page_info = - let open Lwt_result_syntax in - let* content = Assert.get_ok ~__LOC__ res in - let expected = expected_data page_info proof_status in - assert_content_is ~__LOC__ ~expected content - - (** Checks if the two provided Page.proof are equal. *) - let eq_page_proof = - let bytes_opt_of_proof page_proof = - Data_encoding.Binary.to_bytes_opt P.proof_encoding page_proof - in - fun pp1 pp2 -> - Option.equal Bytes.equal (bytes_opt_of_proof pp1) (bytes_opt_of_proof pp2) - - let slot_confirmed_but_page_data_not_provided ~__LOC__ = - failing_check_produce_result - ~__LOC__ - ~expected_error: - (Hist.Dal_proof_error - "The page ID's slot is confirmed, but no page content and proof are \ - provided.") - - let slot_not_confirmed_but_page_data_provided ~__LOC__ = - failing_check_produce_result - ~__LOC__ - ~expected_error: - (Hist.Dal_proof_error - "The page ID's slot is not confirmed, but page content and proof \ - are provided.") -end diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/dal_helpers.mli b/src/proto_017_PtNairob/lib_protocol/test/helpers/dal_helpers.mli deleted file mode 100644 index 1eef4b51ec663989c01f9401347d00cb81bf089a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/dal_helpers.mli +++ /dev/null @@ -1,177 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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 - -(** Returns an object of type {!Cryptobox.t} from the given DAL paramters. *) -val mk_cryptobox : Cryptobox.parameters -> Cryptobox.t tzresult - -(** Derive new DAL parameters from the given ones by: - - setting the given redundancy factor ; - - dividing the other fields by the given factor. -*) -val derive_dal_parameters : - Cryptobox.parameters -> - redundancy_factor:int -> - constants_divider:int -> - Cryptobox.parameters - -module Make (P : sig - val dal_parameters : Alpha_context.Constants.Parametric.dal - - val cryptobox : Cryptobox.t Lazy.t -end) : sig - (** Some global constants. *) - - val genesis_history : Dal_slot_repr.History.t - - val genesis_history_cache : Dal_slot_repr.History.History_cache.t - - val level_one : Raw_level_repr.t - - val level_ten : Raw_level_repr.t - - (** Helper functions. *) - - (** Retrieves the history from a given cache. *) - val get_history : - Dal_slot_repr.History.History_cache.t -> - Dal_slot_repr.History.hash -> - Dal_slot_repr.History.t option Lwt.t - - (** Returns the slot's polynomial from the given slot's data. *) - val dal_mk_polynomial_from_slot : bytes -> Cryptobox.polynomial tzresult - - (* Commits to the given polynomial. *) - val dal_commit : - Cryptobox.t -> - Cryptobox.polynomial -> - (Cryptobox.commitment, error trace) result - - (** Using the given slot's polynomial, this function computes the page proof of - the page whose ID is provided. *) - val dal_mk_prove_page : - Cryptobox.polynomial -> - Dal_slot_repr.Page.t -> - Cryptobox.page_proof tzresult - - (** Constructs a slot whose ID is defined from the given level and given - index, and whose data are built using the given fill function. The function - returns the slot's data, polynomial, and header (in the sense: ID + kate - commitment). *) - val mk_slot : - ?level:Raw_level_repr.t -> - ?index:Dal_slot_index_repr.t -> - ?fill_function:(int -> char) -> - unit -> - (bytes * Cryptobox.polynomial * Dal_slot_repr.Header.t) tzresult - - (** Constructs a record value of type Page.id. *) - val mk_page_id : - Raw_level_repr.t -> Dal_slot_index_repr.t -> int -> Dal_slot_repr.Page.t - - val no_data : (default_char:char -> int -> bytes option) option - - (** Constructs a page whose level and slot indexes are those of the given slot - (except if level is redefined via [?level]), and whose page index and data - are given by arguments [page_index] and [mk_data]. If [mk_data] is set to - [No], the function returns the pair (None, page_id). Otherwise, the page's - [data] and [proof] is computed, and the function returns [Some (data, - proof), page_id]. *) - val mk_page_info : - ?default_char:char -> - ?level:Raw_level_repr.t -> - ?page_index:int -> - ?custom_data:(default_char:char -> int -> bytes option) option -> - Dal_slot_repr.Header.t -> - Cryptobox.polynomial -> - ( (bytes * Cryptobox.page_proof) option * Dal_slot_repr.Page.t, - error trace ) - result - - (** Returns the char after [c]. Restarts from the char whose code is 0 if [c]'s - code is 255. *) - val next_char : char -> char - - (** Increment the given slot index. Returns zero in case of overflow. *) - val succ_slot_index : Dal_slot_index_repr.t -> Dal_slot_index_repr.t - - (** Auxiliary test function used by both unit and PBT tests: This function - produces a proof from the given information and verifies the produced - result, if any. The result of each step is checked with - [check_produce_result] and [check_verify_result], respectively. *) - val produce_and_verify_proof : - check_produce: - ((Dal_slot_repr.History.proof * bytes option) tzresult -> - (bytes * Cryptobox.page_proof) option -> - (unit, tztrace) result Lwt.t) -> - ?check_verify: - (bytes option tzresult -> - (bytes * Cryptobox.page_proof) option -> - (unit, tztrace) result Lwt.t) -> - get_history: - (Dal_slot_repr.History.hash -> Dal_slot_repr.History.t option Lwt.t) -> - Dal_slot_repr.History.t -> - page_info:(bytes * Cryptobox.page_proof) option -> - page_id:Dal_slot_repr.Page.t -> - (unit, tztrace) result Lwt.t - - (** Check if two page proofs are equal. *) - val eq_page_proof : Cryptobox.page_proof -> Cryptobox.page_proof -> bool - - (** Helper for the case where produce_proof is expected to succeed. *) - val successful_check_produce_result : - __LOC__:string -> - [`Confirmed | `Unconfirmed] -> - (Dal_slot_repr.History.proof * bytes option) tzresult -> - (bytes * 'a) option -> - (unit, tztrace) result Lwt.t - - (** Helper for the case where verify_proof is expected to succeed. *) - val successful_check_verify_result : - __LOC__:string -> - [> `Confirmed] -> - bytes option tzresult -> - (bytes * 'a) option -> - (unit, tztrace) result Lwt.t - - (** Helper for the case where produce_proof is expected to fail because the slot - is confirmed but no page information are provided. *) - val slot_confirmed_but_page_data_not_provided : - __LOC__:string -> 'a tzresult -> 'b -> unit tzresult Lwt.t - - (** Helper for the case where produce_proof is expected to fail because the slot - is not confirmed but page_info are provided. *) - val slot_not_confirmed_but_page_data_provided : - __LOC__:string -> 'a tzresult -> 'b -> unit tzresult Lwt.t - - (** Helper for the case where produce_proof is expected to fail. *) - val failing_check_produce_result : - __LOC__:string -> - expected_error:Environment.Error_monad.error -> - 'a tzresult -> - 'b -> - unit tzresult Lwt.t -end diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/dummy_zk_rollup.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/dummy_zk_rollup.ml deleted file mode 100644 index b473deaf56b361d0b7719bf28bf7e704f99da9fc..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/dummy_zk_rollup.ml +++ /dev/null @@ -1,632 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Dummy ZK Rollup for testing the ZKRU integration in the protocol. - The library Plompiler is used to build the circuits (in a module V as - verifier) and the corresponding functions to produce the inputs for the - circuits (in a module P as prover). - - The state of this rollup is a boolean value, which will be - represented with a scalar value of [zero] for [false] and - [one] for [true]. - - This RU has only one operation, with [op_code] 0. In addition to the - common header (see {!Zk_rollup_operation_repr}), this operation has - as payload one scalar representing a boolean value. - - The transition function [f] for this rollup is: - - {[ - f : operation -> state -> state - f (Op b) s = if b = s then not s else s - ]} - - That is, the state bool is flipped only if the operation's payload is - equal to the current state. - - The operation can be used publicly or in a private batch. The circuits - that describe the RU are: - - ["op"]: for a single public operation. - - ["batch-"[N]]: for a batch of [N] private operations. [N] is determined - by the [batch_size] parameter to the [Operator] functor. - - ["fee"]: the trivial fees circuit, since this RU has no concept of fees. - - NB: the "op" circuit does not add any constraints over the operation's - [exit_validity] other than it being in [{0, 1}]. This means that the dummy - rollup can be used to test deposits/withdrawals, but the rollup will not - perform any monetary bookkeeping. -*) - -open Plompiler - -(** Helper types and modules *) - -(** Empty types to represent bounds *) - -type balance - -type amount - -type fee - -type op_code - -(** Bounds required for the dummy rollup. *) -module Bound : sig - type 'a t = private Z.t - - val bound_balance : balance t - - val bound_amount : amount t - - val bound_fee : fee t - - val bound_op_code : op_code t - - val v : 'a t -> Z.t -end = struct - type 'a t = Z.t - - (** These bounds are exclusive. *) - - (** Upper bound for ticket balance, as found in the price field of an - operation's header *) - let bound_balance = Z.(shift_left one 20) - - (** Upper bound for ticket amount, used for fee circuit *) - let bound_amount = Z.(shift_left one 20) - - (** Upper bound for fee amount of one public operation *) - let bound_fee = Z.(shift_left one 10) - - (** Upper bound for op code *) - let bound_op_code = Z.one - - let v x = x -end - -(** Modules to manipulate bounded integers, both as OCaml values and in circuit - representation. -*) -module Bounded = Bounded.Make (Bound) - -(** Types used for the Dummy Rollup circuits. - This module is split into: - - P: concrete OCaml version of the types, - - V: Plompiler's circuit representation for P's types, and - - Encodings: conversion between P and V. -*) -module Types = struct - module P = struct - type state = bool - - module Bounded = Bounded.P - - type 'a ticket = {id : S.t; amount : 'a Bounded.t} - - type tezos_pkh = Environment.Signature.Public_key_hash.t - - type header = { - op_code : op_code Bounded.t; - price : balance ticket; - l1_dst : tezos_pkh; - rollup_id : tezos_pkh; - } - - type op = {header : header; payload : bool} - - (** Dummy values for these types. Useful to get the circuit without having - the actual inputs. *) - module Dummy = struct - let op_code = Bounded.make ~bound:Bound.bound_op_code Z.zero - - let balance = Bounded.make ~bound:Bound.bound_balance Z.zero - - let tezos_pkh = Environment.Signature.Public_key_hash.zero - - let ticket_balance = {id = S.zero; amount = balance} - - let header = - { - op_code; - price = ticket_balance; - l1_dst = tezos_pkh; - rollup_id = tezos_pkh; - } - end - end - - module V (L : LIB) = struct - open L - module Bounded_u = Bounded.V (L) - - type 'a ticket_u = {id : scalar repr; amount : 'a Bounded_u.t} - - type tezos_pkh_u = scalar repr - - type header_u = { - op_code : op_code Bounded_u.t; - price : balance ticket_u; - l1_dst : tezos_pkh_u; - rollup_id : tezos_pkh_u; - } - - type op_u = {header : header_u; payload : bool repr} - end - - module Encodings (L : LIB) = struct - module Bounded_e = Bounded.Encoding (L) - open P - - open V (L) - - open L.Encodings - - let op_code_encoding ~safety = - Bounded_e.encoding ~safety Bound.bound_op_code - - let encoding_to_scalar e x = - let bs = Data_encoding.Binary.to_bytes_exn e x in - let z = Z.of_bits @@ Bytes.to_string bs in - Bls12_381.Fr.of_z z - - let encoding_of_scalar e x = - let z = Bls12_381.Fr.to_z x in - let bs = Bytes.of_string @@ Z.to_bits z in - Data_encoding.Binary.of_bytes_exn e bs - - let tezos_pkh_encoding : (tezos_pkh, tezos_pkh_u, _) encoding = - conv - (fun pkhu -> pkhu) - (fun w -> w) - (encoding_to_scalar Signature.Public_key_hash.encoding) - (encoding_of_scalar Signature.Public_key_hash.encoding) - scalar_encoding - - let amount_encoding ~safety = Bounded_e.encoding ~safety Bound.bound_amount - - let fee_encoding ~safety = Bounded_e.encoding ~safety Bound.bound_fee - - let ticket_encoding ~safety (bound : 'a Bound.t) : - ('a ticket, 'a ticket_u, _) encoding = - conv - (fun {id; amount} -> (id, amount)) - (fun (id, amount) -> {id; amount}) - (fun ({id; amount} : 'a ticket) -> (id, amount)) - (fun (id, amount) -> {id; amount}) - (obj2_encoding scalar_encoding (Bounded_e.encoding ~safety bound)) - - let ticket_balance_encoding ~safety = - ticket_encoding ~safety Bound.bound_balance - - let header_encoding ~safety : (header, header_u, _) encoding = - conv - (fun {op_code; price; l1_dst; rollup_id} -> - (op_code, (price, (l1_dst, rollup_id)))) - (fun (op_code, (price, (l1_dst, rollup_id))) -> - {op_code; price; l1_dst; rollup_id}) - (fun ({op_code; price; l1_dst; rollup_id} : header) -> - (op_code, (price, (l1_dst, rollup_id)))) - (fun (op_code, (price, (l1_dst, rollup_id))) -> - {op_code; price; l1_dst; rollup_id}) - (obj4_encoding - (op_code_encoding ~safety) - (* We use an Unsafe Bounded scalar encoding here to be able to - detect that an out-of-range value has been passed. - This encoding is unsafe in the sense that such value will cause - a failure in proving, instead of a circuit that can prove that - the argument is out-of-range. - This is enough for Protocol testing purposes, while keeping - the dummy circuit small. - *) - (ticket_balance_encoding ~safety:Unsafe) - tezos_pkh_encoding - tezos_pkh_encoding) - - let op_encoding : (op, op_u, _) encoding = - conv - (fun {header; payload} -> (header, payload)) - (fun (header, payload) -> {header; payload}) - (fun ({header; payload} : op) -> (header, payload)) - (fun (header, payload) -> {header; payload}) - (obj2_encoding (header_encoding ~safety:NoCheck) bool_encoding) - end -end - -(** Plompiler circuits for the dummy rollup *) -module V (L : LIB) = struct - open L - module E = Types.Encodings (L) - module Encodings = L.Encodings - open Encodings - - open Types.V (L) - - let coerce (type a) (x : a Bounded_u.t) = - fst (x : a Bounded_u.t :> scalar repr * Z.t) - - (** Common logic for the state transition function *) - let logic_op ~old_state ~rollup_id op = - ignore rollup_id ; - let* valid = equal old_state op.payload in - let* new_state = Bool.bnot old_state in - let* expected_new_state = Bool.ifthenelse valid new_state old_state in - Num.assert_eq_const (coerce op.header.op_code) S.zero - (* >* assert_equal rollup_id op.header.rollup_id *) - >* ret expected_new_state - - (** Circuit definition for one public operation *) - let predicate_op ?(kind = `Public) ~old_state ~new_state ~fee ~exit_validity - ~rollup_id op = - let* old_state = input ~kind:`Public @@ Input.bool old_state in - let* new_state = input ~kind:`Public @@ Input.bool new_state in - let* (_fee : scalar repr) = - input ~kind:`Public - @@ E.((fee_encoding ~safety:Bounded_e.Unsafe).input) fee - in - let* (_exit_validity : bool repr) = - input ~kind:`Public @@ Input.bool exit_validity - in - let* rollup_id = - input ~kind:`Public @@ E.(tezos_pkh_encoding.input) rollup_id - in - let* op = input ~kind @@ E.op_encoding.input op in - let op = E.op_encoding.decode op in - let* expected_new_state = logic_op ~old_state ~rollup_id op in - assert_equal expected_new_state new_state - - (** Circuit definition for a batch of private operations *) - let predicate_batch ~old_state ~new_state ~fees ~rollup_id ops = - let* old_state = input ~kind:`Public @@ Input.bool old_state in - let* new_state = input ~kind:`Public @@ Input.bool new_state in - let* (_fees : scalar repr) = - input ~kind:`Public - @@ E.((amount_encoding ~safety:Bounded_e.Unsafe).input) fees - in - let* rollup_id = - input ~kind:`Public @@ E.(tezos_pkh_encoding.input) rollup_id - in - let* ops = input @@ (Encodings.list_encoding E.op_encoding).input ops in - let ops = (Encodings.list_encoding E.op_encoding).decode ops in - let* computed_final_state = - foldM - (fun old_state op -> logic_op ~old_state ~rollup_id op) - old_state - ops - in - assert_equal computed_final_state new_state - - (** Fee circuit *) - let predicate_fees ~old_state ~new_state ~fees = - let* old_state = input ~kind:`Public @@ Input.bool old_state in - let* new_state = input ~kind:`Public @@ Input.bool new_state in - let* (_fees : scalar repr) = - input ~kind:`Public - @@ E.((amount_encoding ~safety:Bounded_e.Unsafe).input) fees - in - assert_equal old_state new_state -end - -(** Basic rollup operator for generating Updates. *) -module Operator (Params : sig - val batch_size : int -end) : sig - open Protocol.Alpha_context - - (** Initial state of the rollup *) - val init_state : Zk_rollup.State.t - - (** Map associating every circuit identifier to its kind *) - val circuits : [`Public | `Private | `Fee] Kzg.SMap.t - - (** Commitment to the circuits *) - val lazy_pp : - (Plonk.Main_protocol.prover_public_parameters - * Plonk.Main_protocol.verifier_public_parameters) - lazy_t - - (** [craft_update state ~zk_rollup ?private_ops ?exit_validities public_ops] - will apply first the [public_ops], then the [private_ops]. While doing so, - the public inputs for every circuit will be collected. A Plonk proof of - correctness of the application these operations is created. *) - val craft_update : - Zk_rollup.State.t -> - zk_rollup:Zk_rollup.t -> - ?private_ops:Zk_rollup.Operation.t list list -> - ?exit_validities:bool list -> - Zk_rollup.Operation.t list -> - Zk_rollup.State.t * Zk_rollup.Update.t - - module Internal_for_tests : sig - val true_op : Zk_rollup.Operation.t - - val false_op : Zk_rollup.Operation.t - - val pending : Zk_rollup.Operation.t list - - val private_ops : Zk_rollup.Operation.t list list - - val lazy_update_data : Zk_rollup.Update.t lazy_t - end -end = struct - open Protocol.Alpha_context - module SMap = Kzg.SMap - module Dummy = Types.P.Dummy - module T = Types.P - module VC = V (LibCircuit) - - let lazy_srs = - lazy - (let open Octez_bls12_381_polynomial in - (Srs.generate_insecure 9 1, Srs.generate_insecure 1 1)) - - let dummy_l1_dst = - Hex.to_bytes_exn (`Hex "0002298c03ed7d454a101eb7022bc95f7e5f41ac78") - - let dummy_rollup_id = - let address = - Zk_rollup.Address.of_b58check_exn "epx18RJJqrYuJQqhB636BWvukU3XBNQGbtm8C" - in - Data_encoding.Binary.to_bytes_exn Zk_rollup.Address.encoding address - - let dummy_ticket_hash = Bytes.make 32 '0' - - let of_proto_state : Zk_rollup.State.t -> Types.P.state = - fun s -> Bls12_381.Fr.is_one s.(0) - - let to_proto_state : Types.P.state -> Zk_rollup.State.t = - fun s -> if s then [|Bls12_381.Fr.one|] else [|Bls12_381.Fr.zero|] - - let dummy_op = T.{header = Dummy.header; payload = false} - - let batch_name = "batch-" ^ string_of_int Params.batch_size - - (* Circuits that define the rollup, alongside their public input size and - solver *) - let circuit_map = - let get_circuit _name c = - let r = LibCircuit.get_cs ~optimize:true c in - (Plonk.Circuit.to_plonk r, r.public_input_size, r.solver) - in - SMap.of_list - @@ List.map - (fun (n, c) -> (n, get_circuit n c)) - [ - ( "op", - VC.predicate_op - ~old_state:false - ~new_state:true - ~fee:(T.Bounded.make ~bound:Bound.bound_fee Z.zero) - ~exit_validity:false - ~rollup_id:Dummy.tezos_pkh - dummy_op ); - ( batch_name, - VC.predicate_batch - ~old_state:false - ~new_state:true - ~fees:(T.Bounded.make ~bound:Bound.bound_amount Z.zero) - ~rollup_id:Dummy.tezos_pkh - (Stdlib.List.init Params.batch_size (Fun.const dummy_op)) ); - ( "fee", - VC.predicate_fees - ~old_state:false - ~new_state:false - ~fees:(T.Bounded.make ~bound:Bound.bound_amount Z.zero) ); - ] - - let circuits = - SMap.(add "op" `Public @@ add batch_name `Private @@ add "fee" `Fee empty) - - let lazy_pp = - lazy - (let srs = Lazy.force lazy_srs in - Plonk.Main_protocol.setup - ~zero_knowledge:false - (SMap.map (fun (a, b, _) -> (a, b)) circuit_map) - ~srs) - - let insert s x m = - match SMap.find_opt s m with - | None -> SMap.add s [x] m - | Some l -> SMap.add s (x :: l) m - - let craft_update : - Zk_rollup.State.t -> - zk_rollup:Zk_rollup.t -> - ?private_ops:Zk_rollup.Operation.t list list -> - ?exit_validities:bool list -> - Zk_rollup.Operation.t list -> - Zk_rollup.State.t * Zk_rollup.Update.t = - fun s ~zk_rollup ?(private_ops = []) ?exit_validities pending -> - let prover_pp, public_parameters = Lazy.force lazy_pp in - let s = of_proto_state s in - let rev_inputs = SMap.empty in - let exit_validities = - match exit_validities with - | None -> List.map (Fun.const true) pending - | Some l -> - assert (List.length l = List.length pending) ; - l - in - let _circ, _pi_size, op_solver = SMap.find "op" circuit_map in - (* Process the public operations *) - let s, rev_inputs, rev_pending_pis = - Stdlib.List.fold_left2 - (fun (s, rev_inputs, rev_pending_pis) op exit_validity -> - let new_state = - if s = of_proto_state Zk_rollup.Operation.(op.payload) then not s - else s - in - let fee = Bls12_381.Fr.zero in - let pi_to_send = - Zk_rollup.Update. - {new_state = to_proto_state new_state; fee; exit_validity} - in - let exit_validity_s = - if exit_validity then Bls12_381.Fr.one else Bls12_381.Fr.zero - in - let public_inputs = - Array.concat - [ - to_proto_state s; - to_proto_state new_state; - [|fee; exit_validity_s; Zk_rollup.to_scalar zk_rollup|]; - Zk_rollup.Operation.to_scalar_array op; - ] - in - let private_inputs = Solver.solve op_solver public_inputs in - ( new_state, - insert - "op" - Plonk.Main_protocol. - {witness = private_inputs; input_commitments = []} - rev_inputs, - ("op", pi_to_send) :: rev_pending_pis )) - (s, rev_inputs, []) - pending - exit_validities - in - let pending_pis = List.rev rev_pending_pis in - - let _circ, _pi_size, batch_solver = SMap.find batch_name circuit_map in - (* Process the private operation batches *) - let s, rev_inputs, rev_private_pis = - if private_ops = [] then (s, rev_inputs, []) - else - List.fold_left - (fun (s, rev_inputs, rev_private_pis) batch -> - let new_state = - List.fold_left - (fun s op -> - if s = of_proto_state Zk_rollup.Operation.(op.payload) then - not s - else s) - s - batch - in - let fees = Bls12_381.Fr.zero in - let pi_to_send : Zk_rollup.Update.private_inner_pi = - Zk_rollup.Update.{new_state = to_proto_state new_state; fees} - in - let public_inputs = - Array.concat - [ - to_proto_state s; - to_proto_state new_state; - [|fees; Zk_rollup.to_scalar zk_rollup|]; - ] - in - let initial = - Array.concat - ([public_inputs] - @ List.map Zk_rollup.Operation.to_scalar_array batch) - in - let private_inputs = Solver.solve batch_solver initial in - ( new_state, - insert - batch_name - Plonk.Main_protocol. - {witness = private_inputs; input_commitments = []} - rev_inputs, - (batch_name, pi_to_send) :: rev_private_pis )) - (s, rev_inputs, []) - private_ops - in - let private_pis = List.rev rev_private_pis in - (* Dummy fee circuit *) - let _circ, _pi_size, fee_solver = SMap.find "fee" circuit_map in - let rev_inputs, fee_pi = - let fee_pi = Zk_rollup.Update.{new_state = to_proto_state s} in - let fees = Bls12_381.Fr.zero in - - let public_inputs = - Array.concat [to_proto_state s; to_proto_state s; [|fees|]] - in - let private_inputs = Solver.solve fee_solver public_inputs in - ( insert - "fee" - Plonk.Main_protocol.{witness = private_inputs; input_commitments = []} - rev_inputs, - fee_pi ) - in - let inputs = SMap.map List.rev rev_inputs in - let proof = Plonk.Main_protocol.prove prover_pp ~inputs in - let verifier_inputs = - Plonk.Main_protocol.to_verifier_inputs prover_pp inputs - in - assert ( - Plonk.Main_protocol.verify public_parameters ~inputs:verifier_inputs proof) ; - ( to_proto_state s, - Zk_rollup.Update.{pending_pis; private_pis; fee_pi; proof} ) - - let init_state = to_proto_state false - - module Internal_for_tests = struct - let true_op = - Zk_rollup.Operation. - { - op_code = 0; - price = - (let id = - Data_encoding.Binary.of_bytes_exn - Ticket_hash.encoding - dummy_ticket_hash - in - {id; amount = Z.zero}); - l1_dst = - Data_encoding.Binary.of_bytes_exn - Signature.Public_key_hash.encoding - dummy_l1_dst; - rollup_id = - Data_encoding.Binary.of_bytes_exn - Zk_rollup.Address.encoding - dummy_rollup_id; - payload = [|Bls12_381.Fr.one|]; - } - - let false_op = {true_op with payload = [|Bls12_381.Fr.zero|]} - - let pending = [false_op; true_op; true_op] - - let n_batches = 2 - - let private_ops = - Stdlib.List.init n_batches @@ Fun.const - @@ Stdlib.List.init Params.batch_size (fun i -> - if i mod 2 = 0 then false_op else true_op) - - let lazy_update_data = - lazy - (snd - @@ craft_update - init_state - ~zk_rollup: - (Data_encoding.Binary.of_bytes_exn - Zk_rollup.Address.encoding - dummy_rollup_id) - ~private_ops - pending) - end -end diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/dune b/src/proto_017_PtNairob/lib_protocol/test/helpers/dune deleted file mode 100644 index 6da4289565d2cb2d6bb0344e23a552e942cec9e6..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/dune +++ /dev/null @@ -1,33 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name tezos_017_PtNairob_test_helpers) - (public_name octez-protocol-017-PtNairob-libs.test-helpers) - (instrumentation (backend bisect_ppx)) - (libraries - qcheck-alcotest - octez-libs.test-helpers - octez-libs.base - octez-libs.micheline - octez-libs.stdlib-unix - tezos-protocol-017-PtNairob.protocol - octez-protocol-017-PtNairob-libs.client - tezos-protocol-017-PtNairob.parameters - octez-proto-libs.protocol-environment - octez-protocol-017-PtNairob-libs.plugin - octez-shell-libs.shell-services - octez-libs.plompiler - octez-libs.crypto-dal) - (flags - (:standard) - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_micheline - -open Tezos_stdlib_unix - -open Tezos_protocol_017_PtNairob - -open Tezos_client_017_PtNairob - -open Tezos_protocol_017_PtNairob_parameters - -open Tezos_protocol_plugin_017_PtNairob - -open Tezos_shell_services - -open Tezos_crypto_dal)) diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/error_monad_operators.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/error_monad_operators.ml deleted file mode 100644 index 9157c0b35a258b7697facdddec467cd30b0dd7e2..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/error_monad_operators.ml +++ /dev/null @@ -1,36 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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 ( >>=?? ) x y = - x >>= function - | Ok s -> y s - | Error err -> Lwt.return @@ Error (Environment.wrap_tztrace err) - -let ( >|=?? ) m f = m >>=?? fun x -> return (f x) - -let ( >>??= ) x y = - match x with - | Ok s -> y s - | Error err -> Lwt.return @@ Error (Environment.wrap_tztrace err) diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/error_monad_operators.mli b/src/proto_017_PtNairob/lib_protocol/test/helpers/error_monad_operators.mli deleted file mode 100644 index bf0726c160b2bdaa85e04d9b2ffd8974b4110768..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/error_monad_operators.mli +++ /dev/null @@ -1,39 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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 ( >>=?? ) : - ('a, Environment.Error_monad.error Environment.Error_monad.trace) result Lwt.t -> - ('a -> ('b, error trace) result Lwt.t) -> - ('b, error trace) result Lwt.t - -val ( >|=?? ) : - ('a, Environment.Error_monad.error Environment.Error_monad.trace) result Lwt.t -> - ('a -> 'b) -> - ('b, error trace) result Lwt.t - -val ( >>??= ) : - ('a, Environment.Error_monad.error Environment.Error_monad.trace) result -> - ('a -> ('b, error trace) result Lwt.t) -> - ('b, error trace) result Lwt.t diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/expr.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/expr.ml deleted file mode 100644 index 468d09535ae84aa3dedf8ec49e29ea3fc82433c8..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/expr.ml +++ /dev/null @@ -1,50 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs, *) -(* *) -(* 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 -open Alpha_context - -exception Expression_from_string - -(** Parse a Michelson expression from string, raising an exception on error. *) -let from_string ?(check_micheline_indentation = false) str : Script.expr = - let ast, errs = - Michelson_v1_parser.parse_expression ~check:check_micheline_indentation str - in - (match errs with - | [] -> () - | lst -> - Format.printf "expr_from_string: %a\n" Error_monad.pp_print_trace lst ; - raise Expression_from_string) ; - ast.expanded - -(** Parses a Michelson contract from string, raising an exception on error. *) -let toplevel_from_string ?(check_micheline_indentation = false) str = - let ast, errs = - Michelson_v1_parser.parse_toplevel ~check:check_micheline_indentation str - in - match errs with [] -> ast.expanded | _ -> Stdlib.failwith "parse toplevel" - -let to_string c = Format.asprintf "%a" Michelson_v1_printer.print_expr c diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/expr_common.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/expr_common.ml deleted file mode 100644 index 554bba47ce079e32b883e183899f58eee56b702f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/expr_common.ml +++ /dev/null @@ -1,98 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context - -(* From OCaml values to Micheline expressions *) - -let seq ?(loc = 0) l = Tezos_micheline.Micheline.Seq (loc, l) - -let pair ?(loc = 0) a b = - Tezos_micheline.Micheline.Prim (loc, Script.D_Pair, [a; b], []) - -let pair_n ?(loc = 0) els = - Tezos_micheline.Micheline.Prim (loc, Script.D_Pair, els, []) - -let comb ?(loc = 0) es = - Tezos_micheline.Micheline.Prim (loc, Script.D_Pair, es, []) - -let none ?(loc = 0) () = - Tezos_micheline.Micheline.Prim (loc, Script.D_None, [], []) - -let some ?(loc = 0) a = - Tezos_micheline.Micheline.Prim (loc, Script.D_Some, [a], []) - -let left ?(loc = 0) a = - Tezos_micheline.Micheline.Prim (loc, Script.D_Left, [a], []) - -let right ?(loc = 0) b = - Tezos_micheline.Micheline.Prim (loc, Script.D_Right, [b], []) - -let unit ?(loc = 0) () = - Tezos_micheline.Micheline.Prim (loc, Script.D_Unit, [], []) - -let int ?(loc = 0) i = Tezos_micheline.Micheline.Int (loc, i) - -let bytes ?(loc = 0) s = Tezos_micheline.Micheline.Bytes (loc, s) - -let string ?(loc = 0) s = Tezos_micheline.Micheline.String (loc, s) - -let mutez ?(loc = 0) m = int ~loc (Z.of_int64 (Tez.to_mutez m)) - -(* Translate a timestamp to a Micheline expression in optimized - form *) -let timestamp ?(loc = 0) ts = int ~loc (Script_timestamp.to_zint ts) - -let address ?(loc = 0) adr = - bytes ~loc @@ Data_encoding.Binary.to_bytes_exn Contract.encoding adr - -let address_string ?(loc = 0) adr = string ~loc @@ Contract.to_b58check adr - -let big_map_id ?(loc = 0) id = int ~loc @@ Big_map.Id.unparse_to_z id - -(* From Micheline expressions to OCaml values *) - -let timestamp_of_zint zint = Script_timestamp.of_zint zint - -let public_key_of_bytes_exn b = - Data_encoding.Binary.of_bytes_exn Signature.Public_key.encoding b - -let address_of_bytes_exn b = - Data_encoding.Binary.of_bytes_exn Contract.encoding b - -type exn += Invalid_address_expr of string - -let address_of_string_exn s = - match Contract.of_b58check s with - | Ok c -> c - | Error _ -> raise @@ Invalid_address_expr s - -let originated_of_string_exn s = - match address_of_string_exn s with - | Contract.Originated addr -> addr - | Contract.Implicit _ -> - invalid_arg - "Expected originated contract address, got implicit contract address" diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/incremental.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/incremental.ml deleted file mode 100644 index 196396137e3423399e260aa0e295668815503a1e..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/incremental.ml +++ /dev/null @@ -1,285 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 -module Proto_Nonce = Nonce (* Renamed otherwise is masked by Alpha_context *) -open Alpha_context - -type t = { - predecessor : Block.t; - state : validation_state * application_state; - rev_operations : Operation.packed list; - rev_tickets : operation_receipt list; - header : Block_header.t; - delegate : Account.t; -} - -type incremental = t - -let predecessor {predecessor; _} = predecessor - -let header {header; _} = header - -let rev_tickets {rev_tickets; _} = rev_tickets - -let validation_state {state = vs, _; _} = vs - -let level st = st.header.shell.level - -let alpha_ctxt {state = _, application_state; _} = application_state.ctxt - -let rpc_context st = - let fitness = (header st).shell.fitness in - let result = Alpha_context.finalize (alpha_ctxt st) fitness in - { - Environment.Updater.block_hash = Block_hash.zero; - block_header = {st.header.shell with fitness = result.fitness}; - context = result.context; - } - -let rpc_ctxt = - new Environment.proto_rpc_context_of_directory - rpc_context - Plugin.RPC.rpc_services - -let set_alpha_ctxt st ctxt = - {st with state = (fst st.state, {(snd st.state) with ctxt})} - -let begin_validation_and_application ctxt chain_id mode ~predecessor = - let open Lwt_result_syntax in - let* validation_state = begin_validation ctxt chain_id mode ~predecessor in - let* application_state = begin_application ctxt chain_id mode ~predecessor in - return (validation_state, application_state) - -let begin_construction ?timestamp ?seed_nonce_hash ?(mempool_mode = false) - ?(policy = Block.By_round 0) (predecessor : Block.t) = - Block.get_next_baker ~policy predecessor - >>=? fun (delegate, _consensus_key, round, real_timestamp) -> - Account.find delegate >>=? fun delegate -> - Round.of_int round |> Environment.wrap_tzresult >>?= fun payload_round -> - let timestamp = Option.value ~default:real_timestamp timestamp in - (match seed_nonce_hash with - | Some _hash -> return seed_nonce_hash - | None -> ( - Plugin.RPC.current_level ~offset:1l Block.rpc_ctxt predecessor - >|=? function - | {expected_commitment = true; _} -> Some (fst (Proto_Nonce.generate ())) - | {expected_commitment = false; _} -> None)) - >>=? fun seed_nonce_hash -> - let contents = - Block.Forge.contents - ?seed_nonce_hash - ~payload_hash:Block_payload_hash.zero - ~payload_round - () - in - let mode = - if mempool_mode then - Partial_construction {predecessor_hash = predecessor.hash; timestamp} - else - let block_header_data = - {Block_header.contents; signature = Signature.zero} - in - Construction - {predecessor_hash = predecessor.hash; timestamp; block_header_data} - in - let header = - { - Block_header.shell = - { - predecessor = predecessor.hash; - proto_level = predecessor.header.shell.proto_level; - validation_passes = predecessor.header.shell.validation_passes; - fitness = predecessor.header.shell.fitness; - timestamp; - level = predecessor.header.shell.level; - context = Context_hash.zero; - operations_hash = Operation_list_list_hash.zero; - }; - protocol_data = {contents; signature = Signature.zero}; - } - in - begin_validation_and_application - predecessor.context - Chain_id.zero - mode - ~predecessor:predecessor.header.shell - >|= fun state -> - Environment.wrap_tzresult state >|? fun state -> - {predecessor; state; rev_operations = []; rev_tickets = []; header; delegate} - -let detect_script_failure : - type kind. kind Apply_results.operation_metadata -> _ = - let rec detect_script_failure : - type kind. kind Apply_results.contents_result_list -> _ = - let open Apply_results in - let open Apply_operation_result in - let open Apply_internal_results in - let detect_script_failure_single (type kind) - (Manager_operation_result - {operation_result; internal_operation_results; _} : - kind Kind.manager Apply_results.contents_result) = - let detect_script_failure (type kind) - (result : (kind, _, _) operation_result) = - match result with - | Applied _ -> Ok () - | Skipped _ -> assert false - | Backtracked (_, None) -> - (* there must be another error for this to happen *) - Ok () - | Backtracked (_, Some errs) -> Error (Environment.wrap_tztrace errs) - | Failed (_, errs) -> Error (Environment.wrap_tztrace errs) - in - detect_script_failure operation_result >>? fun () -> - List.iter_e - (fun (Internal_operation_result (_, r)) -> detect_script_failure r) - internal_operation_results - in - function - | Single_result (Manager_operation_result _ as res) -> - detect_script_failure_single res - | Single_result _ -> Ok () - | Cons_result (res, rest) -> - detect_script_failure_single res >>? fun () -> - detect_script_failure rest - in - fun {contents} -> detect_script_failure contents - -let check_operation_size ?(check_size = true) op = - if check_size then - let operation_size = Data_encoding.Binary.length Operation.encoding op in - if operation_size > Constants_repr.max_operation_data_length then - raise - (invalid_arg - (Format.sprintf - "The operation size is %d: it exceeds the constant maximum size \ - %d." - operation_size - Constants_repr.max_operation_data_length)) - -let validate_operation ?expect_failure ?check_size st op = - let open Lwt_result_syntax in - check_operation_size ?check_size op ; - let validation_state, application_state = st.state in - let oph = Operation.hash_packed op in - let*! res = validate_operation validation_state oph op in - match (expect_failure, Environment.wrap_tzresult res) with - | Some _, Ok _ -> failwith "Error expected while validating operation" - | Some f, Error err -> - let* () = f err in - return st - | None, Error err -> fail err - | None, Ok validation_state -> - return {st with state = (validation_state, application_state)} - -let add_operation ?expect_failure ?expect_apply_failure ?allow_manager_failure - ?check_size st op = - let open Lwt_result_syntax in - let open Apply_results in - let* st = validate_operation ?expect_failure ?check_size st op in - match expect_failure with - | Some _ -> - (* The expected failure has already been observed in - [validate_operation]. *) - return st - | None -> ( - let validation_state, application_state = st.state in - let oph = Operation.hash_packed op in - let*! res = apply_operation application_state oph op in - let*? application_state, metadata = Environment.wrap_tzresult res in - let st = - { - st with - state = (validation_state, application_state); - rev_operations = op :: st.rev_operations; - rev_tickets = metadata :: st.rev_tickets; - } - in - match allow_manager_failure with - | Some true -> return st - | None | Some false -> ( - match (expect_apply_failure, metadata) with - | None, No_operation_metadata -> return st - | None, Operation_metadata result -> - let*? () = detect_script_failure result in - return st - | Some _, No_operation_metadata -> - failwith "Error expected while adding operation" - | Some f, Operation_metadata result -> ( - match detect_script_failure result with - | Ok _ -> failwith "Error expected while adding operation" - | Error err -> - let* () = f err in - return st))) - -let finalize_validation_and_application (validation_state, application_state) - shell_header = - let open Lwt_result_syntax in - let* () = finalize_validation validation_state in - finalize_application application_state shell_header - -let finalize_block st = - let open Lwt_result_syntax in - let operations = List.rev st.rev_operations in - let operations_hash = - Operation_list_list_hash.compute - [Operation_list_hash.compute (List.map Operation.hash_packed operations)] - in - let shell_header = - { - st.header.shell with - level = Int32.succ st.header.shell.level; - operations_hash; - } - in - let*! res = - finalize_validation_and_application st.state (Some shell_header) - in - let*? validation_result, _ = Environment.wrap_tzresult res in - let operations = List.rev st.rev_operations in - let operations_hash = - Operation_list_list_hash.compute - [Operation_list_hash.compute (List.map Operation.hash_packed operations)] - in - let header = - { - st.header with - shell = - { - st.header.shell with - level = Int32.succ st.header.shell.level; - operations_hash; - fitness = validation_result.fitness; - }; - } - in - let hash = Block_header.hash header in - return {Block.hash; header; operations; context = validation_result.context} - -let assert_validate_operation_fails expect_failure op block = - let open Lwt_result_syntax in - let* i = begin_construction block in - let* (_i : incremental) = validate_operation ~expect_failure i op in - return_unit diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/incremental.mli b/src/proto_017_PtNairob/lib_protocol/test/helpers/incremental.mli deleted file mode 100644 index c5bfd01302cd93595e51042b372150a329fae915..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/incremental.mli +++ /dev/null @@ -1,137 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 -open Alpha_context - -type t - -type incremental = t - -val predecessor : incremental -> Block.t - -val header : incremental -> Block_header.t - -val rev_tickets : incremental -> operation_receipt list - -val validation_state : incremental -> validation_state - -val level : incremental -> int32 - -(** [begin_construction ?mempool_mode predecessor] uses - {!Main.begin_validation_and_application} to create a validation and - application state on top of [predecessor] for the construction of a - new block. - - Optional arguments allow to override defaults: - - {ul {li [?mempool_mode:bool]: when [true], use [Partial_construction] - mode. By default, it is [false] and the mode is [Construction].}} *) -val begin_construction : - ?timestamp:Time.Protocol.t -> - ?seed_nonce_hash:Nonce_hash.t -> - ?mempool_mode:bool -> - ?policy:Block.baker_policy -> - Block.t -> - incremental tzresult Lwt.t - -(** [validate_operation ?expect_failure ?check_size i op] tries to - validate [op] in the validation state of [i]. If the validation - succeeds, the function returns the incremental value with a - validation state updated after the validate. Otherwise raise the - error from the validation of [op]. - - Optional arguments allow to override defaults: - - {ul {li [?expect_failure:(error list -> unit tzresult Lwt.t)]: - validation of [op] is expected to fail and [expect_failure] should - handle the error. In case validate does not fail and an - [expect_failure] is provided, [validate_operation] fails.} - - {li [?check_size:bool]: enable the check that an operation size - should not exceed [Constants_repr.max_operation_data_length]. - Enabled (set to [true]) by default. }} *) -val validate_operation : - ?expect_failure:(error list -> unit tzresult Lwt.t) -> - ?check_size:bool -> - incremental -> - Operation.packed -> - incremental tzresult Lwt.t - -(** [add_operation ?expect_failure ?expect_apply_failure - ?allow_manager_failure ?check_size i op] tries to validate then - apply [op] in the validation and application state of [i]. If the - validation of [op] succeeds, the function returns the incremental - value with a validation state updated after the application of - [op]. Otherwise raise the error from the validation of [op]. - - Optional arguments allow to override defaults: - - @param expect_failure - validation of [op] is expected to fail and [expect_failure] should - handle the error. In case validate does not fail and - [expect_failure] is provided, [validate_operation] fails. - - @param expect_apply_failure - application of [op] is expected to fail and - [expect_apply_failure] should handle the errror. In case the - application of [op] does not fail and [expect_apply_failure] is - provided, [add_operation] fails. - - @param allow_manager_failure - marks that manager operation failures after fee taken are ignored. - - @param check_size - enable the check that an operation size should not exceed - [Constants_repr.max_operation_data_length]. Enabled (set to [true]) by - default. *) -val add_operation : - ?expect_failure:(error list -> unit tzresult Lwt.t) -> - ?expect_apply_failure:(error list -> unit tzresult Lwt.t) -> - ?allow_manager_failure:bool -> - ?check_size:bool -> - incremental -> - Operation.packed -> - incremental tzresult Lwt.t - -(** [finalize_block i] creates a [Block.t] based on the protocol - states and the operations contained in [i]. The function calls - [Main.finalize_application] to compute a new context. *) -val finalize_block : incremental -> Block.t tzresult Lwt.t - -(** [assert_validate_operation_fails expect_failure operation block] - calls {!begin_construction} on top of [block], then - {!validate_operation} with [~expect_failure]. *) -val assert_validate_operation_fails : - (tztrace -> unit tzresult Lwt.t) -> - Operation.packed -> - Block.t -> - unit tzresult Lwt.t - -val rpc_ctxt : incremental Environment.RPC_context.simple - -val alpha_ctxt : incremental -> Alpha_context.context - -val set_alpha_ctxt : incremental -> Alpha_context.context -> incremental diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/liquidity_baking_generator.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/liquidity_baking_generator.ml deleted file mode 100644 index 2a81f101afae6a8f4c97faf0fddb29d589ae483c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/liquidity_baking_generator.ml +++ /dev/null @@ -1,328 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 Liquidity_baking_machine -open QCheck2.Gen - -let total_xtz = 32_000_000_000_000L - -let ten_subsidies = 25_000_000L - -let rec remove_last_element = function - | [_] -> [] - | x :: rst -> x :: remove_last_element rst - | [] -> raise (Invalid_argument "remove_last_element") - -(** Try to shrink a list by removing elements from the tail of said - list. - - The elements themselves are not shrinked. *) -let rec shrink_list l = - if l == [] then Seq.empty - else - let l = remove_last_element l in - Seq.cons l (shrink_list l) - -let gen_balances : int64 -> int -> int -> balances QCheck2.Gen.t = - fun max_xtz max_tzbtc max_liquidity -> - let open Tezos_test_helpers.Qcheck2_helpers in - let+ xtz = int64_strictly_positive_gen max_xtz - and+ tzbtc = int_strictly_positive_gen max_tzbtc - and+ liquidity = int_strictly_positive_gen max_liquidity in - {xtz; tzbtc; liquidity} - -let gen_specs : int -> int -> specs QCheck2.Gen.t = - fun total_tzbtc total_liquidity -> - (* 1. We pick a random number to decide how many implicit account we - will set-up in the specs. Note that there will be one more - implicit accounts, the [Holder], that we will use to reach the - expected balances for the CPMM and the implicit accounts. *) - let* accounts_numbers = int_range 10 20 in - (* 2. To keep the generator simpler, we do not try to strictly reach - the [total_tzbtc] and [total_liquidity] value, but rather we - compute maxima for the implicit accounts balances from - them. *) - (* 2.1. We divide a fraction of the [total_xtz] that we need to - share to the implicit accounts. The rationale is to provide - a large amount to xtz to [Holder], so that we do not have to - worry about it being “rich enough.†*) - let max_xtz = Int64.(div total_xtz (of_int (50 * accounts_numbers))) in - (* 2.2. We divide [total_tzbtc] between the implicit accounts *and* - the CPMM contract. *) - let max_tzbtc = total_tzbtc / (accounts_numbers + 1) in - (* 2.2. We divide [total_liquidity] between the implicit accounts only. *) - let max_liquidity = total_liquidity / accounts_numbers in - let+ cpmm_balance = gen_balances max_xtz max_tzbtc 1 - and+ accounts_balances = - list_repeat accounts_numbers (gen_balances max_xtz max_tzbtc max_liquidity) - in - { - cpmm_min_xtz_balance = cpmm_balance.xtz; - cpmm_min_tzbtc_balance = cpmm_balance.tzbtc; - accounts_balances; - } - -type 'a optgen = 'a option QCheck2.Gen.t - -let ( let*? ) (m : 'a optgen) (f : 'a -> 'b optgen) = - let* x = m in - match x with None -> return None | Some x -> f x - -(** [genopt_oneof l] tries to generate a value using the generators of - [l], one at a time. - - First, the list [l] is randomized, then each generator is - tried. The first one to return a result (not [None]) is picked. If - all generators returns [None], the generators tries again with the - whole list (at most 100 times). If no generator of [l] is able to - return a result, then [genopt_oneof l] returns [None]. *) -let genopt_oneof (l : 'a optgen list) : 'a optgen = - let* l = QCheck2.Gen.shuffle_l l in - let rec aux n = function - | [] -> if n = 0 then pure None else aux (n - 1) l - | g :: l -> ( - let* x = g in - match x with None -> aux n l | Some x -> pure @@ Some x) - in - aux 100 l - -let genopt_account ?choice ?(filter = Fun.const true) env : contract_id optgen = - let l = - List.filter - filter - (Option.fold ~none:env.implicit_accounts ~some:(fun x -> [x]) choice) - in - if l = [] then return None else map Option.some (oneofl l) - -let genopt_account_with_tzbtc ?choice ?(min = 1) env state = - genopt_account - ?choice - ~filter:(fun a -> SymbolicMachine.get_tzbtc_balance a env state >= min) - env - -let genopt_account_with_xtz ?choice ?(min = 1L) env state = - genopt_account - ?choice - ~filter:(fun a -> SymbolicMachine.get_xtz_balance a state >= min) - env - -let genopt_account_with_liquidity ?choice ?(min = 1) env state = - genopt_account - ?choice - ~filter:(fun a -> SymbolicMachine.get_liquidity_balance a env state >= min) - env - -let genopt_step_tzbtc_to_xtz : - ?source:contract_id -> - ?destination:contract_id -> - contract_id env -> - SymbolicMachine.t -> - contract_id step optgen = - fun ?source ?destination env state -> - let*? source = genopt_account_with_tzbtc ?choice:source env state in - let*? destination = genopt_account ?choice:destination env in - let+ tzbtc_deposit = - Tezos_test_helpers.Qcheck2_helpers.int_strictly_positive_gen - (SymbolicMachine.get_tzbtc_balance source env state) - in - (* See note (2) *) - if - SymbolicMachine.get_tzbtc_balance env.cpmm_contract env state - < Int.max_int - tzbtc_deposit - then Some (SellTzBTC {source; destination; tzbtc_deposit}) - else None - -let genopt_step_xtz_to_tzbtc : - ?source:contract_id -> - ?destination:contract_id -> - contract_id env -> - SymbolicMachine.t -> - contract_id step optgen = - fun ?source ?destination env state -> - let*? source = genopt_account_with_xtz ?choice:source env state in - let*? destination = genopt_account ?choice:destination env in - let+ xtz_deposit = - map - Int64.of_int - (int_range - 1 - (Int64.to_int @@ SymbolicMachine.get_xtz_balance source state)) - in - (* See note (2) *) - if - SymbolicMachine.get_xtz_balance env.cpmm_contract state - < Int64.(sub max_int (add ten_subsidies xtz_deposit)) - then Some (BuyTzBTC {source; destination; xtz_deposit}) - else None - -let genopt_step_add_liquidity : - ?source:contract_id -> - ?destination:contract_id -> - contract_id env -> - SymbolicMachine.t -> - contract_id step optgen = - fun ?source ?destination env state -> - let rec find_xtz_deposit candidate max_tzbtc_deposit = - let tzbtc_deposit = - SymbolicMachine.predict_required_tzbtc_deposit candidate env state - in - if tzbtc_deposit <= max_tzbtc_deposit then candidate - else find_xtz_deposit (Int64.div candidate 2L) max_tzbtc_deposit - in - let*? source = genopt_account_with_xtz ?choice:source env state in - let*? destination = genopt_account ?choice:destination env in - let source_xtz_pool = SymbolicMachine.get_xtz_balance source state in - (* the source needs at least one xtz *) - if 1L < source_xtz_pool then - let+ candidate = - Tezos_test_helpers.Qcheck2_helpers.int64_strictly_positive_gen - source_xtz_pool - in - let xtz_deposit = - find_xtz_deposit - candidate - (SymbolicMachine.get_tzbtc_balance source env state) - in - (* See note (2) *) - if - SymbolicMachine.get_xtz_balance env.cpmm_contract state - < Int64.(sub max_int (add ten_subsidies xtz_deposit)) - then Some (AddLiquidity {source; destination; xtz_deposit}) - else None - else pure None - -let genopt_step_remove_liquidity : - ?source:contract_id -> - ?destination:contract_id -> - contract_id env -> - SymbolicMachine.t -> - contract_id step optgen = - fun ?source ?destination env state -> - let*? source = genopt_account_with_liquidity ?choice:source env state in - let*? destination = genopt_account ?choice:destination env in - let lqt_available = SymbolicMachine.get_liquidity_balance source env state in - if 1 < lqt_available then - let+ lqt_burned = - int_range 1 (SymbolicMachine.get_liquidity_balance source env state) - in - Some (RemoveLiquidity {source; destination; lqt_burned}) - else return None - -let genopt_step : - ?source:contract_id -> - ?destination:contract_id -> - contract_id env -> - SymbolicMachine.t -> - contract_id step optgen = - fun ?source ?destination env state -> - genopt_oneof - [ - genopt_step_tzbtc_to_xtz env state ?source ?destination; - genopt_step_xtz_to_tzbtc env state ?source ?destination; - genopt_step_add_liquidity env state ?source ?destination; - genopt_step_remove_liquidity env state ?source ?destination; - ] - -let gen_steps : - ?source:contract_id -> - ?destination:contract_id -> - contract_id env -> - SymbolicMachine.t -> - int -> - contract_id step list QCheck2.Gen.t = - fun ?source ?destination env state size -> - let rec inner env state size random_state = - if size <= 0 then [] - else - let h = - QCheck2.Gen.generate1 - ~rand:random_state - (genopt_step ?source ?destination env state) - in - match h with - | None -> [] - | Some h -> - let state = SymbolicMachine.step h env state in - let rst = inner env state (size - 1) random_state in - h :: rst - in - QCheck2.Gen.make_primitive ~gen:(inner env state size) ~shrink:(fun l -> - shrink_list l) - -let gen_scenario : - tzbtc -> liquidity -> int -> (specs * contract_id step list) QCheck2.Gen.t = - fun total_tzbtc total_liquidity size -> - let* specs = gen_specs total_tzbtc total_liquidity in - let state, env = SymbolicMachine.build specs in - let+ scenario = gen_steps env state size in - (specs, scenario) - -let pp_scenario fmt (specs, steps) = - Format.( - fprintf - fmt - "@[{@ @[ @[specs@ = %a;@]@ @[steps@ = @[[ \ - %a]@]@]@]}@]" - pp_specs - specs - (pp_print_list - ~pp_sep:(fun fmt _ -> fprintf fmt "@ ; ") - (pp_step pp_contract_id)) - steps) - -let print_scenario = Format.asprintf "%a" pp_scenario - -let gen_adversary_scenario : - tzbtc -> - liquidity -> - int -> - (specs * contract_id * contract_id step list) QCheck2.Gen.t = - fun total_tzbtc total_liquidity size -> - let* specs = gen_specs total_tzbtc total_liquidity in - let state, env = SymbolicMachine.build ~subsidy:0L specs in - let* c = oneofl env.implicit_accounts in - let+ scenario = gen_steps ~source:c ~destination:c env state size in - (specs, c, scenario) - -let print_adversary_scenario (specs, _, steps) = - Format.asprintf "%a" pp_scenario (specs, steps) - -(* -------------------------------------------------------------------------- *) - -(* Note (1) - - We shrink a valid scenario by removing steps from its tails, - because a prefix of a valid scenario remains a valid - scenario. Removing a random element of a scenario could lead to an - invalid scenario. We have to use QCheck2.Gen.make_primitive to specify - the shrinking method of the generator, and avoid defaulting on the - shrinking implied by QCheck2.Gen.bind *) - -(* Note (2) - - If we are not being careful, it is possible to provoke an overflow - in the xtzPool and tzbtcPool. We try to avoid that as much as - possible by being very careful with the steps that are likely to - add xtz to the contract. *) diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/liquidity_baking_generator.mli b/src/proto_017_PtNairob/lib_protocol/test/helpers/liquidity_baking_generator.mli deleted file mode 100644 index 02a0a12ebc93f8707cc1810b68b03d2f4ff96f12..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/liquidity_baking_generator.mli +++ /dev/null @@ -1,86 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 module provides a set of abstractions to reason about the - so-called “liquidity baking†feature[1]. - - [1]: https://gitlab.com/tezos/tzip/-/blob/367628e1a576c3926bedc1d6107b2945607c2605/drafts/current/draft-liquidity_baking.md - - We remind that this feature is built upon three smart contracts: - (1) a CPMM contract initially based on Dexter 2, and (2) two - tokens contracts. - - Our purpose for Liquidity Baking is to easily express and test - invariants regarding the execution of these contracts. To that - end, we have introduced a set of dedicated types to describe - arbitrary contexts in terms of account balances (see - [Liquidity_baking_machine.specs]), along with [build] functions - that turn a description of a context into concrete states. - - In this module, we provide QCheck2 generators which allow to - construct arbitrary specifications for states, and so-called - scenarios ({i i.e.}, sequences of entrypoint calls). *) - -open Liquidity_baking_machine - -(** [gen_specs max_tzbtc max_liquidity] constructs arbitrary Liquidity - Baking [specs] for an initial state, where at most [max_tzbtc] and - [max_liquidity] are shared among an arbitrary number of implicit - accounts. *) -val gen_specs : tzbtc -> liquidity -> specs QCheck2.Gen.t - -(** [gen_scenario max_tzbtc max_liquidity size] constructs arbitrary - Liquidity Baking [specs] with a semantics similar to [gen_specs], along with sequences of {b valid} - scenarios ({i i.e.}, sequences of entrypoint calls) of length - [size]. By valid, we mean that running the scenario using a - Liquidity baking machine initialized with the [specs] should - succeed. *) -val gen_scenario : - tzbtc -> liquidity -> int -> (specs * contract_id step list) QCheck2.Gen.t - -(** [print_scenario scenario] produces a string representation of [scenario], - as produced by [gen_scenario]. *) -val print_scenario : specs * contract_id step list -> string - -(** [gen_adversary_scenario max_tzbtc max_liquidity size] constructs - arbitrary scenarios that can be used to challenge the “no global - gain†property of Liquidity Baking. - - The key idea of this property is the following: a given contract - cannot profit from Liquidity Baking if they are the only one to - interact with the CPMM (in the absence of subsidies). The scenario - generated by [gen_adversary_scenario] only consists in [step] - performed by one contract. This contract is identified by the - [contract_id] returned by this function. *) -val gen_adversary_scenario : - tzbtc -> - liquidity -> - int -> - (specs * contract_id * contract_id step list) QCheck2.Gen.t - -(** [print_adversary_scenario scenario] produces a string representation of [scenario], - as produced by [gen_adversary_scenario]. *) -val print_adversary_scenario : - specs * contract_id * contract_id step list -> string diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/liquidity_baking_machine.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/liquidity_baking_machine.ml deleted file mode 100644 index 20a6ba32c9b5ad3ad2ff4d4f3760f9d9837bcf7f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/liquidity_baking_machine.ml +++ /dev/null @@ -1,1362 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* Copyright (c) 2022 Trili Tech *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Protocol -open Alpha_context - -(** To implement the interface of this module, as described and - documented in the related MLI file, we rely on the OCaml module - system. More precisely, most of the implementation of the two - public machines ([ValidationMachine] and [SymbolicMachine]) is - derived by means of functors. - - The machines provide two key functions which can be used in a - test suite: - - - [M.build specs] which allows to construct an initial state of - a machine [M] that satisfies the properties described by - [specs] (along with the so-called “environment†of the - machine) - - [M.step s env state] (resp. [M.run]) which allows to execute a - so-called scenario [step] (resp. a sequence of [step]s, {i - i.e.}, a complete scenario) by the machine [M] from the state - [state]. - - The module is organized as follows: - - 1. We introduce the necessary abstractions we later use to - specify the properties the initial state of a given machine - needs to satisfy (most notably the [specs] type). - 2. Then, we introduce the [step] type, which describes the - various actions we can make a machine perform as part of a - more complete scenario. - 3. We introduce the [MACHINE] module type which lists the - necessary types and functions we need to derive a machine - capable of executing scenarios, and the [Machine.Make] - functor that we can use to derive such a machine - automatically. - 4. We introduce the [MACHINE_WITH_INIT] module type which is a - superset of [MACHINE], extended with an [init] function - (analogous to {! Context.init_n}) to create an initial, mostly - blank state, and the [MachineBuilder.Make] functor that we - can use to derive a machine with a [build] function. - 5. We construct the [ConcreteMachine], that allows to - asynchronously execute scenarios against the Tezos - blockchain. - 6. We implement the [AbstractMachine.Make] functor, which we - can use to construct machines that can simulate the - execution scenarios completely off-chains, by reimplementing - the LB features logic in pure OCaml. - 7. We use [AbstractMachine.Make] to create the [SymbolicMachine]. - 8. We use the [AbstractMachine.Make] functor in conjuction with - the [ConcreteMachine] to introduce the [ValidationMachine]. - - _ - / \ A warning for developers willing to modify this module: - / | \ dealing with the subsidy of the Liquidity Baking (LB) - / · \ feature is probably the main source of complexity and - /_______\ fragility of this module. - - At several places (marked with a /!\ note), we need to predict the - xtz pool of the CPMM contract, in order to compute the amount of - tzBTC token it will provide or request. To make this prediction, - we need to determine how many blocks have been/will be baked. This - means that each time we modify the code of the machine functors, - we will probably have to modify the code marked with /!\ too. - - To reduce the potential to get things wrong, we have introduced - constants to prevent the use of “magic numbers†(numbers whose - meaning cannot be guessed only by looking at the formula). The - value of these constants is not statically checked, so pay extra - attention before modifying them. - - Ideally, we could probably compute these magic numbers using a - dedicated machine, whose purpose would be to count the number of - call to the [bake] function. For the sake of simplicity, we do not - do it currently. *) - -(** The number of blocks baked in order to execute the {! - AddLiquidity} step. *) -let blocks_per_add_liquidity_step = 2L - -(** The number of blocks baked by the [init] function. Since - Tenderbake, we need to compensate for deposits, so the number is - no longer constant. It is linear wrt. the number of accounts. *) -let blocks_during_init len = Int64.add 3L len - -(** The number of blocks baked by the [mint_tzbtc] functions *) -let blocks_per_mint_tzbtc = 1L - -(** A timestamp “far in the future†which should not be exceeded when - running tests. *) -let far_future = Script_timestamp.of_zint (Z.of_int 42_000) -(* Hypothesis: the tests start at timestamp 0, and 42000 is - “big enough.†*) - -(* --------------------------------------------------------------------------- *) - -(** {1 Miscellaneous Helpers} *) -module List_helpers = struct - let rec zip l r = - match (l, r) with - | xl :: rstl, xr :: rstr -> (xl, xr) :: zip rstl rstr - | _ -> [] - - let nth_exn l n = - match List.nth l n with - | Some x -> x - | _ -> raise (Invalid_argument "nth_exn") - - let assoc_exn c l = - match List.assoc ~equal:( = ) c l with - | Some x -> x - | _ -> raise (Invalid_argument "assoc_exn") -end - -(* --------------------------------------------------------------------------- *) - -(** {1 Characterizing Initial Machines States} *) - -(** In order to run so-called scenarios against our machines, we first - need to characterize their initial state. *) - -type xtz = int64 - -type tzbtc = int - -type liquidity = int - -type balances = {xtz : xtz; tzbtc : tzbtc; liquidity : liquidity} - -let pp_balances fmt b = - Format.fprintf - fmt - "@[{xtz = %a; tzbtc = %d; liquidity = %d}@]" - Tez.pp - (Tez.of_mutez_exn b.xtz) - b.tzbtc - b.liquidity - -let xtz {xtz; _} = xtz - -type specs = { - cpmm_min_xtz_balance : xtz; - cpmm_min_tzbtc_balance : tzbtc; - accounts_balances : balances list; -} - -let pp_specs fmt specs = - Format.( - fprintf - fmt - "@[{@ @[cpmm = {min_xtz = %a; min_tzbtc = %d}@ @[accounts = \ - [@ %a@ ]@]@]@ }@]" - Tez.pp - (Tez.of_mutez_exn specs.cpmm_min_xtz_balance) - specs.cpmm_min_tzbtc_balance - (pp_print_list ~pp_sep:pp_print_space pp_balances) - specs.accounts_balances) - -(* --------------------------------------------------------------------------- *) - -(** {1 Scenario [step] }*) - -type 'a step = - | SellTzBTC of {source : 'a; destination : 'a; tzbtc_deposit : tzbtc} - | BuyTzBTC of {source : 'a; destination : 'a; xtz_deposit : xtz} - | AddLiquidity of {source : 'a; destination : 'a; xtz_deposit : xtz} - | RemoveLiquidity of {source : 'a; destination : 'a; lqt_burned : liquidity} - -let pp_step pp_contract fmt = function - | SellTzBTC p -> - Format.( - fprintf - fmt - "@[SellTzBTC(%a, %dtzâ‚¿, %a)@]" - pp_contract - p.source - p.tzbtc_deposit - pp_contract - p.destination) - | BuyTzBTC p -> - Format.( - fprintf - fmt - "@[BuyTzBTC(%a, %aꜩ, %a)@]" - pp_contract - p.source - Tez.pp - (Tez.of_mutez_exn p.xtz_deposit) - pp_contract - p.destination) - | AddLiquidity p -> - Format.( - fprintf - fmt - "@[AddLiquidity(%a, %aꜩ, %a)@]" - pp_contract - p.source - Tez.pp - (Tez.of_mutez_exn p.xtz_deposit) - pp_contract - p.destination) - | RemoveLiquidity p -> - Format.( - fprintf - fmt - "@[RemoveLiquidity(%a, %d lqt, %a)@]" - pp_contract - p.source - p.lqt_burned - pp_contract - p.destination) - -type contract_id = - | Cpmm - | Holder - | TzBTC - | TzBTCAdmin - | Liquidity - | LiquidityAdmin - | ImplicitAccount of int - -let contract_id_to_string = function - | Holder -> "holder" - | Cpmm -> "cpmm" - | TzBTC -> "tzbtc" - | TzBTCAdmin -> "tzbtc_admin" - | Liquidity -> "lqt" - | LiquidityAdmin -> "lqt_admin" - | ImplicitAccount i -> Format.sprintf "#%d" i - -let pp_contract_id fmt c = Format.(fprintf fmt "[%s]" (contract_id_to_string c)) - -(* --------------------------------------------------------------------------- *) - -(** {1 Machines} *) - -(** {2 Machine Environment} *) - -type 'a env = { - cpmm_contract : 'a; - tzbtc_contract : 'a; - tzbtc_admin : 'a; - liquidity_contract : 'a; - liquidity_admin : 'a; - implicit_accounts : 'a list; - holder : 'a; - subsidy : xtz; -} - -let refine_contract env = function - | Cpmm -> env.cpmm_contract - | TzBTC -> env.tzbtc_contract - | TzBTCAdmin -> env.tzbtc_admin - | Liquidity -> env.liquidity_contract - | LiquidityAdmin -> env.liquidity_admin - | Holder -> env.holder - | ImplicitAccount i -> List_helpers.nth_exn env.implicit_accounts i - -let refine_step env step = - match step with - | SellTzBTC p -> - SellTzBTC - { - p with - source = refine_contract env p.source; - destination = refine_contract env p.destination; - } - | BuyTzBTC p -> - BuyTzBTC - { - p with - source = refine_contract env p.source; - destination = refine_contract env p.destination; - } - | AddLiquidity p -> - AddLiquidity - { - p with - source = refine_contract env p.source; - destination = refine_contract env p.destination; - } - | RemoveLiquidity p -> - RemoveLiquidity - { - p with - source = refine_contract env p.source; - destination = refine_contract env p.destination; - } - -(** {2 Machine Module Type} *) - -module type MACHINE = sig - type 'a m - - type contract - - type t - - type operation - - val pp_contract : Format.formatter -> contract -> unit - - val ( >>= ) : 'a m -> ('a -> 'b m) -> 'b m - - val fold_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m - - val pure : 'a -> 'a m - - val get_balances : contract -> contract env -> t -> balances m - - val get_xtz_balance : contract -> t -> xtz m - - val get_tzbtc_balance : contract -> contract env -> t -> tzbtc m - - val get_liquidity_balance : contract -> contract env -> t -> liquidity m - - val get_cpmm_total_liquidity : contract env -> t -> liquidity m - - val bake : - invariant:(contract env -> t -> bool m) -> - baker:contract -> - operation list -> - contract env -> - t -> - t m - - val transaction : src:contract -> contract -> xtz -> t -> operation m - - val token_to_xtz : - src:contract -> contract -> tzbtc -> contract env -> t -> operation m - - val xtz_to_token : - src:contract -> contract -> xtz -> contract env -> t -> operation m - - (* [mint_or_burn_tzbtc contract amount env state] will construct an - operation to credit or remove [amount] tzbtc tokens to [contract] *) - val mint_or_burn_tzbtc : - contract -> liquidity -> contract env -> t -> operation m - - (** [approve_tzbtc contract amount env state] will construct an - operation to authorize the CPMM contract to spend [amount] tzbtc - on behalf of [contract] *) - val approve_tzbtc : contract -> tzbtc -> contract env -> t -> operation m - - val add_liquidity : - src:contract -> contract -> xtz -> tzbtc -> contract env -> t -> operation m - - val remove_liquidity : - src:contract -> contract -> liquidity -> contract env -> t -> operation m - - val reveal : Account.t -> t -> operation m -end - -(** {2 Tezos Constants} *) - -let default_subsidy = - let open Tezos_protocol_017_PtNairob_parameters in - Tez.to_mutez @@ Default_parameters.constants_test.liquidity_baking_subsidy - -let security_deposit = 640_000_000L - -(* When calling [Context.init_n] with a list of initial balances, the - sum of these balances should be equal to this constant. *) -let total_xtz = 32_000_000_000_000L - -let tzbtc_admin_account : Account.t = - { - pkh = - Signature.Public_key_hash.of_b58check_exn - "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"; - pk = - Signature.Public_key.of_b58check_exn - "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav"; - sk = - Signature.Secret_key.of_b58check_exn - "edsk3gUfUPyBSfrS9CCgmCiQsTCHGkviBDusMxDJstFtojtc1zcpsh"; - } - -let cpmm_initial_balance = {xtz = 100L; tzbtc = 1; liquidity = 0} - -let cpmm_initial_liquidity_supply = 100 - -(** {2 Machine Functor} *) - -module Machine = struct - module Make (S : MACHINE) = struct - open S - - let mint_tzbtc destination ~invariant amount env state = - mint_or_burn_tzbtc destination amount env state >>= fun op -> - bake ~invariant ~baker:env.holder [op] env state - - let add_liquidity ~invariant src dst xtz_deposit tzbtc_deposit env state = - approve_tzbtc src tzbtc_deposit env state >>= fun lqt_op -> - bake ~invariant ~baker:env.holder [lqt_op] env state >>= fun state -> - add_liquidity ~src dst xtz_deposit tzbtc_deposit env state - >>= fun cpmm_op -> bake ~invariant ~baker:env.holder [cpmm_op] env state - - let remove_liquidity ~invariant src dst lqt_burned env state = - remove_liquidity ~src dst lqt_burned env state >>= fun cpmm_op -> - bake ~invariant ~baker:env.holder [cpmm_op] env state - - let sell_tzbtc ~invariant src dst tzbtc_deposit env state = - approve_tzbtc src tzbtc_deposit env state >>= fun tzbtc_op -> - bake ~invariant ~baker:env.holder [tzbtc_op] env state >>= fun state -> - token_to_xtz ~src dst tzbtc_deposit env state >>= fun cpmm_op -> - bake ~invariant ~baker:env.holder [cpmm_op] env state - - let buy_tzbtc ~invariant src dst xtz_deposit env state = - xtz_to_token ~src dst xtz_deposit env state >>= fun cpmm_op -> - bake ~invariant ~baker:env.holder [cpmm_op] env state - - let check_state_satisfies_specs (env : S.contract env) (state : S.t) - (specs : specs) = - let implicit_accounts_targets = - List_helpers.zip env.implicit_accounts specs.accounts_balances - in - fold_m - (fun _ acc -> - let expected = List_helpers.assoc_exn acc implicit_accounts_targets in - get_balances acc env state >>= fun amount -> - assert (expected = amount) ; - pure ()) - () - env.implicit_accounts - >>= fun () -> - get_tzbtc_balance env.cpmm_contract env state - >>= fun cpmm_tzbtc_balance -> - assert (specs.cpmm_min_tzbtc_balance <= cpmm_tzbtc_balance) ; - get_xtz_balance env.cpmm_contract state >>= fun current_cpmm_xtz -> - assert ( - Int64.(to_int specs.cpmm_min_xtz_balance <= to_int @@ current_cpmm_xtz)) ; - pure () - - (** [predict_required_tzbtc_deposit xtz_deposit env state] - predicts the tzbtc deposit which will be required by the CPMM - contract for a deposit of [xtz_deposit]. - - This function is used by the machines to make the according - call to the [approve] entrypoint of the TzBTC contract. *) - let predict_required_tzbtc_deposit xtz_deposit env state = - get_xtz_balance env.cpmm_contract state >>= fun xtzPool -> - (* /!\ We need to take into accounts the number of blocks baked - to actually call the [add_liquidity] entry point of the - CPMM. *) - let xtzPool = - Tez.of_mutez_exn - Int64.(add xtzPool (mul blocks_per_add_liquidity_step env.subsidy)) - in - get_tzbtc_balance env.cpmm_contract env state >>= fun tokenPool -> - let tokenPool = Z.of_int tokenPool in - get_cpmm_total_liquidity env state >>= fun lqtTotal -> - let lqtTotal = Z.of_int lqtTotal in - let amount = Tez.of_mutez_exn xtz_deposit in - let _, tokens_deposited = - Cpmm_logic.Simulate_raw.addLiquidity - ~tokenPool - ~xtzPool - ~lqtTotal - ~amount - in - pure (Z.to_int tokens_deposited) - - let step ?(invariant = fun _ _ -> pure true) s env state = - match s with - | SellTzBTC {source; destination; tzbtc_deposit} -> - sell_tzbtc ~invariant source destination tzbtc_deposit env state - | BuyTzBTC {source; destination; xtz_deposit} -> - buy_tzbtc ~invariant source destination xtz_deposit env state - | AddLiquidity {source; destination; xtz_deposit} -> - predict_required_tzbtc_deposit xtz_deposit env state - >>= fun tzbtc_deposit -> - add_liquidity - ~invariant - source - destination - xtz_deposit - tzbtc_deposit - env - state - | RemoveLiquidity {source; destination; lqt_burned} -> - remove_liquidity ~invariant source destination lqt_burned env state - - let run ?(invariant = fun _ _ -> pure true) scenario env state = - fold_m - (fun state s -> step ~invariant (refine_step env s) env state) - state - scenario - end -end - -let initial_xtz_repartition accounts_balances = - let distributed_xtz = List.fold_left Int64.add 0L accounts_balances in - let bootstrap1_xtz = Int64.sub total_xtz distributed_xtz in - let bootstrap_balances = bootstrap1_xtz :: accounts_balances in - let n = List.length bootstrap_balances in - (n, bootstrap_balances) - -(* --------------------------------------------------------------------------- *) - -(** {1 Machines with a [build] Function} *) - -module type MACHINE_WITH_INIT = sig - include MACHINE - - (** [init balances] will create an “initial†state wherein the - [balances] have been distributed to [n] implicit contracts ([n] - being the size of the [balances] list). This function also - creates a [holder] implicit account which has the rest of the - xtz liquidity (the test framework forces the sum of xtz balances - to be equal to [total_xtz]). [init] also accepts an optional - argument [subsidy] to modify the default value of the subsidy - minted by the protocol in favor of the CPMM. *) - val init : - invariant:(contract env -> t -> bool m) -> - ?subsidy:xtz -> - xtz list -> - (t * contract env) m -end - -(** [initial_xtz_pool] balances predicts the value of the CPMM’s xtz - pool just before we start using the [add_liquidity] entrypoint to - provide to each implicit accounts the necessary liquidity - tokens. *) -let initial_xtz_pool balances subsidy = - (* /!\ In addition to the initial CPMM balances, we need to take - into account the subsidies of each block baked before this - point, which currently consist in: - - - One call to the [init] function - - One call to the [mint_tzbtc] function per implicit - accounts - - If the [build] function changes, this functions needs to be - updated accordingly. *) - let len = Int64.of_int (List.length balances) in - Int64.( - add - cpmm_initial_balance.xtz - (mul - (add (blocks_during_init len) (mul blocks_per_mint_tzbtc len)) - subsidy)) - -(** [predict_initial_balances xtz_pool tzbtc_pool lqt_total balances] - evaluates the extra xtz and tzbtc tokens to add to each balance of - the list [balances] so that the related implicit accounts can call - the [add_liquidity] entrypoint in order to have the required - liquidity token. - - For instance, for a balance [b] such that [b.liquidity = 10], we - compute [xtz_etra] and [tzbtc_extra] so that the implicit account - will be able to buy [10] liquidity tokens, and replace [b] with - [{b with xtz = b.xtz + xtz_extra; tzbtc = b.tzbtc + tzbtc_extra}] - in the returned list. - - The implementation of this function is made more complex than it - should due to the mechanism of subsidy of LB. In particular, it is - depends on the number of block baked to buy liquidities. *) -let predict_initial_balances balances subsidy = - let open Z in - let subsidy_z = of_int64 subsidy in - (* Due to the roundness of [Z.( / )], it is not straightforward to - find the inverse of the equation used to compute the number of - liquidity tokens bought with the [add_liquidity] entrypoint. To - find the suitable number of xtz to propose in order to buy - [liquidity_target], we naively search for the correct - solution. We compute a [xtz_candidate] by ignoring the roundness - of [Z.( / )], then increment it until it works. *) - let find_xtz_extra xtz_pool lqt_total liquidity_target = - let rec aux xtz_candidate = - let liquidity_z = xtz_candidate * lqt_total / xtz_pool in - if liquidity_z = liquidity_target then xtz_candidate - else aux (xtz_candidate + Z.one) - in - let xtz_extra_candidate = liquidity_target * xtz_pool / lqt_total in - aux xtz_extra_candidate - in - let rec predict_initial_balances xtz_pool tzbtc_pool lqt_total = function - | {xtz; tzbtc; liquidity} :: rst -> - (* balance inputs *) - (* /!\ We compute two blocks per [add_liquidity] entrypoint, - hence the two subsidies *) - let xtz_pool = - xtz_pool + (Z.of_int64 blocks_per_add_liquidity_step * subsidy_z) - in - let xtz_z = of_int64 xtz in - let tzbtc_z = of_int tzbtc in - let liquidity_z = of_int liquidity in - (* compute extra for being able to buy liquidity tokens *) - let xtz_extra = find_xtz_extra xtz_pool lqt_total liquidity_z in - let tzbtc_extra = cdiv (xtz_extra * tzbtc_pool) xtz_pool in - (* compute new balances *) - let xtz = to_int64 (xtz_z + xtz_extra) in - let tzbtc = to_int (tzbtc_z + tzbtc_extra) in - let liquidity = to_int liquidity_z in - (* new pools *) - let xtz_pool' = xtz_pool + xtz_extra in - let tzbtc_pool' = tzbtc_pool + tzbtc_extra in - let lqt_total' = lqt_total + liquidity_z in - (* recursion time *) - {xtz; tzbtc; liquidity} - :: predict_initial_balances xtz_pool' tzbtc_pool' lqt_total' rst - | [] -> [] - in - predict_initial_balances - (of_int64 @@ initial_xtz_pool balances subsidy) - (of_int cpmm_initial_balance.tzbtc) - (of_int cpmm_initial_liquidity_supply) - balances - -module MachineBuilder = struct - module Make (S : MACHINE_WITH_INIT) = struct - open S - include Machine.Make (S) - - let build : - ?invariant:(S.contract env -> S.t -> bool m) -> - ?subsidy:xtz -> - specs -> - (S.t * S.contract env) m = - fun ?(invariant = fun _ _ -> pure true) - ?(subsidy = default_subsidy) - ({cpmm_min_xtz_balance; accounts_balances; cpmm_min_tzbtc_balance} as - specs) -> - let accounts_balances_with_extra = - predict_initial_balances accounts_balances subsidy - in - let xtz_balances_with_extra = List.map xtz accounts_balances_with_extra in - (* 1. Create an initial context *) - init ~invariant ~subsidy xtz_balances_with_extra >>= fun (state, env) -> - invariant env state >>= fun cond -> - assert cond ; - (* 2. Provide the initial tzBTC liquidities to implicit accounts *) - let accounts = - List_helpers.zip - env.implicit_accounts - (List_helpers.zip accounts_balances accounts_balances_with_extra) - in - fold_m - (fun state (address, (_, balances)) -> - mint_tzbtc ~invariant address balances.tzbtc env state) - state - accounts - >>= fun state -> - (* 3. Make implicit accounts buy liquidities *) - fold_m - (fun state (address, (target_balances, balances_with_extra)) -> - let xtz = Int64.sub balances_with_extra.xtz target_balances.xtz in - let tzbtc = balances_with_extra.tzbtc - target_balances.tzbtc in - add_liquidity ~invariant address address xtz tzbtc env state) - state - accounts - >>= fun state -> - (* 4. Provide any missing tzbtc tokens to [cpmm_contract], if necessary *) - get_tzbtc_balance env.cpmm_contract env state - >>= fun current_cpmm_tzbtc_balance -> - let tzbtc_missing = cpmm_min_tzbtc_balance - current_cpmm_tzbtc_balance in - (if 0 < tzbtc_missing then - (* 4.1. Provide the tokens to the [bootstrap1] account, as a - temporary holder for CPMM missing tzBTC balance *) - mint_tzbtc ~invariant env.holder tzbtc_missing env state >>= fun state -> - (* 4.1. Make [bootstrap1] buy some xtz against the appropriate - amount of tzbtc *) - sell_tzbtc ~invariant env.holder env.holder tzbtc_missing env state - else pure state) - >>= fun state -> - (* 5. Provide any missing xtz tokens to [cpmm_contract], if necessary *) - get_xtz_balance env.cpmm_contract state - >>= fun current_cpmm_xtz_balance -> - let xtz_missing = - Int64.sub cpmm_min_xtz_balance current_cpmm_xtz_balance - in - (if 0L < xtz_missing then - transaction ~src:env.holder env.cpmm_contract xtz_missing state - >>= fun op -> bake ~invariant ~baker:env.holder [op] env state - else pure state) - >>= fun state -> - check_state_satisfies_specs env state specs >>= fun () -> pure (state, env) - end -end - -(* --------------------------------------------------------------------------- *) - -module ConcreteBaseMachine : - MACHINE_WITH_INIT - with type 'a m = 'a tzresult Lwt.t - and type contract = Contract.t - and type t = Block.t = struct - type 'a m = 'a tzresult Lwt.t - - type contract = Contract.t - - type operation = packed_operation - - type t = Block.t - - let pp_contract = Contract.pp - - let ( >>= ) = ( >>=? ) - - let fold_m = Environment.List.fold_left_es - - let pure = return - - let get_xtz_balance contract blk = - Context.Contract.balance (B blk) contract >>= fun x -> - pure @@ Tez.to_mutez x - - let get_tzbtc_balance contract env blk = - let destination = Destination.Contract contract in - Lqt_fa12_repr.Storage.getBalance_opt - (B blk) - ~contract:env.tzbtc_contract - {destination; entrypoint = Entrypoint.default} - >>=? fun mamount -> - pure (Option.value (Option.map Z.to_int mamount) ~default:0) - - let get_liquidity_balance contract env blk = - let destination = Destination.Contract contract in - Lqt_fa12_repr.Storage.getBalance_opt - (B blk) - ~contract:env.liquidity_contract - {destination; entrypoint = Entrypoint.default} - >>=? fun mamount -> - pure (Option.value (Option.map Z.to_int mamount) ~default:0) - - let get_cpmm_total_liquidity env blk = - Cpmm_repr.Storage.get (B blk) ~contract:env.cpmm_contract - >>=? fun cpmm_storage -> pure @@ Z.to_int cpmm_storage.lqtTotal - - let get_balances contract env blk = - get_xtz_balance contract blk >>= fun xtz -> - get_tzbtc_balance contract env blk >>= fun tzbtc -> - get_liquidity_balance contract env blk >>= fun liquidity -> - pure {xtz; tzbtc; liquidity} - - let bake ~invariant ~baker ops env blk = - Incremental.begin_construction - ~policy:(Block.By_account (Context.Contract.pkh baker)) - blk - >>= fun incr -> - fold_m Incremental.add_operation incr ops >>= fun incr -> - Incremental.finalize_block incr >>= fun blk -> - invariant env blk >>= fun cond -> - assert cond ; - return blk - - let reveal (account : Account.t) blk = Op.revelation (B blk) account.pk - - let transaction ~src dst amount blk = - Op.transaction (B blk) src dst (Tez.of_mutez_exn amount) - - let token_to_xtz ~src dst tzbtc_deposit env blk = - Cpmm_repr.transaction - (B blk) - ~src - ~contract:env.cpmm_contract - (Cpmm_repr.Parameter.TokenToXtz - { - to_ = dst; - minXtzBought = Tez.zero; - tokensSold = Z.of_int tzbtc_deposit; - deadline = far_future; - }) - - let xtz_to_token ~src dst amount env blk = - Cpmm_repr.transaction - (B blk) - ~src - ~contract:env.cpmm_contract - (Cpmm_repr.Parameter.XtzToToken - {to_ = dst; minTokensBought = Z.zero; deadline = far_future}) - ~amount:(Tez.of_mutez_exn amount) - - let approve_tzbtc src tzbtc env blk = - let maxTokensDeposited = Z.of_int tzbtc in - Lqt_fa12_repr.transaction - (B blk) - ~src - ~contract:env.tzbtc_contract - (Lqt_fa12_repr.Parameter.Approve - {spender = env.cpmm_contract; value = maxTokensDeposited}) - - let mint_or_burn_tzbtc target amount env blk = - let quantity = Z.of_int amount in - let ctxt = Context.B blk in - Lqt_fa12_repr.transaction - ctxt - ~src:env.tzbtc_admin - ~contract:env.tzbtc_contract - (Lqt_fa12_repr.Parameter.mintOrBurn {target; quantity}) - - let add_liquidity ~src dst xtz_deposit tzbtc_deposit env blk = - let amount = Tez.of_mutez_exn xtz_deposit in - let maxTokensDeposited = Z.of_int tzbtc_deposit in - Cpmm_repr.transaction - (B blk) - ~src - ~contract:env.cpmm_contract - ~amount - (Cpmm_repr.Parameter.AddLiquidity - { - owner = dst; - maxTokensDeposited; - minLqtMinted = Z.zero; - deadline = far_future; - }) - - let remove_liquidity ~src dst lqt_burned env blk = - let lqtBurned = Z.of_int lqt_burned in - Cpmm_repr.transaction - (B blk) - ~src - ~contract:env.cpmm_contract - (Cpmm_repr.Parameter.RemoveLiquidity - { - to_ = dst; - lqtBurned; - minXtzWithdrawn = Tez.zero; - minTokensWithdrawn = Z.zero; - deadline = far_future; - }) - - let reveal_tzbtc_admin ~invariant env state = - Account.add_account tzbtc_admin_account ; - transaction ~src:env.holder env.tzbtc_admin 1L state >>= fun op1 -> - bake ~invariant ~baker:env.holder [op1] env state >>= fun state -> - reveal tzbtc_admin_account state >>= fun op2 -> - bake ~invariant ~baker:env.holder [op2] env state - - let init ~invariant ?subsidy accounts_balances = - let liquidity_baking_subsidy = Option.map Tez.of_mutez_exn subsidy in - let n, bootstrap_balances = initial_xtz_repartition accounts_balances in - Context.init_n - n - ~consensus_threshold:0 - ~bootstrap_balances - ~cost_per_byte:Tez.zero - ~endorsing_reward_per_slot:Tez.zero - ~baking_reward_bonus_per_slot:Tez.zero - ~baking_reward_fixed_portion:Tez.zero - ~origination_size:0 - ~blocks_per_cycle:10_000l - ~cycles_per_voting_period:1l - ?liquidity_baking_subsidy - () - >>= function - | blk, holder :: accounts -> - let ctxt = Context.B blk in - Context.get_liquidity_baking_cpmm_address ctxt >>= fun cpmm_contract -> - Context.Contract.storage ctxt cpmm_contract >>= fun storage -> - let storage = Cpmm_repr.Storage.of_expr_exn (Micheline.root storage) in - let tzbtc_contract = storage.tokenAddress in - let liquidity_contract = storage.lqtAddress in - Context.Contract.storage ctxt tzbtc_contract >>= fun storage -> - let storage = - Lqt_fa12_repr.Storage.of_expr_exn (Micheline.root storage) - in - let tzbtc_admin = storage.admin in - Context.Contract.storage ctxt liquidity_contract >>= fun storage -> - let storage = - Lqt_fa12_repr.Storage.of_expr_exn (Micheline.root storage) - in - let liquidity_admin = storage.admin in - Context.get_liquidity_baking_subsidy (B blk) >>=? fun subsidy -> - let env = - { - cpmm_contract = Contract.Originated cpmm_contract; - tzbtc_contract = Contract.Originated tzbtc_contract; - tzbtc_admin; - liquidity_contract = Contract.Originated liquidity_contract; - liquidity_admin; - implicit_accounts = accounts; - holder; - subsidy = Tez.to_mutez subsidy; - } - in - reveal_tzbtc_admin ~invariant:(fun _ _ -> pure true) env blk - >>= fun blk -> - mint_or_burn_tzbtc env.cpmm_contract cpmm_initial_balance.tzbtc env blk - >>= fun op -> - bake ~invariant:(fun _ _ -> pure true) ~baker:env.holder [op] env blk - >>= fun blk -> - (* Since Tenderbake, we need to compensate for potential deposits - related to the consensus. *) - List.fold_left_i_es - (fun idx blk contract -> - match List.nth accounts_balances idx with - | Some target -> - get_xtz_balance contract blk >>=? fun balance -> - let delta = Int64.(sub target balance) in - if Compare.Int64.(0L = delta) then - (* We need to be able to determine the number of - blocks baked in the init function (to predict the - CPMM balance). So even when there is no delta to - compensate with, we bake an empty block. *) - bake - ~invariant:(fun _ _ -> pure true) - ~baker:env.holder - [] - env - blk - else if Compare.Int64.(0L < delta) then - transaction ~src:env.holder contract delta blk >>= fun op -> - bake - ~invariant:(fun _ _ -> pure true) - ~baker:env.holder - [op] - env - blk - else assert false - | None -> assert false) - blk - accounts - >>=? fun blk -> - (* We did not check the invariant before, because the CPMM - contract was in an inconsistent state. More precisely, it - was supposed to hold tzbtc tokens, while in practice it was - not. This was solved by the last call to [bake]. *) - invariant env blk >>= fun cond -> - assert cond ; - pure (blk, env) - | _ -> assert false -end - -module ConcreteMachine = struct - include ConcreteBaseMachine - include Machine.Make (ConcreteBaseMachine) - include MachineBuilder.Make (ConcreteBaseMachine) -end - -(* --------------------------------------------------------------------------- *) - -(** {1 Abstract Machines} *) - -type 'a state = { - cpmm_total_liquidity : liquidity; - accounts_balances : ('a * balances) list; -} - -let refine_state env state = - { - cpmm_total_liquidity = state.cpmm_total_liquidity; - accounts_balances = - List.map - (fun (c, b) -> (refine_contract env c, b)) - state.accounts_balances; - } - -let update_balances account f state = - match List.assoc ~equal:( = ) account state.accounts_balances with - | Some b -> - { - state with - accounts_balances = - (account, f b) - :: List.remove_assoc ~equal:( = ) account state.accounts_balances; - } - | _ -> assert false - -let update_xtz_balance account f = - update_balances account (fun b -> {b with xtz = f b.xtz}) - -let update_tzbtc_balance account f = - update_balances account (fun b -> {b with tzbtc = f b.tzbtc}) - -let update_liquidity_balance account f = - update_balances account (fun b -> {b with liquidity = f b.liquidity}) - -let transfer_xtz_balance src dest d st = - update_xtz_balance src (fun b -> Int64.sub b d) st - |> update_xtz_balance dest (fun b -> Int64.add b d) - -let transfer_tzbtc_balance src dest d st = - update_tzbtc_balance src (fun b -> b - d) st - |> update_tzbtc_balance dest (fun b -> d + b) - -module AbstractMachine = struct - module type C = sig - type t - - val pp : Format.formatter -> t -> unit - end - - module Make (C : C) : - MACHINE with type 'a m = 'a and type contract = C.t and type t = C.t state = - struct - type 'a m = 'a - - type contract = C.t - - type t = C.t state - - type operation = t -> t - - let pp_contract = C.pp - - let ( >>= ) x f = f x - - let pure = Fun.id - - let fold_m = List.fold_left - - let get_balances account state = - match List.assoc ~equal:( = ) account state.accounts_balances with - | Some x -> x - | _ -> assert false - - let get_xtz_balance account state = (get_balances account state).xtz - - let get_tzbtc_balance account _env state = - (get_balances account state).tzbtc - - let get_liquidity_balance account _env state = - (get_balances account state).liquidity - - let get_balances account _env state = get_balances account state - - let get_cpmm_total_liquidity _env state = state.cpmm_total_liquidity - - let reveal _pk _state state = state - - let transaction ~src dst amount _ state = - transfer_xtz_balance src dst amount state - - let xtz_bought tzbtc env state = - let xtzPool = - Tez.of_mutez_exn @@ get_xtz_balance env.cpmm_contract state - in - let tokenPool = - Z.of_int @@ get_tzbtc_balance env.cpmm_contract env state - in - let tokensSold = Z.of_int tzbtc in - let xtz_bought, xtz_net_bought = - Cpmm_logic.Simulate_raw.tokenToXtz ~xtzPool ~tokenPool ~tokensSold - in - (Z.to_int64 xtz_net_bought, Tez.to_mutez xtz_bought) - - let token_to_xtz ~src dst amount env _ state = - let xtz_bought, xtz_net_bought = xtz_bought amount env state in - state - |> transfer_tzbtc_balance src env.cpmm_contract amount - |> update_xtz_balance env.cpmm_contract (fun b -> Int64.sub b xtz_bought) - |> update_xtz_balance dst (Int64.add xtz_net_bought) - - let tzbtc_bought env state amount = - let xtzPool = - Tez.of_mutez_exn @@ get_xtz_balance env.cpmm_contract state - in - let tokenPool = - Z.of_int @@ get_tzbtc_balance env.cpmm_contract env state - in - let amount = Tez.of_mutez_exn amount in - let tzbtc_bought, xtz_earnt = - Cpmm_logic.Simulate_raw.xtzToToken ~xtzPool ~tokenPool ~amount - in - (Z.to_int tzbtc_bought, Z.to_int64 xtz_earnt) - - let xtz_to_token ~src dst amount env _ state = - let tzbtc_bought, xtz_earnt = tzbtc_bought env state amount in - update_xtz_balance src (fun b -> Int64.sub b amount) state - |> update_xtz_balance env.cpmm_contract (Int64.add xtz_earnt) - |> transfer_tzbtc_balance env.cpmm_contract dst tzbtc_bought - - let mint_or_burn_tzbtc target amount _ _ = - update_tzbtc_balance target (( + ) amount) - - let approve_tzbtc _contract _amount _env _state = Fun.id - - let add_liquidity ~src dst xtz_deposit _tzbtc_deposit env _ state = - let xtzPool = - Tez.of_mutez_exn (get_xtz_balance env.cpmm_contract state) - in - let tokenPool = - Z.of_int (get_tzbtc_balance env.cpmm_contract env state) - in - let lqtTotal = Z.of_int state.cpmm_total_liquidity in - let amount = Tez.of_mutez_exn xtz_deposit in - let lqt_minted, tokens_deposited = - Cpmm_logic.Simulate_raw.addLiquidity - ~tokenPool - ~xtzPool - ~lqtTotal - ~amount - in - let lqt_minted = Z.to_int lqt_minted in - let tokens_deposited = Z.to_int tokens_deposited in - let state = - transfer_xtz_balance src env.cpmm_contract xtz_deposit state - |> transfer_tzbtc_balance src env.cpmm_contract tokens_deposited - |> update_liquidity_balance dst (( + ) lqt_minted) - in - { - state with - cpmm_total_liquidity = state.cpmm_total_liquidity + lqt_minted; - } - - let remove_liquidity ~src dst lqt_burned env _ state = - let xtzPool = - Tez.of_mutez_exn (get_xtz_balance env.cpmm_contract state) - in - let tokenPool = - Z.of_int (get_tzbtc_balance env.cpmm_contract env state) - in - let lqtTotal = Z.of_int state.cpmm_total_liquidity in - let lqtBurned = Z.of_int lqt_burned in - let xtz_withdrawn, tokens_withdrawn = - Cpmm_logic.Simulate_raw.removeLiquidity - ~tokenPool - ~xtzPool - ~lqtTotal - ~lqtBurned - in - let xtz_withdrawn = Tez.to_mutez xtz_withdrawn in - let tokens_withdrawn = Z.to_int tokens_withdrawn in - let state = - update_xtz_balance dst (fun b -> Int64.add b xtz_withdrawn) state - |> update_tzbtc_balance dst (( + ) tokens_withdrawn) - |> update_liquidity_balance src (fun b -> b - lqt_burned) - |> update_xtz_balance env.cpmm_contract (fun b -> - Int64.sub b xtz_withdrawn) - |> update_tzbtc_balance env.cpmm_contract (fun b -> - b - tokens_withdrawn) - in - { - state with - cpmm_total_liquidity = state.cpmm_total_liquidity - lqt_burned; - } - - (* Ideally, we should also deal with the release of security - deposit, but since our tests are not long enough for this to - happen, we omit this aspect of the simulation. *) - let bake ~invariant ~baker operations env state = - let state = - update_xtz_balance env.cpmm_contract (Int64.add env.subsidy) state - |> (fun state -> List.fold_left ( |> ) state operations) - |> update_xtz_balance baker (fun b -> Int64.sub b security_deposit) - in - assert (invariant env state) ; - state - end -end - -(* --------------------------------------------------------------------------- *) - -(** {1 Symbolic Machine} *) - -module SymbolicBaseMachine : - MACHINE_WITH_INIT - with type 'a m = 'a - and type contract = contract_id - and type t = contract_id state = struct - include AbstractMachine.Make (struct - type t = contract_id - - let pp = pp_contract_id - end) - - let init ~invariant:_ ?(subsidy = default_subsidy) accounts_balances = - let _, bootstrap_balances = initial_xtz_repartition accounts_balances in - let len = Int64.of_int (List.length accounts_balances) in - match bootstrap_balances with - | holder_xtz :: accounts -> - let xtz_cpmm = - Int64.( - add cpmm_initial_balance.xtz (mul (blocks_during_init len) subsidy)) - in - ( { - cpmm_total_liquidity = cpmm_initial_liquidity_supply; - accounts_balances = - (Cpmm, {cpmm_initial_balance with xtz = xtz_cpmm}) - :: (Holder, {xtz = holder_xtz; tzbtc = 0; liquidity = 0}) - :: (TzBTCAdmin, {xtz = 0L; tzbtc = 0; liquidity = 0}) - :: List.mapi - (fun i xtz -> - (ImplicitAccount i, {xtz; tzbtc = 0; liquidity = 0})) - accounts; - }, - { - cpmm_contract = Cpmm; - tzbtc_contract = TzBTC; - tzbtc_admin = TzBTCAdmin; - liquidity_contract = Liquidity; - liquidity_admin = LiquidityAdmin; - implicit_accounts = - List.mapi (fun i _ -> ImplicitAccount i) accounts; - holder = Holder; - subsidy; - } ) - | [] -> assert false -end - -module SymbolicMachine = struct - include SymbolicBaseMachine - include Machine.Make (SymbolicBaseMachine) - include MachineBuilder.Make (SymbolicBaseMachine) -end - -(* --------------------------------------------------------------------------- *) - -(** {1 Validation Machine} *) - -module ValidationBaseMachine : - MACHINE_WITH_INIT - with type 'a m = 'a ConcreteBaseMachine.m - and type t = ConcreteBaseMachine.t * Contract.t state - and type contract = Contract.t = struct - module GhostMachine = AbstractMachine.Make (struct - type t = Contract.t - - let pp = Contract.pp - end) - - type 'a m = 'a ConcreteBaseMachine.m - - type t = ConcreteBaseMachine.t * GhostMachine.t - - type contract = Contract.t - - type operation = ConcreteBaseMachine.operation * GhostMachine.operation - - let pp_contract = Contract.pp - - let ( >>= ) = ConcreteBaseMachine.( >>= ) - - let fold_m = ConcreteBaseMachine.fold_m - - let pure = ConcreteBaseMachine.pure - - let get_balances contract env (_, state) = - pure (GhostMachine.get_balances contract env state) - - let get_xtz_balance contract (_, state) = - pure (GhostMachine.get_xtz_balance contract state) - - let get_tzbtc_balance contract env (_, state) = - pure (GhostMachine.get_tzbtc_balance contract env state) - - let get_liquidity_balance contract env (_, state) = - pure (GhostMachine.get_liquidity_balance contract env state) - - let get_cpmm_total_liquidity env (_, state) = - pure (GhostMachine.get_cpmm_total_liquidity env state) - - let bake ~invariant ~baker ops env (blk, state) = - let cops = List.map fst ops in - let rops = List.map snd ops in - ConcreteBaseMachine.( - bake ~invariant:(fun _ _ -> pure true) ~baker cops env blk) - >>= fun blk -> - let state = - GhostMachine.bake ~invariant:(fun _ _ -> true) ~baker rops env state - in - invariant env (blk, state) >>= fun cond -> - assert cond ; - pure (blk, state) - - let transaction ~src dst xtz (blk, state) = - ConcreteBaseMachine.transaction ~src dst xtz blk >>= fun cop -> - pure (cop, GhostMachine.transaction ~src dst xtz state) - - let token_to_xtz ~src dst tzbtc env (blk, state) = - ConcreteBaseMachine.token_to_xtz ~src dst tzbtc env blk >>= fun cop -> - pure (cop, GhostMachine.token_to_xtz ~src dst tzbtc env state) - - let xtz_to_token ~src dst xtz env (blk, state) = - ConcreteBaseMachine.xtz_to_token ~src dst xtz env blk >>= fun cop -> - pure (cop, GhostMachine.xtz_to_token ~src dst xtz env state) - - let mint_or_burn_tzbtc dst tzbtc env (blk, state) = - ConcreteBaseMachine.mint_or_burn_tzbtc dst tzbtc env blk >>= fun cop -> - pure (cop, GhostMachine.mint_or_burn_tzbtc dst tzbtc env state) - - let approve_tzbtc dst tzbtc env (blk, state) = - ConcreteBaseMachine.approve_tzbtc dst tzbtc env blk >>= fun cop -> - pure (cop, GhostMachine.approve_tzbtc dst tzbtc env state) - - let add_liquidity ~src dst xtz_deposit tzbtc_deposit env (blk, state) = - ConcreteBaseMachine.add_liquidity ~src dst xtz_deposit tzbtc_deposit env blk - >>= fun cop -> - pure - ( cop, - GhostMachine.add_liquidity ~src dst xtz_deposit tzbtc_deposit env state - ) - - let remove_liquidity ~src dst lqt_burned env (blk, state) = - ConcreteBaseMachine.remove_liquidity ~src dst lqt_burned env blk - >>= fun cop -> - pure (cop, GhostMachine.remove_liquidity ~src dst lqt_burned env state) - - let reveal account (blk, state) = - ConcreteBaseMachine.reveal account blk >>= fun cop -> - pure (cop, GhostMachine.reveal account state) - - let init ~invariant ?subsidy balances = - ConcreteBaseMachine.init - ~invariant:(fun _ _ -> return true) - ?subsidy - balances - >>= fun (blk, env) -> - let state, _ = - SymbolicBaseMachine.init ~invariant:(fun _ _ -> true) ?subsidy balances - in - let state = refine_state env state in - invariant env (blk, state) >>= fun cond -> - assert cond ; - pure ((blk, state), env) -end - -module ValidationMachine = struct - include ValidationBaseMachine - include Machine.Make (ValidationBaseMachine) - include MachineBuilder.Make (ValidationBaseMachine) - - module Symbolic = struct - let get_xtz_balance = get_xtz_balance - - let get_tzbtc_balance = get_tzbtc_balance - - let get_liquidity_balance = get_liquidity_balance - - let get_cpmm_total_liquidity = get_cpmm_total_liquidity - end - - module Concrete = struct - let get_xtz_balance contract (blk, _) = - ConcreteMachine.get_xtz_balance contract blk - - let get_tzbtc_balance contract env (blk, _) = - ConcreteMachine.get_tzbtc_balance contract env blk - - let get_liquidity_balance contract env (blk, _) = - ConcreteMachine.get_liquidity_balance contract env blk - - let get_cpmm_total_liquidity env (blk, _) = - ConcreteMachine.get_cpmm_total_liquidity env blk - end -end diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/liquidity_baking_machine.mli b/src/proto_017_PtNairob/lib_protocol/test/helpers/liquidity_baking_machine.mli deleted file mode 100644 index 76107f8b4d616c33e83d334a8f394e923260d148..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/liquidity_baking_machine.mli +++ /dev/null @@ -1,387 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context - -(** This module provides the means to test extensively the Liquidity - Baking (LB) feature. We recall that this feature is built upon - three smart contracts: (1) a CPMM contract initially based on - Dexter 2, and (2) two tokens contracts. Our objective is to run - “scenarios†consisting in interleaved, realistic calls to these - contracts, and to assert these scenarios do not yield any - undesirable behaviors. - - To that end, three “machines†are provided. - - - The {! SymbolicMachine} allows to simulate scenarios involving - the LB feature completely off-chain. It can be seen as an - abstraction of the concrete implementation provided by the Tezos - node. - - The {! ConcreteMachine } allows to execute scenarios on-chain. - - The {! ValidationMachine } combines the two previously mentioned - machines. In other words, the {! ValidationMachine} makes the {! - SymbolicMachine} and the [ConcreteMachine] execute the same - scenarios, and asserts they remain synchronized after each baked - block. - - The {! ValidationMachine} allows to (1) validate the {! - SymbolicMachine} ({i i.e.,} the reimplementation of the LB - contracts logic) against the real implementation provided by - Tezos, {b and} the contracts originated by the protocol correctly - implement the LB logic, as implemented by the {! SymbolicMachine}. - That is, the {! ValidationMachine} reports desynchronization of - the two machines, but cannot explain this desynchronization. *) - -(** {1 Machine State Characterization} *) - -type xtz = int64 - -type tzbtc = int - -type liquidity = int - -(** As far as liquidity baking is concerned, an account can hold three - kinds of tokens: [xtz], [tzbtc], and [liquidity]. *) -type balances = {xtz : xtz; tzbtc : tzbtc; liquidity : liquidity} - -val pp_balances : Format.formatter -> balances -> unit - -(** A value of type [specs] allows to specify an initial state of a - “machineâ€. - - In a nutshell, it consists in specifying the minimal balances of - the CPMM contracts and a set of implicit contracts. The two - machines provided by this module has a [build] function which - turns a [specs] into a consistent initial state for this - machine. *) -type specs = { - cpmm_min_xtz_balance : xtz; - cpmm_min_tzbtc_balance : tzbtc; - accounts_balances : balances list; -} - -val pp_specs : Format.formatter -> specs -> unit - -(** A value of type ['a env] (where ['a] is the type of contract - identifiers) summarizes the different contracts involved in the LB - feature. - - Values of type [env] are constructed by the [build] function of - the machines. *) -type 'a env = private { - cpmm_contract : 'a; - tzbtc_contract : 'a; - tzbtc_admin : 'a; - liquidity_contract : 'a; - liquidity_admin : 'a; - implicit_accounts : 'a list; - holder : 'a; - subsidy : xtz; -} - -(** A value of type ['a step] (where ['a] is the type used to identify - contracts) describes a consistent sequence of LB smart contract - calls. - - For instance, [SellTzBTC] consists in approving an allowance in - the [TzBTC] contract, then calling the [token_to_xtz] entry point - of the [CPMM]. *) -type 'a step = - | SellTzBTC of {source : 'a; destination : 'a; tzbtc_deposit : tzbtc} - | BuyTzBTC of {source : 'a; destination : 'a; xtz_deposit : xtz} - | AddLiquidity of {source : 'a; destination : 'a; xtz_deposit : xtz} - | RemoveLiquidity of {source : 'a; destination : 'a; lqt_burned : liquidity} - -val pp_step : - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a step -> unit - -(** A summary of the state of a machine, parameterized by the type of - contract identifier. *) -type 'a state = { - cpmm_total_liquidity : liquidity; - accounts_balances : ('a * balances) list; -} - -(** {1 The Symbolic Machine} *) - -(** In the {! SymbolicMachine}, a contract is identified by a symbolic - value. *) -type contract_id = - | Cpmm - | Holder - | TzBTC - | TzBTCAdmin - | Liquidity - | LiquidityAdmin - (* We use integers to distinguish between implicit account because - this integer has the extra benefit of being the index of the - related account in [env.implicit_accounts]. *) - | ImplicitAccount of int - -val pp_contract_id : Format.formatter -> contract_id -> unit - -module SymbolicMachine : sig - (** The state of the {! SymbolicMachine}. *) - type t = contract_id state - - (** [get_xtz_balance c state] returns the amount of mutez owned by - [c] in [state]. *) - val get_xtz_balance : contract_id -> t -> xtz - - (** [get_tzbtc_balance c env state] returns the amount of TzBTC - owned by [c] in [state], according to the [TzBTC] contract. *) - val get_tzbtc_balance : contract_id -> contract_id env -> t -> tzbtc - - (** [get_liquidity_balance c env state] returns the amount of - liquidity token owned by [c] in [state], according to the - [Liquidity] contract. *) - val get_liquidity_balance : contract_id -> contract_id env -> t -> liquidity - - (** [get_cpmm_total_liquidity env state] fetches the current amount - of liquidity tokens distributed by the CPMM contract from the - state [state]. *) - val get_cpmm_total_liquidity : contract_id env -> t -> liquidity - - (** [predict_required_tzbtc_deposit xtz_deposit env state] predicts - the deposit in TzBTC which will be required by the CPMM contract - when executing a step [AddLiquidity] with [xtz_deposit] from - [state]. *) - val predict_required_tzbtc_deposit : xtz -> contract_id env -> t -> tzbtc - - (** [build specs] computes (1) an initial state for the {! - SymbolicMachine}, and (2) the environment associated to this - state. - - The machine enforces the resulting state is consistent with the - [specs] given as inputs, and raises an [Assert_failure] - exception if it does not. - - One can use the optional argument [subsidy] to set the subsidy - amount to a given value (by default, we use the same as the main - chain). Additionally, the [invariant] optional argument can be - used to verify that a given invariant holds at the end of the - initialization. *) - val build : - ?invariant:(contract_id env -> t -> bool) -> - ?subsidy:xtz -> - specs -> - t * contract_id env - - (** [step s env state] executes a single step [s] from [state]. - - The [invariant] optional argument can be used to verify that a - given invariant holds after each baked block. *) - val step : - ?invariant:(contract_id env -> t -> bool) -> - contract_id step -> - contract_id env -> - t -> - t - - (** [run steps env state] executes a list of steps from [state]. - - The [invariant] optional argument can be used to verify that a - given invariant holds after each baked block. *) - val run : - ?invariant:(contract_id env -> t -> bool) -> - contract_id step list -> - contract_id env -> - t -> - t -end - -(** A machine that can execute scenarios onchain. *) -module ConcreteMachine : sig - (** The state of the {! ConcreteMachine}. *) - type t = Block.t - - (** [get_xtz_balance c state] returns the amount of mutez owned by - [c] in [state]. *) - val get_xtz_balance : Contract.t -> t -> xtz tzresult Lwt.t - - (** [get_tzbtc_balance c env state] returns the amount of TzBTC - owned by [c] in [state], according to the [TzBTC] contract. *) - val get_tzbtc_balance : - Contract.t -> Contract.t env -> t -> tzbtc tzresult Lwt.t - - (** [get_liquidity_balance c env state] returns the amount of - liquidity token owned by [c] in [state], according to the - [Liquidity] contract. *) - val get_liquidity_balance : - Contract.t -> Contract.t env -> t -> liquidity tzresult Lwt.t - - (** [get_cpmm_total_liquidity env state] fetches the current amount - of liquidity tokens distributed by the CPMM contract from the - state [state]. *) - val get_cpmm_total_liquidity : Contract.t env -> t -> liquidity tzresult Lwt.t - - (** [build specs] asynchronously computes (1) an initial block for - the {! ConcreteMachine}, and (2) the environment associated to - this block. - - The machine enforces the resulting state is consistent with the - [specs] given as inputs, and raises an [Assert_failure] - exception if it does not. It also enforces that the machines - used underneath remain in sync. - - One can use the optional argument [subsidy] to set the subsidy - amount to a given value (by default, we use the same as the main - chain). Additionally, the [invariant] optional argument can be - used to verify that a given invariant holds at the end of the - initialization. *) - val build : - ?invariant:(Contract.t env -> t -> bool tzresult Lwt.t) -> - ?subsidy:xtz -> - specs -> - (t * Contract.t env) tzresult Lwt.t - - (** [step s env state] asynchronously executes a single step [s] - from [state]. - - The [invariant] optional argument can be used to verify that a - given invariant holds after each baked block. *) - val step : - ?invariant:(Contract.t env -> t -> bool tzresult Lwt.t) -> - Contract.t step -> - Contract.t env -> - t -> - t tzresult Lwt.t - - (** [run lss env state] asynchronously executes a list of steps from - [state]. - - The [invariant] optional argument can be used to verify that a - given invariant holds after each baked block. *) - val run : - ?invariant:(Contract.t env -> t -> bool tzresult Lwt.t) -> - contract_id step list -> - Contract.t env -> - t -> - t tzresult Lwt.t -end - -module ValidationMachine : sig - (** The state of the {! ValidationMachine}. *) - type t = ConcreteMachine.t * Contract.t state - - module Symbolic : sig - (** A collections of functions to introspect the symbolic part of - the [ValidationMachine] state. *) - - (** [get_xtz_balance c state] returns the amount of mutez owned by - [c] in the symbolic part of [state]. *) - val get_xtz_balance : Contract.t -> t -> xtz tzresult Lwt.t - - (** [get_tzbtc_balance c env state] returns the amount of TzBTC - owned by [c] in the symbolic part of [state], according to the - [TzBTC] contract. *) - val get_tzbtc_balance : - Contract.t -> Contract.t env -> t -> tzbtc tzresult Lwt.t - - (** [get_liquidity_balance c env state] returns the amount of - liquidity token owned by [c] in the symbolic part of [state], - according to the [Liquidity] contract. *) - val get_liquidity_balance : - Contract.t -> Contract.t env -> t -> liquidity tzresult Lwt.t - - (** [get_cpmm_total_liquidity env state] fetches the   current - amount of liquidity tokens distributed by the CPMM   contract - using the symbolic part of the state [state]. *) - val get_cpmm_total_liquidity : - Contract.t env -> t -> liquidity tzresult Lwt.t - end - - module Concrete : sig - (** A collections of functions to introspect the concrete part of - the [ValidationMachine] state. *) - - (** [get_xtz_balance c state] returns the amount of mutez owned by - [c] in the concrete part of [state]. *) - val get_xtz_balance : Contract.t -> t -> xtz tzresult Lwt.t - - (** [get_tzbtc_balance c env state] returns the amount of TzBTC - owned by [c] in the concrete part of [state], according to the - [TzBTC] contract. *) - val get_tzbtc_balance : - Contract.t -> Contract.t env -> t -> tzbtc tzresult Lwt.t - - (** [get_liquidity_balance c env state] returns the amount of - liquidity token owned by [c] in the concrete part of [state], - according to the [Liquidity] contract. *) - val get_liquidity_balance : - Contract.t -> Contract.t env -> t -> liquidity tzresult Lwt.t - - (** [get_cpmm_total_liquidity env state] fetches the current - amount of liquidity tokens distributed by the CPMM contract - using the concrete part of the state [state]. *) - val get_cpmm_total_liquidity : - Contract.t env -> t -> liquidity tzresult Lwt.t - end - - (** [build specs] asynchronously computes (1) an initial state for - the {! ValidationMachine}, and (2) the environment associated to - this state. - - The machine enforces the resulting state is consistent with the - [specs] given as inputs, and raises an [Assert_failure] - exception if it does not. It also enforces that the machines - used underneath remain in sync. - - One can use the optional argument [subsidy] to set the subsidy - amount to a given value (by default, we use the same as the main - chain). Additionally, the [invariant] optional argument can be - used to verify that a given invariant holds at the end of the - initialization. *) - val build : - ?invariant:(Contract.t env -> t -> bool tzresult Lwt.t) -> - ?subsidy:xtz -> - specs -> - (t * Contract.t env) tzresult Lwt.t - - (** [step s env state] asynchronously executes a single step [s] - from [state]. - - The [invariant] optional argument can be used to verify that a - given invariant holds after each baked block. *) - val step : - ?invariant:(Contract.t env -> t -> bool tzresult Lwt.t) -> - Contract.t step -> - Contract.t env -> - t -> - t tzresult Lwt.t - - (** [run lss env state] asynchronously executes a list of steps from - [state]. - - The [invariant] optional argument can be used to verify that a - given invariant holds after each baked block. *) - val run : - ?invariant:(Contract.t env -> t -> bool tzresult Lwt.t) -> - contract_id step list -> - Contract.t env -> - t -> - t tzresult Lwt.t -end diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/lqt_fa12_repr.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/lqt_fa12_repr.ml deleted file mode 100644 index af27ec2e2e93a1d7600c6f979e3d8f0592156643..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/lqt_fa12_repr.ml +++ /dev/null @@ -1,253 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021-2022 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context -open Expr_common - -module Parameter = struct - (* // ============================================================================= - * // Entrypoints - * // ============================================================================= *) - - (* Note: in the lqt_fa12 contract, [value] is a nat. Hence, it - should always be positive *) - type approve = {spender : Contract.t; value : Z.t} - - type mintOrBurn = {quantity : Z.t; target : Contract.t} - - (* Note: this wrapper does not implement a reprensentation for the - entrypoints transfer, getAllowance, getBalance, getTotalSupply, - as they are not used as of yet. *) - type t = Approve of approve | MintOrBurn of mintOrBurn - - let approve p = - assert (Z.lt Z.zero p.value || Z.equal Z.zero p.value) ; - Approve p - - let mintOrBurn p = MintOrBurn p - - let approve_to_string {spender; value} = - Format.asprintf - "{ spender: %a; value: %a }" - Contract.pp - spender - Z.pp_print - value - - let mint_or_burn_to_string {quantity; target} = - Format.asprintf - "{ quantity: %a; target: %a }" - Z.pp_print - quantity - Contract.pp - target - - let to_string : t -> string = function - | Approve p -> Format.asprintf "Approve %s" (approve_to_string p) - | MintOrBurn p -> Format.asprintf "MintOrBurn %s" (mint_or_burn_to_string p) - - let entrypoint_of_parameter : t -> Entrypoint.t = function - | Approve _ -> Entrypoint.of_string_strict_exn "approve" - | MintOrBurn _ -> Entrypoint.of_string_strict_exn "mintOrBurn" - - let pp fmt s = Format.fprintf fmt "%s" (to_string s) - - let eq s s' = s = s' - - let to_expr_rooted : - loc:'a -> - t -> - ('a, Michelson_v1_primitives.prim) Tezos_micheline.Micheline.node = - fun ~loc -> function - | MintOrBurn {quantity; target} -> - comb ~loc [int ~loc quantity; address_string ~loc target] - | Approve {spender; value} -> - comb ~loc [address_string ~loc spender; int ~loc value] - - let to_expr : - loc:'a -> - t -> - ('a, Michelson_v1_primitives.prim) Tezos_micheline.Micheline.node = - fun ~loc p -> - let rooted = to_expr_rooted ~loc p in - match p with - | MintOrBurn _ -> right ~loc @@ left ~loc rooted - | Approve _ -> left ~loc @@ left ~loc @@ left ~loc rooted - - let to_michelson_string e = - let e = to_expr ~loc:0 e in - Format.asprintf - "%a" - Michelson_v1_printer.print_expr - (Micheline.strip_locations e) -end - -(* // ============================================================================= - * // Storage - * // ============================================================================= *) - -module Storage = struct - let pp_big_map_id fmt v = Z.pp_print fmt (Big_map.Id.unparse_to_z v) - - type t = { - tokens : Big_map.Id.t; - allowances : Big_map.Id.t; - admin : Contract.t; - totalSupply : Z.t; - } - - let pp {tokens; allowances; admin; totalSupply} = - Format.asprintf - "{ tokens: %a; allowances: %a; admin: %a; totalSupply: %a}" - Z.pp_print - (Big_map.Id.unparse_to_z tokens) - Z.pp_print - (Big_map.Id.unparse_to_z allowances) - Contract.pp - admin - Z.pp_print - totalSupply - - let null : t = - { - tokens = Big_map.Id.parse_z Z.zero; - allowances = Big_map.Id.parse_z Z.one; - admin = Contract.Implicit Signature.Public_key_hash.zero; - totalSupply = Z.zero; - } - - let eq s s' = s = s' - - let to_expr : - loc:'a -> - t -> - ('a, Michelson_v1_primitives.prim) Tezos_micheline.Micheline.node = - fun ~loc {tokens; allowances; admin; totalSupply} -> - comb - ~loc - [ - big_map_id ~loc tokens; - big_map_id ~loc allowances; - address_string ~loc admin; - int ~loc totalSupply; - ] - - let to_michelson_string e = - let e = to_expr ~loc:0 e in - Format.asprintf - "%a" - Michelson_v1_printer.print_expr - (Micheline.strip_locations e) - - type exn += Invalid_storage_expr of string - - (** Note: parses a storage unparsed in readable mode (as - e.g. returned by [Alpha_services.Contract.storage]), so that - contracts are represented by strings. *) - let of_expr_exn : - ('a, Michelson_v1_primitives.prim) Tezos_micheline.Micheline.node -> t = - function - | Tezos_micheline.Micheline.Prim - ( _, - Script.D_Pair, - [ - Tezos_micheline.Micheline.Int (_, tokens); - Tezos_micheline.Micheline.Int (_, allowances); - Tezos_micheline.Micheline.String (_, admin); - Tezos_micheline.Micheline.Int (_, totalSupply); - ], - [] ) -> - let tokens = Big_map.Id.parse_z tokens in - let allowances = Big_map.Id.parse_z allowances in - let admin = address_of_string_exn admin in - {tokens; allowances; admin; totalSupply} - | e -> - let canonical = Micheline.strip_locations e in - let msg = - Format.asprintf - "Not a valid LQT_FA1.2 storage: %s /// %a" - (try - Michelson_v1_printer.micheline_string_of_expression - ~zero_loc:true - canonical - with Z.Overflow -> - "Cannot represent as micheline due to overflowing Z -> int") - Michelson_v1_printer.print_expr - canonical - in - raise (Invalid_storage_expr msg) - - let get (ctxt : Context.t) ~(contract : Contract.t) : t tzresult Lwt.t = - match contract with - | Implicit _ -> - invalid_arg "Lqt_fa12_repr.Storage.get called on implicit account" - | Originated c -> - Context.Contract.storage ctxt c >|=? Micheline.root >|=? of_expr_exn - - let get_alpha_context (ctxt : Context.t) : Alpha_context.t tzresult Lwt.t = - (match ctxt with - | B b -> - (* can perhaps be retrieved through Raw_context.prepare ? *) - Incremental.begin_construction b - | I i -> return i) - >|=? Incremental.alpha_ctxt - - let getBalance_opt (ctxt : Context.t) ~(contract : Contract.t) - (owner : Script_typed_ir.address) = - get ctxt ~contract >>=? fun storage -> - let tokens = storage.tokens in - get_alpha_context ctxt >>=? fun ctxt -> - Script_ir_translator.hash_data ctxt Script_typed_ir.address_t owner - >|= Environment.wrap_tzresult - >>=? fun (address_hash, ctxt) -> - Big_map.get_opt ctxt tokens address_hash >|= Environment.wrap_tzresult - >>=? function - | _, Some canonical -> ( - match Tezos_micheline.Micheline.root canonical with - | Tezos_micheline.Micheline.Int (_, amount) -> return @@ Some amount - | _ -> assert false) - | _, None -> return @@ None - - let getBalance (ctxt : Context.t) ~(contract : Contract.t) - (owner : Script_typed_ir.address) = - getBalance_opt ctxt ~contract owner >|=? Option.value ~default:Z.zero -end - -let transaction (ctxt : Context.t) ~(contract : Contract.t) ~(src : Contract.t) - ?(amount = Tez.zero) (parameters : Parameter.t) = - let entrypoint = Parameter.entrypoint_of_parameter parameters in - let rooted_param_lazy = - parameters - |> Parameter.to_expr_rooted ~loc:0 - |> Micheline.strip_locations |> Alpha_context.Script.lazy_expr - in - Op.transaction - ctxt - src - contract - amount - ~entrypoint - ~parameters:rooted_param_lazy diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/lwt_result_wrap_syntax.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/lwt_result_wrap_syntax.ml deleted file mode 100644 index d22a583e4660c7de0794d8e8a7c4335f6e07a577..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/lwt_result_wrap_syntax.ml +++ /dev/null @@ -1,40 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -include Tezos_base.TzPervasives.Lwt_result_syntax - -let wrap m = m >|= Environment.wrap_tzresult - -let ( let*@ ) m f = - let* x = wrap m in - f x - -let ( let*?@ ) m f = - let*? x = Environment.wrap_tzresult m in - f x - -let ( let+@ ) m f = - let+ x = wrap m in - f x diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/lwt_result_wrap_syntax.mli b/src/proto_017_PtNairob/lib_protocol/test/helpers/lwt_result_wrap_syntax.mli deleted file mode 100644 index 9ea00a3f380bb68c4cc6b1ae592419fd99c1d77f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/lwt_result_wrap_syntax.mli +++ /dev/null @@ -1,62 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** Extends the {!Lwt_result_syntax} with additional utilities for wrapping - results produced by the protocol, i.e. [Environment.Error_monad.tzresult], - to [tzresult Lwt.t] values used in the tests. - - The added utilities are binding operators. They use the same symbols as - the ones from {!Lwt_result_syntax} with an added [@] character. This - character symbolizes the {!e wrapping} of the internal error monad type in a - shell error. *) - -include module type of Tezos_base.TzPervasives.Lwt_result_syntax - -(** [wrap res] maps the result type contained in [res] to a tzresult - value. *) -val wrap : 'a Environment.Error_monad.tzresult Lwt.t -> 'a tzresult Lwt.t - -(** [let*@ x = m in f x] is equivalent to [let* x = wrap m in f x]. - - Mnemonic: [@] "wraps" a protocol error in a shell error. *) -val ( let*@ ) : - 'a Environment.Error_monad.tzresult Lwt.t -> - ('a -> 'b tzresult Lwt.t) -> - 'b tzresult Lwt.t - -(** [let*?@ x = m in f x] is equivalent to [let*? x = Environment.wrap_tzresult - m in f x]. - - Mnemonic: [@] "wraps" a protocol error in a shell error. *) -val ( let*?@ ) : - 'a Environment.Error_monad.tzresult -> - ('a -> 'b tzresult Lwt.t) -> - 'b tzresult Lwt.t - -(** [let+@ x = m in f x] is equivalent to [let+ x = wrap m in f x]. - - Mnemonic: [@] "wraps" a protocol error in a shell error. *) -val ( let+@ ) : - 'a Environment.Error_monad.tzresult Lwt.t -> ('a -> 'b) -> 'b tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/merkle_list_helper.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/merkle_list_helper.ml deleted file mode 100644 index bf823ad6f954fecd22e67e1e42d7ed881eaa197a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/merkle_list_helper.ml +++ /dev/null @@ -1,54 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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 prefix = "\001\002\003" (* 8uE(36) *) - -module Hash = - Environment.Blake2B.Make - (Environment.Base58) - (struct - let name = "Merkle_list" - - let title = "Merkle_list" - - let b58check_prefix = prefix - - let size = Some 20 - end) - -module ML = - Protocol.Merkle_list.Make - (struct - type t = bytes - - let to_bytes x = x - end) - (Hash) - -include ML - -(* Hash two hashes *) -let hash2 (h1 : Hash.t) (h2 : Hash.t) = - Hash.(hash_bytes [to_bytes h1; to_bytes h2]) diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/nonce.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/nonce.ml deleted file mode 100644 index 23edb62e017f4bb8449c5d3b8ed80fa1b9b5f769..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/nonce.ml +++ /dev/null @@ -1,35 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2018. *) -(* Dynamic Ledger Solutions, Inc.< contact@tezos.com > *) -(* *) -(* All rights reserved.No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -open Protocol - -module Table = Hashtbl.Make (struct - type t = Nonce_hash.t - - let hash h = Int32.to_int (TzEndian.get_int32 (Nonce_hash.to_bytes h) 0) - - let equal = Nonce_hash.equal -end) - -let known_nonces = Table.create 17 - -let generate () = - match - Alpha_context.Nonce.of_bytes - @@ Tezos_crypto.Rand.generate Alpha_context.Constants.nonce_length - with - | Ok nonce -> - let hash = Alpha_context.Nonce.hash nonce in - Table.add known_nonces hash nonce ; - (hash, nonce) - | Error _ -> assert false - -let forget_all () = Table.clear known_nonces - -let get hash = Table.find known_nonces hash diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/nonce.mli b/src/proto_017_PtNairob/lib_protocol/test/helpers/nonce.mli deleted file mode 100644 index 8a8b258b065852028e44aad28577dbcb231c6ef3..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/nonce.mli +++ /dev/null @@ -1,33 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 - -(** Returns a fresh nonce and its corresponding hash (and stores them). *) -val generate : unit -> Nonce_hash.t * Alpha_context.Nonce.t - -val get : Nonce_hash.t -> Alpha_context.Nonce.t option - -val forget_all : unit -> unit diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/op.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/op.ml deleted file mode 100644 index e57b68457d9bfa6c408d58b67fdb6730235f2f8d..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/op.ml +++ /dev/null @@ -1,1005 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 -open Alpha_context - -let pack_operation ctxt signature contents = - let branch = Context.branch ctxt in - Operation.pack - ({shell = {branch}; protocol_data = {contents; signature}} : _ Operation.t) - -let sign ?(watermark = Signature.Generic_operation) sk branch contents = - let unsigned = - Data_encoding.Binary.to_bytes_exn - Operation.unsigned_encoding - ({branch}, Contents_list contents) - in - let signature = Some (Signature.sign ~watermark sk unsigned) in - ({shell = {branch}; protocol_data = {contents; signature}} : _ Operation.t) - -(** Generates the block payload hash based on the hash [pred_hash] of - the predecessor block and the hash of non-consensus operations of - the current block [b]. *) -let mk_block_payload_hash payload_round (b : Block.t) = - let ops = Block.Forge.classify_operations b.operations in - let non_consensus_operations = - List.concat (match List.tl ops with None -> [] | Some l -> l) - in - let hashes = List.map Operation.hash_packed non_consensus_operations in - Block_payload.hash - ~predecessor_hash:b.header.shell.predecessor - ~payload_round - hashes - -let mk_consensus_content_signer_and_branch ?delegate ?slot ?level ?round - ?block_payload_hash ?branch endorsed_block = - let open Lwt_result_syntax in - let branch = - match branch with - | None -> endorsed_block.Block.header.shell.predecessor - | Some branch -> branch - in - let* delegate_pkh, slots = - match delegate with - | None -> Context.get_endorser (B endorsed_block) - | Some del -> ( - let* slots = Context.get_endorser_slot (B endorsed_block) del in - match slots with - | None -> return (del, []) - | Some slots -> return (del, slots)) - in - let slot = - match slot with None -> Stdlib.List.hd slots | Some slot -> slot - in - let* level = - match level with - | None -> - let*? level = Context.get_level (B endorsed_block) in - return level - | Some level -> return level - in - let* round = - match round with - | None -> - let*? round = Block.get_round endorsed_block in - return round - | Some round -> return round - in - let block_payload_hash = - match block_payload_hash with - | None -> mk_block_payload_hash round endorsed_block - | Some block_payload_hash -> block_payload_hash - in - let consensus_content = {slot; level; round; block_payload_hash} in - let* signer = Account.find delegate_pkh in - return (consensus_content, signer.sk, branch) - -let raw_endorsement ?delegate ?slot ?level ?round ?block_payload_hash ?branch - endorsed_block = - let open Lwt_result_syntax in - let* consensus_content, signer, branch = - mk_consensus_content_signer_and_branch - ?delegate - ?slot - ?level - ?round - ?block_payload_hash - ?branch - endorsed_block - in - let op = Single (Endorsement consensus_content) in - return - (sign - ~watermark:Operation.(to_watermark (Endorsement Chain_id.zero)) - signer - branch - op) - -let endorsement ?delegate ?slot ?level ?round ?block_payload_hash ?branch - endorsed_block = - let open Lwt_result_syntax in - let* op = - raw_endorsement - ?delegate - ?slot - ?level - ?round - ?block_payload_hash - ?branch - endorsed_block - in - return (Operation.pack op) - -let raw_preendorsement ?delegate ?slot ?level ?round ?block_payload_hash ?branch - endorsed_block = - let open Lwt_result_syntax in - let* consensus_content, signer, branch = - mk_consensus_content_signer_and_branch - ?delegate - ?slot - ?level - ?round - ?block_payload_hash - ?branch - endorsed_block - in - let op = Single (Preendorsement consensus_content) in - return - (sign - ~watermark:Operation.(to_watermark (Preendorsement Chain_id.zero)) - signer - branch - op) - -let preendorsement ?delegate ?slot ?level ?round ?block_payload_hash ?branch - endorsed_block = - let open Lwt_result_syntax in - let* op = - raw_preendorsement - ?delegate - ?slot - ?level - ?round - ?block_payload_hash - ?branch - endorsed_block - in - return (Operation.pack op) - -let sign ?watermark sk ctxt (Contents_list contents) = - Operation.pack (sign ?watermark sk ctxt contents) - -let batch_operations ?(recompute_counters = false) ~source ctxt - (operations : packed_operation list) = - let operations = - List.map - (function - | {Alpha_context.protocol_data = Operation_data {contents; _}; _} -> - Operation.to_list (Contents_list contents)) - operations - |> List.flatten - in - (if recompute_counters then - Context.Contract.counter ctxt source >>=? fun counter -> - (* Update counters and transform into a contents_list *) - let _, rev_operations = - List.fold_left - (fun (counter, acc) -> function - | Contents (Manager_operation m) -> - ( Manager_counter.succ counter, - Contents (Manager_operation {m with counter}) :: acc ) - | x -> (counter, x :: acc)) - (Manager_counter.succ counter, []) - operations - in - return (List.rev rev_operations) - else return operations) - >>=? fun operations -> - Context.Contract.manager ctxt source >>=? fun account -> - Environment.wrap_tzresult @@ Operation.of_list operations - >>?= fun operations -> - return @@ sign account.sk (Context.branch ctxt) operations - -type gas_limit = Max | High | Low | Zero | Custom_gas of Gas.Arith.integral - -let default_low_gas_limit op pkh = - let {shell; protocol_data = Operation_data protocol_data} = op in - let op : _ operation = {shell; protocol_data} in - let check_sig_gas = - Operation_costs.check_signature_cost - (Michelson_v1_gas.Cost_of.Interpreter.algo_of_public_key_hash pkh) - op - in - let total_cost = - Gas.(Michelson_v1_gas.Cost_of.manager_operation +@ check_sig_gas) - in - (* Some tests need milligas precision to distinguish failures in - validation from failures in application but limits in the - protocol are statically guaranteed to be integral values so we - use Obj.magic to bypass them. *) - (Obj.magic total_cost : Gas.Arith.integral) - -let default_high_gas_limit = - Gas.Arith.integral_of_int_exn - (49_000 + Michelson_v1_gas.Internal_for_tests.int_cost_of_manager_operation) - -let resolve_gas_limit ?(force_reveal = false) ctxt op source gas_limit = - let open Lwt_result_syntax in - let pkh = Context.Contract.pkh source in - let* revealed = Context.Contract.is_manager_key_revealed ctxt source in - match gas_limit with - | Max -> - Context.get_constants ctxt >>=? fun c -> - return (c.parametric.hard_gas_limit_per_operation, None) - | High -> return (default_high_gas_limit, None) - | Low when force_reveal && not revealed -> - (* If force reveal is set, the operation is a batch where the reveal is - the first operation. This operation should have a gas_limit - corresponding to the manager_operation constant (Low) + the cost of the - signature checking. The second op should only have Low as gas_limit *) - let op_gas : Gas.Arith.integral = - Obj.magic Michelson_v1_gas.Cost_of.manager_operation - in - return (op_gas, Some (default_low_gas_limit op pkh)) - | Low -> return (default_low_gas_limit op pkh, None) - | Zero -> return (Gas.Arith.zero, None) - | Custom_gas x -> return (x, None) - -let pp_gas_limit fmt = function - | Max -> Format.fprintf fmt "Max" - | High -> - Format.fprintf fmt "High: %a" Gas.Arith.pp_integral default_high_gas_limit - | Low -> Format.fprintf fmt "Low" - | Zero -> Format.fprintf fmt "Zero: %a" Gas.Arith.pp_integral Gas.Arith.zero - | Custom_gas x -> Format.fprintf fmt "Custom: %a" Gas.Arith.pp_integral x - -let combine_operations ?public_key ?counter ?spurious_operation ~source ctxt - (packed_operations : packed_operation list) = - assert (match packed_operations with [] -> false | _ :: _ -> true) ; - (* Hypothesis : each operation must have the same branch (is this really true?) *) - let {Tezos_base.Operation.branch} = - (WithExceptions.Option.get ~loc:__LOC__ @@ List.hd packed_operations).shell - in - assert ( - List.for_all - (fun {shell = {Tezos_base.Operation.branch = b; _}; _} -> - Block_hash.(branch = b)) - packed_operations) ; - (* TODO? : check signatures consistency *) - let unpacked_operations = - List.map - (function - | {Alpha_context.protocol_data = Operation_data {contents; _}; _} -> ( - match Contents_list contents with - | Contents_list (Single o) -> Contents o - | Contents_list - (Cons (Manager_operation {operation = Reveal _; _}, Single o)) - -> - Contents o - | _ -> (* TODO : decent error *) assert false)) - packed_operations - in - (match counter with - | Some counter -> return counter - | None -> Context.Contract.counter ctxt source) - >>=? fun counter -> - (* We increment the counter *) - let counter = Manager_counter.succ counter in - Context.Contract.manager ctxt source >>=? fun account -> - let public_key = Option.value ~default:account.pk public_key in - (Context.Contract.is_manager_key_revealed ctxt source >|=? function - | false -> - let reveal_op = - Manager_operation - { - source = Signature.Public_key.hash public_key; - fee = Tez.zero; - counter; - operation = Reveal public_key; - gas_limit = default_high_gas_limit; - storage_limit = Z.zero; - } - in - (Some (Contents reveal_op), Manager_counter.succ counter) - | true -> (None, counter)) - >>=? fun (manager_op, counter) -> - (* Update counters and transform into a contents_list *) - let counter, rev_operations = - List.fold_left - (fun (counter, acc) -> function - | Contents (Manager_operation m) -> - ( Manager_counter.succ counter, - Contents (Manager_operation {m with counter}) :: acc ) - | x -> (counter, x :: acc)) - (counter, match manager_op with None -> [] | Some op -> [op]) - unpacked_operations - in - let operations = List.rev rev_operations in - (* patch a random operation with a corrupted pkh *) - let operations = - match spurious_operation with - | None -> operations - | Some op -> - let op = - match op with - | {protocol_data; shell = _} -> ( - match protocol_data with - | Operation_data {contents; _} -> ( - match contents with - | Cons _ -> assert false - | Single (Manager_operation m) -> - Alpha_context.Contents - (Manager_operation {m with counter}) - | Single op -> Contents op)) - in - (* Insert at the end *) - operations @ [op] - in - Environment.wrap_tzresult @@ Operation.of_list operations - >>?= fun operations -> - return @@ sign account.sk (Context.branch ctxt) operations - -let manager_operation_with_fixed_gas_limit ?(force_reveal = false) ?counter - ~gas_limit ?(reveal_gas_limit = default_high_gas_limit) ?(fee = Tez.zero) - ?storage_limit ?public_key ~source ctxt operation = - (match counter with - | Some counter -> return counter - | None -> Context.Contract.counter ctxt source) - >>=? fun counter -> - Context.get_constants ctxt >>=? fun c -> - let storage_limit = - Option.value - ~default:c.parametric.hard_storage_limit_per_operation - storage_limit - in - Context.Contract.manager ctxt source >>=? fun account -> - let public_key = Option.value ~default:account.pk public_key in - let counter = Manager_counter.succ counter in - Context.Contract.is_manager_key_revealed ctxt source >|=? fun revealed -> - (* If the manager is revealed or we are not forcing reveals, we - generate a singleton manager operation. *) - if revealed || not force_reveal then - let op = - Manager_operation - { - source = Signature.Public_key.hash public_key; - fee; - counter; - operation; - gas_limit; - storage_limit; - } - in - Contents_list (Single op) - (* Otherwise if the manager is unrevealed and we are - force_revaling managers by default, we pre-attach a revelation - for it. *) - else - let op_reveal = - Manager_operation - { - source = Signature.Public_key.hash public_key; - fee = Tez.zero; - counter; - operation = Reveal public_key; - gas_limit = reveal_gas_limit; - storage_limit = Z.zero; - } - in - let op = - Manager_operation - { - source = Signature.Public_key.hash public_key; - fee; - counter = Manager_counter.succ counter; - operation; - gas_limit; - storage_limit; - } - in - Contents_list (Cons (op_reveal, Single op)) - -let manager_operation ?force_reveal ?counter ?fee ?(gas_limit = High) - ?storage_limit ?public_key ~source ctxt operation = - let default_gas_limit = default_high_gas_limit in - manager_operation_with_fixed_gas_limit - ?force_reveal - ?counter - ~gas_limit:default_gas_limit - ?fee - ?storage_limit - ?public_key - ~source - ctxt - operation - >>=? fun (Contents_list dummy_operation) -> - resolve_gas_limit - ?force_reveal - ctxt - { - shell = {branch = Context.branch ctxt}; - protocol_data = - Operation_data {contents = dummy_operation; signature = None}; - } - source - gas_limit - >>=? fun (gas_limit, reveal_gas_limit) -> - manager_operation_with_fixed_gas_limit - ?force_reveal - ?counter - ~gas_limit - ?reveal_gas_limit - ?fee - ?storage_limit - ?public_key - ~source - ctxt - operation - -let revelation_with_fixed_gas_limit ?(fee = Tez.zero) ~gas_limit - ?(storage_limit = Z.zero) ?counter ?(forge_pkh = None) ctxt public_key = - (* If Some pkh is provided to ?forge_pkh we take that hash at face - value, otherwise we honestly compute the hash from - [public_key]. This is useful to test forging Reveal operations - (cf. tezos!5182). *) - let pkh = - match forge_pkh with - | Some pkh -> pkh - | None -> Signature.Public_key.hash public_key - in - let source = Contract.Implicit pkh in - (match counter with - | None -> Context.Contract.counter ctxt source - | Some ctr -> return ctr) - >|=? fun counter -> - let counter = Manager_counter.succ counter in - Manager_operation - { - source = pkh; - fee; - counter; - operation = Reveal public_key; - gas_limit; - storage_limit; - } - -let revelation ?fee ?(gas_limit = High) ?storage_limit ?counter ?forge_pkh ctxt - public_key = - revelation_with_fixed_gas_limit - ?fee - ~gas_limit:default_high_gas_limit - ?storage_limit - ?counter - ?forge_pkh - ctxt - public_key - >>=? fun (Manager_operation {source; _} as dummy_operation) -> - resolve_gas_limit - ctxt - { - shell = {branch = Context.branch ctxt}; - protocol_data = - Operation_data {contents = Single dummy_operation; signature = None}; - } - (Contract.Implicit source) - gas_limit - >>=? fun (gas_limit, _) -> - revelation_with_fixed_gas_limit - ?fee - ~gas_limit - ?storage_limit - ?counter - ?forge_pkh - ctxt - public_key - >>=? fun op -> - let sop = Contents_list (Single op) in - Context.Contract.manager ctxt (Implicit source) >|=? fun account -> - sign account.sk (Context.branch ctxt) sop - -let failing_noop ctxt source arbitrary = - let op = Contents_list (Single (Failing_noop arbitrary)) in - Account.find source >>=? fun account -> - return @@ sign account.sk (Context.branch ctxt) op - -let originated_contract_hash op = - let nonce = Protocol.Origination_nonce.initial (Operation.hash_packed op) in - Contract_hash.of_nonce nonce - -let originated_contract op = Contract.Originated (originated_contract_hash op) - -exception Impossible - -let contract_origination_gen k ?force_reveal ?counter ?delegate ~script - ?public_key ?credit ?fee ?gas_limit ?storage_limit ctxt source = - Context.Contract.manager ctxt source >>=? fun account -> - let default_credit = Tez.of_mutez @@ Int64.of_int 1000001 in - let default_credit = - WithExceptions.Option.to_exn ~none:Impossible default_credit - in - let credit = Option.value ~default:default_credit credit in - let operation = Origination {delegate; script; credit} in - manager_operation - ?force_reveal - ?counter - ?public_key - ?fee - ?gas_limit - ?storage_limit - ~source - ctxt - operation - >|=? fun sop -> k (sign account.sk (Context.branch ctxt) sop) - -let contract_origination = - contract_origination_gen (fun op -> (op, originated_contract op)) - -let contract_origination_hash = - contract_origination_gen (fun op -> (op, originated_contract_hash op)) - -let register_global_constant ?force_reveal ?counter ?public_key ?fee ?gas_limit - ?storage_limit ctxt ~source ~value = - Context.Contract.manager ctxt source >>=? fun account -> - let operation = Register_global_constant {value} in - manager_operation - ?force_reveal - ?counter - ?public_key - ?fee - ?gas_limit - ?storage_limit - ~source - ctxt - operation - >|=? fun sop -> sign account.sk (Context.branch ctxt) sop - -let unsafe_transaction ?force_reveal ?counter ?fee ?gas_limit ?storage_limit - ?(parameters = Script.unit_parameter) ?(entrypoint = Entrypoint.default) - ctxt (src : Contract.t) (destination : Contract.t) (amount : Tez.t) = - let top = Transaction {amount; parameters; destination; entrypoint} in - manager_operation - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ~source:src - ctxt - top - >>=? fun sop -> - Context.Contract.manager ctxt src >|=? fun account -> - sign account.sk (Context.branch ctxt) sop - -let transaction ?force_reveal ?counter ?fee ?gas_limit ?storage_limit - ?parameters ?entrypoint ctxt (src : Contract.t) (dst : Contract.t) - (amount : Tez.t) = - unsafe_transaction - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ?parameters - ?entrypoint - ctxt - src - dst - amount - -let delegation ?force_reveal ?fee ?gas_limit ?counter ?storage_limit ctxt source - dst = - let top = Delegation dst in - manager_operation - ?force_reveal - ?fee - ?counter - ?gas_limit - ?storage_limit - ~source - ctxt - top - >>=? fun sop -> - Context.Contract.manager ctxt source >|=? fun account -> - sign account.sk (Context.branch ctxt) sop - -let set_deposits_limit ?force_reveal ?fee ?gas_limit ?storage_limit ?counter - ctxt source limit = - let top = Set_deposits_limit limit in - manager_operation - ?force_reveal - ?fee - ?counter - ?storage_limit - ?gas_limit - ~source - ctxt - top - >>=? fun sop -> - Context.Contract.manager ctxt source >|=? fun account -> - sign account.sk (Context.branch ctxt) sop - -let increase_paid_storage ?force_reveal ?counter ?fee ?gas_limit ?storage_limit - ctxt ~source ~destination (amount : Z.t) = - let top = Increase_paid_storage {amount_in_bytes = amount; destination} in - manager_operation - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ~source - ctxt - top - >>=? fun sop -> - Context.Contract.manager ctxt source >|=? fun account -> - sign account.sk (Context.branch ctxt) sop - -let activation ctxt (pkh : Signature.Public_key_hash.t) activation_code = - (match pkh with - | Ed25519 edpkh -> return edpkh - | _ -> - failwith - "Wrong public key hash : %a - Commitments must be activated with an \ - Signature.Ed25519 encrypted public key hash" - Signature.Public_key_hash.pp - pkh) - >|=? fun id -> - let contents = Single (Activate_account {id; activation_code}) in - let branch = Context.branch ctxt in - { - shell = {branch}; - protocol_data = Operation_data {contents; signature = None}; - } - -let double_endorsement ctxt op1 op2 = - let contents = Single (Double_endorsement_evidence {op1; op2}) in - let branch = Context.branch ctxt in - { - shell = {branch}; - protocol_data = Operation_data {contents; signature = None}; - } - -let double_preendorsement ctxt op1 op2 = - let contents = Single (Double_preendorsement_evidence {op1; op2}) in - let branch = Context.branch ctxt in - { - shell = {branch}; - protocol_data = Operation_data {contents; signature = None}; - } - -let double_baking ctxt bh1 bh2 = - let contents = Single (Double_baking_evidence {bh1; bh2}) in - let branch = Context.branch ctxt in - { - shell = {branch}; - protocol_data = Operation_data {contents; signature = None}; - } - -let seed_nonce_revelation ctxt level nonce = - { - shell = {branch = Context.branch ctxt}; - protocol_data = - Operation_data - { - contents = Single (Seed_nonce_revelation {level; nonce}); - signature = None; - }; - } - -let vdf_revelation ctxt solution = - { - shell = {branch = Context.branch ctxt}; - protocol_data = - Operation_data - {contents = Single (Vdf_revelation {solution}); signature = None}; - } - -let get_period ?period ctxt = - let open Lwt_result_syntax in - match period with - | Some period -> return period - | None -> - let* current_period = Context.Vote.get_current_period ctxt in - return current_period.voting_period.index - -let proposals_contents ctxt proposer ?period proposals = - let open Lwt_result_syntax in - let source = Context.Contract.pkh proposer in - let* period = get_period ?period ctxt in - return (Single (Proposals {source; period; proposals})) - -let proposals ctxt proposer ?period proposals = - let open Lwt_result_syntax in - let* contents = proposals_contents ctxt proposer ?period proposals in - let* account = Account.find (Context.Contract.pkh proposer) in - return (sign account.sk (Context.branch ctxt) (Contents_list contents)) - -let ballot_contents ctxt voter ?period proposal ballot = - let open Lwt_result_syntax in - let source = Context.Contract.pkh voter in - let* period = get_period ?period ctxt in - return (Single (Ballot {source; period; proposal; ballot})) - -let ballot ctxt voter ?period proposal ballot = - let open Lwt_result_syntax in - let* contents = ballot_contents ctxt voter ?period proposal ballot in - let* account = Account.find (Context.Contract.pkh voter) in - return (sign account.sk (Context.branch ctxt) (Contents_list contents)) - -let dummy_script = - let open Micheline in - Script. - { - code = - lazy_expr - (strip_locations - (Seq - ( (), - [ - Prim ((), K_parameter, [Prim ((), T_unit, [], [])], []); - Prim ((), K_storage, [Prim ((), T_unit, [], [])], []); - Prim - ( (), - K_code, - [ - Seq - ( (), - [ - Prim ((), I_CDR, [], []); - Prim - ( (), - I_NIL, - [Prim ((), T_operation, [], [])], - [] ); - Prim ((), I_PAIR, [], []); - ] ); - ], - [] ); - ] ))); - storage = lazy_expr (strip_locations (Prim ((), D_Unit, [], []))); - } - -let dummy_script_cost = Test_tez.of_mutez_exn 9_500L - -let transfer_ticket ?force_reveal ?counter ?fee ?gas_limit ?storage_limit ctxt - ~(source : Contract.t) ~contents ~ty ~ticketer ~amount ~destination - ~entrypoint = - manager_operation - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ~source - ctxt - (Transfer_ticket {contents; ty; ticketer; amount; destination; entrypoint}) - >>=? fun to_sign_op -> - Context.Contract.manager ctxt source >|=? fun account -> - sign account.sk (Context.branch ctxt) to_sign_op - -let originated_sc_rollup op = - let packed = Operation.hash_packed op in - let nonce = Origination_nonce.Internal_for_tests.initial packed in - Sc_rollup.Internal_for_tests.originated_sc_rollup nonce - -let sc_rollup_origination ?force_reveal ?counter ?fee ?gas_limit ?storage_limit - ~origination_proof ctxt (src : Contract.t) kind ~boot_sector ~parameters_ty - = - let open Lwt_result_syntax in - let* to_sign_op = - manager_operation - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ~source:src - ctxt - (Sc_rollup_originate {kind; boot_sector; origination_proof; parameters_ty}) - in - let* account = Context.Contract.manager ctxt src in - let op = sign account.sk (Context.branch ctxt) to_sign_op in - let t = originated_sc_rollup op |> fun addr -> (op, addr) in - return t - -let sc_rollup_publish ?force_reveal ?counter ?fee ?gas_limit ?storage_limit ctxt - (src : Contract.t) rollup commitment = - manager_operation - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ~source:src - ctxt - (Sc_rollup_publish {rollup; commitment}) - >>=? fun to_sign_op -> - Context.Contract.manager ctxt src >|=? fun account -> - sign account.sk (Context.branch ctxt) to_sign_op - -let sc_rollup_cement ?force_reveal ?counter ?fee ?gas_limit ?storage_limit ctxt - (src : Contract.t) rollup commitment = - manager_operation - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ~source:src - ctxt - (Sc_rollup_cement {rollup; commitment}) - >>=? fun to_sign_op -> - Context.Contract.manager ctxt src >|=? fun account -> - sign account.sk (Context.branch ctxt) to_sign_op - -let sc_rollup_execute_outbox_message ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ctxt (src : Contract.t) rollup cemented_commitment - ~output_proof = - manager_operation - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ~source:src - ctxt - (Sc_rollup_execute_outbox_message - {rollup; cemented_commitment; output_proof}) - >>=? fun to_sign_op -> - Context.Contract.manager ctxt src >|=? fun account -> - sign account.sk (Context.branch ctxt) to_sign_op - -let sc_rollup_recover_bond ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ctxt (source : Contract.t) (sc_rollup : Sc_rollup.t) - (staker : public_key_hash) = - manager_operation - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ~source - ctxt - (Sc_rollup_recover_bond {sc_rollup; staker}) - >>=? fun to_sign_op -> - Context.Contract.manager ctxt source >|=? fun account -> - sign account.sk (Context.branch ctxt) to_sign_op - -let sc_rollup_add_messages ?force_reveal ?counter ?fee ?gas_limit ?storage_limit - ctxt (src : Contract.t) messages = - manager_operation - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ~source:src - ctxt - (Sc_rollup_add_messages {messages}) - >>=? fun to_sign_op -> - Context.Contract.manager ctxt src >|=? fun account -> - sign account.sk (Context.branch ctxt) to_sign_op - -let sc_rollup_refute ?force_reveal ?counter ?fee ?gas_limit ?storage_limit ctxt - (src : Contract.t) rollup opponent refutation = - manager_operation - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ~source:src - ctxt - (Sc_rollup_refute {rollup; opponent; refutation}) - >>=? fun to_sign_op -> - Context.Contract.manager ctxt src >|=? fun account -> - sign account.sk (Context.branch ctxt) to_sign_op - -let sc_rollup_timeout ?force_reveal ?counter ?fee ?gas_limit ?storage_limit ctxt - (src : Contract.t) rollup stakers = - manager_operation - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ~source:src - ctxt - (Sc_rollup_timeout {rollup; stakers}) - >>=? fun to_sign_op -> - Context.Contract.manager ctxt src >|=? fun account -> - sign account.sk (Context.branch ctxt) to_sign_op - -let dal_publish_slot_header ?force_reveal ?counter ?fee ?gas_limit - ?storage_limit ctxt (src : Contract.t) slot_header = - manager_operation - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ~source:src - ctxt - (Dal_publish_slot_header slot_header) - >>=? fun to_sign_op -> - Context.Contract.manager ctxt src >|=? fun account -> - sign account.sk (Context.branch ctxt) to_sign_op - -let originated_zk_rollup op = - let packed = Operation.hash_packed op in - let nonce = Origination_nonce.Internal_for_tests.initial packed in - Zk_rollup.Internal_for_tests.originated_zk_rollup nonce - -let zk_rollup_origination ?force_reveal ?counter ?fee ?gas_limit ?storage_limit - ctxt (src : Contract.t) ~public_parameters ~circuits_info ~init_state - ~nb_ops = - manager_operation - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ~source:src - ctxt - (Zk_rollup_origination - {public_parameters; circuits_info; init_state; nb_ops}) - >>=? fun to_sign_op -> - Context.Contract.manager ctxt src >|=? fun account -> - let op = sign account.sk (Context.branch ctxt) to_sign_op in - originated_zk_rollup op |> fun addr -> (op, addr) - -let update_consensus_key ?force_reveal ?counter ?fee ?gas_limit ?storage_limit - ctxt (src : Contract.t) pkh = - manager_operation - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ~source:src - ctxt - (Update_consensus_key pkh) - >>=? fun to_sign_op -> - Context.Contract.manager ctxt src >|=? fun account -> - sign account.sk (Context.branch ctxt) to_sign_op - -let drain_delegate ctxt ~consensus_key ~delegate ~destination = - let contents = - Single (Drain_delegate {consensus_key; delegate; destination}) - in - Context.Contract.manager ctxt (Contract.Implicit consensus_key) - >|=? fun account -> - sign account.sk (Context.branch ctxt) (Contents_list contents) - -let zk_rollup_publish ?force_reveal ?counter ?fee ?gas_limit ?storage_limit ctxt - (src : Contract.t) ~zk_rollup ~ops = - manager_operation - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ~source:src - ctxt - (Zk_rollup_publish {zk_rollup; ops}) - >>=? fun to_sign_op -> - Context.Contract.manager ctxt src >|=? fun account -> - sign account.sk (Context.branch ctxt) to_sign_op - -let zk_rollup_update ?force_reveal ?counter ?fee ?gas_limit ?storage_limit ctxt - (src : Contract.t) ~zk_rollup ~update = - manager_operation - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ~source:src - ctxt - (Zk_rollup_update {zk_rollup; update}) - >>=? fun to_sign_op -> - Context.Contract.manager ctxt src >|=? fun account -> - sign account.sk (Context.branch ctxt) to_sign_op diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/op.mli b/src/proto_017_PtNairob/lib_protocol/test/helpers/op.mli deleted file mode 100644 index 56158fc3572b0172a14b7d6b95c19a8a95761e1f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/op.mli +++ /dev/null @@ -1,633 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 -open Alpha_context - -(* TODO: https://gitlab.com/tezos/tezos/-/issues/3181 - Improve documentation of the operation helpers *) - -(** Assemble the given signature and [contents_list] into a - [packed_operation]. - - The context argument is used to retrieve the branch. - - If the [signature option] argument is [None], then the resulting - operation is unsigned. - - This function is mainly useful to craft an operation with a - missing or invalid signatue. Otherwise, it is often better to use - one of the helpers below: they handle the signature internally to - directly return well-signed operations. *) -val pack_operation : - Context.t -> signature option -> 'a contents_list -> packed_operation - -val sign : - ?watermark:Signature.watermark -> - Signature.secret_key -> - Block_hash.t -> - packed_contents_list -> - packed_operation - -(** Create an unpacked endorsement that is expected for given [Block.t]. - - Optional parameters allow to specify the endorsed values: [level], - [round] and/or [block_payload_hash]. - - They also allow to specify the endorser ([delegate]), and/or the - [slot]. These default to the first slot and its delegate. - - Finally, the operation [branch] can be specified. It defaults to the - predecessor of the endorsed block. *) -val raw_endorsement : - ?delegate:public_key_hash -> - ?slot:Slot.t -> - ?level:Raw_level.t -> - ?round:Round.t -> - ?block_payload_hash:Block_payload_hash.t -> - ?branch:Block_hash.t -> - Block.t -> - Kind.endorsement Operation.t tzresult Lwt.t - -(** Create an unpacked preendorsement that is expected for a given - [Block.t]. - - Optional parameters are the same than {!raw_endorsement}. *) -val raw_preendorsement : - ?delegate:public_key_hash -> - ?slot:Slot.t -> - ?level:Raw_level.t -> - ?round:Round.t -> - ?block_payload_hash:Block_payload_hash.t -> - ?branch:Block_hash.t -> - Block.t -> - Kind.preendorsement Operation.t tzresult Lwt.t - -(** Create a packed endorsement that is expected for a given - [Block.t] by packing the result of {!raw_endorsement}. *) -val endorsement : - ?delegate:public_key_hash -> - ?slot:Slot.t -> - ?level:Raw_level.t -> - ?round:Round.t -> - ?block_payload_hash:Block_payload_hash.t -> - ?branch:Block_hash.t -> - Block.t -> - Operation.packed tzresult Lwt.t - -(** Create a packed preendorsement that is expected for a given - [Block.t] by packing the result of {!raw_preendorsement}. *) -val preendorsement : - ?delegate:public_key_hash -> - ?slot:Slot.t -> - ?level:Raw_level.t -> - ?round:Round.t -> - ?block_payload_hash:Block_payload_hash.t -> - ?branch:Block_hash.t -> - Block.t -> - Operation.packed tzresult Lwt.t - -type gas_limit = - | Max (** Max corresponds to the [max_gas_limit_per_operation] constant. *) - | High - (** High corresponds to [50_000] gas unit which should cover a - majority of use-cases. This is the default used when forging - manager operations. *) - | Low (** Low corresponds to the gas entry cost of a manager operation *) - | Zero - | Custom_gas of Gas.Arith.integral - -(** Pretty printer for gas_limit type. *) -val pp_gas_limit : Format.formatter -> gas_limit -> unit - -val transaction : - ?force_reveal:bool -> - ?counter:Manager_counter.t -> - ?fee:Tez.tez -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - ?parameters:Script.lazy_expr -> - ?entrypoint:Entrypoint.t -> - Context.t -> - Contract.t -> - Contract.t -> - Tez.t -> - Operation.packed tzresult Lwt.t - -(** Same as [transaction], but with a more generic destination - parameter. It is said unsafe because it can construct transactions - that will always fail, such as - - {ul {li Transaction to the deposit entrypoint of a transaction - rollup, as these transactions are necessarily internals.}} - - Optional arguments allow to override defaults: - - {ul {li [?force_reveal:bool]: prepend the operation to reveal - [source]'s public key if the latter has not been revealed - yet. Disabled (set to [false]) by default.}} *) -val unsafe_transaction : - ?force_reveal:bool -> - ?counter:Manager_counter.t -> - ?fee:Tez.t -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - ?parameters: - Michelson_v1_primitives.prim Micheline.canonical Data_encoding.lazy_t -> - ?entrypoint:Entrypoint_repr.t -> - Context.t -> - Contract.t -> - Contract.t -> - Tez.t -> - packed_operation tzresult Lwt.t - -val delegation : - ?force_reveal:bool -> - ?fee:Tez.tez -> - ?gas_limit:gas_limit -> - ?counter:Manager_counter.t -> - ?storage_limit:Z.t -> - Context.t -> - Contract.t -> - public_key_hash option -> - Operation.packed tzresult Lwt.t - -val set_deposits_limit : - ?force_reveal:bool -> - ?fee:Tez.tez -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - ?counter:Manager_counter.t -> - Context.t -> - Contract.t -> - Tez.tez option -> - Operation.packed tzresult Lwt.t - -val increase_paid_storage : - ?force_reveal:bool -> - ?counter:Manager_counter.t -> - ?fee:Tez.tez -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - Context.t -> - source:Contract.t -> - destination:Contract_hash.t -> - Z.t -> - Operation.packed tzresult Lwt.t - -(** [revelation ?fee ?gas_limit ?forge_pkh ctxt pkh] Creates a new - [Reveal] {!manager_operation} to reveal a public key [pkh] - applying to current context [ctxt]. - - Optional arguments allow to override defaults: - - {ul {li [?fee:Tez.tez]: specify a fee, otherwise set to - [Tez.zero].} - - {li [?gas_limit:Gas.Arith.integral]: force a gas limit, otherwise - set to 10000 gas units.} - - {li [?forge_pkh]: use a provided [pkh] as source, instead of - hashing [pkh]. Useful for forging non-honest reveal operations} - - {li [?storage_limit:Z.t]: forces a storage limit, otherwise - set to [Z.zero]}} -*) -val revelation : - ?fee:Tez.t -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - ?counter:Manager_counter.t -> - ?forge_pkh:public_key_hash option -> - Context.t -> - public_key -> - (packed_operation, tztrace) result Lwt.t - -val failing_noop : - Context.t -> public_key_hash -> string -> Operation.packed tzresult Lwt.t - -(** [contract_origination ctxt source] Create a new contract origination - operation, sign it with [source] and returns it alongside the contract - address. The contract address is using the initial origination nonce with the - hash of the operation. If this operation is combined with [combine_operations] - then the contract address is false as the nonce is not based on the correct - operation hash. - - Optional arguments allow to override defaults: - - {ul {li [?force_reveal:bool]: prepend the operation to reveal - [source]'s public key if the latter has not been revealed - yet. Disabled (set to [false]) by default.}} *) -val contract_origination : - ?force_reveal:bool -> - ?counter:Manager_counter.t -> - ?delegate:public_key_hash -> - script:Script.t -> - ?public_key:public_key -> - ?credit:Tez.tez -> - ?fee:Tez.tez -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - Context.t -> - Contract.t -> - (Operation.packed * Contract.t) tzresult Lwt.t - -val contract_origination_hash : - ?force_reveal:bool -> - ?counter:Manager_counter.t -> - ?delegate:public_key_hash -> - script:Script.t -> - ?public_key:public_key -> - ?credit:Tez.tez -> - ?fee:Tez.tez -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - Context.t -> - Contract.t -> - (Operation.packed * Contract_hash.t) tzresult Lwt.t - -val originated_contract : Operation.packed -> Contract.t - -val register_global_constant : - ?force_reveal:bool -> - ?counter:Manager_counter.t -> - ?public_key:Signature.public_key -> - ?fee:Tez.tez -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - Context.t -> - (* Account doing the registration *) - source:Contract.t -> - (* Micheline value to be registered *) - value:Protocol.Alpha_context.Script.lazy_expr -> - (Protocol.operation, tztrace) result Lwt.t - -val double_endorsement : - Context.t -> - Kind.endorsement Operation.t -> - Kind.endorsement Operation.t -> - Operation.packed - -val double_preendorsement : - Context.t -> - Kind.preendorsement Operation.t -> - Kind.preendorsement Operation.t -> - Operation.packed - -val double_baking : - Context.t -> - Block_header.block_header -> - Block_header.block_header -> - Operation.packed - -val activation : - Context.t -> - Signature.Public_key_hash.t -> - Blinded_public_key_hash.activation_code -> - Operation.packed tzresult Lwt.t - -val combine_operations : - ?public_key:public_key -> - ?counter:Manager_counter.t -> - ?spurious_operation:packed_operation -> - source:Contract.t -> - Context.t -> - packed_operation list -> - packed_operation tzresult Lwt.t - -(** Batch a list of (already signed) operations and (re-)sign with the - [source]. No revelation is inserted and the counters are kept as - they are unless [recompute_counters] is set to [true] (defaults false). *) -val batch_operations : - ?recompute_counters:bool -> - source:Contract.t -> - Context.t -> - packed_operation list -> - packed_operation tzresult Lwt.t - -(** Reveals a seed_nonce that was previously committed at a certain level *) -val seed_nonce_revelation : - Context.t -> Raw_level.t -> Nonce.t -> Operation.packed - -(** Reveals a VDF with a proof of correctness *) -val vdf_revelation : Context.t -> Seed.vdf_solution -> Operation.packed - -(** Craft the [contents_list] for a Proposals operation. - - Invocation: [proposals_contents ctxt source ?period proposals]. - - @param period defaults to the index of the current voting period - in [ctxt]. *) -val proposals_contents : - Context.t -> - Contract.t -> - ?period:int32 -> - Protocol_hash.t list -> - Kind.proposals contents_list tzresult Lwt.t - -(** Craft a Proposals operation. - - Invocation: [proposals ctxt source ?period proposals]. - - @param period defaults to the index of the current voting period - in [ctxt]. *) -val proposals : - Context.t -> - Contract.t -> - ?period:int32 -> - Protocol_hash.t list -> - Operation.packed tzresult Lwt.t - -(** Craft the [contents_list] for a Ballot operation. - - Invocation: [ballot_contents ctxt source ?period proposal ballot]. - - @param period defaults to the index of the current voting period - in [ctxt]. *) -val ballot_contents : - Context.t -> - Contract.t -> - ?period:int32 -> - Protocol_hash.t -> - Vote.ballot -> - Kind.ballot contents_list tzresult Lwt.t - -(** Craft a Ballot operation. - - Invocation: [ballot ctxt source ?period proposal ballot]. - - @param period defaults to the index of the current voting period - in [ctxt]. *) -val ballot : - Context.t -> - Contract.t -> - ?period:int32 -> - Protocol_hash.t -> - Vote.ballot -> - Operation.packed tzresult Lwt.t - -val dummy_script : Script.t - -val dummy_script_cost : Tez.t - -(** [transfer_ticket] allows an implicit account to transfer tickets they owned. - - The arguments are: - - {ul - {li [Context.t]: the context on which to apply the operation} - {li [source:Contract.t]: the source contract of the operation} - {li [Tx_rollup.t]: the rollup to which the withdrawal pertains} - {li [Tx_rollup_level.t]: the level on which the withdrawal was commited} - {li [contents:Script.lazy_expr]: the contents of the ticket of - the withdrawal} - {li [ty:Script.lazy_expr]: the type of the ticket of the withdrawal} - {li [ticketer:Contract.t]: the ticketer of the ticket of the withdrawal} - {li [Z.t]: the quantity of the ticket of the withdrawal} - {li [destination:Contract.t]: the destination contract that - should receive the ticket of the withdrawal} - {li [Entrypoint_repr.t]: the entrypoint of the destination - contract to which the ticket should be sent}} - - Optional arguments allow to override defaults: - - {ul {li [?force_reveal:bool]: prepend the operation to reveal - [source]'s public key if the latter has not been revealed - yet. Disabled (set to [false]) by default.}} *) -val transfer_ticket : - ?force_reveal:bool -> - ?counter:Manager_counter.t -> - ?fee:Tez.t -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - Context.t -> - source:Contract.t -> - contents:Script.lazy_expr -> - ty:Script.lazy_expr -> - ticketer:Contract.t -> - amount:Ticket_amount.t -> - destination:Contract.t -> - entrypoint:Entrypoint_repr.t -> - (packed_operation, tztrace) result Lwt.t - -(** [sc_rollup_origination ctxt source kind boot_sector] originates a - new smart contract rollup of some given [kind] booting using - [boot_sector]. - - Optional arguments allow to override defaults: - - {ul {li [?force_reveal:bool]: prepend the operation to reveal - [source]'s public key if the latter has not been revealed - yet. Disabled (set to [false]) by default.}} *) -val sc_rollup_origination : - ?force_reveal:bool -> - ?counter:Manager_counter.t -> - ?fee:Tez.t -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - origination_proof:Sc_rollup.Proof.serialized -> - Context.t -> - Contract.t -> - Sc_rollup.Kind.t -> - boot_sector:string -> - parameters_ty:Script.lazy_expr -> - (packed_operation * Sc_rollup.t) tzresult Lwt.t - -(** [sc_rollup_publish ctxt source rollup commitment] tries to publish - a commitment to the SCORU. Optional arguments allow to override - defaults: - - Optional arguments allow to override defaults: - - {ul {li [?force_reveal:bool]: prepend the operation to reveal - [source]'s public key if the latter has not been revealed - yet. Disabled (set to [false]) by default.}} *) -val sc_rollup_publish : - ?force_reveal:bool -> - ?counter:Manager_counter.t -> - ?fee:Tez.tez -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - Context.t -> - Contract.t -> - Sc_rollup.t -> - Sc_rollup.Commitment.t -> - Operation.packed tzresult Lwt.t - -(** [sc_rollup_cement ctxt source rollup commitment] tries to cement - the specified commitment. - - Optional arguments allow to override defaults: - - {ul {li [?force_reveal:bool]: prepend the operation to reveal - [source]'s public key if the latter has not been revealed - yet. Disabled (set to [false]) by default.}} *) -val sc_rollup_cement : - ?force_reveal:bool -> - ?counter:Manager_counter.t -> - ?fee:Tez.tez -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - Context.t -> - Contract.t -> - Sc_rollup.t -> - Sc_rollup.Commitment.Hash.t -> - Operation.packed tzresult Lwt.t - -val sc_rollup_execute_outbox_message : - ?counter:Manager_counter.t -> - ?fee:Tez.t -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - ?force_reveal:bool -> - Context.t -> - Contract.t -> - Sc_rollup.t -> - Sc_rollup.Commitment.Hash.t -> - output_proof:string -> - (packed_operation, tztrace) result Lwt.t - -(** [sc_rollup_recover_bond ctxt source sc_rollup staker] recovers the - commitment bond of [staker]. *) -val sc_rollup_recover_bond : - ?counter:Manager_counter.t -> - ?fee:Tez.tez -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - ?force_reveal:bool -> - Context.t -> - Contract.t -> - Sc_rollup.t -> - public_key_hash -> - Operation.packed tzresult Lwt.t - -val sc_rollup_add_messages : - ?force_reveal:bool -> - ?counter:Manager_counter.t -> - ?fee:Tez.tez -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - Context.t -> - Contract.t -> - string list -> - Operation.packed tzresult Lwt.t - -val sc_rollup_refute : - ?force_reveal:bool -> - ?counter:Manager_counter.t -> - ?fee:Tez.tez -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - Context.t -> - Contract.t -> - Sc_rollup.t -> - public_key_hash -> - Sc_rollup.Game.refutation -> - Operation.packed tzresult Lwt.t - -val sc_rollup_timeout : - ?force_reveal:bool -> - ?counter:Manager_counter.t -> - ?fee:Tez.tez -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - Context.t -> - Contract.t -> - Sc_rollup.t -> - Sc_rollup.Game.Index.t -> - Operation.packed tzresult Lwt.t - -val dal_publish_slot_header : - ?force_reveal:bool -> - ?counter:Manager_counter.t -> - ?fee:Tez.t -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - Context.t -> - Contract.t -> - Dal.Operations.Publish_slot_header.t -> - (packed_operation, tztrace) result Lwt.t - -(** [zk_rollup_origination ctxt source ~public_parameters ~circuits_info - ~init_state ~nb_ops] tries to originate a ZK Rollup. *) -val zk_rollup_origination : - ?force_reveal:bool -> - ?counter:Manager_counter.t -> - ?fee:Tez.t -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - Context.t -> - Contract.t -> - public_parameters:Plonk.Main_protocol.verifier_public_parameters -> - circuits_info:[`Public | `Private | `Fee] Zk_rollup.Account.SMap.t -> - init_state:Zk_rollup.State.t -> - nb_ops:int -> - (Operation.packed * Zk_rollup.t) tzresult Lwt.t - -val update_consensus_key : - ?force_reveal:bool -> - ?counter:Manager_counter.t -> - ?fee:Tez.t -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - Context.t -> - Contract.t -> - public_key -> - (packed_operation, tztrace) result Lwt.t - -val drain_delegate : - Context.t -> - consensus_key:Signature.Public_key_hash.t -> - delegate:Signature.Public_key_hash.t -> - destination:Signature.Public_key_hash.t -> - packed_operation tzresult Lwt.t - -(** [zk_rollup_publish ctxt source ~zk_rollup ~op] tries to add an operation - to the pending list of a ZK Rollup. *) -val zk_rollup_publish : - ?force_reveal:bool -> - ?counter:Manager_counter.t -> - ?fee:Tez.t -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - Context.t -> - Contract.t -> - zk_rollup:Zk_rollup.t -> - ops:(Zk_rollup.Operation.t * Zk_rollup.Ticket.t option) list -> - Operation.packed tzresult Lwt.t - -(** [zk_rollup_update ctxt source ~zk_rollup ~update] tries to apply an update - to a ZK Rollup. *) -val zk_rollup_update : - ?force_reveal:bool -> - ?counter:Manager_counter.t -> - ?fee:Tez.t -> - ?gas_limit:gas_limit -> - ?storage_limit:Z.t -> - Context.t -> - Contract.t -> - zk_rollup:Zk_rollup.t -> - update:Zk_rollup.Update.t -> - Operation.packed tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/operation_generator.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/operation_generator.ml deleted file mode 100644 index ce00e9d4f8a848939794e342f38ace74174fd9bc..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/operation_generator.ml +++ /dev/null @@ -1,739 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** These generators aims at generating operations which are not - necessary correct. The goal is to tests functions such as {! - Operation.compare} with as much as possible parameters that play a - role in operation [weight] computation. - - When adding a new operation, one should also add its weight - computation, hence knows which kind of generator should be provided - for this new operation.*) - -open Protocol -open Alpha_context - -(** {2 Operations kind labelling.} *) - -let consensus_pass = `PConsensus - -let anonymous_pass = `PAnonymous - -let vote_pass = `PVote - -let manager_pass = `PManager - -let all_passes = [`PConsensus; `PAnonymous; `PVote; `PManager] - -let all_non_manager_passes = [`PConsensus; `PAnonymous; `PVote] - -let consensus_kinds = [`KPreendorsement; `KEndorsement; `KDal_attestation] - -let anonymous_kinds = - [ - `KSeed_nonce_revelation; - `KVdf_revelation; - `KDouble_endorsement; - `KDouble_preendorsement; - `KDouble_baking; - `KActivate_account; - ] - -let vote_kinds = [`KProposals; `KBallot] - -(* N.b. we do not consider Failing_noop as those will never be valid. *) -let manager_kinds = - [ - `KReveal; - `KTransaction; - `KOrigination; - `KDelegation; - `KSet_deposits_limit; - `KIncrease_paid_storage; - `KRegister_global_constant; - `KTransfer_ticket; - `KDal_publish_slot_header; - `KSc_rollup_originate; - `KSc_rollup_add_messages; - `KSc_rollup_cement; - `KSc_rollup_publish; - `KSc_rollup_refute; - `KSc_rollup_timeout; - `KSc_rollup_execute_outbox_message; - `KSc_rollup_recover_bond; - ] - -let pass_to_operation_kinds = function - | `PConsensus -> consensus_kinds - | `PVote -> vote_kinds - | `PAnonymous -> anonymous_kinds - | `PManager -> [`KManager] - -let pp_kind fmt k = - Format.fprintf - fmt - "%s" - (match k with - | `KPreendorsement -> "KPreendorsement" - | `KEndorsement -> "KEndorsement" - | `KDal_attestation -> "KDal_attestation" - | `KSeed_nonce_revelation -> "KSeed_nonce_revelation" - | `KVdf_revelation -> "KVdf_revelation" - | `KDouble_endorsement -> "KDouble_endorsement" - | `KDouble_preendorsement -> "KDouble_preendorsement" - | `KDouble_baking -> "KDouble_baking" - | `KActivate_account -> "KActivate_account" - | `KProposals -> "KProposals" - | `KBallot -> "KBallot" - | `KManager -> "KManager") - -(** {2 Generators} *) - -module Gen_hash (H : sig - type t - - val size : int - - val of_bytes_exn : bytes -> t -end) = -struct - let gen = - let open QCheck2.Gen in - let+ str = string_size (pure H.size) in - H.of_bytes_exn (Bytes.unsafe_of_string str) -end - -(** {3 Selection in hashes list} *) - -let gen_block_hash = - let module G = Gen_hash (Block_hash) in - G.gen - -let random_payload_hash = - let module G = Gen_hash (Block_payload_hash) in - G.gen - -let gen_algo = QCheck2.Gen.oneofl Signature.algos - -let random_seed = - let open QCheck2.Gen in - let+ str = string_size (pure Tezos_crypto.Hacl.Ed25519.sk_size) in - Bytes.unsafe_of_string str - -let random_keys = - let open QCheck2.Gen in - let* algo = gen_algo in - let+ seed = random_seed in - Signature.generate_key ~algo ~seed () - -let random_tz1 = - let open QCheck2.Gen in - let+ str = string_size (pure Signature.Ed25519.Public_key_hash.size) in - (Ed25519 (Signature.Ed25519.Public_key_hash.of_string_exn str) - : public_key_hash) - -let random_tz2 = - let open QCheck2.Gen in - let+ str = string_size (pure Signature.Secp256k1.Public_key_hash.size) in - (Secp256k1 (Signature.Secp256k1.Public_key_hash.of_string_exn str) - : public_key_hash) - -let random_tz3 = - let open QCheck2.Gen in - let+ str = string_size (pure Signature.P256.Public_key_hash.size) in - (P256 (Signature.P256.Public_key_hash.of_string_exn str) : public_key_hash) - -let random_tz4 = - let open QCheck2.Gen in - let+ str = string_size (pure Signature.Bls.Public_key_hash.size) in - (Bls (Signature.Bls.Public_key_hash.of_string_exn str) : public_key_hash) - -let random_pkh = - let open QCheck2.Gen in - let* algo = gen_algo in - match algo with - | Ed25519 -> random_tz1 - | Secp256k1 -> random_tz2 - | P256 -> random_tz3 - | Bls -> random_tz4 - -let random_pk = - let open QCheck2.Gen in - let+ _, pk, _ = random_keys in - pk - -let random_signature = - let open QCheck2.Gen in - let* algo = option ~ratio:0.8 gen_algo in - match algo with - | None -> - let+ str = string_size (pure Signature.Ed25519.size) in - (Unknown (Bytes.unsafe_of_string str) : Signature.t) - | Some Ed25519 -> - let+ str = string_size (pure Signature.Ed25519.size) in - (Ed25519 (Signature.Ed25519.of_string_exn str) : Signature.t) - | Some Secp256k1 -> - let+ str = string_size (pure Signature.Secp256k1.size) in - (Secp256k1 (Signature.Secp256k1.of_string_exn str) : Signature.t) - | Some P256 -> - let+ str = string_size (pure Signature.P256.size) in - (P256 (Signature.P256.of_string_exn str) : Signature.t) - | Some Bls -> - let+ seed = random_seed in - let _, _, sk = Signature.generate_key ~algo:Bls ~seed () in - Signature.sign sk Bytes.empty - -let random_signature = - let open QCheck2.Gen in - graft_corners - random_signature - Signature. - [ - of_ed25519 Signature.Ed25519.zero; - of_secp256k1 Signature.Secp256k1.zero; - of_p256 Signature.P256.zero; - of_bls Signature.Bls.zero; - Unknown (Bytes.make 64 '\000'); - ] - () - -let random_contract_hash = - let module G = Gen_hash (Contract_hash) in - G.gen - -let block_headers = - let bh1 = - {json|{ "level": 2, "proto": 1, "predecessor": "BLbcVY1kYiKQy2MJJfoHJMN2xRk5QPG1PEKWMDSyW2JMxBsMmiL", "timestamp": "2022-08-08T11:16:30Z", "validation_pass": 4, "operations_hash": "LLoa7bxRTKaQN2bLYoitYB6bU2DvLnBAqrVjZcvJ364cTcX2PZYKU", "fitness": [ "02", "00000002", "", "ffffffff", "00000001" ], "context": "CoUvpF8XBUfz3w9CJumt4ZKGZkrcdcfs1Qdrrd1ZeFij64E1QCud", "payload_hash": "vh2TyrWeZ2dydEy9ZjmvrjQvyCs5sdHZPypcZrXDUSM1tNuPermf", "payload_round": 1, "proof_of_work_nonce": "62de1e0d00000000", "liquidity_baking_toggle_vote": "pass", "signature": "sigaXGo4DWsZwo1SvbKCp2hLgE5jcwd61Ufkc3iMt3sXy3NBj9jticuJKJnRhyH2ZPJQMwEuDqQTgZgoK5xRH6HeF7YxLb4u" }|json} - in - let bh2 = - {json|{ "level": 3, "proto": 1, "predecessor": "BLAUNUbzKHgA4DYQEXCbxY73wdE2roGAzvJJbFp8dQe62Ekpada", "timestamp": "2022-08-08T11:16:32Z", "validation_pass": 4, "operations_hash": "LLoaWjBX8Cm8DVpoLNtm7FPNnxUdL6Dakq122pVfNHYaf2rE9GQXi", "fitness": [ "02", "00000003", "", "fffffffe", "00000000" ], "context": "CoUtWowJUqXwMm4pbR1jjyFfVRHqRHGs6bYVDaaByvbmULoAND2x", "payload_hash": "vh1p1VzeYjZLEW6WDqdTwVy354KEmGCDgPmagEKcLN4NT4X58mNk", "payload_round": 0, "proof_of_work_nonce": "62de1e0d00000000", "liquidity_baking_toggle_vote": "pass", "signature": "sigVqWWE7BPuxHqPWiVRmzQ1eMZZAPAxGJ94ytY2sjV8Y1Z4QH1F2bPGZS1ZeWDbqmcppPPFobRpi7wNasQ17Mm9CFGKag2t" }|json} - in - let bh3 = - {json|{ "level": 4, "proto": 1, "predecessor": "BLuurCvGmNPTzXSnGCpcFPy5h8A49PwH2LnfAWBnp5R1qv5czwe", "timestamp": "2022-08-08T11:16:33Z", "validation_pass": 4, "operations_hash": "LLoaf8AANzyNxhk715zykDrwG5Bpqw6FsZLWWNp2Dcm3ewFrcc3Wc", "fitness": [ "02", "00000004", "", "ffffffff", "00000000" ], "context": "CoVzxEBMDhxpGVxrguik6r5qVogJBFyhuvwm2KZBcsmvqhekPiwL", "payload_hash": "vh2gWcSUUhJBwvjx4vS7JN5ioMVWpHCSK6W2MKNPr5dn6NUdfFDQ", "payload_round": 0, "proof_of_work_nonce": "62de1e0d00000000", "seed_nonce_hash": "nceV3VjdHp1yk6uqcQicQBxLJY1AfWvLSabQpqnpiqkC1q2tS35EN", "liquidity_baking_toggle_vote": "pass", "signature": "sigijumaDLSQwjh2AKK7af1VcEDsZsRwbweL8hF176puhHy3ySVocNCbrwPqJLiQP8EbqY5YL6z6b1vDaw12h8MQU2Rh4SW1" }|json} - in - List.map - (fun s -> - let open Data_encoding.Json in - from_string s |> function - | Ok json -> destruct Alpha_context.Block_header.encoding json - | Error _ -> assert false) - [bh1; bh2; bh3] - -let random_block_header = QCheck2.Gen.oneofl block_headers - -let random_sc_rollup = - let module G = Gen_hash (Sc_rollup.Address) in - G.gen - -let random_proto = - let module G = Gen_hash (Protocol_hash) in - G.gen - -let random_code = - let open QCheck2.Gen in - let+ str = string_size (pure Signature.Ed25519.Public_key_hash.size) in - let (`Hex hex) = Hex.of_string str in - Blinded_public_key_hash.activation_code_of_hex hex - |> WithExceptions.Option.get ~loc:__LOC__ - -(** {2 Operations parameters generators} *) - -let random_shell : Tezos_base.Operation.shell_header QCheck2.Gen.t = - let open QCheck2.Gen in - let+ branch = gen_block_hash in - Tezos_base.Operation.{branch} - -let gen_slot = - let open QCheck2.Gen in - let+ i = small_nat in - match Slot.Internal_for_tests.of_int i with - | Ok slot -> slot - | Error _ -> assert false - -let gen_level = - let open QCheck2.Gen in - let+ i = ui32 in - match Raw_level.of_int32 i with Ok v -> v | Error _ -> assert false - -let gen_round = - let open QCheck2.Gen in - let+ i = ui32 in - match Round.of_int32 i with Ok v -> v | Error _ -> assert false - -let generate_consensus_content : consensus_content QCheck2.Gen.t = - let open QCheck2.Gen in - let* slot = gen_slot in - let* level = gen_level in - let* round = gen_round in - let+ block_payload_hash = random_payload_hash in - {slot; level; round; block_payload_hash} - -let gen_tez = - let open QCheck2.Gen in - let+ i = ui64 in - match Tez.of_mutez i with None -> Tez.zero | Some v -> v - -let gen_fee = gen_tez - -let gen_amount = gen_tez - -let gen_amount_in_bytes = - let open QCheck2.Gen in - let+ i = nat in - Z.of_int i - -let random_contract = - let open QCheck2.Gen in - let* b = bool in - if b then - let+ pkh = random_pkh in - Contract.Implicit pkh - else - let+ contract_hash = random_contract_hash in - Contract.Originated contract_hash - -let gen_counters = - let open QCheck2.Gen in - let+ i = nat in - Manager_counter.Internal_for_tests.of_int i - -let gen_ticket_amounts = - let open QCheck2.Gen in - let+ i = nat in - Option.value (Ticket_amount.of_zint (Z.of_int i)) ~default:Ticket_amount.one - -let gen_gas_limit = - let open QCheck2.Gen in - let+ i = nat in - Gas.Arith.integral_of_int_exn i - -let gen_storage_limit = - let open QCheck2.Gen in - let+ i = nat in - Z.of_int i - -let nonces = - List.map - (fun i -> - let b = Bytes.create 32 in - Bytes.set_int8 b 0 i ; - Alpha_context.Nonce.of_bytes b |> function - | Ok v -> v - | Error _ -> assert false) - [1; 2; 3] - -let random_nonce = QCheck2.Gen.oneofl nonces - -let vdf_solutions = - let open Environment.Vdf in - let opt_assert = function Some v -> v | None -> assert false in - List.map - (fun i -> - let b = Bytes.create form_size_bytes in - Bytes.set_int8 b 0 i ; - let result = result_of_bytes_opt b |> opt_assert in - let proof = proof_of_bytes_opt b |> opt_assert in - (result, proof)) - [1; 2; 3] - -(** {2 Generators for each Operation Kind} *) - -let wrap_operation sh (pdata : 'kind protocol_data) : 'kind operation = - {shell = sh; protocol_data = pdata} - -let generate_op (gen_op : 'kind contents QCheck2.Gen.t) : - 'kind operation QCheck2.Gen.t = - let open QCheck2.Gen in - let* op = gen_op in - let* signature = option ~ratio:0.9 random_signature in - let+ shell = random_shell in - let contents = Single op in - let protocol_data = {contents; signature} in - wrap_operation shell protocol_data - -let generate_operation gen_op = - let open QCheck2.Gen in - let+ op = generate_op gen_op in - Operation.pack op - -let generate_preendorsement = - let open QCheck2.Gen in - let+ cc = generate_consensus_content in - Preendorsement cc - -let generate_endorsement = - let open QCheck2.Gen in - let+ cc = generate_consensus_content in - Endorsement cc - -let generate_dal_attestation = - let open QCheck2.Gen in - let+ attestor = random_pkh in - Dal_attestation - Dal.Attestation. - {attestor; attestation = Dal.Attestation.empty; level = Raw_level.root} - -let generate_vdf_revelation = - let open QCheck2.Gen in - let+ solution = oneofl vdf_solutions in - Vdf_revelation {solution} - -let generate_seed_nonce_revelation = - let open QCheck2.Gen in - let* level = gen_level in - let+ nonce = random_nonce in - Seed_nonce_revelation {level; nonce} - -let generate_double_preendorsement = - let open QCheck2.Gen in - let* op1 = generate_op generate_preendorsement in - let+ op2 = generate_op generate_preendorsement in - Double_preendorsement_evidence {op1; op2} - -let generate_double_endorsement = - let open QCheck2.Gen in - let* op1 = generate_op generate_endorsement in - let+ op2 = generate_op generate_endorsement in - Double_endorsement_evidence {op1; op2} - -let generate_double_baking = - let open QCheck2.Gen in - let* bh1 = random_block_header in - let+ bh2 = random_block_header in - Double_baking_evidence {bh1; bh2} - -let generate_activate_account = - let open QCheck2.Gen in - let* activation_code = random_code in - let+ id = random_tz1 in - let id = match id with Signature.Ed25519 pkh -> pkh | _ -> assert false in - Activate_account {id; activation_code} - -let random_period = - let open QCheck2.Gen in - let+ i = ui32 in - i - -let generate_proposals = - let open QCheck2.Gen in - let* source = random_pkh in - let+ period = random_period in - let proposals = [] in - Proposals {source; period; proposals} - -let generate_ballot = - let open QCheck2.Gen in - let* source = random_pkh in - let* period = random_period in - let+ proposal = random_proto in - let ballot = Vote.Pass in - Ballot {source; period; proposal; ballot} - -let generate_manager_aux ?source gen_manop = - let open QCheck2.Gen in - let* source = - match source with None -> random_pkh | Some source -> return source - in - let* fee = gen_fee in - let* counter = gen_counters in - let* gas_limit = gen_gas_limit in - let* storage_limit = gen_storage_limit in - let+ operation = gen_manop in - Manager_operation {source; fee; counter; operation; gas_limit; storage_limit} - -let generate_manager ?source gen_manop = - generate_op (generate_manager_aux ?source gen_manop) - -let generate_manager_operation ?source gen_manop = - let open QCheck2.Gen in - let+ manop = generate_manager ?source gen_manop in - Operation.pack manop - -let generate_reveal = - let open QCheck2.Gen in - let+ pk = random_pk in - Reveal pk - -let generate_transaction = - let open QCheck2.Gen in - let* amount = gen_amount in - let+ destination = random_contract in - let parameters = Script.unit_parameter in - let entrypoint = Entrypoint.default in - Transaction {amount; parameters; entrypoint; destination} - -let generate_origination = - let open QCheck2.Gen in - let+ credit = gen_amount in - let delegate = None in - let script = Script.{code = unit_parameter; storage = unit_parameter} in - Origination {delegate; script; credit} - -let generate_delegation = - let open QCheck2.Gen in - let+ delegate = option random_pkh in - Delegation delegate - -let generate_increase_paid_storage = - let open QCheck2.Gen in - let* amount_in_bytes = gen_amount_in_bytes in - let+ destination = random_contract_hash in - Increase_paid_storage {amount_in_bytes; destination} - -let generate_set_deposits_limit = - let open QCheck2.Gen in - let+ amount_opt = option gen_amount in - Set_deposits_limit amount_opt - -let generate_register_global_constant = - let value = Script_repr.lazy_expr (Expr.from_string "Pair 1 2") in - QCheck2.Gen.pure (Register_global_constant {value}) - -let generate_transfer_ticket = - let open QCheck2.Gen in - let* ticketer = random_contract in - let* destination = random_contract in - let+ amount = gen_ticket_amounts in - let contents = Script.lazy_expr (Expr.from_string "1") in - let ty = Script.lazy_expr (Expr.from_string "nat") in - let entrypoint = Entrypoint.default in - Transfer_ticket {contents; ty; ticketer; amount; destination; entrypoint} - -let generate_dal_publish_slot_header = - let published_level = Alpha_context.Raw_level.of_int32_exn Int32.zero in - let slot_index = Alpha_context.Dal.Slot_index.zero in - let commitment = Alpha_context.Dal.Slot.Commitment.zero in - let commitment_proof = Alpha_context.Dal.Slot.Commitment_proof.zero in - let slot_header = - Alpha_context.Dal.Operations.Publish_slot_header. - {published_level; slot_index; commitment; commitment_proof} - in - QCheck2.Gen.pure (Dal_publish_slot_header slot_header) - -let generate_sc_rollup_originate = - let kind = Sc_rollup.Kind.Example_arith in - let boot_sector = "" in - let parameters_ty = Script.lazy_expr (Expr.from_string "1") in - let origination_proof = - Lwt_main.run (Sc_rollup_helpers.compute_origination_proof ~boot_sector kind) - in - QCheck2.Gen.pure - (Sc_rollup_originate {kind; boot_sector; origination_proof; parameters_ty}) - -let generate_sc_rollup_add_messages = - let open QCheck2.Gen in - return (Sc_rollup_add_messages {messages = []}) - -let sc_dummy_commitment = - let number_of_ticks = - match Sc_rollup.Number_of_ticks.of_value 3000L with - | None -> assert false - | Some x -> x - in - Sc_rollup.Commitment. - { - predecessor = Sc_rollup.Commitment.Hash.zero; - inbox_level = Raw_level.of_int32_exn Int32.zero; - number_of_ticks; - compressed_state = Sc_rollup.State_hash.zero; - } - -let generate_sc_rollup_cement = - let open QCheck2.Gen in - let+ rollup = random_sc_rollup in - let commitment = Sc_rollup.Commitment.hash_uncarbonated sc_dummy_commitment in - Sc_rollup_cement {rollup; commitment} - -let generate_sc_rollup_publish = - let open QCheck2.Gen in - let+ rollup = random_sc_rollup in - let commitment = sc_dummy_commitment in - Sc_rollup_publish {rollup; commitment} - -let generate_sc_rollup_refute = - let open QCheck2.Gen in - let* opponent = random_pkh in - let+ rollup = random_sc_rollup in - let refutation : Sc_rollup.Game.refutation = - Sc_rollup.Game.Move {choice = Sc_rollup.Tick.initial; step = Dissection []} - in - Sc_rollup_refute {rollup; opponent; refutation} - -let generate_sc_rollup_timeout = - let open QCheck2.Gen in - let* source = random_pkh in - let* rollup = random_sc_rollup in - let+ staker = random_pkh in - let stakers = Sc_rollup.Game.Index.make source staker in - Sc_rollup_timeout {rollup; stakers} - -let generate_sc_rollup_execute_outbox_message = - let open QCheck2.Gen in - let+ rollup = random_sc_rollup in - let cemented_commitment = - Sc_rollup.Commitment.hash_uncarbonated sc_dummy_commitment - in - let output_proof = "" in - Sc_rollup_execute_outbox_message {rollup; cemented_commitment; output_proof} - -let generate_sc_rollup_recover_bond = - let open QCheck2.Gen in - let* staker = random_pkh in - let+ sc_rollup = random_sc_rollup in - Sc_rollup_recover_bond {sc_rollup; staker} - -(** {2 By Kind Operation Generator} *) - -let generator_of ?source = function - | `KReveal -> generate_manager_operation ?source generate_reveal - | `KTransaction -> generate_manager_operation ?source generate_transaction - | `KOrigination -> generate_manager_operation ?source generate_origination - | `KSet_deposits_limit -> - generate_manager_operation ?source generate_set_deposits_limit - | `KIncrease_paid_storage -> - generate_manager_operation ?source generate_increase_paid_storage - | `KDelegation -> generate_manager_operation ?source generate_delegation - | `KRegister_global_constant -> - generate_manager_operation ?source generate_register_global_constant - | `KTransfer_ticket -> - generate_manager_operation ?source generate_transfer_ticket - | `KDal_publish_slot_header -> - generate_manager_operation ?source generate_dal_publish_slot_header - | `KSc_rollup_originate -> - generate_manager_operation ?source generate_sc_rollup_originate - | `KSc_rollup_add_messages -> - generate_manager_operation ?source generate_sc_rollup_add_messages - | `KSc_rollup_cement -> - generate_manager_operation ?source generate_sc_rollup_cement - | `KSc_rollup_publish -> - generate_manager_operation ?source generate_sc_rollup_publish - | `KSc_rollup_refute -> - generate_manager_operation ?source generate_sc_rollup_refute - | `KSc_rollup_timeout -> - generate_manager_operation ?source generate_sc_rollup_timeout - | `KSc_rollup_execute_outbox_message -> - generate_manager_operation - ?source - generate_sc_rollup_execute_outbox_message - | `KSc_rollup_recover_bond -> - generate_manager_operation ?source generate_sc_rollup_recover_bond - -let generate_non_manager_operation = - let open QCheck2.Gen in - let* pass = oneofl all_non_manager_passes in - let* kind = oneofl (pass_to_operation_kinds pass) in - match kind with - | `KPreendorsement -> generate_operation generate_preendorsement - | `KEndorsement -> generate_operation generate_endorsement - | `KDal_attestation -> generate_operation generate_dal_attestation - | `KSeed_nonce_revelation -> generate_operation generate_seed_nonce_revelation - | `KVdf_revelation -> generate_operation generate_vdf_revelation - | `KDouble_endorsement -> generate_operation generate_double_endorsement - | `KDouble_preendorsement -> generate_operation generate_double_preendorsement - | `KDouble_baking -> generate_operation generate_double_baking - | `KActivate_account -> generate_operation generate_activate_account - | `KProposals -> generate_operation generate_proposals - | `KBallot -> generate_operation generate_ballot - | `KManager -> assert false - -let generate_manager_operation batch_size = - let open QCheck2.Gen in - let* source = random_pkh in - let source = Some source in - let* l = - flatten_l (Stdlib.List.init batch_size (fun _ -> oneofl manager_kinds)) - in - let* packed_manager_ops = flatten_l (List.map (generator_of ?source) l) in - let first_op = Stdlib.List.hd packed_manager_ops in - let unpacked_operations = - List.map - (function - | {Alpha_context.protocol_data = Operation_data {contents; _}; _} -> ( - match Contents_list contents with - | Contents_list (Single o) -> Contents o - | Contents_list - (Cons (Manager_operation {operation = Reveal _; _}, Single o)) - -> - Contents o - | _ -> assert false)) - packed_manager_ops - in - let contents_list = - List.fold_left - (fun acc -> function - | Contents (Manager_operation m) -> - Contents (Manager_operation m) :: acc - | x -> x :: acc) - [] - unpacked_operations - |> List.rev - in - let (Contents_list contents_list) = - match Operation.of_list contents_list with Ok v -> v | _ -> assert false - in - let signature = - match first_op.protocol_data with - | Operation_data {signature; _} -> signature - in - let protocol_data = {contents = contents_list; signature} in - return (Operation.pack {shell = first_op.shell; protocol_data}) - -(** The default upper bound on the number of manager operations in a batch. - - As of December 2022, there is no batch maximal size enforced - anywhere in the protocol. However, the Octez Shell only accepts - batches of at most [operations_batch_size] operations, which has a - default value of [50] in [src/lib_shell_services/shell_limits.ml]. - The protocol tests do not necessarily have to align with this - value, but there is no reason either to choose a different - one. Therefore, they use the same bound, but decremented once to - account for some tests adding a reveal at the front of the batch as - needed. *) -let max_batch_size = 49 - -let generate_operation = - let open QCheck2.Gen in - let* pass = oneofl all_passes in - let* kind = oneofl (pass_to_operation_kinds pass) in - let+ packed_operation = - match kind with - | `KPreendorsement -> generate_operation generate_preendorsement - | `KEndorsement -> generate_operation generate_endorsement - | `KDal_attestation -> generate_operation generate_dal_attestation - | `KSeed_nonce_revelation -> - generate_operation generate_seed_nonce_revelation - | `KVdf_revelation -> generate_operation generate_vdf_revelation - | `KDouble_endorsement -> generate_operation generate_double_endorsement - | `KDouble_preendorsement -> - generate_operation generate_double_preendorsement - | `KDouble_baking -> generate_operation generate_double_baking - | `KActivate_account -> generate_operation generate_activate_account - | `KProposals -> generate_operation generate_proposals - | `KBallot -> generate_operation generate_ballot - | `KManager -> - let* batch_size = int_range 1 max_batch_size in - generate_manager_operation batch_size - in - (kind, (Operation.hash_packed packed_operation, packed_operation)) diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/rewards.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/rewards.ml deleted file mode 100644 index bc9c833a82211c53e0538be7e3d589ab57eeb9f5..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/rewards.ml +++ /dev/null @@ -1,1641 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2019--2021 Nomadic Labs, *) -(* Copyright (c) 2019 Cryptium Labs *) -(* *) -(* 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 tables are precomputed using this the following formulas: - -let max_endos = 256 -let max_reward = 40 - -let r = 0.5 -let a = 3. -let b = 1.5 - -let ( -- ) i j = List.init (j - i + 1) (fun x -> x + i) - -let baking_rewards = - let reward p e = - let r_aux = - if p = 0 then - r *. (float_of_int max_reward) - else - a - in - let r = r_aux /. (float_of_int max_endos) in - let r = 1_000_000. *. r in - Float.to_int ((float_of_int e) *. (ceil r)) in - - let ps = 0 -- 2 in - let es = 0 -- max_endos in - - List.map (fun p -> - List.map (fun e -> - reward p e - ) es |> Array.of_list - ) ps |> Array.of_list - - -let endorsing_rewards = - let reward p e = - let r_aux = - (1. -. r) *. - (float_of_int max_reward) /. - (float_of_int max_endos) in - let r = if p = 0 then r_aux else r_aux /. b in - let r = 1_000_000. *. r in - Float.to_int ((float_of_int e) *. (floor r)) in - - let ps = 0 -- 2 in - let es = 0 -- max_endos in - - List.map (fun p -> - List.map (fun e -> - reward p e - ) es |> Array.of_list - ) ps |> Array.of_list - - *) - -let baking_rewards : int array array = - [| - [| - 0; - 78125; - 156250; - 234375; - 312500; - 390625; - 468750; - 546875; - 625000; - 703125; - 781250; - 859375; - 937500; - 1015625; - 1093750; - 1171875; - 1250000; - 1328125; - 1406250; - 1484375; - 1562500; - 1640625; - 1718750; - 1796875; - 1875000; - 1953125; - 2031250; - 2109375; - 2187500; - 2265625; - 2343750; - 2421875; - 2500000; - 2578125; - 2656250; - 2734375; - 2812500; - 2890625; - 2968750; - 3046875; - 3125000; - 3203125; - 3281250; - 3359375; - 3437500; - 3515625; - 3593750; - 3671875; - 3750000; - 3828125; - 3906250; - 3984375; - 4062500; - 4140625; - 4218750; - 4296875; - 4375000; - 4453125; - 4531250; - 4609375; - 4687500; - 4765625; - 4843750; - 4921875; - 5000000; - 5078125; - 5156250; - 5234375; - 5312500; - 5390625; - 5468750; - 5546875; - 5625000; - 5703125; - 5781250; - 5859375; - 5937500; - 6015625; - 6093750; - 6171875; - 6250000; - 6328125; - 6406250; - 6484375; - 6562500; - 6640625; - 6718750; - 6796875; - 6875000; - 6953125; - 7031250; - 7109375; - 7187500; - 7265625; - 7343750; - 7421875; - 7500000; - 7578125; - 7656250; - 7734375; - 7812500; - 7890625; - 7968750; - 8046875; - 8125000; - 8203125; - 8281250; - 8359375; - 8437500; - 8515625; - 8593750; - 8671875; - 8750000; - 8828125; - 8906250; - 8984375; - 9062500; - 9140625; - 9218750; - 9296875; - 9375000; - 9453125; - 9531250; - 9609375; - 9687500; - 9765625; - 9843750; - 9921875; - 10000000; - 10078125; - 10156250; - 10234375; - 10312500; - 10390625; - 10468750; - 10546875; - 10625000; - 10703125; - 10781250; - 10859375; - 10937500; - 11015625; - 11093750; - 11171875; - 11250000; - 11328125; - 11406250; - 11484375; - 11562500; - 11640625; - 11718750; - 11796875; - 11875000; - 11953125; - 12031250; - 12109375; - 12187500; - 12265625; - 12343750; - 12421875; - 12500000; - 12578125; - 12656250; - 12734375; - 12812500; - 12890625; - 12968750; - 13046875; - 13125000; - 13203125; - 13281250; - 13359375; - 13437500; - 13515625; - 13593750; - 13671875; - 13750000; - 13828125; - 13906250; - 13984375; - 14062500; - 14140625; - 14218750; - 14296875; - 14375000; - 14453125; - 14531250; - 14609375; - 14687500; - 14765625; - 14843750; - 14921875; - 15000000; - 15078125; - 15156250; - 15234375; - 15312500; - 15390625; - 15468750; - 15546875; - 15625000; - 15703125; - 15781250; - 15859375; - 15937500; - 16015625; - 16093750; - 16171875; - 16250000; - 16328125; - 16406250; - 16484375; - 16562500; - 16640625; - 16718750; - 16796875; - 16875000; - 16953125; - 17031250; - 17109375; - 17187500; - 17265625; - 17343750; - 17421875; - 17500000; - 17578125; - 17656250; - 17734375; - 17812500; - 17890625; - 17968750; - 18046875; - 18125000; - 18203125; - 18281250; - 18359375; - 18437500; - 18515625; - 18593750; - 18671875; - 18750000; - 18828125; - 18906250; - 18984375; - 19062500; - 19140625; - 19218750; - 19296875; - 19375000; - 19453125; - 19531250; - 19609375; - 19687500; - 19765625; - 19843750; - 19921875; - 20000000; - |]; - [| - 0; - 11719; - 23438; - 35157; - 46876; - 58595; - 70314; - 82033; - 93752; - 105471; - 117190; - 128909; - 140628; - 152347; - 164066; - 175785; - 187504; - 199223; - 210942; - 222661; - 234380; - 246099; - 257818; - 269537; - 281256; - 292975; - 304694; - 316413; - 328132; - 339851; - 351570; - 363289; - 375008; - 386727; - 398446; - 410165; - 421884; - 433603; - 445322; - 457041; - 468760; - 480479; - 492198; - 503917; - 515636; - 527355; - 539074; - 550793; - 562512; - 574231; - 585950; - 597669; - 609388; - 621107; - 632826; - 644545; - 656264; - 667983; - 679702; - 691421; - 703140; - 714859; - 726578; - 738297; - 750016; - 761735; - 773454; - 785173; - 796892; - 808611; - 820330; - 832049; - 843768; - 855487; - 867206; - 878925; - 890644; - 902363; - 914082; - 925801; - 937520; - 949239; - 960958; - 972677; - 984396; - 996115; - 1007834; - 1019553; - 1031272; - 1042991; - 1054710; - 1066429; - 1078148; - 1089867; - 1101586; - 1113305; - 1125024; - 1136743; - 1148462; - 1160181; - 1171900; - 1183619; - 1195338; - 1207057; - 1218776; - 1230495; - 1242214; - 1253933; - 1265652; - 1277371; - 1289090; - 1300809; - 1312528; - 1324247; - 1335966; - 1347685; - 1359404; - 1371123; - 1382842; - 1394561; - 1406280; - 1417999; - 1429718; - 1441437; - 1453156; - 1464875; - 1476594; - 1488313; - 1500032; - 1511751; - 1523470; - 1535189; - 1546908; - 1558627; - 1570346; - 1582065; - 1593784; - 1605503; - 1617222; - 1628941; - 1640660; - 1652379; - 1664098; - 1675817; - 1687536; - 1699255; - 1710974; - 1722693; - 1734412; - 1746131; - 1757850; - 1769569; - 1781288; - 1793007; - 1804726; - 1816445; - 1828164; - 1839883; - 1851602; - 1863321; - 1875040; - 1886759; - 1898478; - 1910197; - 1921916; - 1933635; - 1945354; - 1957073; - 1968792; - 1980511; - 1992230; - 2003949; - 2015668; - 2027387; - 2039106; - 2050825; - 2062544; - 2074263; - 2085982; - 2097701; - 2109420; - 2121139; - 2132858; - 2144577; - 2156296; - 2168015; - 2179734; - 2191453; - 2203172; - 2214891; - 2226610; - 2238329; - 2250048; - 2261767; - 2273486; - 2285205; - 2296924; - 2308643; - 2320362; - 2332081; - 2343800; - 2355519; - 2367238; - 2378957; - 2390676; - 2402395; - 2414114; - 2425833; - 2437552; - 2449271; - 2460990; - 2472709; - 2484428; - 2496147; - 2507866; - 2519585; - 2531304; - 2543023; - 2554742; - 2566461; - 2578180; - 2589899; - 2601618; - 2613337; - 2625056; - 2636775; - 2648494; - 2660213; - 2671932; - 2683651; - 2695370; - 2707089; - 2718808; - 2730527; - 2742246; - 2753965; - 2765684; - 2777403; - 2789122; - 2800841; - 2812560; - 2824279; - 2835998; - 2847717; - 2859436; - 2871155; - 2882874; - 2894593; - 2906312; - 2918031; - 2929750; - 2941469; - 2953188; - 2964907; - 2976626; - 2988345; - 3000064; - |]; - [| - 0; - 11719; - 23438; - 35157; - 46876; - 58595; - 70314; - 82033; - 93752; - 105471; - 117190; - 128909; - 140628; - 152347; - 164066; - 175785; - 187504; - 199223; - 210942; - 222661; - 234380; - 246099; - 257818; - 269537; - 281256; - 292975; - 304694; - 316413; - 328132; - 339851; - 351570; - 363289; - 375008; - 386727; - 398446; - 410165; - 421884; - 433603; - 445322; - 457041; - 468760; - 480479; - 492198; - 503917; - 515636; - 527355; - 539074; - 550793; - 562512; - 574231; - 585950; - 597669; - 609388; - 621107; - 632826; - 644545; - 656264; - 667983; - 679702; - 691421; - 703140; - 714859; - 726578; - 738297; - 750016; - 761735; - 773454; - 785173; - 796892; - 808611; - 820330; - 832049; - 843768; - 855487; - 867206; - 878925; - 890644; - 902363; - 914082; - 925801; - 937520; - 949239; - 960958; - 972677; - 984396; - 996115; - 1007834; - 1019553; - 1031272; - 1042991; - 1054710; - 1066429; - 1078148; - 1089867; - 1101586; - 1113305; - 1125024; - 1136743; - 1148462; - 1160181; - 1171900; - 1183619; - 1195338; - 1207057; - 1218776; - 1230495; - 1242214; - 1253933; - 1265652; - 1277371; - 1289090; - 1300809; - 1312528; - 1324247; - 1335966; - 1347685; - 1359404; - 1371123; - 1382842; - 1394561; - 1406280; - 1417999; - 1429718; - 1441437; - 1453156; - 1464875; - 1476594; - 1488313; - 1500032; - 1511751; - 1523470; - 1535189; - 1546908; - 1558627; - 1570346; - 1582065; - 1593784; - 1605503; - 1617222; - 1628941; - 1640660; - 1652379; - 1664098; - 1675817; - 1687536; - 1699255; - 1710974; - 1722693; - 1734412; - 1746131; - 1757850; - 1769569; - 1781288; - 1793007; - 1804726; - 1816445; - 1828164; - 1839883; - 1851602; - 1863321; - 1875040; - 1886759; - 1898478; - 1910197; - 1921916; - 1933635; - 1945354; - 1957073; - 1968792; - 1980511; - 1992230; - 2003949; - 2015668; - 2027387; - 2039106; - 2050825; - 2062544; - 2074263; - 2085982; - 2097701; - 2109420; - 2121139; - 2132858; - 2144577; - 2156296; - 2168015; - 2179734; - 2191453; - 2203172; - 2214891; - 2226610; - 2238329; - 2250048; - 2261767; - 2273486; - 2285205; - 2296924; - 2308643; - 2320362; - 2332081; - 2343800; - 2355519; - 2367238; - 2378957; - 2390676; - 2402395; - 2414114; - 2425833; - 2437552; - 2449271; - 2460990; - 2472709; - 2484428; - 2496147; - 2507866; - 2519585; - 2531304; - 2543023; - 2554742; - 2566461; - 2578180; - 2589899; - 2601618; - 2613337; - 2625056; - 2636775; - 2648494; - 2660213; - 2671932; - 2683651; - 2695370; - 2707089; - 2718808; - 2730527; - 2742246; - 2753965; - 2765684; - 2777403; - 2789122; - 2800841; - 2812560; - 2824279; - 2835998; - 2847717; - 2859436; - 2871155; - 2882874; - 2894593; - 2906312; - 2918031; - 2929750; - 2941469; - 2953188; - 2964907; - 2976626; - 2988345; - 3000064; - |]; - |] - -let endorsing_rewards : int array array = - [| - [| - 0; - 78125; - 156250; - 234375; - 312500; - 390625; - 468750; - 546875; - 625000; - 703125; - 781250; - 859375; - 937500; - 1015625; - 1093750; - 1171875; - 1250000; - 1328125; - 1406250; - 1484375; - 1562500; - 1640625; - 1718750; - 1796875; - 1875000; - 1953125; - 2031250; - 2109375; - 2187500; - 2265625; - 2343750; - 2421875; - 2500000; - 2578125; - 2656250; - 2734375; - 2812500; - 2890625; - 2968750; - 3046875; - 3125000; - 3203125; - 3281250; - 3359375; - 3437500; - 3515625; - 3593750; - 3671875; - 3750000; - 3828125; - 3906250; - 3984375; - 4062500; - 4140625; - 4218750; - 4296875; - 4375000; - 4453125; - 4531250; - 4609375; - 4687500; - 4765625; - 4843750; - 4921875; - 5000000; - 5078125; - 5156250; - 5234375; - 5312500; - 5390625; - 5468750; - 5546875; - 5625000; - 5703125; - 5781250; - 5859375; - 5937500; - 6015625; - 6093750; - 6171875; - 6250000; - 6328125; - 6406250; - 6484375; - 6562500; - 6640625; - 6718750; - 6796875; - 6875000; - 6953125; - 7031250; - 7109375; - 7187500; - 7265625; - 7343750; - 7421875; - 7500000; - 7578125; - 7656250; - 7734375; - 7812500; - 7890625; - 7968750; - 8046875; - 8125000; - 8203125; - 8281250; - 8359375; - 8437500; - 8515625; - 8593750; - 8671875; - 8750000; - 8828125; - 8906250; - 8984375; - 9062500; - 9140625; - 9218750; - 9296875; - 9375000; - 9453125; - 9531250; - 9609375; - 9687500; - 9765625; - 9843750; - 9921875; - 10000000; - 10078125; - 10156250; - 10234375; - 10312500; - 10390625; - 10468750; - 10546875; - 10625000; - 10703125; - 10781250; - 10859375; - 10937500; - 11015625; - 11093750; - 11171875; - 11250000; - 11328125; - 11406250; - 11484375; - 11562500; - 11640625; - 11718750; - 11796875; - 11875000; - 11953125; - 12031250; - 12109375; - 12187500; - 12265625; - 12343750; - 12421875; - 12500000; - 12578125; - 12656250; - 12734375; - 12812500; - 12890625; - 12968750; - 13046875; - 13125000; - 13203125; - 13281250; - 13359375; - 13437500; - 13515625; - 13593750; - 13671875; - 13750000; - 13828125; - 13906250; - 13984375; - 14062500; - 14140625; - 14218750; - 14296875; - 14375000; - 14453125; - 14531250; - 14609375; - 14687500; - 14765625; - 14843750; - 14921875; - 15000000; - 15078125; - 15156250; - 15234375; - 15312500; - 15390625; - 15468750; - 15546875; - 15625000; - 15703125; - 15781250; - 15859375; - 15937500; - 16015625; - 16093750; - 16171875; - 16250000; - 16328125; - 16406250; - 16484375; - 16562500; - 16640625; - 16718750; - 16796875; - 16875000; - 16953125; - 17031250; - 17109375; - 17187500; - 17265625; - 17343750; - 17421875; - 17500000; - 17578125; - 17656250; - 17734375; - 17812500; - 17890625; - 17968750; - 18046875; - 18125000; - 18203125; - 18281250; - 18359375; - 18437500; - 18515625; - 18593750; - 18671875; - 18750000; - 18828125; - 18906250; - 18984375; - 19062500; - 19140625; - 19218750; - 19296875; - 19375000; - 19453125; - 19531250; - 19609375; - 19687500; - 19765625; - 19843750; - 19921875; - 20000000; - |]; - [| - 0; - 52083; - 104166; - 156249; - 208332; - 260415; - 312498; - 364581; - 416664; - 468747; - 520830; - 572913; - 624996; - 677079; - 729162; - 781245; - 833328; - 885411; - 937494; - 989577; - 1041660; - 1093743; - 1145826; - 1197909; - 1249992; - 1302075; - 1354158; - 1406241; - 1458324; - 1510407; - 1562490; - 1614573; - 1666656; - 1718739; - 1770822; - 1822905; - 1874988; - 1927071; - 1979154; - 2031237; - 2083320; - 2135403; - 2187486; - 2239569; - 2291652; - 2343735; - 2395818; - 2447901; - 2499984; - 2552067; - 2604150; - 2656233; - 2708316; - 2760399; - 2812482; - 2864565; - 2916648; - 2968731; - 3020814; - 3072897; - 3124980; - 3177063; - 3229146; - 3281229; - 3333312; - 3385395; - 3437478; - 3489561; - 3541644; - 3593727; - 3645810; - 3697893; - 3749976; - 3802059; - 3854142; - 3906225; - 3958308; - 4010391; - 4062474; - 4114557; - 4166640; - 4218723; - 4270806; - 4322889; - 4374972; - 4427055; - 4479138; - 4531221; - 4583304; - 4635387; - 4687470; - 4739553; - 4791636; - 4843719; - 4895802; - 4947885; - 4999968; - 5052051; - 5104134; - 5156217; - 5208300; - 5260383; - 5312466; - 5364549; - 5416632; - 5468715; - 5520798; - 5572881; - 5624964; - 5677047; - 5729130; - 5781213; - 5833296; - 5885379; - 5937462; - 5989545; - 6041628; - 6093711; - 6145794; - 6197877; - 6249960; - 6302043; - 6354126; - 6406209; - 6458292; - 6510375; - 6562458; - 6614541; - 6666624; - 6718707; - 6770790; - 6822873; - 6874956; - 6927039; - 6979122; - 7031205; - 7083288; - 7135371; - 7187454; - 7239537; - 7291620; - 7343703; - 7395786; - 7447869; - 7499952; - 7552035; - 7604118; - 7656201; - 7708284; - 7760367; - 7812450; - 7864533; - 7916616; - 7968699; - 8020782; - 8072865; - 8124948; - 8177031; - 8229114; - 8281197; - 8333280; - 8385363; - 8437446; - 8489529; - 8541612; - 8593695; - 8645778; - 8697861; - 8749944; - 8802027; - 8854110; - 8906193; - 8958276; - 9010359; - 9062442; - 9114525; - 9166608; - 9218691; - 9270774; - 9322857; - 9374940; - 9427023; - 9479106; - 9531189; - 9583272; - 9635355; - 9687438; - 9739521; - 9791604; - 9843687; - 9895770; - 9947853; - 9999936; - 10052019; - 10104102; - 10156185; - 10208268; - 10260351; - 10312434; - 10364517; - 10416600; - 10468683; - 10520766; - 10572849; - 10624932; - 10677015; - 10729098; - 10781181; - 10833264; - 10885347; - 10937430; - 10989513; - 11041596; - 11093679; - 11145762; - 11197845; - 11249928; - 11302011; - 11354094; - 11406177; - 11458260; - 11510343; - 11562426; - 11614509; - 11666592; - 11718675; - 11770758; - 11822841; - 11874924; - 11927007; - 11979090; - 12031173; - 12083256; - 12135339; - 12187422; - 12239505; - 12291588; - 12343671; - 12395754; - 12447837; - 12499920; - 12552003; - 12604086; - 12656169; - 12708252; - 12760335; - 12812418; - 12864501; - 12916584; - 12968667; - 13020750; - 13072833; - 13124916; - 13176999; - 13229082; - 13281165; - 13333248; - |]; - [| - 0; - 52083; - 104166; - 156249; - 208332; - 260415; - 312498; - 364581; - 416664; - 468747; - 520830; - 572913; - 624996; - 677079; - 729162; - 781245; - 833328; - 885411; - 937494; - 989577; - 1041660; - 1093743; - 1145826; - 1197909; - 1249992; - 1302075; - 1354158; - 1406241; - 1458324; - 1510407; - 1562490; - 1614573; - 1666656; - 1718739; - 1770822; - 1822905; - 1874988; - 1927071; - 1979154; - 2031237; - 2083320; - 2135403; - 2187486; - 2239569; - 2291652; - 2343735; - 2395818; - 2447901; - 2499984; - 2552067; - 2604150; - 2656233; - 2708316; - 2760399; - 2812482; - 2864565; - 2916648; - 2968731; - 3020814; - 3072897; - 3124980; - 3177063; - 3229146; - 3281229; - 3333312; - 3385395; - 3437478; - 3489561; - 3541644; - 3593727; - 3645810; - 3697893; - 3749976; - 3802059; - 3854142; - 3906225; - 3958308; - 4010391; - 4062474; - 4114557; - 4166640; - 4218723; - 4270806; - 4322889; - 4374972; - 4427055; - 4479138; - 4531221; - 4583304; - 4635387; - 4687470; - 4739553; - 4791636; - 4843719; - 4895802; - 4947885; - 4999968; - 5052051; - 5104134; - 5156217; - 5208300; - 5260383; - 5312466; - 5364549; - 5416632; - 5468715; - 5520798; - 5572881; - 5624964; - 5677047; - 5729130; - 5781213; - 5833296; - 5885379; - 5937462; - 5989545; - 6041628; - 6093711; - 6145794; - 6197877; - 6249960; - 6302043; - 6354126; - 6406209; - 6458292; - 6510375; - 6562458; - 6614541; - 6666624; - 6718707; - 6770790; - 6822873; - 6874956; - 6927039; - 6979122; - 7031205; - 7083288; - 7135371; - 7187454; - 7239537; - 7291620; - 7343703; - 7395786; - 7447869; - 7499952; - 7552035; - 7604118; - 7656201; - 7708284; - 7760367; - 7812450; - 7864533; - 7916616; - 7968699; - 8020782; - 8072865; - 8124948; - 8177031; - 8229114; - 8281197; - 8333280; - 8385363; - 8437446; - 8489529; - 8541612; - 8593695; - 8645778; - 8697861; - 8749944; - 8802027; - 8854110; - 8906193; - 8958276; - 9010359; - 9062442; - 9114525; - 9166608; - 9218691; - 9270774; - 9322857; - 9374940; - 9427023; - 9479106; - 9531189; - 9583272; - 9635355; - 9687438; - 9739521; - 9791604; - 9843687; - 9895770; - 9947853; - 9999936; - 10052019; - 10104102; - 10156185; - 10208268; - 10260351; - 10312434; - 10364517; - 10416600; - 10468683; - 10520766; - 10572849; - 10624932; - 10677015; - 10729098; - 10781181; - 10833264; - 10885347; - 10937430; - 10989513; - 11041596; - 11093679; - 11145762; - 11197845; - 11249928; - 11302011; - 11354094; - 11406177; - 11458260; - 11510343; - 11562426; - 11614509; - 11666592; - 11718675; - 11770758; - 11822841; - 11874924; - 11927007; - 11979090; - 12031173; - 12083256; - 12135339; - 12187422; - 12239505; - 12291588; - 12343671; - 12395754; - 12447837; - 12499920; - 12552003; - 12604086; - 12656169; - 12708252; - 12760335; - 12812418; - 12864501; - 12916584; - 12968667; - 13020750; - 13072833; - 13124916; - 13176999; - 13229082; - 13281165; - 13333248; - |]; - |] diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/sapling_helpers.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/sapling_helpers.ml deleted file mode 100644 index 330b49c8db5ed55ba5d4f67d09ca409e51608789..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/sapling_helpers.ml +++ /dev/null @@ -1,471 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020-2021 Nomadic Labs *) -(* *) -(* 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 - -module Common = struct - let memo_size_of_int i = - match Alpha_context.Sapling.Memo_size.parse_z @@ Z.of_int i with - | Ok memo_size -> memo_size - | Error _ -> assert false - - let int_of_memo_size ms = - Alpha_context.Sapling.Memo_size.unparse_to_z ms |> Z.to_int - - let wrap e = Lwt.return (Environment.wrap_tzresult e) - - let assert_true res = res >|=? fun res -> assert res - - let assert_false res = res >|=? fun res -> assert (not res) - - let assert_some res = res >|=? function Some s -> s | None -> assert false - - let assert_none res = - res >>=? function Some _ -> assert false | None -> return_unit - - let assert_error res = - res >>= function Ok _ -> assert false | Error _ -> return_unit - - let print ?(prefix = "") e v = - Format.printf - "%s: %s\n" - prefix - Data_encoding.(Json.to_string (Json.construct e v)) - - let to_hex x encoding = - Hex.show (Hex.of_bytes Data_encoding.Binary.(to_bytes_exn encoding x)) - - let randomized_byte ?pos v encoding = - let bytes = Data_encoding.Binary.(to_bytes_exn encoding v) in - let rec aux () = - let random_char = Random.int 256 |> char_of_int in - let pos = Option.value ~default:(Random.int (Bytes.length bytes)) pos in - if random_char = Bytes.get bytes pos then aux () - else Bytes.set bytes pos random_char - in - aux () ; - Data_encoding.Binary.(of_bytes_exn encoding bytes) - - type wallet = { - sk : Tezos_sapling.Core.Wallet.Spending_key.t; - vk : Tezos_sapling.Core.Wallet.Viewing_key.t; - } - - let wallet_gen () = - let sk = - Tezos_sapling.Core.Wallet.Spending_key.of_seed - (Tezos_crypto.Hacl.Rand.gen 32) - in - let vk = Tezos_sapling.Core.Wallet.Viewing_key.of_sk sk in - {sk; vk} - - let gen_addr n vk = - let rec aux n index res = - if Compare.Int.( <= ) n 0 then res - else - let new_index, new_addr = - Tezos_sapling.Core.Client.Viewing_key.new_address vk index - in - aux (n - 1) new_index (new_addr :: res) - in - aux n Tezos_sapling.Core.Client.Viewing_key.default_index [] - - let gen_nf () = - let {vk; _} = wallet_gen () in - let addr = - snd - @@ Tezos_sapling.Core.Wallet.Viewing_key.(new_address vk default_index) - in - let amount = 10L in - let rcm = Tezos_sapling.Core.Client.Rcm.random () in - let position = 10L in - Tezos_sapling.Core.Client.Nullifier.compute addr vk ~amount rcm ~position - - let gen_cm_cipher ~memo_size () = - let open Tezos_sapling.Core.Client in - let {vk; _} = wallet_gen () in - let addr = - snd - @@ Tezos_sapling.Core.Wallet.Viewing_key.(new_address vk default_index) - in - let amount = 10L in - let rcm = Tezos_sapling.Core.Client.Rcm.random () in - let cm = Commitment.compute addr ~amount rcm in - let cipher = - let payload_enc = - Data_encoding.Binary.to_bytes_exn - Data_encoding.bytes - (Tezos_crypto.Hacl.Rand.gen (memo_size + 4 + 16 + 11 + 32 + 8)) - in - Data_encoding.Binary.of_bytes_exn - Ciphertext.encoding - (Bytes.concat - Bytes.empty - [ - Bytes.create (32 + 32); - payload_enc; - Bytes.create (24 + 64 + 16 + 24); - ]) - in - (cm, cipher) - - (* rebuilds from empty at each call *) - let client_state_of_diff ~memo_size (root, diff) = - let open Alpha_context.Sapling in - let cs = - Tezos_sapling.Storage.add - (Tezos_sapling.Storage.empty ~memo_size) - diff.commitments_and_ciphertexts - in - assert (Tezos_sapling.Storage.get_root cs = root) ; - List.fold_left - (fun s nf -> Tezos_sapling.Storage.add_nullifier s nf) - cs - diff.nullifiers -end - -module Alpha_context_helpers = struct - include Common - - let init () = - Context.init1 () >>=? fun (b, _contract) -> - Alpha_context.prepare - b.context - ~level:b.header.shell.level - ~predecessor_timestamp:b.header.shell.timestamp - ~timestamp:b.header.shell.timestamp - (* ~fitness:b.header.shell.fitness *) - >>= wrap - >|=? fun (ctxt, _, _) -> ctxt - - (* takes a state obtained from Sapling.empty_state or Sapling.state_from_id and - passed through Sapling.verify_update *) - let finalize ctx = - let open Alpha_context in - let open Sapling in - function - | {id = None; diff; memo_size} -> - Sapling.fresh ~temporary:false ctx >>= wrap >>=? fun (ctx, id) -> - let init = Lazy_storage.Alloc {memo_size} in - let lazy_storage_diff = Lazy_storage.Update {init; updates = diff} in - let diffs = [Lazy_storage.make Sapling_state id lazy_storage_diff] in - Lazy_storage.apply ctx diffs >>= wrap >|=? fun (ctx, _added_size) -> - (ctx, id) - | {id = Some id; diff; _} -> - let init = Lazy_storage.Existing in - let lazy_storage_diff = Lazy_storage.Update {init; updates = diff} in - let diffs = [Lazy_storage.make Sapling_state id lazy_storage_diff] in - Lazy_storage.apply ctx diffs >>= wrap >|=? fun (ctx, _added_size) -> - (ctx, id) - - (* disk only version *) - let verify_update ctx ?memo_size ?id vt = - let anti_replay = "anti-replay" in - (match id with - | None -> - (match memo_size with - | None -> ( - match vt.Environment.Sapling.UTXO.outputs with - | [] -> failwith "Can't infer memo_size from empty outputs" - | output :: _ -> - return - @@ Environment.Sapling.Ciphertext.get_memo_size - output.ciphertext) - | Some memo_size -> return memo_size) - >>=? fun memo_size -> - let memo_size = memo_size_of_int memo_size in - let vs = Alpha_context.Sapling.empty_state ~memo_size () in - return (vs, ctx) - | Some id -> - (* Storage.Sapling.Roots.get (Obj.magic ctx, id) 0l *) - (* >>= wrap *) - (* >>=? fun (_, root) -> *) - (* print ~prefix:"verify: " Environment.Sapling.Hash.encoding root ; *) - Alpha_context.Sapling.state_from_id ctx id >>= wrap) - >>=? fun (vs, ctx) -> - Alpha_context.Sapling.verify_update ctx vs vt anti_replay >>= wrap - >>=? fun (ctx, res) -> - match res with - | None -> return_none - | Some (_balance, vs) -> - finalize ctx vs >>=? fun (ctx, id) -> - let fake_fitness = - Alpha_context.( - let level = - match Raw_level.of_int32 0l with - | Error _ -> assert false - | Ok l -> l - in - Fitness.create_without_locked_round - ~level - ~predecessor_round:Round.zero - ~round:Round.zero - |> Fitness.to_raw) - in - let ectx = (Alpha_context.finalize ctx fake_fitness).context in - (* bump the level *) - Alpha_context.prepare - ectx - ~level: - Alpha_context.( - Raw_level.to_int32 Level.((succ ctx (current ctx)).level)) - ~predecessor_timestamp:(Time.Protocol.of_seconds Int64.zero) - ~timestamp:(Time.Protocol.of_seconds Int64.zero) - >>= wrap - >|=? fun (ctx, _, _) -> Some (ctx, id) - - (* Same as before but for legacy *) - let verify_update_legacy ctx ?memo_size ?id vt = - let anti_replay = "anti-replay" in - (match id with - | None -> - (match memo_size with - | None -> ( - match vt.Environment.Sapling.UTXO.Legacy.outputs with - | [] -> failwith "Can't infer memo_size from empty outputs" - | output :: _ -> - return - @@ Environment.Sapling.Ciphertext.get_memo_size - output.ciphertext) - | Some memo_size -> return memo_size) - >>=? fun memo_size -> - let memo_size = memo_size_of_int memo_size in - let vs = Alpha_context.Sapling.empty_state ~memo_size () in - return (vs, ctx) - | Some id -> - (* Storage.Sapling.Roots.get (Obj.magic ctx, id) 0l *) - (* >>= wrap *) - (* >>=? fun (_, root) -> *) - (* print ~prefix:"verify: " Environment.Sapling.Hash.encoding root ; *) - Alpha_context.Sapling.state_from_id ctx id >>= wrap) - >>=? fun (vs, ctx) -> - Alpha_context.Sapling.Legacy.verify_update ctx vs vt anti_replay >>= wrap - >>=? fun (ctx, res) -> - match res with - | None -> return_none - | Some (_balance, vs) -> - finalize ctx vs >>=? fun (ctx, id) -> - let fake_fitness = - Alpha_context.( - let level = - match Raw_level.of_int32 0l with - | Error _ -> assert false - | Ok l -> l - in - Fitness.create_without_locked_round - ~level - ~predecessor_round:Round.zero - ~round:Round.zero - |> Fitness.to_raw) - in - let ectx = (Alpha_context.finalize ctx fake_fitness).context in - (* bump the level *) - Alpha_context.prepare - ectx - ~level: - Alpha_context.( - Raw_level.to_int32 Level.((succ ctx (current ctx)).level)) - ~predecessor_timestamp:(Time.Protocol.of_seconds Int64.zero) - ~timestamp:(Time.Protocol.of_seconds Int64.zero) - >>= wrap - >|=? fun (ctx, _, _) -> Some (ctx, id) - - let transfer_inputs_outputs w cs is = - (* Tezos_sapling.Storage.size cs *) - (* |> fun (a, b) -> *) - (* Printf.printf "%Ld %Ld" a b ; *) - let inputs = - List.map - (fun i -> - Tezos_sapling.Forge.Input.get cs (Int64.of_int i) w.vk - |> WithExceptions.Option.get ~loc:__LOC__ - |> snd) - is - in - let addr = - snd - @@ Tezos_sapling.Core.Wallet.Viewing_key.(new_address w.vk default_index) - in - let memo_size = Tezos_sapling.Storage.get_memo_size cs in - let o = - Tezos_sapling.Forge.make_output addr 1000000L (Bytes.create memo_size) - in - (inputs, [o]) - - let transfer w cs is = - let anti_replay = "anti-replay" in - let ins, outs = transfer_inputs_outputs w cs is in - (* change the wallet of this last line *) - Tezos_sapling.Forge.forge_transaction - ins - outs - w.sk - anti_replay - ~bound_data:"" - cs - - let transfer_legacy w cs is = - let anti_replay = "anti-replay" in - let ins, outs = transfer_inputs_outputs w cs is in - (* change the wallet of this last line *) - Tezos_sapling.Forge.forge_transaction_legacy ins outs w.sk anti_replay cs - - let client_state_alpha ctx id = - Alpha_context.Sapling.get_diff ctx id () >>= wrap >>=? fun diff -> - Alpha_context.Sapling.state_from_id ctx id >>= wrap - >|=? fun ({memo_size; _}, _ctx) -> - let memo_size = int_of_memo_size memo_size in - client_state_of_diff ~memo_size diff -end - -(* - Interpreter level -*) - -module Interpreter_helpers = struct - include Common - include Contract_helpers - - (** Returns a block in which the contract is originated. - Also returns the associated anti-replay string and KT1 address. *) - let originate_contract_hash file storage src b baker = - originate_contract_hash file storage src b baker >|=? fun (dst, b) -> - let anti_replay = - Format.asprintf "%a%a" Contract_hash.pp dst Chain_id.pp Chain_id.zero - in - (dst, b, anti_replay) - - let hex_shield ~memo_size wallet anti_replay = - let ps = Tezos_sapling.Storage.empty ~memo_size in - let addr = - snd - @@ Tezos_sapling.Core.Wallet.Viewing_key.( - new_address wallet.vk default_index) - in - let output = - Tezos_sapling.Forge.make_output addr 15L (Bytes.create memo_size) - in - let pt = - Tezos_sapling.Forge.forge_transaction - [] - [output] - wallet.sk - anti_replay - ~bound_data:"" - ps - in - let hex_string = - "0x" - ^ Hex.show - (Hex.of_bytes - Data_encoding.Binary.( - to_bytes_exn - Tezos_sapling.Core.Client.UTXO.transaction_encoding - pt)) - in - hex_string - - (* Make a transaction and sync a local client state. [to_exclude] is the list - of addresses that cannot bake the block*) - let transac_and_sync ~memo_size block parameters amount src dst baker = - let amount_tez = - Test_tez.(Alpha_context.Tez.one_mutez *! Int64.of_int amount) - in - let fee = Test_tez.of_int 10 in - Op.transaction - ~gas_limit:Max - ~fee - (B block) - src - (Alpha_context.Contract.Originated dst) - amount_tez - ~parameters - >>=? fun operation -> - Incremental.begin_construction ~policy:Block.(By_account baker) block - >>=? fun incr -> - Incremental.add_operation incr operation >>=? fun incr -> - Incremental.finalize_block incr >>=? fun block -> - Alpha_services.Contract.single_sapling_get_diff - Block.rpc_ctxt - block - dst - ~offset_commitment:0L - ~offset_nullifier:0L - () - >|=? fun diff -> - let state = client_state_of_diff ~memo_size diff in - (block, state) - - (* Returns a list of printed shield transactions and their total amount. *) - let shield ~memo_size sk number_transac vk printer anti_replay = - let state = Tezos_sapling.Storage.empty ~memo_size in - let rec aux number_transac number_outputs index amount_output total res = - if Compare.Int.(number_transac <= 0) then (res, total) - else - let new_index, new_addr = - Tezos_sapling.Core.Wallet.Viewing_key.(new_address vk index) - in - let outputs = - WithExceptions.List.init ~loc:__LOC__ number_outputs (fun _ -> - Tezos_sapling.Forge.make_output - new_addr - amount_output - (Bytes.create memo_size)) - in - let tr_hex = - to_hex - (Tezos_sapling.Forge.forge_transaction - ~number_dummy_inputs:0 - ~number_dummy_outputs:0 - [] - outputs - sk - anti_replay - ~bound_data:"" - state) - Tezos_sapling.Core.Client.UTXO.transaction_encoding - in - aux - (number_transac - 1) - (number_outputs + 1) - new_index - (Int64.add 20L amount_output) - (total + (number_outputs * Int64.to_int amount_output)) - (printer tr_hex :: res) - in - aux - number_transac - 2 - Tezos_sapling.Core.Wallet.Viewing_key.default_index - 20L - 0 - [] - - (* This fails if the operation is not correct wrt the block *) - let next_block block operation = - Incremental.begin_construction block >>=? fun incr -> - Incremental.add_operation incr operation >>=? fun incr -> - Incremental.finalize_block incr -end diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/sc_rollup_helpers.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/sc_rollup_helpers.ml deleted file mode 100644 index 71123093c6bdaa644eeaad608d6bc2fd0bde3e2e..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/sc_rollup_helpers.ml +++ /dev/null @@ -1,890 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context - -let originated_rollup op = - let nonce = - Origination_nonce.Internal_for_tests.initial (Operation.hash_packed op) - in - Contract.Internal_for_tests.originated_contract nonce - -module Make_in_memory_context (Context : sig - type tree - - include - Tezos_context_sigs.Context.TEZOS_CONTEXT - with type memory_context_tree := tree - and type tree := tree - and type value_key = Context_hash.t - and type node_key = Context_hash.t -end) = -struct - module Tree = struct - include Context.Tree - - type tree = Context.tree - - type t = Context.t - - type key = string list - - type value = bytes - end - - type tree = Tree.tree - - type proof = Context.Proof.tree Context.Proof.t - - let hash_tree _ = assert false - - let verify_proof p f = - Lwt.map Result.to_option (Context.verify_tree_proof p f) - - let produce_proof context state step = - let open Lwt_syntax in - let* context = Context.add_tree context [] state in - let* h = Context.commit ~time:Time.Protocol.epoch context in - let index = Context.index context in - let* context = Context.checkout_exn index h in - match Tree.kinded_key state with - | Some k -> - let index = Context.index context in - let* p = Context.produce_tree_proof index k step in - return (Some p) - | None -> return None - - let kinded_hash_to_state_hash = function - | `Value hash | `Node hash -> - Sc_rollup.State_hash.context_hash_to_state_hash hash - - let proof_before proof = kinded_hash_to_state_hash proof.Context.Proof.before - - let proof_after proof = kinded_hash_to_state_hash proof.Context.Proof.after - - let proof_encoding = - Tezos_context_merkle_proof_encoding.Merkle_proof_encoding.V2.Tree2 - .tree_proof_encoding -end - -module In_memory_context = - Make_in_memory_context (Tezos_context_memory.Context_binary) -module Wrong_in_memory_context = - Make_in_memory_context (Tezos_context_memory.Context) - -module Arith_pvm : - Sc_rollup.PVM.S - with type context = In_memory_context.Tree.t - and type state = In_memory_context.tree - and type proof = - Tezos_context_memory.Context.Proof.tree - Tezos_context_memory.Context.Proof.t = - Sc_rollup.ArithPVM.Make (In_memory_context) - -module Wrong_arith_pvm : - Sc_rollup.PVM.S - with type context = Wrong_in_memory_context.Tree.t - and type state = Wrong_in_memory_context.tree - and type proof = - Tezos_context_memory.Context.Proof.tree - Tezos_context_memory.Context.Proof.t = - Sc_rollup.ArithPVM.Make (Wrong_in_memory_context) - -module Wasm_pvm : - Sc_rollup.PVM.S - with type context = In_memory_context.Tree.t - and type state = In_memory_context.tree - and type proof = - Tezos_context_memory.Context.Proof.tree - Tezos_context_memory.Context.Proof.t = - Sc_rollup.Wasm_2_0_0PVM.Make (Environment.Wasm_2_0_0.Make) (In_memory_context) - -(* TODO: https://gitlab.com/tezos/tezos/-/issues/4386 - Extracted and adapted from {!Tezos_context_memory}. *) -let make_empty_context ?(root = "/tmp") () = - let open Lwt_syntax in - let context_promise = - let+ index = Tezos_context_memory.Context_binary.init root in - Tezos_context_memory.Context_binary.empty index - in - match Lwt.state context_promise with - | Lwt.Return result -> result - | Lwt.Fail exn -> raise exn - | Lwt.Sleep -> - (* The in-memory context should never block *) - assert false - -(* TODO: https://gitlab.com/tezos/tezos/-/issues/4386 - Extracted and adapted from {!Tezos_context_memory}. *) -let make_empty_tree = - let dummy_context = make_empty_context ~root:"dummy" () in - fun () -> Tezos_context_memory.Context_binary.Tree.empty dummy_context - -let compute_origination_proof ~boot_sector = function - | Sc_rollup.Kind.Example_arith -> - let open Lwt_syntax in - let context = make_empty_context () in - let+ proof = Arith_pvm.produce_origination_proof context boot_sector in - let proof = WithExceptions.Result.get_ok ~loc:__LOC__ proof in - WithExceptions.Result.get_ok ~loc:__LOC__ - @@ Sc_rollup.Proof.serialize_pvm_step ~pvm:(module Arith_pvm) proof - | Sc_rollup.Kind.Wasm_2_0_0 -> - let open Lwt_syntax in - let context = make_empty_context () in - let+ proof = Wasm_pvm.produce_origination_proof context boot_sector in - let proof = WithExceptions.Result.get_ok ~loc:__LOC__ proof in - WithExceptions.Result.get_ok ~loc:__LOC__ - @@ Sc_rollup.Proof.serialize_pvm_step ~pvm:(module Wasm_pvm) proof - -(** [wrong_arith_origination_proof ~alter_binary_bit ~boot_sector] - returns a serialized proof computed with a Arith PVM using 32-ary - trees. - - If [alter_binary_bit] is set to true, the resulting proof lies - about the arity of its trees. *) -let wrong_arith_origination_proof ~alter_binary_bit ~boot_sector = - let open Lwt_syntax in - let context = Tezos_context_memory.Context.make_empty_context () in - let+ proof = Wrong_arith_pvm.produce_origination_proof context boot_sector in - let proof = WithExceptions.Result.get_ok ~loc:__LOC__ proof in - let proof = - (* TODO: https://gitlab.com/tezos/tezos/-/issues/4386 This should - be exposed more cleanly in the Tezos context libraries. - - Basically, the 2nd bit of the `version` field is set to 1 to - signal a proof for a [Context_binary] tree.*) - if alter_binary_bit then {proof with version = proof.version land 0b10} - else proof - in - WithExceptions.Result.get_ok ~loc:__LOC__ - @@ Sc_rollup.Proof.serialize_pvm_step ~pvm:(module Arith_pvm) proof - -let wrap_origination_proof ~kind ~boot_sector proof_string_opt : - Sc_rollup.Proof.serialized tzresult Lwt.t = - let open Lwt_result_syntax in - match proof_string_opt with - | None -> - let*! origination_proof = compute_origination_proof ~boot_sector kind in - return origination_proof - | Some proof_string -> return proof_string - -let genesis_commitment ~boot_sector ~origination_level = function - | Sc_rollup.Kind.Example_arith -> - let open Lwt_syntax in - let context = make_empty_context () in - let* proof = Arith_pvm.produce_origination_proof context boot_sector in - let proof = WithExceptions.Result.get_ok ~loc:__LOC__ proof in - let genesis_state_hash = Arith_pvm.proof_stop_state proof in - return - Sc_rollup.Commitment.( - genesis_commitment ~origination_level ~genesis_state_hash) - | Sc_rollup.Kind.Wasm_2_0_0 -> - let open Lwt_syntax in - let context = make_empty_context () in - let* proof = Wasm_pvm.produce_origination_proof context boot_sector in - let proof = WithExceptions.Result.get_ok ~loc:__LOC__ proof in - let genesis_state_hash = Wasm_pvm.proof_stop_state proof in - return - Sc_rollup.Commitment.( - genesis_commitment ~origination_level ~genesis_state_hash) - -let genesis_commitment_raw ~boot_sector ~origination_level kind = - let open Lwt_syntax in - let origination_level = - Raw_level_repr.to_int32 origination_level - |> Alpha_context.Raw_level.of_int32_exn - in - let kind = - match kind with - | Sc_rollups.Kind.Example_arith -> Sc_rollup.Kind.Example_arith - | Sc_rollups.Kind.Wasm_2_0_0 -> Sc_rollup.Kind.Wasm_2_0_0 - in - let* res = genesis_commitment ~boot_sector ~origination_level kind in - let res = - Data_encoding.Binary.to_bytes_exn Sc_rollup.Commitment.encoding res - |> Data_encoding.Binary.of_bytes_exn Sc_rollup_commitment_repr.encoding - in - return res - -(** {2 Inbox message helpers.} *) - -(** {1 Above [Alpha_context].} *) - -let message_serialize msg = - WithExceptions.Result.get_ok - ~loc:__LOC__ - Sc_rollup.Inbox_message.(serialize msg) - -let make_external_inbox_message str = message_serialize (External str) - -let make_internal_inbox_message internal_msg = - message_serialize (Internal internal_msg) - -let make_input ?(inbox_level = Raw_level.root) ?(message_counter = Z.zero) - payload = - Sc_rollup.Inbox_message {inbox_level; message_counter; payload} - -let make_external_input ?inbox_level ?message_counter str = - let payload = make_external_inbox_message str in - make_input ?inbox_level ?message_counter payload - -let make_sol ~inbox_level = - let payload = make_internal_inbox_message Start_of_level in - make_input ~inbox_level ~message_counter:Z.zero payload - -let make_eol ~inbox_level ~message_counter = - let payload = make_internal_inbox_message End_of_level in - make_input ~inbox_level ~message_counter payload - -let make_info_per_level ~inbox_level ~predecessor_timestamp ~predecessor = - let payload = - make_internal_inbox_message - (Info_per_level {predecessor_timestamp; predecessor}) - in - make_input ~inbox_level ~message_counter:Z.one payload - -let make_protocol_migration ~inbox_level = - let payload = - make_internal_inbox_message - Sc_rollup.Inbox_message.protocol_migration_internal_message - in - make_input ~inbox_level ~message_counter:Z.(succ one) payload - -(** Message is the combination of a [message] and its associated [input]. - - [message] is used to: - - Construct the protocol inbox, when [message] is [`Message]. The protocol - adds [`SOL] and [`EOL] itself. - - Construct the players' inboxes. - - [input] is used to evaluate the players' inboxes. - -*) -type message = { - input : Sc_rollup.input; - message : - [ `SOL - | `Info_per_level of Timestamp.t * Block_hash.t - | `Message of string - | `EOL ]; -} - -(** Put as much information as possible in this record so it can be used - in different setups: - 1. Creating an inbox on the protocol-side, requires [messages] only. - 2. Re-construct an inbox, requires [payloads], [timestamp], [predecessor]. - 3. Evaluate inputs in a PVM, requires [inputs] - - [level] is useful for (1) (2) (3). - *) -type payloads_per_level = { - messages : string list; (** List of external messages. *) - payloads : Sc_rollup.Inbox_message.serialized list; - (** List of external serialized messages. *) - predecessor_timestamp : Time.Protocol.t; - (** predecessor timestamp of the [Info_per_level]. *) - predecessor : Block_hash.t; (** Predecessor of the [Info_per_level]. *) - level : Raw_level.t; - inputs : Sc_rollup.input list; - (** List of all inputs for the level, to be read by a PVM. *) -} - -let pp_input fmt (input : Sc_rollup.input) = - match input with - | Reveal _ -> assert false - | Inbox_message {inbox_level; message_counter; _} -> - Format.fprintf - fmt - "(%a, %s)" - Raw_level.pp - inbox_level - (Z.to_string message_counter) - -let pp_message fmt {input; message} = - Format.fprintf - fmt - "{ input = %a; message = %S }" - pp_input - input - (match message with - | `SOL -> "SOL" - | `Info_per_level (predecessor_timestamp, block_hash) -> - Format.asprintf - "Info_per_level (%s, %a)" - (Timestamp.to_notation predecessor_timestamp) - Block_hash.pp - block_hash - | `Message msg -> msg - | `EOL -> "EOL") - -(** Creates inputs based on string messages. *) -let strs_to_inputs inbox_level messages = - List.fold_left - (fun (acc, message_counter) message -> - let input = make_external_input ~inbox_level ~message_counter message in - ({input; message = `Message message} :: acc, Z.succ message_counter)) - ([], Z.of_int 2) - messages - -(** Transform the list of all inputs the PVM should read. *) -let make_inputs ~first_block predecessor_timestamp predecessor messages - inbox_level = - (* SOL is at index 0. *) - let sol = make_sol ~inbox_level in - (* Info_per_level is at index 1. *) - let info_per_level = - make_info_per_level ~inbox_level ~predecessor_timestamp ~predecessor - in - let mig = - if first_block then [make_protocol_migration ~inbox_level] else [] - in - (* External inputs start at index 2. *) - let external_inputs = - List.mapi - (fun i message -> - make_external_input - ~inbox_level - ~message_counter:(Z.of_int (2 + List.length mig + i)) - message) - messages - in - (* EOL is after SOL/Info_per_level and all external inputs, therefore, - at index [2 + List.length messages]. *) - let eol = - let message_counter = - Z.of_int (2 + List.length mig + List.length messages) - in - make_eol ~inbox_level ~message_counter - in - [sol; info_per_level] @ mig @ external_inputs @ [eol] - -let predecessor_timestamp_and_hash_from_level level = - let level_int64 = Int64.of_int32 @@ Raw_level.to_int32 level in - let predecessor_timestamp = Time.Protocol.of_seconds level_int64 in - let hash = Block_hash.hash_string [Int64.to_string level_int64] in - (predecessor_timestamp, hash) - -(** Wrap messages, predecessor_timestamp and predecessor of a level into a - [payloads_per_level] .*) -let wrap_messages level - ?(pred_info = predecessor_timestamp_and_hash_from_level level) messages : - payloads_per_level = - let predecessor_timestamp, predecessor = pred_info in - let payloads = List.map make_external_inbox_message messages in - let inputs = - make_inputs - ~first_block:(level = Raw_level.root || level = Raw_level.(succ root)) - predecessor_timestamp - predecessor - messages - level - in - {payloads; predecessor_timestamp; predecessor; messages; level; inputs} - -(** An empty inbox level is a SOL,IPL and EOL. *) -let make_empty_level ?pred_info inbox_level = - wrap_messages ?pred_info inbox_level [] - -let gen_messages ?pred_info inbox_level gen_message = - let open QCheck2.Gen in - let* input = gen_message in - let* inputs = small_list gen_message in - return (wrap_messages ?pred_info inbox_level (input :: inputs)) - -let gen_payloads_for_levels ~start_level ~max_level gen_message = - let open QCheck2.Gen in - let rec aux acc n = - match n with - | n when n < 0 -> - (* Prevent [Stack_overflow]. *) - assert false - | 0 -> return acc - | n -> - let inbox_level = - Raw_level.of_int32_exn (Int32.of_int (start_level + n - 1)) - in - let* empty_level = bool in - let* level_messages = - if empty_level then return (make_empty_level inbox_level) - else gen_messages inbox_level gen_message - in - aux (level_messages :: acc) (n - 1) - in - aux [] (max_level - start_level) - -(** {1 Below [Alpha_context].} *) - -let message_serialize_repr msg = - WithExceptions.Result.get_ok - ~loc:__LOC__ - Sc_rollup_inbox_message_repr.(serialize msg) - -let make_external_inbox_message_repr str = message_serialize_repr (External str) - -let make_internal_inbox_message_repr internal_msg = - message_serialize_repr (Internal internal_msg) - -let make_input_repr ?(inbox_level = Raw_level_repr.root) - ?(message_counter = Z.zero) payload = - Sc_rollup_PVM_sig.Inbox_message {inbox_level; message_counter; payload} - -let make_external_input_repr ?inbox_level ?message_counter str = - let payload = make_external_inbox_message_repr str in - make_input_repr ?inbox_level ?message_counter payload - -let make_sol_repr ~inbox_level = - let payload = make_internal_inbox_message_repr Start_of_level in - make_input_repr ~inbox_level ~message_counter:Z.zero payload - -let make_eol_repr ~inbox_level ~message_counter = - let payload = make_internal_inbox_message_repr End_of_level in - make_input_repr ~inbox_level ~message_counter payload - -(** Message is the combination of a [message] and its associated [input]. - - [message] is used to: - - Construct the protocol inbox, when [message] is [`Message]. The protocol - adds [`SOL] and [`EOL] itself. - - Construct the players' inboxes. - - [input] is used to evaluate the players' inboxes. - -*) -type message_repr = { - input_repr : Sc_rollup_PVM_sig.input; - message_repr : [`SOL | `Message of string | `EOL]; -} - -let pp_input_repr fmt (input_repr : Sc_rollup_PVM_sig.input) = - match input_repr with - | Reveal _ -> assert false - | Inbox_message {inbox_level; message_counter; _} -> - Format.fprintf - fmt - "(%a, %s)" - Raw_level_repr.pp - inbox_level - (Z.to_string message_counter) - -let pp_message_repr fmt {input_repr; message_repr} = - Format.fprintf - fmt - "{ input_repr = %a; message_repr = %S }" - pp_input_repr - input_repr - (match message_repr with - | `SOL -> "SOL" - | `Message msg -> msg - | `EOL -> "EOL") - -(** An empty inbox level is a SOL,IPL and EOL. *) -let make_empty_level_repr inbox_level = - let sol = {input_repr = make_sol_repr ~inbox_level; message_repr = `SOL} in - let eol = - { - input_repr = make_eol_repr ~inbox_level ~message_counter:Z.one; - message_repr = `EOL; - } - in - (inbox_level, [sol; eol]) - -(** Creates input_reprs based on string message_reprs. *) -let strs_to_input_reprs_repr inbox_level message_reprs = - List.fold_left - (fun (acc, message_counter) message_repr -> - let input_repr = - make_external_input_repr ~inbox_level ~message_counter message_repr - in - ( {input_repr; message_repr = `Message message_repr} :: acc, - Z.succ message_counter )) - ([], Z.one) - message_reprs - -(** Transform message_reprs into input_reprs and wrap them between SOL and EOL. *) -let wrap_message_reprs_repr inbox_level strs = - let sol = {input_repr = make_sol_repr ~inbox_level; message_repr = `SOL} in - let rev_input_reprs, message_counter = - strs_to_input_reprs_repr inbox_level strs - in - let input_reprs = List.rev rev_input_reprs in - let eol = - { - input_repr = make_eol_repr ~inbox_level ~message_counter; - message_repr = `EOL; - } - in - (sol :: input_reprs) @ [eol] - -let gen_message_reprs_for_levels_repr ~start_level ~max_level gen_message_repr = - let open QCheck2.Gen in - let rec aux acc n = - match n with - | 0 -> return acc - | n when n > 0 -> - let inbox_level = - Raw_level_repr.of_int32_exn (Int32.of_int (start_level + n - 1)) - in - let* empty_level = bool in - let* level_message_reprs = - if empty_level then return (make_empty_level_repr inbox_level) - else - let* message_reprs = - let* input_repr = gen_message_repr in - let* input_reprs = small_list gen_message_repr in - return (input_repr :: input_reprs) - in - return - (inbox_level, wrap_message_reprs_repr inbox_level message_reprs) - in - aux (level_message_reprs :: acc) (n - 1) - | _ -> - (* Prevent [Stack_overflow]. *) - assert false - in - aux [] (max_level - start_level) - -module Payloads_histories = - Map.Make (Sc_rollup.Inbox_merkelized_payload_hashes.Hash) - -type payloads_histories = - Sc_rollup.Inbox_merkelized_payload_hashes.History.t Payloads_histories.t - -let get_payloads_history payloads_histories witness = - Payloads_histories.find witness payloads_histories - |> WithExceptions.Option.get ~loc:__LOC__ - |> Lwt.return - -let get_history history i = Sc_rollup.Inbox.History.find i history |> Lwt.return - -let inbox_message_of_input input = - match input with Sc_rollup.Inbox_message x -> Some x | _ -> None - -let payloads_from_messages = - List.map (fun {input; _} -> - match input with - | Inbox_message {payload; _} -> payload - | Reveal _ -> assert false) - -let first_after payloads_per_levels level message_counter = - let payloads_at_level level = - List.find - (fun {level = payloads_level; _} -> level = payloads_level) - payloads_per_levels - in - let payloads_per_level = - WithExceptions.Option.get ~loc:__LOC__ @@ payloads_at_level level - in - match List.nth payloads_per_level.inputs (Z.to_int message_counter) with - | Some input -> inbox_message_of_input input - | None -> ( - (* If no input at (l, n), the next input is (l+1, 0). *) - let next_level = Raw_level.succ level in - match payloads_at_level next_level with - | None -> None - | Some payloads_per_level -> - let input = Stdlib.List.hd payloads_per_level.inputs in - inbox_message_of_input input) - -let list_of_inputs_from_list_of_messages - (payloads_per_levels : message list list) = - List.map - (fun inputs -> - let payloads = List.map (fun {input; _} -> input) inputs in - payloads) - payloads_per_levels - -let dumb_init level = - Sc_rollup.Inbox.genesis - ~predecessor_timestamp:Time.Protocol.epoch - ~predecessor:Block_hash.zero - level - -let dumb_init_repr level = - Sc_rollup_inbox_repr.genesis - ~protocol_migration_message: - Raw_context.protocol_migration_serialized_message - ~predecessor_timestamp:Time.Protocol.epoch - ~predecessor:Block_hash.zero - level - -let origination_op ?force_reveal ?counter ?fee ?gas_limit ?storage_limit - ?origination_proof ?(boot_sector = "") ?(parameters_ty = "unit") ctxt src - kind = - let open Lwt_result_syntax in - let*! origination_proof = - match origination_proof with - | Some origination_proof -> Lwt.return origination_proof - | None -> compute_origination_proof ~boot_sector kind - in - Op.sc_rollup_origination - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ctxt - src - kind - ~boot_sector - ~parameters_ty:(Script.lazy_expr @@ Expr.from_string parameters_ty) - ~origination_proof - -let latest_level_proof inbox = - Sc_rollup.Inbox.Internal_for_tests.level_proof_of_history_proof - @@ Sc_rollup.Inbox.old_levels_messages inbox - -let latest_level_proof_hash inbox = (latest_level_proof inbox).hash - -module Node_inbox = struct - type t = { - inbox : Sc_rollup.Inbox.t; - history : Sc_rollup.Inbox.History.t; - payloads_histories : payloads_histories; - } - - let new_inbox ?(genesis_predecessor_timestamp = Time.Protocol.epoch) - ?(genesis_predecessor = Block_hash.zero) - ?(inbox_creation_level = Raw_level.root) () = - let open Result_syntax in - let inbox = - Sc_rollup.Inbox.genesis - ~predecessor_timestamp:genesis_predecessor_timestamp - ~predecessor:genesis_predecessor - inbox_creation_level - in - let history = Sc_rollup.Inbox.History.empty ~capacity:10000L in - let payloads_histories = Payloads_histories.empty in - return {inbox; history; payloads_histories} - - let fill_inbox ~inbox_creation_level node_inbox payloads_per_levels = - let open Result_syntax in - let rec aux {inbox; history; payloads_histories} = function - | [] -> return {inbox; history; payloads_histories} - | ({ - payloads = _; - predecessor_timestamp; - predecessor; - messages; - level; - inputs = _; - } : - payloads_per_level) - :: rst -> - let messages = - List.map - (fun message -> Sc_rollup.Inbox_message.External message) - messages - in - let* payloads_history, history, inbox, witness, _messages = - Environment.wrap_tzresult - @@ Sc_rollup.Inbox.add_all_messages - ~first_block: - Raw_level.(equal (succ inbox_creation_level) level) - ~predecessor_timestamp - ~predecessor - history - inbox - messages - in - (* Store in the history this archived level. *) - let witness_hash = - Sc_rollup.Inbox_merkelized_payload_hashes.hash witness - in - let payloads_histories = - Payloads_histories.add - witness_hash - payloads_history - payloads_histories - in - aux {inbox; history; payloads_histories} rst - in - aux node_inbox payloads_per_levels - - let construct_inbox ?(inbox_creation_level = Raw_level.root) - ?genesis_predecessor_timestamp ?genesis_predecessor payloads_per_levels = - let open Result_syntax in - let* node_inbox = - new_inbox - ?genesis_predecessor_timestamp - ?genesis_predecessor - ~inbox_creation_level - () - in - fill_inbox ~inbox_creation_level node_inbox payloads_per_levels - - let get_history history hash = - Lwt.return @@ Sc_rollup.Inbox.History.find hash history - - let produce_proof {payloads_histories; history; _} inbox_snapshot - (level, message_counter) = - Lwt.map Environment.wrap_tzresult - @@ Sc_rollup.Inbox.produce_proof - ~get_payloads_history:(get_payloads_history payloads_histories) - ~get_history:(get_history history) - inbox_snapshot - (level, message_counter) - - let produce_and_expose_proof node_inbox node_inbox_snapshot - (level, message_counter) = - let open Lwt_result_syntax in - let* proof, input = - produce_proof node_inbox node_inbox_snapshot (level, message_counter) - in - let exposed_proof = Sc_rollup.Inbox.Internal_for_tests.expose_proof proof in - return (exposed_proof, input) - - let produce_payloads_proof {payloads_histories; _} - (head_cell_hash : Sc_rollup.Inbox_merkelized_payload_hashes.Hash.t) - message_counter = - Lwt.map Environment.wrap_tzresult - @@ Sc_rollup.Inbox.Internal_for_tests.produce_payloads_proof - (get_payloads_history payloads_histories) - head_cell_hash - ~index:message_counter - - let produce_inclusion_proof {history; _} inbox_snapshot level = - Lwt.map Environment.wrap_tzresult - @@ Sc_rollup.Inbox.Internal_for_tests.produce_inclusion_proof - (get_history history) - inbox_snapshot - level -end - -module Protocol_inbox = struct - let new_inbox ?(genesis_predecessor_timestamp = Time.Protocol.epoch) - ?(genesis_predecessor = Block_hash.zero) - ?(inbox_creation_level = Raw_level.root) () = - Sc_rollup.Inbox.genesis - ~predecessor_timestamp:genesis_predecessor_timestamp - ~predecessor:genesis_predecessor - inbox_creation_level - - let fill_inbox ~inbox_creation_level inbox payloads_per_levels = - let open Result_syntax in - let rec aux inbox = function - | [] -> return inbox - | ({ - payloads = _; - predecessor_timestamp; - predecessor; - messages; - level; - inputs = _; - } : - payloads_per_level) - :: rst -> - let payloads = - List.map - (fun message -> Sc_rollup.Inbox_message.(External message)) - messages - in - let* _, _, inbox, _, _ = - Environment.wrap_tzresult - @@ Sc_rollup.Inbox.add_all_messages - ~first_block: - Raw_level.(equal (succ inbox_creation_level) level) - ~predecessor_timestamp - ~predecessor - (Sc_rollup.Inbox.History.empty ~capacity:1000L) - inbox - payloads - in - aux inbox rst - in - aux inbox payloads_per_levels - - let add_new_level ?pred_info inbox messages = - let next_level = Raw_level.succ @@ Sc_rollup.Inbox.inbox_level inbox in - let messages_per_level = wrap_messages ?pred_info next_level messages in - fill_inbox inbox [messages_per_level] - - let add_new_empty_level ?pred_info inbox = - let next_level = Raw_level.succ @@ Sc_rollup.Inbox.inbox_level inbox in - let empty_level = [make_empty_level ?pred_info next_level] in - fill_inbox inbox empty_level - - let construct_inbox ?(inbox_creation_level = Raw_level.root) - ?genesis_predecessor_timestamp ?genesis_predecessor payloads_per_levels = - let inbox = - new_inbox - ?genesis_predecessor_timestamp - ?genesis_predecessor - ~inbox_creation_level - () - in - fill_inbox ~inbox_creation_level inbox payloads_per_levels -end - -let construct_node_and_protocol_inbox ?inbox_creation_level - ?genesis_predecessor_timestamp ?genesis_predecessor payloads_per_levels = - let open Result_syntax in - let* node_inbox = - Node_inbox.construct_inbox - ?inbox_creation_level - ?genesis_predecessor_timestamp - ?genesis_predecessor - payloads_per_levels - in - let* protocol_inbox = - Protocol_inbox.construct_inbox - ?inbox_creation_level - ?genesis_predecessor_timestamp - ?genesis_predecessor - payloads_per_levels - in - return (node_inbox, protocol_inbox) - -module Protocol_inbox_with_ctxt = struct - let fill_inbox block list_of_messages contract = - let open Lwt_result_syntax in - let* block, list_of_messages = - List.fold_left_map_es - (fun (block : Block.t) ({messages; _} as messages_per_level) -> - let predecessor = block.hash in - let predecessor_timestamp = block.header.shell.timestamp in - - let* block = - match messages with - | [] -> - let* block = Block.bake block in - return block - | messages -> - let* operation_add_message = - Op.sc_rollup_add_messages (B block) contract messages - in - let* block = - Block.bake ~operation:operation_add_message block - in - return block - in - - return - (block, {messages_per_level with predecessor; predecessor_timestamp})) - block - list_of_messages - in - return (block, list_of_messages) -end diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/script_big_map.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/script_big_map.ml deleted file mode 100644 index 6a7745859af01c1c49a96880b7b16dbf92bd2405..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/script_big_map.ml +++ /dev/null @@ -1,30 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) - -let update k v m ctxt = Protocol.Script_big_map.update ctxt k v m - -let of_list key_ty ty xs ctxt = - List.fold_left_es - (fun (bm, ctxt) (k, v) -> update k (Some v) bm ctxt) - (Protocol.Script_big_map.empty key_ty ty, ctxt) - xs diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/script_big_map.mli b/src/proto_017_PtNairob/lib_protocol/test/helpers/script_big_map.mli deleted file mode 100644 index 0a6bcc4d51ade0f8ba124118e20258f77fbf9577..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/script_big_map.mli +++ /dev/null @@ -1,44 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) - -(** Update a big map. See [Script_typed_ir.big_map_get_and_update] for details. *) -val update : - 'key -> - 'value option -> - ('key, 'value) Protocol.Script_typed_ir.big_map -> - Protocol.Alpha_context.t -> - (('key, 'value) Protocol.Script_typed_ir.big_map * Protocol.Alpha_context.t) - Environment.Error_monad.tzresult - Lwt.t - -(** Convert a list to a [Script_big_map]. If the list contains duplicate keys, - the first occurence is used. - *) -val of_list : - 'key Protocol.Script_typed_ir.comparable_ty -> - ('value, _) Protocol.Script_typed_ir.ty -> - ('key * 'value) list -> - Protocol.Alpha_context.t -> - (('key, 'value) Protocol.Script_typed_ir.big_map * Protocol.Alpha_context.t) - Environment.Error_monad.tzresult - Lwt.t diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/script_map.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/script_map.ml deleted file mode 100644 index 5b780f7ac8e2f4b457839b183fc4e52991be2019..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/script_map.ml +++ /dev/null @@ -1,36 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2020 Metastate AG *) -(* *) -(* 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 of_list : - type k v. - k Protocol.Script_typed_ir.comparable_ty -> - (k * v) list -> - (k, v) Protocol.Script_typed_ir.map = - fun ty1 xs -> - List.fold_left - (fun rs (k, v) -> Protocol.Script_map.update k (Some v) rs) - (Protocol.Script_map.empty ty1) - xs diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/script_map.mli b/src/proto_017_PtNairob/lib_protocol/test/helpers/script_map.mli deleted file mode 100644 index e81cf5956c933f1c15f23a8bbbd80fb042fde901..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/script_map.mli +++ /dev/null @@ -1,31 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Trili Tech *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** Convert a list to a [Script_map]. If the list contains duplicate keys, - the last occurence is used. *) -val of_list : - 'k Protocol.Script_typed_ir.comparable_ty -> - ('k * 'v) list -> - ('k, 'v) Protocol.Script_typed_ir.map diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/script_set.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/script_set.ml deleted file mode 100644 index b02d082465a43506be1a0e37681b2122965e3310..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/script_set.ml +++ /dev/null @@ -1,31 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2020 Metastate AG *) -(* *) -(* 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 of_list ty1 xs = - List.fold_left - (fun rs k -> Protocol.Script_set.update k true rs) - (Protocol.Script_set.empty ty1) - xs diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/script_set.mli b/src/proto_017_PtNairob/lib_protocol/test/helpers/script_set.mli deleted file mode 100644 index 7df70020e3b3a43f2caa805541aacf465dc14ec8..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/script_set.mli +++ /dev/null @@ -1,32 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2020 Metastate AG *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Convert a list to a Script IR set. If the list contains duplicates, - the last occurence is used. *) -val of_list : - 'a Protocol.Script_typed_ir.comparable_ty -> - 'a list -> - 'a Protocol.Script_typed_ir.set diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/test_global_constants.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/test_global_constants.ml deleted file mode 100644 index 341d5b63e5c51600be6fa6c9ac18632a42be50cd..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/test_global_constants.ml +++ /dev/null @@ -1,321 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 -open Alpha_context -open Micheline -open Michelson_v1_primitives - -let create_context () = - let open Lwt_result_syntax in - let*? accounts = Account.generate_accounts 2 in - Block.alpha_context (Account.make_bootstrap_accounts accounts) - -let expr_to_hash expr = - let lexpr = Script_repr.lazy_expr expr in - Script_repr.force_bytes lexpr >|? fun b -> Script_expr_hash.hash_bytes [b] - -let assert_expr_equal loc = - Assert.equal - ~loc - ( = ) - "Michelson Expressions Not Equal" - Michelson_v1_printer.print_expr - -let assert_proto_error_id loc id result = - let test err = - (Error_monad.find_info_of_error err).id - = "proto." ^ Protocol.name ^ "." ^ id - in - Assert.error ~loc result test - -let assert_ok_lwt x = - match Lwt_main.run x with - | Ok x -> x - | Error _ -> raise @@ Failure "Called assert_ok_lwt on Error" - -let assert_ok = function - | Ok x -> x - | Error _ -> raise @@ Failure "Called assert_ok on Error" - -(** Filters out values that would cause [register] *) -let assume_expr_not_too_large expr = - let node = root expr in - QCheck2.assume @@ not - @@ Global_constants_storage.Internal_for_tests.node_too_large node - -module Generators = struct - let context_gen () = QCheck2.Gen.return (create_context () |> assert_ok_lwt) - - let prims = - [ - 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_CHAIN_ID; - 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_BIG_MAP; - I_EMPTY_MAP; - I_EMPTY_SET; - I_EQ; - I_EXEC; - I_APPLY; - I_FAILWITH; - I_GE; - I_GET; - I_GET_AND_UPDATE; - 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_LEVEL; - 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_UNPAIR; - I_PUSH; - I_RIGHT; - I_SIZE; - I_SOME; - I_SOURCE; - I_SENDER; - I_SELF; - I_SELF_ADDRESS; - 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; - I_SAPLING_EMPTY_STATE; - I_SAPLING_VERIFY_UPDATE; - I_DIG; - I_DUG; - I_NEVER; - I_VOTING_POWER; - I_TOTAL_VOTING_POWER; - I_KECCAK; - I_SHA3; - I_PAIRING_CHECK; - I_TICKET; - I_READ_TICKET; - I_SPLIT_TICKET; - I_JOIN_TICKETS; - 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; - T_sapling_transaction_deprecated; - T_sapling_state; - T_chain_id; - T_never; - T_bls12_381_g1; - T_bls12_381_g2; - T_bls12_381_fr; - T_ticket; - H_constant; - ] - - let prim_gen = QCheck2.Gen.oneofl prims - - let prims_without_constants_gen = - QCheck2.Gen.oneofl (List.filter (fun x -> x != H_constant) prims) - - let z_gen = QCheck2.Gen.map Z.of_int QCheck2.Gen.int - - let micheline_node_gen l_gen p_gen annot_gen : - ('l, 'p) Micheline.node QCheck2.Gen.t = - let open Micheline in - let open QCheck2.Gen in - fix - (fun self () -> - frequency - [ - (3, map (fun (l, x) -> Int (l, x)) (pair l_gen z_gen)); - (3, map (fun (l, x) -> String (l, x)) (pair l_gen string)); - ( 3, - map - (fun (l, x) -> Bytes (l, Bytes.of_string x)) - (pair l_gen string) ); - ( 1, - map - (fun (l, p, args, annot) -> Prim (l, p, args, annot)) - (quad - l_gen - p_gen - (list_size (int_bound 10) (self ())) - annot_gen) ); - ( 1, - map - (fun (l, args) -> Seq (l, args)) - (pair l_gen (list_size (int_bound 10) (self ()))) ); - ]) - () - - let rec replace_with_constant : - Script.node -> Script.location -> Script.node * Script.node option = - fun node loc -> - let open Michelson_v1_primitives in - let open Micheline in - let rec loop : Script.node list -> Script.node list * Script.node option = - function - | [] -> ([], None) - | hd :: tl -> ( - match replace_with_constant hd loc with - | node, Some x -> (node :: tl, Some x) - | _, None -> - let l, x = loop tl in - (hd :: l, x)) - in - match node with - | (Int (l, _) | String (l, _) | Bytes (l, _)) as node -> - if l = loc then - let hash = - node |> strip_locations |> expr_to_hash |> assert_ok - |> Script_expr_hash.to_b58check - in - (Prim (-1, H_constant, [String (-1, hash)], []), Some node) - else (node, None) - | Prim (l, prim, args, annot) as node -> - if l = loc then - let hash = - node |> strip_locations |> expr_to_hash |> assert_ok - |> Script_expr_hash.to_b58check - in - (Prim (-1, H_constant, [String (-1, hash)], []), Some node) - else - let result, x = loop args in - (Prim (l, prim, result, annot), x) - | Seq (l, args) as node -> - if l = loc then - let hash = - node |> strip_locations |> expr_to_hash |> assert_ok - |> Script_expr_hash.to_b58check - in - (Prim (-1, H_constant, [String (-1, hash)], []), Some node) - else - let result, x = loop args in - (Seq (l, result), x) - - let micheline_gen p_gen annot_gen = - QCheck2.Gen.map - Micheline.strip_locations - (micheline_node_gen (QCheck2.Gen.return (-1)) p_gen annot_gen) - - let canonical_without_constant_gen () = - QCheck2.Gen.map - strip_locations - (micheline_node_gen - (QCheck2.Gen.return (-1)) - prims_without_constants_gen - (QCheck2.Gen.return [])) - - let canonical_with_constant_gen () = - let open QCheck2.Gen in - canonical_without_constant_gen () >>= fun expr -> - let size = Script_repr.micheline_nodes (root expr) in - 0 -- (size - 1) >|= fun loc -> - match replace_with_constant (root expr) loc with - | _, None -> assert false - | node, Some replaced_node -> - (expr, strip_locations node, strip_locations replaced_node) -end diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/test_tez.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/test_tez.ml deleted file mode 100644 index 5809c11c2adf2b6237b7e456cdfa33717825f278..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/test_tez.ml +++ /dev/null @@ -1,70 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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 -open Alpha_context -open Environment - -(* This module wraps the errors from the protocol *) -open Tez - -let ( +? ) t1 t2 = t1 +? t2 |> wrap_tzresult - -let ( -? ) t1 t2 = t1 -? t2 |> wrap_tzresult - -let ( *? ) t1 t2 = t1 *? t2 |> wrap_tzresult - -let ( /? ) t1 t2 = t1 /? t2 |> wrap_tzresult - -let ( +! ) t1 t2 = - match t1 +? t2 with Ok r -> r | Error _ -> Pervasives.failwith "adding tez" - -let ( -! ) t1 t2 = - match t1 -? t2 with - | Ok r -> r - | Error _ -> Pervasives.failwith "subtracting tez" - -let ( *! ) t1 t2 = - match t1 *? t2 with - | Ok r -> r - | Error _ -> Pervasives.failwith "multiplying tez" - -let ( /! ) t1 t2 = - match t1 /? t2 with - | Ok r -> r - | Error _ -> Pervasives.failwith "dividing tez" - -let of_int x = - match Tez.of_mutez (Int64.mul (Int64.of_int x) 1_000_000L) with - | None -> invalid_arg "tez_of_int" - | Some x -> x - -let of_mutez_exn x = - match Tez.of_mutez x with None -> invalid_arg "tez_of_mutez" | Some x -> x - -let to_mutez = Tez.to_mutez - -let max_tez = - match Tez.of_mutez Int64.max_int with None -> assert false | Some p -> p diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/testable.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/testable.ml deleted file mode 100644 index 287b46840b00e683605577744487c0a096bf49cf..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/testable.ml +++ /dev/null @@ -1,38 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs. *) -(* *) -(* 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 contract : Protocol.Alpha_context.Contract.t Alcotest.testable = - let open Protocol in - let open Alpha_context in - Alcotest.testable Contract.pp Contract.( = ) - -let script_expr : Protocol.Alpha_context.Script.expr Alcotest.testable = - Alcotest.testable Michelson_v1_printer.print_expr ( = ) - -let trace : tztrace Alcotest.testable = Alcotest.testable pp_print_trace ( = ) - -let protocol_error : Environment.Error_monad.error Alcotest.testable = - let open Environment.Error_monad in - Alcotest.testable pp ( = ) diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/ticket_helpers.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/ticket_helpers.ml deleted file mode 100644 index ba0f48f795643205e843f2b85f1d402435673e44..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/ticket_helpers.ml +++ /dev/null @@ -1,59 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) - -open Protocol -open Alpha_context - -let assert_balance ctxt ~loc key expected = - let open Lwt_result_syntax in - let* balance, _ = - Ticket_balance.get_balance ctxt key >|= Environment.wrap_tzresult - in - match (balance, expected) with - | Some b, Some eb -> Assert.equal_int ~loc (Z.to_int b) eb - | None, Some eb -> failwith "Expected balance %d" eb - | Some eb, None -> failwith "Expected None but got %d" (Z.to_int eb) - | None, None -> return_unit - -let string_ticket_token ticketer content = - let open Lwt_result_syntax in - let contents = - Result.value_f ~default:(fun _ -> assert false) - @@ Script_string.of_string content - in - let*? ticketer = Environment.wrap_tzresult @@ Contract.of_b58check ticketer in - return - (Ticket_token.Ex_token - {ticketer; contents_type = Script_typed_ir.string_t; contents}) - -let adjust_ticket_token_balance alpha_ctxt owner ticket_token ~delta = - let open Lwt_result_syntax in - let* ticket_token_hash, ctxt = - Ticket_balance_key.of_ex_token alpha_ctxt ~owner ticket_token - >|= Environment.wrap_tzresult - in - let* _, alpha_ctxt = - Ticket_balance.adjust_balance ctxt ticket_token_hash ~delta - >|= Environment.wrap_tzresult - in - return (ticket_token_hash, alpha_ctxt) diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/transfers.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/transfers.ml deleted file mode 100644 index 7d92c8c3ad305b5415497edfcbcb53fcb6b6bb2e..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/transfers.ml +++ /dev/null @@ -1,69 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context -open Test_tez - -let transfer_and_check_balances ?(with_burn = false) ~loc b ?(fee = Tez.zero) - ?expect_apply_failure src dst amount = - let open Lwt_result_syntax in - let*? amount_fee = fee +? amount in - let* bal_src = Context.Contract.balance (I b) src in - let* bal_dst = Context.Contract.balance (I b) dst in - let* op = - Op.transaction - ~force_reveal:true - ~gas_limit:(Custom_gas (Alpha_context.Gas.Arith.integral_of_int_exn 3000)) - (I b) - ~fee - src - dst - amount - in - let* b = Incremental.add_operation ?expect_apply_failure b op in - let* {parametric = {origination_size; cost_per_byte; _}; _} = - Context.get_constants (I b) - in - let*? origination_burn = cost_per_byte *? Int64.of_int origination_size in - let*? amount_fee_burn = amount_fee +? origination_burn in - let amount_fee_maybe_burn = - if with_burn then amount_fee_burn else amount_fee - in - let* () = - Assert.balance_was_debited ~loc (I b) src bal_src amount_fee_maybe_burn - in - let+ () = Assert.balance_was_credited ~loc (I b) dst bal_dst amount in - (b, op) - -let n_transactions n b ?fee source dest amount = - List.fold_left_es - (fun b _ -> - transfer_and_check_balances ~loc:__LOC__ b ?fee source dest amount - >>=? fun (i, _) -> - Incremental.finalize_block i >>=? fun b -> - Incremental.begin_construction b) - b - (1 -- n) diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/transfers.mli b/src/proto_017_PtNairob/lib_protocol/test/helpers/transfers.mli deleted file mode 100644 index 86e17da6e2e475e233e6361c33757a9bba33b964..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/transfers.mli +++ /dev/null @@ -1,68 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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 -open Alpha_context - -(** [transfer_and_check_balances b fee src dst amount] - this function takes a block, an optional parameter fee if fee does not - given it will be set to zero tez, a source contract, a destination contract - and the amount that one wants to transfer. - - 1- Transfer the amount of tez (w/wo fee) from a source contract to a - destination contract. - - 2- Check the equivalent of the balance of the source/destination - contract before and after transfer is validated. - - This function returns a pair: - - A block that added a valid operation - - a valid operation *) -val transfer_and_check_balances : - ?with_burn:bool -> - loc:string -> - Incremental.t -> - ?fee:Tez.t -> - ?expect_apply_failure:(error trace -> unit tzresult Lwt.t) -> - Contract.t -> - Contract.t -> - Tez.t -> - (Incremental.t * packed_operation) tzresult Lwt.t - -(** [n_transactions n b fee source dest amount] - this function takes a number of "n" that one wish to transfer, - a block, an optional parameter fee, a source contract, - a destination contract and an amount one wants to transfer. - - This function will do a transaction from a source contract to - a destination contract with the amount "n" times. *) -val n_transactions : - int -> - Incremental.t -> - ?fee:Tez.t -> - Contract.t -> - Contract.t -> - Tez.t -> - Incremental.t tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_protocol/test/helpers/zk_rollup_l2_helpers.ml b/src/proto_017_PtNairob/lib_protocol/test/helpers/zk_rollup_l2_helpers.ml deleted file mode 100644 index eb710552b7cc8a4d493180c80f1b3c9db9df6221..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/helpers/zk_rollup_l2_helpers.ml +++ /dev/null @@ -1,26 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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 Dummy_zk_rollup = Dummy_zk_rollup diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/dune b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/dune deleted file mode 100644 index 231ccb2b94d2b5bba035a3b5707d23eec3efa789..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/dune +++ /dev/null @@ -1,65 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name - src_proto_017_PtNairob_lib_protocol_test_integration_consensus_tezt_lib) - (instrumentation (backend bisect_ppx)) - (libraries - tezt.core - octez-alcotezt - octez-libs.base - tezos-protocol-017-PtNairob.protocol - octez-protocol-017-PtNairob-libs.test-helpers - octez-libs.base-test-helpers - tezos-protocol-017-PtNairob.parameters - octez-protocol-017-PtNairob-libs.plugin) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezt_core - -open Tezt_core.Base - -open Octez_alcotezt - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_protocol_017_PtNairob - -open Tezos_017_PtNairob_test_helpers - -open Tezos_base_test_helpers - -open Tezos_protocol_017_PtNairob_parameters - -open Tezos_protocol_plugin_017_PtNairob) - (modules - test_baking - test_consensus_key - test_deactivation - test_delegation - test_double_baking - test_double_endorsement - test_double_preendorsement - test_endorsement - test_frozen_deposits - test_helpers_rpcs - test_participation - test_preendorsement_functor - test_preendorsement - test_seed)) - -(executable - (name main) - (instrumentation (backend bisect_ppx --bisect-sigterm)) - (libraries - src_proto_017_PtNairob_lib_protocol_test_integration_consensus_tezt_lib - tezt) - (link_flags - (:standard) - (:include %{workspace_root}/macos-link-flags.sexp)) - (modules main)) - -(rule - (alias runtest) - (package tezos-protocol-017-PtNairob-tests) - (enabled_if (<> false %{env:RUNTEZTALIAS=true})) - (action (run %{dep:./main.exe}))) - -(rule - (targets main.ml) - (action (with-stdout-to %{targets} (echo "let () = Tezt.Test.run ()")))) diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_baking.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_baking.ml deleted file mode 100644 index 6d2ee39ec61b4be1cae7cf749f31f6478e9f5c80..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_baking.ml +++ /dev/null @@ -1,455 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2020 Metastate AG *) -(* Copyright (c) 2022 Trili Tech *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (baking) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/consensus/main.exe \ - -- --file test_baking.ml - Subject: Rewards and bakers. Tests based on RPCs. -*) - -open Protocol -open Alpha_context - -(** Verify the level is correctly computed when the first cycle is - passed and after baking a certain fixed number of blocks (10 for - the moment). The result should be [blocks_per_cycle + 10] where - [blocks_per_cycle] comes from the constants of the selected - protocol. - - IMPROVEMENTS: - - Randomize the number of cycle. - - Randomize the number of accounts created at the beginning - - Randomize the blocks per cycle. - - Randomize the number of blocks baked after the n cycles baked - previously. *) -let test_cycle () = - Context.init_n ~consensus_threshold:0 5 () >>=? fun (b, _contracts) -> - Context.get_constants (B b) >>=? fun csts -> - let blocks_per_cycle = csts.parametric.blocks_per_cycle in - let pp fmt x = Format.fprintf fmt "%ld" x in - Block.bake b >>=? fun b -> - Block.bake_until_cycle_end b >>=? fun b -> - Context.get_level (B b) >>?= fun curr_level -> - Assert.equal - ~loc:__LOC__ - Int32.equal - "not the right level" - pp - (Alpha_context.Raw_level.to_int32 curr_level) - blocks_per_cycle - >>=? fun () -> - Context.get_level (B b) >>?= fun l -> - Block.bake_n 10 b >>=? fun b -> - Context.get_level (B b) >>?= fun curr_level -> - Assert.equal - ~loc:__LOC__ - Int32.equal - "not the right level" - pp - (Alpha_context.Raw_level.to_int32 curr_level) - (Int32.add (Alpha_context.Raw_level.to_int32 l) 10l) - -(** Test baking [n] cycles in a raw works smoothly. *) -let test_bake_n_cycles n () = - let open Block in - let policy = By_round 0 in - Context.init1 ~consensus_threshold:0 () >>=? fun (block, _contract) -> - Block.bake_until_n_cycle_end ~policy n block >>=? fun (_block : block) -> - return_unit - -(** Check that, after one or two voting periods, the voting power of a baker is - updated according to the rewards it receives for baking the blocks in the - voting periods. Note we consider only one baker. *) -let test_voting_power_cache () = - let open Block in - let policy = By_round 0 in - Context.init1 ~consensus_threshold:0 () >>=? fun (genesis, _contract) -> - Context.get_constants (B genesis) >>=? fun csts -> - let blocks_per_voting_period = - Int32.( - mul - csts.parametric.blocks_per_cycle - csts.parametric.cycles_per_voting_period) - in - let blocks_per_voting_periods n = - Int64.of_int (n * Int32.to_int blocks_per_voting_period) - in - Context.get_baking_reward_fixed_portion (B genesis) >>=? fun baking_reward -> - Context.get_bakers (B genesis) >>=? fun bakers -> - let baker = WithExceptions.Option.get ~loc:__LOC__ @@ List.hd bakers in - Context.Delegate.full_balance (B genesis) baker >>=? fun full_balance -> - let assert_voting_power ~loc n block = - Context.get_voting_power (B block) baker >>=? fun voting_power -> - Assert.equal_int64 ~loc n voting_power - in - (* the voting power is the full staking balance *) - let initial_voting_power_at_genesis = Tez.to_mutez full_balance in - assert_voting_power ~loc:__LOC__ initial_voting_power_at_genesis genesis - >>=? fun () -> - let rewards_after_one_voting_period = - Test_tez.(baking_reward *! Int64.pred (blocks_per_voting_periods 1)) - in - let expected_delta_voting_power_after_one_voting_period = - Tez.to_mutez rewards_after_one_voting_period - in - Block.bake_n ~policy (Int32.to_int blocks_per_voting_period - 1) genesis - >>=? fun block -> - let expected_voting_power_after_one_voting_period = - Int64.add - initial_voting_power_at_genesis - expected_delta_voting_power_after_one_voting_period - in - assert_voting_power - ~loc:__LOC__ - expected_voting_power_after_one_voting_period - block - >>=? fun () -> - let rewards_after_two_voting_periods = - Test_tez.(baking_reward *! Int64.pred (blocks_per_voting_periods 2)) - in - let expected_delta_voting_power_after_two_voting_periods = - Tez.to_mutez rewards_after_two_voting_periods - in - Block.bake_n ~policy (Int32.to_int blocks_per_voting_period) block - >>=? fun block -> - let expected_voting_power_after_two_voting_periods = - Int64.add - initial_voting_power_at_genesis - expected_delta_voting_power_after_two_voting_periods - in - assert_voting_power - ~loc:__LOC__ - expected_voting_power_after_two_voting_periods - block - -(** test that after baking, one gets the baking reward fixed portion. *) -let test_basic_baking_reward () = - Context.init1 ~consensus_threshold:0 () >>=? fun (genesis, baker) -> - Block.bake genesis >>=? fun b -> - let baker_pkh = Context.Contract.pkh baker in - Context.Contract.balance (B b) baker >>=? fun bal -> - Context.Delegate.current_frozen_deposits (B b) baker_pkh - >>=? fun frozen_deposit -> - Context.get_baking_reward_fixed_portion (B b) >>=? fun br -> - let open Test_tez in - let expected_initial_balance = bal +! frozen_deposit -! br in - Assert.equal_tez - ~loc:__LOC__ - expected_initial_balance - Account.default_initial_balance - -let get_contract_for_pkh contracts pkh = - let rec find_contract = function - | [] -> assert false - | c :: t -> - let c_pkh = Context.Contract.pkh c in - if Signature.Public_key_hash.equal c_pkh pkh then return c - else find_contract t - in - find_contract contracts - -(** Test that - - the block producer gets the bonus for including the endorsements; - - the payload producer gets the baking reward. - - The test checks this in two scenarios, in the first one the payload producer - and the block producer are the same delegate, in the second one they are - different. The first scenario is checked by first baking block [b1] and then - block [b2] at round 0 containing a number of endorsements for [b1] and the - checking the balance of [b2]'s baker. For the second scenario another block - [b2'] is build on top of [b1] by a different baker, using the same payload as - [b2]. *) -let test_rewards_block_and_payload_producer () = - Context.init_n ~consensus_threshold:1 10 () >>=? fun (genesis, contracts) -> - Context.get_baker (B genesis) ~round:Round.zero >>=? fun baker_b1 -> - get_contract_for_pkh contracts baker_b1 >>=? fun baker_b1_contract -> - Block.bake ~policy:(By_round 0) genesis >>=? fun b1 -> - Context.get_endorsers (B b1) >>=? fun endorsers -> - List.map_es - (function - | {Plugin.RPC.Validators.delegate; slots; _} -> return (delegate, slots)) - endorsers - >>=? fun endorsers -> - (* We let just a part of the endorsers vote; we assume here that 5 of 10 - endorsers will have together at least one slot (to pass the threshold), but - not all slots (to make the test more interesting, otherwise we know the - total endorsing power). *) - let endorsers = List.take_n 5 endorsers in - List.map_ep - (fun (endorser, _slots) -> Op.endorsement ~delegate:endorser b1) - endorsers - >>=? fun endos -> - let endorsing_power = - List.fold_left - (fun acc (_pkh, slots) -> acc + List.length slots) - 0 - endorsers - in - let fee = Tez.one in - Op.transaction (B b1) ~fee baker_b1_contract baker_b1_contract Tez.one - >>=? fun tx -> - Block.bake ~policy:(By_round 0) ~operations:(endos @ [tx]) b1 >>=? fun b2 -> - Context.get_baker (B b1) ~round:Round.zero >>=? fun baker_b2 -> - get_contract_for_pkh contracts baker_b2 >>=? fun baker_b2_contract -> - Context.Contract.balance (B b2) baker_b2_contract >>=? fun bal -> - Context.Delegate.current_frozen_deposits (B b2) baker_b2 - >>=? fun frozen_deposit -> - Context.get_baking_reward_fixed_portion (B b2) >>=? fun baking_reward -> - Context.get_bonus_reward (B b2) ~endorsing_power >>=? fun bonus_reward -> - (if Signature.Public_key_hash.equal baker_b2 baker_b1 then - Context.get_baking_reward_fixed_portion (B b1) - else return Tez.zero) - >>=? fun reward_for_b1 -> - (* we are in the first scenario where the payload producer is the same as the - block producer, in our case, [baker_b2]. [baker_b2] gets the baking reward - plus the fee for the transaction [tx]. *) - let expected_balance = - let open Test_tez in - Account.default_initial_balance -! frozen_deposit +! baking_reward - +! bonus_reward +! reward_for_b1 +! fee - in - Assert.equal_tez ~loc:__LOC__ bal expected_balance >>=? fun () -> - (* Some new baker [baker_b2'] bakes b2' at the first round which does not - correspond to a slot of [baker_b2] and it includes the PQC for [b2]. We - check that the fixed baking reward goes to the payload producer [baker_b2], - while the bonus goes to the the block producer (aka baker) [baker_b2']. *) - Context.get_endorsers (B b2) >>=? fun endorsers -> - List.map_es - (function - | {Plugin.RPC.Validators.delegate; slots; _} -> return (delegate, slots)) - endorsers - >>=? fun preendorsers -> - List.map_ep - (fun (endorser, _slots) -> Op.preendorsement ~delegate:endorser b2) - preendorsers - >>=? fun preendos -> - Context.get_baker (B b1) ~round:Round.zero >>=? fun baker_b2 -> - Context.get_bakers (B b1) >>=? fun bakers -> - let baker_b2' = Context.get_first_different_baker baker_b2 bakers in - Block.bake - ~payload_round:(Some Round.zero) - ~locked_round:(Some Round.zero) - ~policy:(By_account baker_b2') - ~operations:(preendos @ endos @ [tx]) - b1 - >>=? fun b2' -> - (* [baker_b2], as payload producer, gets the block reward and the fees *) - Context.Contract.balance (B b2') baker_b2_contract >>=? fun bal -> - Context.Delegate.current_frozen_deposits (B b2') baker_b2 - >>=? fun frozen_deposit -> - let reward_for_b1 = - if Signature.Public_key_hash.equal baker_b2 baker_b1 then baking_reward - else Tez.zero - in - let expected_balance = - let open Test_tez in - Account.default_initial_balance +! baking_reward -! frozen_deposit - +! reward_for_b1 +! fee - in - Assert.equal_tez ~loc:__LOC__ bal expected_balance >>=? fun () -> - (* [baker_b2'] gets the bonus because he is the one who included the - endorsements *) - get_contract_for_pkh contracts baker_b2' >>=? fun baker_b2'_contract -> - Context.Contract.balance (B b2') baker_b2'_contract >>=? fun bal' -> - Context.Delegate.current_frozen_deposits (B b2') baker_b2' - >>=? fun frozen_deposits' -> - Context.get_baker (B genesis) ~round:Round.zero >>=? fun baker_b1 -> - let reward_for_b1' = - if Signature.Public_key_hash.equal baker_b2' baker_b1 then baking_reward - else Tez.zero - in - let expected_balance' = - let open Test_tez in - Account.default_initial_balance +! bonus_reward +! reward_for_b1' - -! frozen_deposits' - in - Assert.equal_tez ~loc:__LOC__ bal' expected_balance' - -(** We test that: - - a delegate that has active stake can bake; - - a delegate that has no active stake cannot bake. -*) -let test_enough_active_stake_to_bake ~has_active_stake () = - Context.init1 () >>=? fun (b_for_constants, _contract) -> - Context.get_constants (B b_for_constants) - >>=? fun Constants.{parametric = {minimal_stake; _}; _} -> - let tpr = Tez.to_mutez minimal_stake in - (* N.B. setting the balance has an impact on the active stake; without - delegation, the full balance is the same as the staking balance and the - active balance is less or equal the staking balance (see - [Delegate_sampler.select_distribution_for_cycle]). *) - let initial_bal1 = if has_active_stake then tpr else Int64.sub tpr 1L in - Context.init2 - ~bootstrap_balances:[initial_bal1; tpr] - ~consensus_threshold:0 - () - >>=? fun (b0, (account1, _account2)) -> - let pkh1 = Context.Contract.pkh account1 in - Context.get_constants (B b0) - >>=? fun Constants.{parametric = {baking_reward_fixed_portion; _}; _} -> - Block.bake ~policy:(By_account pkh1) b0 >>= fun b1 -> - if has_active_stake then - b1 >>?= fun b1 -> - Context.Contract.balance (B b1) account1 >>=? fun bal -> - Context.Delegate.current_frozen_deposits (B b1) pkh1 - >>=? fun frozen_deposit -> - let expected_bal = - Test_tez.( - Tez.of_mutez_exn initial_bal1 - -! frozen_deposit +! baking_reward_fixed_portion) - in - Assert.equal_tez ~loc:__LOC__ bal expected_bal - else - (* pkh1 has less than minimal_stake so it will have no slots, thus it - cannot be a proposer, thus it cannot bake. Precisely, bake fails because - get_next_baker_by_account fails with "No slots found for pkh1" *) - Assert.error ~loc:__LOC__ b1 (fun _ -> true) - -let test_committee_sampling () = - let test_distribution max_round distribution = - let bootstrap_balances, bounds = List.split distribution in - Account.generate_accounts (List.length bootstrap_balances) - >>?= fun accounts -> - let bootstrap_accounts = - Account.make_bootstrap_accounts ~bootstrap_balances accounts - in - let consensus_committee_size = max_round in - assert ( - (* Enforce that we are not mistakenly testing a value for committee_size - that violates invariants of module Slot_repr. *) - Result.is_ok - (Slot_repr.of_int consensus_committee_size)) ; - let constants = - { - Default_parameters.constants_test with - consensus_committee_size; - consensus_threshold = 0; - } - in - let parameters = - Default_parameters.parameters_of_constants ~bootstrap_accounts constants - in - Block.genesis_with_parameters parameters >>=? fun genesis -> - Plugin.RPC.Baking_rights.get Block.rpc_ctxt ~all:true ~max_round genesis - >|=? fun bakers -> - let stats = Stdlib.Hashtbl.create 10 in - Stdlib.List.iter2 - (fun acc bounds -> Stdlib.Hashtbl.add stats acc.Account.pkh (bounds, 0)) - accounts - bounds ; - List.iter - (fun {Plugin.RPC.Baking_rights.delegate = pkh; _} -> - let bounds, n = Stdlib.Hashtbl.find stats pkh in - Stdlib.Hashtbl.replace stats pkh (bounds, n + 1)) - bakers ; - let one_failed = ref false in - - Format.eprintf - "@[Testing with baker distribution [%a],@ committee size %d.@]@." - (Format.pp_print_list - ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ") - (fun ppf (tez, _) -> Format.fprintf ppf "%Ld" tez)) - distribution - max_round ; - - Format.eprintf - "@[@,%a@]@." - (fun ppf stats -> - Stdlib.Hashtbl.iter - (fun pkh ((min_p, max_p), n) -> - let failed = not (n >= min_p && n <= max_p) in - Format.fprintf - ppf - "@[- %a %d%a@]@," - Signature.Public_key_hash.pp - pkh - n - (fun ppf failed -> - if failed then - Format.fprintf ppf " [FAIL] should be in [%d, %d]" min_p max_p - else Format.fprintf ppf "") - failed ; - one_failed := failed || !one_failed) - stats) - stats ; - - if !one_failed then - Stdlib.failwith - "The proportion of bakers marked as [FAILED] in the log output appear \ - in the wrong proportion in the committee." - else Format.eprintf "Test succesful.@." - in - (* The tests below are not deterministic, but the probability that - they fail is infinitesimal. *) - let accounts = - let expected_lower_bound = 6_100 and expected_upper_bound = 6_900 in - let balance = 8_000_000_000L in - let account = (balance, (expected_lower_bound, expected_upper_bound)) in - Array.(make 10 account |> to_list) - in - test_distribution 65535 accounts >>=? fun () -> - test_distribution - 10_000 - [ - (16_000_000_000L, (4_600, 5_400)); - (8_000_000_000L, (2_200, 2_800)); - (8_000_000_000L, (2_200, 2_800)); - ] - >>=? fun () -> - test_distribution - 10_000 - [(792_000_000_000L, (9_830, 9_970)); (8_000_000_000L, (40, 160))] - -let tests = - [ - Tztest.tztest "cycle" `Quick test_cycle; - Tztest.tztest "bake_n_cycles for 12 cycles" `Quick (test_bake_n_cycles 12); - Tztest.tztest "voting_power" `Quick test_voting_power_cache; - Tztest.tztest - "the fixed baking reward is given after a bake" - `Quick - test_basic_baking_reward; - Tztest.tztest - "the block producer gets the bonus while the payload producer gets the \ - baking reward " - `Quick - test_rewards_block_and_payload_producer; - Tztest.tztest - "a delegate with 8000 tez can bake" - `Quick - (test_enough_active_stake_to_bake ~has_active_stake:true); - Tztest.tztest - "a delegate with 7999 tez cannot bake" - `Quick - (test_enough_active_stake_to_bake ~has_active_stake:false); - Tztest.tztest "committee sampling" `Quick test_committee_sampling; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("baking", tests)] |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_consensus_key.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_consensus_key.ml deleted file mode 100644 index b6a4e9ec6ab1ddecc3837443bb789970eeb43b81..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_consensus_key.ml +++ /dev/null @@ -1,304 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (delegate_storage) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/consensus/main.exe \ - -- --file test_consensus_key.ml - Subject: consistency of the [Drain_delegate] operation - *) - -open Protocol -open Alpha_context - -let constants = - { - Default_parameters.constants_test with - endorsing_reward_per_slot = Tez.zero; - baking_reward_bonus_per_slot = Tez.zero; - baking_reward_fixed_portion = Tez.zero; - consensus_threshold = 0; - origination_size = 0; - } - -(** Checks that staking balance is sum of delegators' stake. *) -let check_delegate_staking_invariant blk delegate_pkh = - Context.Delegate.staking_balance (B blk) delegate_pkh - >>=? fun delegate_staking_balance -> - Context.Delegate.full_balance (B blk) delegate_pkh - >>=? fun self_staking_balance -> - Context.Delegate.info (B blk) delegate_pkh >>=? fun delegate_info -> - let delegate_contract = Contract.Implicit delegate_pkh in - let delegated_contracts = - List.filter - (fun c -> Contract.(c <> delegate_contract)) - delegate_info.delegated_contracts - in - List.fold_left_es - (fun total pkh -> - Context.Contract.balance_and_frozen_bonds (B blk) pkh - >>=? fun staking_balance -> - Lwt.return Tez.(total +? staking_balance) >|= Environment.wrap_tzresult) - self_staking_balance - delegated_contracts - >>=? fun delegators_stake -> - Assert.equal_tez ~loc:__LOC__ delegate_staking_balance delegators_stake - -let update_consensus_key blk delegate public_key = - let nb_delay_cycles = constants.preserved_cycles + 1 in - Op.update_consensus_key (B blk) (Contract.Implicit delegate) public_key - >>=? fun update_ck -> - Block.bake ~operation:update_ck blk >>=? fun blk' -> - Block.bake_until_n_cycle_end nb_delay_cycles blk' - -let delegate_stake blk source delegate = - Op.delegation (B blk) (Contract.Implicit source) (Some delegate) - >>=? fun delegation -> Block.bake ~operation:delegation blk - -let transfer_tokens blk source destination amount = - Op.transaction - (B blk) - (Contract.Implicit source) - (Contract.Implicit destination) - amount - >>=? fun transfer_op -> Block.bake ~operation:transfer_op blk - -let may_reveal_manager_key blk (pkh, pk) = - let open Lwt_result_syntax in - let* is_revealed = - Context.Contract.is_manager_key_revealed (B blk) (Contract.Implicit pkh) - in - if is_revealed then return blk - else - Op.revelation (B blk) pk >>=? fun reveal_op -> - Block.bake ~operation:reveal_op blk - -let drain_delegate ~policy blk consensus_key delegate destination - expected_final_balance = - Op.drain_delegate (B blk) ~consensus_key ~delegate ~destination - >>=? fun drain_del -> - Block.bake ~policy ~operation:drain_del blk >>=? fun blk' -> - check_delegate_staking_invariant blk' delegate >>=? fun () -> - Context.Contract.balance (B blk') (Contract.Implicit delegate) - >>=? fun final_balance -> - Assert.equal_tez ~loc:__LOC__ final_balance expected_final_balance - -let get_first_2_accounts_contracts (a1, a2) = - ((a1, Context.Contract.pkh a1), (a2, Context.Contract.pkh a2)) - -let test_drain_delegate_scenario f = - Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let (_contract1, account1_pkh), (_contract2, account2_pkh) = - get_first_2_accounts_contracts contracts - in - let consensus_account = Account.new_account () in - let delegate = account1_pkh in - let consensus_pk = consensus_account.pk in - let consensus_pkh = consensus_account.pkh in - transfer_tokens genesis account2_pkh consensus_pkh Tez.one_mutez - >>=? fun blk' -> - update_consensus_key blk' delegate consensus_pk >>=? fun blk' -> - f blk' consensus_pkh consensus_pk delegate - -let test_drain_delegate ~low_balance ~exclude_ck ~ck_delegates () = - test_drain_delegate_scenario (fun blk consensus_pkh consensus_pk delegate -> - let policy = - if exclude_ck then Block.Excluding [consensus_pkh] - else Block.By_account delegate - in - (if ck_delegates then - may_reveal_manager_key blk (consensus_pkh, consensus_pk) >>=? fun blk -> - delegate_stake blk consensus_pkh delegate - else return blk) - >>=? fun blk -> - Context.Contract.balance (B blk) (Contract.Implicit delegate) - >>=? fun delegate_balance -> - (if low_balance then - transfer_tokens blk delegate consensus_pkh delegate_balance - >>=? fun blk -> - may_reveal_manager_key blk (consensus_pkh, consensus_pk) >>=? fun blk -> - transfer_tokens blk consensus_pkh delegate Tez.(of_mutez_exn 1_000_000L) - else return blk) - >>=? fun blk -> - Context.Contract.balance (B blk) (Contract.Implicit delegate) - >>=? fun delegate_balance -> - let expected_final_balance = - if exclude_ck then Tez.zero - else Tez.(max one (div_exn delegate_balance 100)) - in - drain_delegate - ~policy - blk - consensus_pkh - delegate - consensus_pkh - expected_final_balance) - -let test_drain_empty_delegate ~exclude_ck () = - test_drain_delegate_scenario (fun blk consensus_pkh _consensus_pk delegate -> - let policy = - if exclude_ck then Block.Excluding [consensus_pkh] - else Block.By_account delegate - in - Context.Contract.balance (B blk) (Contract.Implicit delegate) - >>=? fun delegate_balance -> - transfer_tokens blk delegate consensus_pkh delegate_balance - >>=? fun blk -> - drain_delegate ~policy blk consensus_pkh delegate consensus_pkh Tez.zero - >>= fun res -> - Assert.proto_error_with_info - ~loc:__LOC__ - res - "Drain delegate without enough balance for allocation burn or drain \ - fees") - -let test_tz4_consensus_key () = - Context.init_with_constants1 constants >>=? fun (genesis, contracts) -> - let account1_pkh = Context.Contract.pkh contracts in - let consensus_account = Account.new_account ~algo:Bls () in - let delegate = account1_pkh in - let consensus_pk = consensus_account.pk in - let consensus_pkh = consensus_account.pkh in - transfer_tokens genesis account1_pkh consensus_pkh Tez.one_mutez - >>=? fun blk' -> - Op.update_consensus_key (B blk') (Contract.Implicit delegate) consensus_pk - >>=? fun operation -> - let tz4_pk = match consensus_pk with Bls pk -> pk | _ -> assert false in - let expect_failure = function - | [ - Environment.Ecoproto_error - (Delegate_consensus_key.Invalid_consensus_key_update_tz4 pk); - ] - when Signature.Bls.Public_key.(pk = tz4_pk) -> - return_unit - | err -> - failwith - "Error trace:@,\ - \ %a does not match the \ - [Delegate_consensus_key.Invalid_consensus_key_update_tz4] error" - Error_monad.pp_print_trace - err - in - Incremental.begin_construction blk' >>=? fun inc -> - Incremental.validate_operation ~expect_failure inc operation - >>=? fun (_i : Incremental.t) -> return_unit - -let test_endorsement_with_consensus_key () = - Context.init_with_constants1 constants >>=? fun (genesis, contracts) -> - let account1_pkh = Context.Contract.pkh contracts in - let consensus_account = Account.new_account () in - let delegate = account1_pkh in - let consensus_pk = consensus_account.pk in - let consensus_pkh = consensus_account.pkh in - transfer_tokens genesis account1_pkh consensus_pkh Tez.one_mutez - >>=? fun blk' -> - update_consensus_key blk' delegate consensus_pk >>=? fun b_pre -> - Block.bake b_pre >>=? fun b -> - let slot = Slot.of_int_do_not_use_except_for_parameters 0 in - Op.endorsement ~delegate:account1_pkh ~slot b >>=? fun endorsement -> - Block.bake ~operation:endorsement b >>= fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Operation.Invalid_signature -> true - | _ -> false) - >>=? fun () -> - Op.endorsement ~delegate:consensus_pkh ~slot b >>=? fun endorsement -> - Block.bake ~operation:endorsement b >>=? fun (_good_block : Block.t) -> - return_unit - -let tests = - Tztest. - [ - tztest - "drain delegate high balance, excluding ck, ck delegates" - `Quick - (test_drain_delegate - ~low_balance:false - ~exclude_ck:true - ~ck_delegates:true); - tztest - "drain delegate high balance, excluding ck, ck does not delegate" - `Quick - (test_drain_delegate - ~low_balance:false - ~exclude_ck:true - ~ck_delegates:false); - tztest - "drain delegate high balance, with ck, ck delegates" - `Quick - (test_drain_delegate - ~low_balance:false - ~exclude_ck:false - ~ck_delegates:true); - tztest - "drain delegate high balance, with ck, ck does not delegate" - `Quick - (test_drain_delegate - ~low_balance:false - ~exclude_ck:false - ~ck_delegates:false); - tztest - "drain delegate low balance, excluding ck, ck delegates" - `Quick - (test_drain_delegate - ~low_balance:true - ~exclude_ck:true - ~ck_delegates:true); - tztest - "drain delegate low balance, excluding ck, ck does not delegate" - `Quick - (test_drain_delegate - ~low_balance:true - ~exclude_ck:true - ~ck_delegates:false); - tztest - "drain delegate low balance, with ck, ck delegates" - `Quick - (test_drain_delegate - ~low_balance:true - ~exclude_ck:false - ~ck_delegates:true); - tztest - "drain delegate low balance, with ck, ck does not delegate" - `Quick - (test_drain_delegate - ~low_balance:true - ~exclude_ck:false - ~ck_delegates:false); - tztest - "empty drain delegate excluding ck" - `Quick - (test_drain_empty_delegate ~exclude_ck:true); - tztest - "empty drain delegate with ck" - `Quick - (test_drain_empty_delegate ~exclude_ck:false); - tztest "tz4 consensus key" `Quick test_tz4_consensus_key; - tztest "endorsement with ck" `Quick test_endorsement_with_consensus_key; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("consensus key", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_deactivation.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_deactivation.ml deleted file mode 100644 index 3686dbdb049f3672f154f2f93492211ddfdf9630..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_deactivation.ml +++ /dev/null @@ -1,361 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/consensus/main.exe \ - -- --file test_deactivation.ml - Subject: After a given number of cycles during which a delegate has not - made use of its baking and endorsing rights, its account will - be deactivated for validator selection. To bake/endorse - again, it will have to re-activate its account. -*) - -open Protocol -open Alpha_context -open Test_tez - -let wrap e = Lwt.return (Environment.wrap_tzresult e) - -(** Check that [Delegate.staking_balance] is the same as [Delegate.full_balance] - (this is not true in general, but in these tests it is because they only deal - with self-delegation. Also, check that [Delegate.staking_balance] coincides - with [Stake_storage.get] when the account is active and it has the minimal - required stake. *) -let check_stake ~loc (b : Block.t) (account : Account.t) = - Context.Delegate.staking_balance (B b) account.pkh >>=? fun staking_balance -> - Context.Delegate.full_balance (B b) account.pkh >>=? fun full_balance -> - Assert.equal_tez ~loc full_balance staking_balance >>=? fun () -> - Raw_context.prepare - b.context - ~level:b.header.shell.level - ~predecessor_timestamp:b.header.shell.timestamp - ~timestamp:b.header.shell.timestamp - >>= wrap - >>=? fun ctxt -> - Stake_storage.get ctxt account.pkh >>= wrap >>=? fun stake -> - Assert.equal_int64 - ~loc - (Tez_repr.to_mutez stake) - (Tez.to_mutez staking_balance) - -(** Check that [Stake_storage.get] returns 0 (following a deactivation). Note - that in case of deactivation [Delegate.staking_balance] does not necessarily - coincide with [Stake_storage.get] in that [Delegate.staking_balance] may be - positive (while [Stake_storage.get] returns 0 because the account is no - longer in [Active_delegate_with_minimal_stake] because of deactivation, see - [Stake_storage].) *) -let check_no_stake ~loc (b : Block.t) (account : Account.t) = - Raw_context.prepare - b.context - ~level:b.header.shell.level - ~predecessor_timestamp:b.header.shell.timestamp - ~timestamp:b.header.shell.timestamp - >>= wrap - >>=? fun ctxt -> - Stake_storage.get ctxt account.pkh >>= wrap >>=? fun stake -> - Assert.equal_int64 ~loc (Tez_repr.to_mutez stake) 0L - -(** Create a block with two initialized contracts/accounts. Assert - that the first account has a staking balance that is equal to its - own balance, and that its staking rights are consistent - (check_stake). *) -let test_simple_staking_rights () = - Context.init2 () >>=? fun (b, (a1, _a2)) -> - Context.Contract.balance (B b) a1 >>=? fun balance -> - let delegate1 = Context.Contract.pkh a1 in - Context.Delegate.current_frozen_deposits (B b) delegate1 - >>=? fun frozen_deposits -> - let expected_initial_balance = - Account.default_initial_balance -! frozen_deposits - in - Assert.equal_tez ~loc:__LOC__ balance expected_initial_balance >>=? fun () -> - Context.Contract.manager (B b) a1 >>=? fun m1 -> - Context.Delegate.info (B b) m1.pkh >>=? fun info -> - Assert.equal_tez - ~loc:__LOC__ - Account.default_initial_balance - info.staking_balance - >>=? fun () -> check_stake ~loc:__LOC__ b m1 - -(** Create a block with two initialized contracts/accounts. Bake - five blocks. Assert that the staking balance of the first account - equals to its balance. Then both accounts have consistent staking - rights. *) -let test_simple_staking_rights_after_baking () = - Context.init2 ~consensus_threshold:0 () >>=? fun (b, (a1, a2)) -> - Context.Contract.manager (B b) a1 >>=? fun m1 -> - Context.Contract.manager (B b) a2 >>=? fun m2 -> - Block.bake_n ~policy:(By_account m2.pkh) 5 b >>=? fun b -> - Context.Contract.balance (B b) a1 >>=? fun balance -> - let delegate1 = Context.Contract.pkh a1 in - Context.Delegate.current_frozen_deposits (B b) delegate1 - >>=? fun frozen_deposits -> - balance +? frozen_deposits >>?= fun full_balance -> - Context.Delegate.info (B b) m1.pkh >>=? fun info -> - Assert.equal_tez ~loc:__LOC__ full_balance info.staking_balance >>=? fun () -> - check_stake ~loc:__LOC__ b m1 >>=? fun () -> check_stake ~loc:__LOC__ b m2 - -let check_active_staking_balance ~loc ~deactivated b (m : Account.t) = - Context.Delegate.info (B b) m.pkh >>=? fun info -> - Assert.equal_bool ~loc info.deactivated deactivated >>=? fun () -> - if deactivated then check_no_stake ~loc b m else check_stake ~loc b m - -let run_until_deactivation () = - Context.init2 ~consensus_threshold:0 () >>=? fun (b, (a1, a2)) -> - Context.Contract.balance (B b) a1 >>=? fun balance_start -> - Context.Contract.manager (B b) a1 >>=? fun m1 -> - Context.Contract.manager (B b) a2 >>=? fun m2 -> - check_active_staking_balance ~loc:__LOC__ ~deactivated:false b m1 - >>=? fun () -> - Context.Delegate.info (B b) m1.pkh >>=? fun info -> - Block.bake_until_cycle ~policy:(By_account m2.pkh) info.grace_period b - >>=? fun b -> - check_active_staking_balance ~loc:__LOC__ ~deactivated:false b m1 - >>=? fun () -> - Block.bake_until_cycle_end ~policy:(By_account m2.pkh) b >>=? fun b -> - check_active_staking_balance ~loc:__LOC__ ~deactivated:true b m1 - >|=? fun () -> (b, ((a1, m1), balance_start), (a2, m2)) - -(** From an initialized block with two contracts/accounts, the first - one is active then deactivated. After baking, check that the - account is active again. Baking rights are ensured. *) -let test_deactivation_then_bake () = - run_until_deactivation () - >>=? fun ( b, - ((_deactivated_contract, deactivated_account), _start_balance), - (_a2, _m2) ) -> - Block.bake ~policy:(By_account deactivated_account.pkh) b >>=? fun b -> - check_active_staking_balance - ~loc:__LOC__ - ~deactivated:false - b - deactivated_account - -(** check that an account which is deactivated for [preserved_cycles] cannot be - part of a committee *) -let test_a_really_deactivated_account_is_not_in_the_committee () = - run_until_deactivation () - >>=? fun ( b, - ((_deactivated_contract, deactivated_account), _start_balance), - (_a2, m2) ) -> - (* at this point, the deactivated account can either bake (because it still - has rights) and become active again, or, in case it is inactive for another - [preserved_cycles], it has no more rights, thus cannot be part of the - committee. *) - let constants = Default_parameters.constants_test in - Block.bake_until_n_cycle_end - (constants.preserved_cycles + 1) - ~policy:(By_account m2.pkh) - b - >>=? fun b -> - Plugin.RPC.Baking_rights.get - Block.rpc_ctxt - ~delegates:[deactivated_account.pkh] - b - >>=? fun bakers -> - match List.hd bakers with Some _ -> assert false | None -> return_unit - -(** A deactivated account, after baking with self-delegation, is - active again. Preservation of its balance is tested. Baking rights - are ensured. *) -let test_deactivation_then_self_delegation () = - run_until_deactivation () - >>=? fun ( b, - ((deactivated_contract, deactivated_account), _start_balance), - (_a2, m2) ) -> - Op.delegation (B b) deactivated_contract (Some deactivated_account.pkh) - >>=? fun self_delegation -> - Block.bake ~policy:(By_account m2.pkh) b ~operation:self_delegation - >>=? fun b -> - check_active_staking_balance - ~loc:__LOC__ - ~deactivated:false - b - deactivated_account - >>=? fun () -> check_stake ~loc:__LOC__ b deactivated_account - -(** A deactivated account, which is emptied (into a newly created sink - account), then self-delegated, becomes activated. Its balance is - zero. Baking rights are ensured. *) -let test_deactivation_then_empty_then_self_delegation () = - run_until_deactivation () - >>=? fun ( b, - ((deactivated_contract, deactivated_account), _start_balance), - (_a2, m2) ) -> - (* empty the contract *) - Context.Contract.balance (B b) deactivated_contract >>=? fun balance -> - let sink_account = Account.new_account () in - let sink_contract = Contract.Implicit sink_account.pkh in - Context.get_constants (B b) - >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} -> - cost_per_byte *? Int64.of_int origination_size >>?= fun origination_burn -> - let amount = - match balance -? origination_burn with Ok r -> r | Error _ -> assert false - in - Op.transaction (B b) deactivated_contract sink_contract amount - >>=? fun empty_contract -> - Block.bake ~policy:(By_account m2.pkh) ~operation:empty_contract b - >>=? fun b1 -> - (* the account is deactivated, the stake is 0. *) - check_no_stake ~loc:__LOC__ b deactivated_account >>=? fun () -> - (* self delegation *) - Op.delegation (B b1) deactivated_contract (Some deactivated_account.pkh) - >>=? fun self_delegation -> - Block.bake ~policy:(By_account m2.pkh) ~operation:self_delegation b1 - >>=? fun b2 -> - check_active_staking_balance - ~loc:__LOC__ - ~deactivated:false - b2 - deactivated_account - >>=? fun () -> - (* the account is activated, the stake is still 0. *) - Context.Contract.balance (B b2) deactivated_contract >>=? fun balance -> - Assert.equal_tez ~loc:__LOC__ Tez.zero balance - -(** A deactivated account, which is emptied, then self-delegated, then - re-credited of the sunk amount, becomes active again. Staking - rights remain consistent. *) -let test_deactivation_then_empty_then_self_delegation_then_recredit () = - run_until_deactivation () - >>=? fun ( b, - ((deactivated_contract, deactivated_account), _start_balance), - (_a2, m2) ) -> - (* empty the contract *) - Context.Contract.balance (B b) deactivated_contract >>=? fun balance -> - let sink_account = Account.new_account () in - let sink_contract = Contract.Implicit sink_account.pkh in - Context.get_constants (B b) - >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} -> - cost_per_byte *? Int64.of_int origination_size >>?= fun origination_burn -> - let amount = - match balance -? origination_burn with Ok r -> r | Error _ -> assert false - in - Op.transaction - ~force_reveal:true - (B b) - deactivated_contract - sink_contract - amount - >>=? fun empty_contract -> - Block.bake ~policy:(By_account m2.pkh) ~operation:empty_contract b - >>=? fun b0 -> - (* the account is deactivated, the stake is 0. *) - check_no_stake ~loc:__LOC__ b deactivated_account >>=? fun () -> - (**** self delegation *) - Op.delegation (B b0) deactivated_contract (Some deactivated_account.pkh) - >>=? fun self_delegation -> - Block.bake ~policy:(By_account m2.pkh) ~operation:self_delegation b0 - >>=? fun b1 -> - (* the account is still deactivated *) - check_no_stake ~loc:__LOC__ b deactivated_account >>=? fun () -> - (**** recredit *) - Op.transaction - ~force_reveal:true - (B b1) - sink_contract - deactivated_contract - amount - >>=? fun recredit_contract -> - Block.bake ~policy:(By_account m2.pkh) ~operation:recredit_contract b1 - >>=? fun b2 -> - check_active_staking_balance - ~loc:__LOC__ - ~deactivated:false - b2 - deactivated_account - >>=? fun () -> - Context.Contract.balance (B b2) deactivated_contract >>=? fun balance2 -> - Assert.equal_tez ~loc:__LOC__ amount balance2 >>=? fun () -> - check_stake ~loc:__LOC__ b2 deactivated_account - -(** Initialize a block with two contracts/accounts. A third new account is also - created. The first account is self-delegated. First account sends to third - one minimal_stake tez (so that, once it is active, it can appear in - [Active_delegate_with_minimal_stake]. The third account has no delegate and is - consistent for baking rights. Then, it is self-delegated and is supposed to - be activated. Again, consistency for baking rights are preserved for the - first and third accounts. *) -let test_delegation () = - Context.init2 ~consensus_threshold:0 () >>=? fun (b, (a1, a2)) -> - let m3 = Account.new_account () in - Account.add_account m3 ; - Context.Contract.manager (B b) a1 >>=? fun m1 -> - Context.Contract.manager (B b) a2 >>=? fun m2 -> - let a3 = Contract.Implicit m3.pkh in - Context.Contract.delegate_opt (B b) a1 >>=? fun delegate -> - (match delegate with - | None -> assert false - | Some pkh -> assert (Signature.Public_key_hash.equal pkh m1.pkh)) ; - let constants = Default_parameters.constants_test in - let minimal_stake = constants.minimal_stake in - Op.transaction ~force_reveal:true (B b) a1 a3 minimal_stake - >>=? fun transact -> - Block.bake ~policy:(By_account m2.pkh) b ~operation:transact >>=? fun b -> - Context.Contract.delegate_opt (B b) a3 >>=? fun delegate -> - (match delegate with None -> () | Some _ -> assert false) ; - check_no_stake ~loc:__LOC__ b m3 >>=? fun () -> - Op.delegation ~force_reveal:true (B b) a3 (Some m3.pkh) >>=? fun delegation -> - Block.bake ~policy:(By_account m2.pkh) b ~operation:delegation >>=? fun b -> - Context.Contract.delegate_opt (B b) a3 >>=? fun delegate -> - (match delegate with - | None -> assert false - | Some pkh -> assert (Signature.Public_key_hash.equal pkh m3.pkh)) ; - check_active_staking_balance ~loc:__LOC__ ~deactivated:false b m3 - >>=? fun () -> - check_stake ~loc:__LOC__ b m3 >>=? fun () -> check_stake ~loc:__LOC__ b m1 - -let tests = - [ - Tztest.tztest "simple staking rights" `Quick test_simple_staking_rights; - Tztest.tztest - "simple staking rights after baking" - `Quick - test_simple_staking_rights_after_baking; - Tztest.tztest "deactivation then bake" `Quick test_deactivation_then_bake; - Tztest.tztest - "deactivation then self delegation" - `Quick - test_deactivation_then_self_delegation; - Tztest.tztest - "deactivation then empty then self delegation" - `Quick - test_deactivation_then_empty_then_self_delegation; - Tztest.tztest - "deactivation then empty then self delegation then recredit" - `Quick - test_deactivation_then_empty_then_self_delegation_then_recredit; - Tztest.tztest "delegate" `Quick test_delegation; - Tztest.tztest - "a really deactivated account is not part of the committee" - `Quick - test_a_really_deactivated_account_is_not_in_the_committee; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("deactivation", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_delegation.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_delegation.ml deleted file mode 100644 index b8f3550093a3e92b3afead760a9c865418e07271..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_delegation.ml +++ /dev/null @@ -1,1619 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (delegation) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/consensus/main.exe \ - -- --file test_delegation.ml - Subject: - Properties on bootstrap contracts (self-delegation, - cannot delete/change their delegate (as opposed to contracts - not-being-delegate which can do these), bootstrap manager - as delegate during origination). - - Properties on delegation depending on whether delegate - keys registration, through origination and delegation. -*) - -open Protocol -open Alpha_context -open Test_tez - -(*****************************************************************************) -(* Bootstrap contracts - ------------------- - Bootstrap contracts are heavily used in other tests. It is helpful to test - some properties of these contracts, so we can correctly interpret the other - tests that use them. *) -(*****************************************************************************) - -let expect_error err = function - | err0 :: _ when err = err0 -> return_unit - | _ -> failwith "Unexpected successful result" - -let expect_alpha_error err = expect_error (Environment.Ecoproto_error err) - -let expect_no_change_registered_delegate_pkh pkh = function - | Environment.Ecoproto_error (Delegate_storage.Contract.No_deletion pkh0) :: _ - when pkh0 = pkh -> - return_unit - | _ -> failwith "Delegate can not be deleted and operation should fail." - -let expect_too_low_balance_error i op = - Incremental.add_operation i op >>= fun err -> - Assert.proto_error_with_info ~loc:__LOC__ err "Balance too low" - -let expect_delegate_already_active_error i op = - Incremental.add_operation i op >>= fun err -> - Assert.proto_error_with_info ~loc:__LOC__ err "Delegate already active" - -(** Bootstrap contracts delegate to themselves. *) -let bootstrap_manager_is_bootstrap_delegate () = - Context.init1 () >>=? fun (b, bootstrap0) -> - Context.Contract.delegate (B b) bootstrap0 >>=? fun delegate0 -> - Context.Contract.manager (B b) bootstrap0 >>=? fun manager0 -> - Assert.equal_pkh ~loc:__LOC__ delegate0 manager0.pkh - -(** Bootstrap contracts cannot change their delegate. *) -let bootstrap_delegate_cannot_change ~fee () = - Context.init2 () >>=? fun (b, (bootstrap0, bootstrap1)) -> - let pkh1 = Context.Contract.pkh bootstrap0 in - Incremental.begin_construction b ~policy:(Block.Excluding [pkh1]) - >>=? fun i -> - Context.Contract.manager (I i) bootstrap1 >>=? fun manager1 -> - Context.Contract.balance (I i) bootstrap0 >>=? fun balance0 -> - Context.Contract.delegate (I i) bootstrap0 >>=? fun delegate0 -> - (* change delegation to bootstrap1 *) - Op.delegation ~fee (I i) bootstrap0 (Some manager1.pkh) - >>=? fun set_delegate -> - if fee > balance0 then expect_too_low_balance_error i set_delegate - else - Incremental.add_operation - ~expect_apply_failure:(expect_no_change_registered_delegate_pkh delegate0) - i - set_delegate - >>=? fun i -> - Incremental.finalize_block i >>=? fun b -> - (* bootstrap0 still has same delegate *) - Context.Contract.delegate (B b) bootstrap0 >>=? fun delegate0_after -> - Assert.equal_pkh ~loc:__LOC__ delegate0_after delegate0 >>=? fun () -> - (* fee has been debited *) - Assert.balance_was_debited ~loc:__LOC__ (B b) bootstrap0 balance0 fee - -(** Bootstrap contracts cannot delete their delegation. *) -let bootstrap_delegate_cannot_be_removed ~fee () = - Context.init1 () >>=? fun (b, bootstrap) -> - Incremental.begin_construction b >>=? fun i -> - Context.Contract.balance (I i) bootstrap >>=? fun balance -> - Context.Contract.delegate (I i) bootstrap >>=? fun delegate -> - Context.Contract.manager (I i) bootstrap >>=? fun manager -> - (* remove delegation *) - Op.delegation ~fee (I i) bootstrap None >>=? fun set_delegate -> - if fee > balance then expect_too_low_balance_error i set_delegate - else - Incremental.add_operation - ~expect_apply_failure: - (expect_no_change_registered_delegate_pkh manager.pkh) - i - set_delegate - >>=? fun i -> - (* delegate has not changed *) - Context.Contract.delegate (I i) bootstrap >>=? fun delegate_after -> - Assert.equal_pkh ~loc:__LOC__ delegate delegate_after >>=? fun () -> - (* fee has been debited *) - Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee - -(** Contracts not registered as delegate can change their - delegation. *) -let delegate_can_be_changed_from_unregistered_contract ~fee () = - Context.init2 ~consensus_threshold:0 () - >>=? fun (b, (bootstrap0, bootstrap1)) -> - let unregistered_account = Account.new_account () in - let unregistered_pkh = Account.(unregistered_account.pkh) in - let unregistered = Contract.Implicit unregistered_pkh in - Context.Contract.manager (B b) bootstrap0 >>=? fun manager0 -> - Context.Contract.manager (B b) bootstrap1 >>=? fun manager1 -> - let credit = of_int 10 in - Op.transaction ~fee:Tez.zero (B b) bootstrap0 unregistered credit - >>=? fun credit_contract -> - Context.Contract.balance (B b) bootstrap0 >>=? fun balance -> - Block.bake b ~operation:credit_contract >>=? fun b -> - (* delegate to bootstrap0 *) - Op.delegation - ~force_reveal:true - ~fee:Tez.zero - (B b) - unregistered - (Some manager0.pkh) - >>=? fun set_delegate -> - Block.bake b ~operation:set_delegate >>=? fun b -> - Context.Contract.delegate (B b) unregistered >>=? fun delegate -> - Assert.equal_pkh ~loc:__LOC__ delegate manager0.pkh >>=? fun () -> - (* change delegation to bootstrap1 *) - Op.delegation ~force_reveal:true ~fee (B b) unregistered (Some manager1.pkh) - >>=? fun change_delegate -> - Incremental.begin_construction b >>=? fun i -> - if fee > balance then expect_too_low_balance_error i change_delegate - else - Incremental.add_operation i change_delegate >>=? fun i -> - (* delegate has changed *) - Context.Contract.delegate (I i) unregistered >>=? fun delegate_after -> - Assert.equal_pkh ~loc:__LOC__ delegate_after manager1.pkh >>=? fun () -> - (* fee has been debited *) - Assert.balance_was_debited ~loc:__LOC__ (I i) unregistered credit fee - -(** Contracts not registered as delegate can delete their - delegation. *) -let delegate_can_be_removed_from_unregistered_contract ~fee () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let unregistered_account = Account.new_account () in - let unregistered_pkh = Account.(unregistered_account.pkh) in - let unregistered = Contract.Implicit unregistered_pkh in - Context.Contract.manager (B b) bootstrap >>=? fun manager -> - let credit = of_int 10 in - Op.transaction - ~force_reveal:true - ~fee:Tez.zero - (B b) - bootstrap - unregistered - credit - >>=? fun credit_contract -> - Context.Contract.balance (B b) bootstrap >>=? fun balance -> - Block.bake b ~operation:credit_contract >>=? fun b -> - (* delegate to bootstrap *) - Op.delegation - ~force_reveal:true - ~fee:Tez.zero - (B b) - unregistered - (Some manager.pkh) - >>=? fun set_delegate -> - Block.bake b ~operation:set_delegate >>=? fun b -> - Context.Contract.delegate (B b) unregistered >>=? fun delegate -> - Assert.equal_pkh ~loc:__LOC__ delegate manager.pkh >>=? fun () -> - (* remove delegation *) - Op.delegation ~fee (B b) unregistered None >>=? fun delete_delegate -> - Incremental.begin_construction b >>=? fun i -> - if fee > balance then expect_too_low_balance_error i delete_delegate - else - Incremental.add_operation i delete_delegate >>=? fun i -> - (* the delegate has been removed *) - (Context.Contract.delegate_opt (I i) unregistered >>=? function - | None -> return_unit - | Some _ -> failwith "Expected delegate to be removed") - >>=? fun () -> - (* fee has been debited *) - Assert.balance_was_debited ~loc:__LOC__ (I i) unregistered credit fee - -(** Bootstrap keys are already registered as delegate keys. *) -let bootstrap_manager_already_registered_delegate ~fee () = - Context.init1 () >>=? fun (b, bootstrap) -> - Incremental.begin_construction b >>=? fun i -> - Context.Contract.manager (I i) bootstrap >>=? fun manager -> - let pkh = manager.pkh in - let impl_contract = Contract.Implicit pkh in - Context.Contract.balance (I i) impl_contract >>=? fun balance -> - Op.delegation ~fee (I i) impl_contract (Some pkh) >>=? fun sec_reg -> - if fee > balance then expect_too_low_balance_error i sec_reg - else - Incremental.add_operation - ~expect_apply_failure:(function - | Environment.Ecoproto_error Delegate_storage.Contract.Active_delegate - :: _ -> - return_unit - | _ -> failwith "Delegate is already active and operation should fail.") - i - sec_reg - >>=? fun i -> - (* fee has been debited *) - Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract balance fee - -(** Bootstrap manager can be set as delegate of an originated contract - (through origination operation). *) -let delegate_to_bootstrap_by_origination ~fee () = - Context.init1 () >>=? fun (b, bootstrap) -> - Incremental.begin_construction b >>=? fun i -> - Context.Contract.manager (I i) bootstrap >>=? fun manager -> - Context.Contract.balance (I i) bootstrap >>=? fun balance -> - (* originate a contract with bootstrap's manager as delegate *) - Op.contract_origination - ~fee - ~credit:Tez.zero - ~delegate:manager.pkh - (I i) - bootstrap - ~script:Op.dummy_script - >>=? fun (op, orig_contract) -> - Context.get_constants (I i) - >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} -> - (* 0.257tz *) - cost_per_byte *? Int64.of_int origination_size >>?= fun origination_burn -> - fee +? origination_burn >>? ( +? ) Op.dummy_script_cost >>?= fun total_fee -> - if fee > balance then expect_too_low_balance_error i op - else if total_fee > balance && balance >= fee then - (* origination did not proceed; fee has been debited *) - let expect_apply_failure = function - | Environment.Ecoproto_error err :: _ -> - Assert.test_error_encodings err ; - let error_info = - Error_monad.find_info_of_error (Environment.wrap_tzerror err) - in - if String.equal error_info.title "Balance too low" then return_unit - else failwith "unexpected failure" - | _ -> - failwith - "Test_delegation.delegate_to_bootstrap_by_origination was expected \ - to fail but has not" - in - Incremental.add_operation i ~expect_apply_failure op >>=? fun i -> - (* fee was taken *) - Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee - >>=? fun () -> - (* originated contract has not been created *) - Context.Contract.balance (I i) orig_contract >>= fun err -> - Assert.error ~loc:__LOC__ err (function - | Tezos_rpc.Context.Not_found _ -> true - | _ -> false) - else - (* bootstrap is delegate, fee + origination burn have been debited *) - Incremental.add_operation i op >>=? fun i -> - Context.Contract.delegate (I i) orig_contract >>=? fun delegate -> - Assert.equal_pkh ~loc:__LOC__ delegate manager.pkh >>=? fun () -> - Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance total_fee - -let undelegated_originated_bootstrap_contract () = - Context.init1 - ~bootstrap_contracts: - [ - Parameters.{delegate = None; amount = Tez.zero; script = Op.dummy_script}; - ] - () - >>=? fun (b, _contract) -> - Block.bake b >>=? fun b -> - (* We know the address of the first originated bootstrap contract because we know the bootstrap origination nonce. This address corresponds to the first TF vesting contract on mainnnet. *) - Lwt.return @@ Environment.wrap_tzresult - @@ Alpha_context.Contract.of_b58check "KT1WPEis2WhAc2FciM2tZVn8qe6pCBe9HkDp" - >>=? fun originated_bootstrap0 -> - Context.Contract.delegate_opt (B b) originated_bootstrap0 - >>=? fun delegate0 -> - match delegate0 with - | None -> return_unit - | Some _ -> failwith "Bootstrap contract should be undelegated (%s)" __LOC__ - -let delegated_implicit_bootstrap_contract () = - Account.generate_accounts 2 >>?= fun accounts -> - let to_pkh, from_pkh = - match accounts with - | [account1; account2] -> (account1.pkh, account2.pkh) - | _ -> assert false - in - let bootstrap_delegations = [None; Some to_pkh] in - let bootstrap_accounts = - Account.make_bootstrap_accounts ~bootstrap_delegations accounts - in - Block.genesis bootstrap_accounts >>=? fun b -> - (Context.Contract.delegate_opt (B b) (Implicit from_pkh) >>=? function - | Some pkh when pkh = to_pkh -> return_unit - | Some _ | None -> - failwith "Bootstrap contract should be delegated (%s)." __LOC__) - >>=? fun () -> - (* Test delegation amount *) - Incremental.begin_construction b >>=? fun i -> - let ctxt = Incremental.alpha_ctxt i in - Delegate.delegated_balance ctxt to_pkh >|= Environment.wrap_tzresult - >>=? fun amount -> - Assert.equal_tez ~loc:__LOC__ amount (Tez.of_mutez_exn 4_000_000_000_000L) - -let tests_bootstrap_contracts = - [ - Tztest.tztest - "bootstrap contracts delegate to themselves" - `Quick - bootstrap_manager_is_bootstrap_delegate; - Tztest.tztest - "bootstrap contracts can change their delegate (small fee)" - `Quick - (bootstrap_delegate_cannot_change ~fee:Tez.one_mutez); - Tztest.tztest - "bootstrap contracts can change their delegate (max fee)" - `Quick - (bootstrap_delegate_cannot_change ~fee:max_tez); - Tztest.tztest - "bootstrap contracts cannot remove their delegation (small fee)" - `Quick - (bootstrap_delegate_cannot_be_removed ~fee:Tez.one_mutez); - Tztest.tztest - "bootstrap contracts cannot remove their delegation (max fee)" - `Quick - (bootstrap_delegate_cannot_be_removed ~fee:max_tez); - Tztest.tztest - "contracts not registered as delegate can change their delegation (small \ - fee)" - `Quick - (delegate_can_be_changed_from_unregistered_contract ~fee:Tez.one_mutez); - Tztest.tztest - "contracts not registered as delegate can change their delegation (max \ - fee)" - `Quick - (delegate_can_be_changed_from_unregistered_contract ~fee:max_tez); - Tztest.tztest - "contracts not registered as delegate can remove their delegation (small \ - fee)" - `Quick - (delegate_can_be_removed_from_unregistered_contract ~fee:Tez.one_mutez); - Tztest.tztest - "contracts not registered as delegate can remove their delegation (max \ - fee)" - `Quick - (delegate_can_be_removed_from_unregistered_contract ~fee:max_tez); - Tztest.tztest - "bootstrap keys are already registered as delegate keys (small fee)" - `Quick - (bootstrap_manager_already_registered_delegate ~fee:Tez.one_mutez); - Tztest.tztest - "bootstrap keys are already registered as delegate keys (max fee)" - `Quick - (bootstrap_manager_already_registered_delegate ~fee:max_tez); - Tztest.tztest - "bootstrap manager can be delegate (init origination, small fee)" - `Quick - (delegate_to_bootstrap_by_origination ~fee:Tez.one_mutez); - (* balance enough for fee but not for fee + origination burn + dummy script storage cost *) - Tztest.tztest - "bootstrap manager can be delegate (init origination, edge case)" - `Quick - (delegate_to_bootstrap_by_origination - ~fee:(Tez.of_mutez_exn 3_999_999_705_000L)); - (* fee bigger than bootstrap's initial balance*) - Tztest.tztest - "bootstrap manager can be delegate (init origination, large fee)" - `Quick - (delegate_to_bootstrap_by_origination ~fee:(Test_tez.of_int 10_000_000)); - Tztest.tztest - "originated bootstrap contract can be undelegated" - `Quick - undelegated_originated_bootstrap_contract; - Tztest.tztest - "originated bootstrap contract can be delegated" - `Quick - delegated_implicit_bootstrap_contract; - ] - -(*****************************************************************************) -(* Delegate registration - --------------------- - A delegate is a pkh. Delegates must be registered. Registration is - done via the self-delegation of the implicit contract corresponding - to the pkh. The implicit contract must be credited when the - self-delegation is done. Furthermore, trying to register an already - registered key raises an error. - - In this series of tests, we verify that - 1- unregistered delegate keys cannot be delegated to, - 2- registered keys can be delegated to, - 3- registering an already registered key raises an error. - - We consider three scenarios for setting a delegate: - - through origination, - - through delegation when the implicit contract has no delegate yet, - - through delegation when the implicit contract already has a delegate. - - We also test that emptying the implicit contract linked to a - registered delegate key does not unregister the delegate key. - - Valid registration - ------------------ - Unregistered key: - - contract not credited and no self-delegation, - - contract credited but no self-delegation, - - contract not credited and self-delegation. - - Not credited: - - no credit operation - - credit operation of 1μꜩ and then debit operation of 1μꜩ *) -(*****************************************************************************) - -(* Part A. - Unregistered delegate keys cannot be used for delegation - - Two main series of tests: without self-delegation and with a failed attempt at self-delegation: - - 1/ no self-delegation - a/ no credit - - no token transfer - - credit of 1μꜩ and then debit of 1μꜩ - b/ with credit of 1μꜩ. - For every scenario, we try three different ways of delegating: - - through origination (init origination) - - through delegation when no delegate was assigned (init delegation) - - through delegation when a delegate was assigned (switch delegation). - - 2/ Self-delegation fails if the contract has no credit. We try the - two possibilities of 1a for non-credited contracts. *) - -let expect_unregistered_key pkh = function - | Environment.Ecoproto_error (Delegate_storage.Unregistered_delegate pkh0) - :: _ - when pkh = pkh0 -> - return_unit - | _ -> failwith "Delegate key is not registered: operation should fail." - -(* Part A. Section 1. - No self-delegation. *) - -(** No token transfer, no self-delegation. Originated account. If - fees are higher than balance, [Balance_too_low] is - raised. Otherwise, it checks the correct exception is raised - (unregistered key), and the fees are still debited. Using RPCs, we - verify the contract has not been originated. *) -let test_unregistered_delegate_key_init_origination ~fee () = - Context.init1 () >>=? fun (b, bootstrap) -> - Incremental.begin_construction b >>=? fun i -> - let unregistered_account = Account.new_account () in - let unregistered_pkh = Account.(unregistered_account.pkh) in - (* origination with delegate argument *) - Op.contract_origination - ~fee - ~delegate:unregistered_pkh - (I i) - bootstrap - ~script:Op.dummy_script - >>=? fun (op, orig_contract) -> - Context.get_constants (I i) - >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} -> - cost_per_byte *? Int64.of_int origination_size >>?= fun origination_burn -> - fee +? origination_burn >>?= fun (_total_fee : Tez.t) -> - (* FIXME unused variable *) - Context.Contract.balance (I i) bootstrap >>=? fun balance -> - if fee > balance then expect_too_low_balance_error i op - else - (* origination did not proceed; fee has been debited *) - Incremental.add_operation - ~expect_apply_failure:(expect_unregistered_key unregistered_pkh) - i - op - >>=? fun i -> - Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee - >>=? fun () -> - (* originated contract has not been created *) - Context.Contract.balance (I i) orig_contract >>= fun err -> - Assert.error ~loc:__LOC__ err (function - | Tezos_rpc.Context.Not_found _ -> true - | _ -> false) - -(** Delegation when delegate key is not assigned. Delegate account is - initialized. If fees are higher than initial credit (10 tez), - [Balance_too_low] is raised. Otherwise, fees are still debited. The - implicit contract has no delegate. *) -let test_unregistered_delegate_key_init_delegation ~fee () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let unregistered_account = Account.new_account () in - let unregistered_pkh = Account.(unregistered_account.pkh) in - let impl_contract = Contract.Implicit unregistered_pkh in - let unregistered_delegate_account = Account.new_account () in - let unregistered_delegate_pkh = Account.(unregistered_delegate_account.pkh) in - (* initial credit for the delegated contract *) - let credit = of_int 10 in - Op.transaction - ~force_reveal:true - ~fee:Tez.zero - (B b) - bootstrap - impl_contract - credit - >>=? fun credit_contract -> - Block.bake b ~operation:credit_contract >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract credit >>=? fun () -> - (* try to delegate *) - Op.delegation - ~force_reveal:true - ~fee - (B b) - impl_contract - (Some unregistered_delegate_pkh) - >>=? fun delegate_op -> - Incremental.begin_construction b >>=? fun i -> - if fee > credit then expect_too_low_balance_error i delegate_op - else - (* fee has been debited; no delegate *) - Incremental.add_operation - i - ~expect_apply_failure:(expect_unregistered_key unregistered_delegate_pkh) - delegate_op - >>=? fun i -> - Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee - >>=? fun () -> - (* implicit contract has no delegate *) - Context.Contract.delegate (I i) impl_contract >>= fun err -> - Assert.error ~loc:__LOC__ err (function - | Tezos_rpc.Context.Not_found _ -> true - | _ -> false) - -(** Re-delegation when a delegate key was already assigned. If fees - are higher than initial credit (10 tez), [Balance_too_low] is - raised. Otherwise, fees are not debited and the implicit contract - delegate remains unchanged. *) -let test_unregistered_delegate_key_switch_delegation ~fee () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let bootstrap_pkh = Context.Contract.pkh bootstrap in - let unregistered_account = Account.new_account () in - let unregistered_pkh = Account.(unregistered_account.pkh) in - let impl_contract = Contract.Implicit unregistered_pkh in - let unregistered_delegate_account = Account.new_account () in - let unregistered_delegate_pkh = Account.(unregistered_delegate_account.pkh) in - (* initial credit for the delegated contract *) - let credit = of_int 10 in - Op.transaction - ~force_reveal:true - ~fee:Tez.zero - (B b) - bootstrap - impl_contract - credit - >>=? fun init_credit -> - Block.bake b ~operation:init_credit >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract credit >>=? fun () -> - (* set and check the initial delegate *) - Op.delegation - ~force_reveal:true - ~fee:Tez.zero - (B b) - impl_contract - (Some bootstrap_pkh) - >>=? fun delegate_op -> - Block.bake b ~operation:delegate_op >>=? fun b -> - Context.Contract.delegate (B b) bootstrap >>=? fun delegate_pkh -> - Assert.equal_pkh ~loc:__LOC__ bootstrap_pkh delegate_pkh >>=? fun () -> - (* try to delegate *) - Op.delegation ~fee (B b) impl_contract (Some unregistered_delegate_pkh) - >>=? fun delegate_op -> - Incremental.begin_construction b >>=? fun i -> - if fee > credit then expect_too_low_balance_error i delegate_op - else - (* fee has been debited; no delegate *) - Incremental.add_operation - i - ~expect_apply_failure:(expect_unregistered_key unregistered_delegate_pkh) - delegate_op - >>=? fun i -> - Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee - >>=? fun () -> - (* implicit contract delegate has not changed *) - Context.Contract.delegate (I i) bootstrap >>=? fun delegate_pkh_after -> - Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate_pkh_after - -(** Same as [unregistered_delegate_key_init_origination] and credits - [amount], no self-delegation. *) -let test_unregistered_delegate_key_init_origination_credit ~fee ~amount () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let unregistered_account = Account.new_account () in - let unregistered_pkh = Account.(unregistered_account.pkh) in - let impl_contract = Contract.Implicit unregistered_pkh in - (* credit + check balance *) - Op.transaction ~fee:Tez.zero (B b) bootstrap impl_contract amount - >>=? fun create_contract -> - Block.bake b ~operation:create_contract >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract amount >>=? fun () -> - (* origination with delegate argument *) - Context.Contract.balance (B b) bootstrap >>=? fun balance -> - Op.contract_origination - ~fee - ~delegate:unregistered_pkh - (B b) - bootstrap - ~script:Op.dummy_script - >>=? fun (op, orig_contract) -> - Incremental.begin_construction b >>=? fun i -> - if fee > balance then expect_too_low_balance_error i op - else - (* origination not done, fee taken *) - Incremental.add_operation - ~expect_apply_failure:(expect_unregistered_key unregistered_pkh) - i - op - >>=? fun i -> - Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee - >>=? fun () -> - Context.Contract.balance (I i) orig_contract >>= fun err -> - Assert.error ~loc:__LOC__ err (function - | Tezos_rpc.Context.Not_found _ -> true - | _ -> false) - -(** Same as [unregistered_delegate_key_init_delegation] and credits - the amount [amount] of the implicit contract. *) -let test_unregistered_delegate_key_init_delegation_credit ~fee ~amount () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let unregistered_account = Account.new_account () in - let unregistered_pkh = Account.(unregistered_account.pkh) in - let impl_contract = Contract.Implicit unregistered_pkh in - let unregistered_delegate_account = Account.new_account () in - let unregistered_delegate_pkh = Account.(unregistered_delegate_account.pkh) in - (* credit + check balance *) - Op.transaction - ~force_reveal:true - ~fee:Tez.zero - (B b) - bootstrap - impl_contract - amount - >>=? fun create_contract -> - Block.bake ~operation:create_contract b >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract amount >>=? fun () -> - (* initial credit for the delegated contract *) - let credit = of_int 10 in - credit +? amount >>?= fun balance -> - Op.transaction ~fee:Tez.zero (B b) bootstrap impl_contract credit - >>=? fun init_credit -> - Block.bake ~operation:init_credit b >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract balance >>=? fun () -> - (* try to delegate *) - Op.delegation - ~force_reveal:true - ~fee - (B b) - impl_contract - (Some unregistered_delegate_pkh) - >>=? fun delegate_op -> - Incremental.begin_construction b >>=? fun i -> - if fee > credit then expect_too_low_balance_error i delegate_op - else - (* fee has been taken, no delegate for contract *) - Incremental.add_operation - ~expect_apply_failure:(expect_unregistered_key unregistered_delegate_pkh) - i - delegate_op - >>=? fun i -> - Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract balance fee - >>=? fun () -> - Context.Contract.delegate (I i) impl_contract >>= fun err -> - Assert.error ~loc:__LOC__ err (function - | Tezos_rpc.Context.Not_found _ -> true - | _ -> false) - -(** Same as in [unregistered_delegate_key_switch_delegation] and - credits the amount [amount] to the implicit contract. *) -let test_unregistered_delegate_key_switch_delegation_credit ~fee ~amount () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let bootstrap_pkh = Context.Contract.pkh bootstrap in - let unregistered_account = Account.new_account () in - let unregistered_pkh = Account.(unregistered_account.pkh) in - let impl_contract = Contract.Implicit unregistered_pkh in - let unregistered_delegate_account = Account.new_account () in - let unregistered_delegate_pkh = Account.(unregistered_delegate_account.pkh) in - (* credit + check balance *) - Op.transaction - ~force_reveal:true - ~fee:Tez.zero - (B b) - bootstrap - impl_contract - amount - >>=? fun create_contract -> - Block.bake ~operation:create_contract b >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract amount >>=? fun () -> - (* initial credit for the delegated contract *) - let credit = of_int 10 in - credit +? amount >>?= fun balance -> - Op.transaction ~fee:Tez.zero (B b) bootstrap impl_contract credit - >>=? fun init_credit -> - Block.bake ~operation:init_credit b >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract balance >>=? fun () -> - (* set and check the initial delegate *) - Op.delegation - ~force_reveal:true - ~fee:Tez.zero - (B b) - impl_contract - (Some bootstrap_pkh) - >>=? fun delegate_op -> - Block.bake ~operation:delegate_op b >>=? fun b -> - Context.Contract.delegate (B b) bootstrap >>=? fun delegate_pkh -> - Assert.equal_pkh ~loc:__LOC__ bootstrap_pkh delegate_pkh >>=? fun () -> - (* switch delegate through delegation *) - Op.delegation ~fee (B b) impl_contract (Some unregistered_delegate_pkh) - >>=? fun delegate_op -> - Incremental.begin_construction b >>=? fun i -> - if fee > credit then expect_too_low_balance_error i delegate_op - else - (* fee has been taken, delegate for contract has not changed *) - Incremental.add_operation - ~expect_apply_failure:(expect_unregistered_key unregistered_delegate_pkh) - i - delegate_op - >>=? fun i -> - Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract balance fee - >>=? fun () -> - Context.Contract.delegate (I i) impl_contract >>=? fun delegate -> - Assert.not_equal_pkh ~loc:__LOC__ delegate unregistered_delegate_pkh - >>=? fun () -> Assert.equal_pkh ~loc:__LOC__ delegate bootstrap_pkh - -(** A credit of some amount followed by a debit of the same amount, - no self-delegation. *) -let test_unregistered_delegate_key_init_origination_credit_debit ~fee ~amount () - = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let unregistered_account = Account.new_account () in - let unregistered_pkh = Account.(unregistered_account.pkh) in - let impl_contract = Contract.Implicit unregistered_pkh in - (* credit + check balance *) - Op.transaction ~force_reveal:true (B b) bootstrap impl_contract amount - >>=? fun create_contract -> - Block.bake b ~operation:create_contract >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract amount >>=? fun () -> - (* debit + check balance *) - Op.transaction ~force_reveal:true (B b) impl_contract bootstrap amount - >>=? fun debit_contract -> - Block.bake b ~operation:debit_contract >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract Tez.zero >>=? fun () -> - (* origination with delegate argument *) - Context.Contract.balance (B b) bootstrap >>=? fun balance -> - Op.contract_origination - ~fee - ~delegate:unregistered_pkh - (B b) - bootstrap - ~script:Op.dummy_script - >>=? fun (op, orig_contract) -> - Incremental.begin_construction b >>=? fun i -> - if fee > balance then expect_too_low_balance_error i op - else - (* fee taken, origination not processed *) - Incremental.add_operation - ~expect_apply_failure:(expect_unregistered_key unregistered_pkh) - i - op - >>=? fun i -> - Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee - >>=? fun () -> - Context.Contract.balance (I i) orig_contract >>= fun err -> - Assert.error ~loc:__LOC__ err (function - | Tezos_rpc.Context.Not_found _ -> true - | _ -> false) - -(** Same as in [unregistered_delegate_key_init_delegation] but credits - then debits the amount [amount] to the implicit contract. *) -let test_unregistered_delegate_key_init_delegation_credit_debit ~amount ~fee () - = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let unregistered_account = Account.new_account () in - let unregistered_pkh = Account.(unregistered_account.pkh) in - let impl_contract = Contract.Implicit unregistered_pkh in - let unregistered_delegate_account = Account.new_account () in - let unregistered_delegate_pkh = Account.(unregistered_delegate_account.pkh) in - (* credit + check balance *) - Op.transaction - ~force_reveal:true - ~fee:Tez.zero - (B b) - bootstrap - impl_contract - amount - >>=? fun create_contract -> - Block.bake b ~operation:create_contract >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract amount >>=? fun () -> - (* debit + check balance *) - Op.transaction - ~force_reveal:true - ~fee:Tez.zero - (B b) - impl_contract - bootstrap - amount - >>=? fun debit_contract -> - Block.bake b ~operation:debit_contract >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract Tez.zero >>=? fun () -> - (* initial credit for the delegated contract *) - let credit = of_int 10 in - Op.transaction ~fee:Tez.zero (B b) bootstrap impl_contract credit - >>=? fun credit_contract -> - Block.bake b ~operation:credit_contract >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract credit >>=? fun () -> - (* try to delegate *) - Op.delegation - ~force_reveal:true - ~fee - (B b) - impl_contract - (Some unregistered_delegate_pkh) - >>=? fun delegate_op -> - Incremental.begin_construction b >>=? fun i -> - if fee > credit then expect_too_low_balance_error i delegate_op - else - (* fee has been taken, no delegate for contract *) - Incremental.add_operation - ~expect_apply_failure:(expect_unregistered_key unregistered_delegate_pkh) - i - delegate_op - >>=? fun i -> - Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee - >>=? fun () -> - Context.Contract.delegate (I i) impl_contract >>= fun err -> - Assert.error ~loc:__LOC__ err (function - | Tezos_rpc.Context.Not_found _ -> true - | _ -> false) - -(** Same as in [unregistered_delegate_key_switch_delegation] but - credits then debits the amount [amount] to the implicit contract. *) -let test_unregistered_delegate_key_switch_delegation_credit_debit ~fee ~amount - () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let bootstrap_pkh = Context.Contract.pkh bootstrap in - let unregistered_account = Account.new_account () in - let unregistered_pkh = Account.(unregistered_account.pkh) in - let impl_contract = Contract.Implicit unregistered_pkh in - let unregistered_delegate_account = Account.new_account () in - let unregistered_delegate_pkh = Account.(unregistered_delegate_account.pkh) in - (* credit + check balance *) - Op.transaction - ~force_reveal:true - ~fee:Tez.zero - (B b) - bootstrap - impl_contract - amount - >>=? fun create_contract -> - Block.bake b ~operation:create_contract >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract amount >>=? fun () -> - (* debit + check balance *) - Op.transaction ~force_reveal:true (B b) impl_contract bootstrap amount - >>=? fun debit_contract -> - Block.bake b ~operation:debit_contract >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract Tez.zero >>=? fun () -> - (* delegation - initial credit for the delegated contract *) - let credit = of_int 10 in - Op.transaction ~fee:Tez.zero (B b) bootstrap impl_contract credit - >>=? fun credit_contract -> - Block.bake b ~operation:credit_contract >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract credit >>=? fun () -> - (* set and check the initial delegate *) - Op.delegation - ~force_reveal:true - ~fee:Tez.zero - (B b) - impl_contract - (Some bootstrap_pkh) - >>=? fun delegate_op -> - Block.bake b ~operation:delegate_op >>=? fun b -> - Context.Contract.delegate (B b) bootstrap >>=? fun delegate_pkh -> - Assert.equal_pkh ~loc:__LOC__ bootstrap_pkh delegate_pkh >>=? fun () -> - (* switch delegate through delegation *) - Op.delegation (B b) ~fee impl_contract (Some unregistered_delegate_pkh) - >>=? fun delegate_op -> - Incremental.begin_construction b >>=? fun i -> - if fee > credit then expect_too_low_balance_error i delegate_op - else - (* fee has been taken, delegate for contract has not changed *) - Incremental.add_operation - ~expect_apply_failure:(expect_unregistered_key unregistered_delegate_pkh) - i - delegate_op - >>=? fun i -> - Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee - >>=? fun () -> - Context.Contract.delegate (I i) impl_contract >>=? fun delegate -> - Assert.not_equal_pkh ~loc:__LOC__ delegate unregistered_delegate_pkh - -(* Part A. Section 2. - Self-delegation to an empty contract fails. *) - -(** Self-delegation with zero-balance contract should fail. *) -let test_failed_self_delegation_no_transaction () = - Context.init1 () >>=? fun (b, _contract) -> - Incremental.begin_construction b >>=? fun i -> - let account = Account.new_account () in - let unregistered_pkh = Account.(account.pkh) in - let impl_contract = Contract.Implicit unregistered_pkh in - (* check balance *) - Context.Contract.balance (I i) impl_contract >>=? fun balance -> - Assert.equal_tez ~loc:__LOC__ Tez.zero balance >>=? fun () -> - (* self delegation fails *) - Op.delegation (I i) impl_contract (Some unregistered_pkh) - >>=? fun self_delegation -> - Incremental.add_operation i self_delegation >>= fun err -> - Assert.proto_error_with_info ~loc:__LOC__ err "Empty implicit contract" - -(** Implicit contract is credited then debited of same amount (i.e., - is emptied). Self-delegation fails. *) -let test_failed_self_delegation_emptied_implicit_contract amount () = - (* create an implicit contract *) - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let account = Account.new_account () in - let unregistered_pkh = Account.(account.pkh) in - let impl_contract = Contract.Implicit unregistered_pkh in - (* credit implicit contract and check balance *) - Op.transaction ~force_reveal:true (B b) bootstrap impl_contract amount - >>=? fun create_contract -> - Block.bake ~operation:create_contract b >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract amount >>=? fun () -> - (* empty implicit contract and check balance *) - Op.transaction ~force_reveal:true (B b) impl_contract bootstrap amount - >>=? fun create_contract -> - Block.bake ~operation:create_contract b >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract Tez.zero >>=? fun () -> - (* self delegation fails *) - Op.delegation (B b) impl_contract (Some unregistered_pkh) - >>=? fun self_delegation -> - Incremental.begin_construction b >>=? fun i -> - Incremental.add_operation i self_delegation >>= fun err -> - Assert.proto_error_with_info ~loc:__LOC__ err "Empty implicit contract" - -(** Implicit contract is credited with a non-zero quantity [amount] - tz, then it is delegated. The operation of debit of [amount] tz - should fail as the contract is already delegated. *) -let test_emptying_delegated_implicit_contract_fails amount () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - Context.Contract.manager (B b) bootstrap >>=? fun bootstrap_manager -> - let account = Account.new_account () in - let unregistered_pkh = Account.(account.pkh) in - let impl_contract = Contract.Implicit unregistered_pkh in - (* credit unregistered implicit contract and check balance *) - Op.transaction ~force_reveal:true (B b) bootstrap impl_contract amount - >>=? fun create_contract -> - Block.bake ~operation:create_contract b >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract amount >>=? fun () -> - (* delegate the contract to the bootstrap *) - Op.delegation - ~force_reveal:true - (B b) - impl_contract - (Some bootstrap_manager.pkh) - >>=? fun delegation -> - Block.bake ~operation:delegation b >>=? fun b -> - (* empty implicit contract and expect error since the contract is delegated *) - Op.transaction (B b) impl_contract bootstrap amount - >>=? fun create_contract -> - Incremental.begin_construction b >>=? fun i -> - Incremental.add_operation i create_contract >>= fun err -> - Assert.proto_error_with_info - ~loc:__LOC__ - err - "Empty implicit delegated contract" - -(* Part B. - - Valid registration: - - Credit implicit contract with some ꜩ + verification of balance - - Self delegation + verification - - Empty contract + verification of balance + verification of not being erased / self-delegation - - Create delegator implicit contract w first implicit contract as delegate + verification of delegation. *) - -(** Initialized account is credited of [amount] tz, then - self-delegated. *) -let test_valid_delegate_registration_init_delegation_credit amount () = - (* create an implicit contract *) - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let delegate_account = Account.new_account () in - let delegate_pkh = Account.(delegate_account.pkh) in - let impl_contract = Contract.Implicit delegate_pkh in - (* credit > 0ꜩ + check balance *) - Op.transaction ~force_reveal:true (B b) bootstrap impl_contract amount - >>=? fun create_contract -> - Block.bake ~operation:create_contract b >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract amount >>=? fun () -> - (* self delegation + verification *) - Op.delegation ~force_reveal:true (B b) impl_contract (Some delegate_pkh) - >>=? fun self_delegation -> - Block.bake ~operation:self_delegation b >>=? fun b -> - Context.Contract.delegate (B b) impl_contract >>=? fun delegate -> - Assert.equal_pkh ~loc:__LOC__ delegate delegate_pkh >>=? fun () -> - (* create an implicit contract with no delegate *) - let unregistered_account = Account.new_account () in - let unregistered_pkh = Account.(unregistered_account.pkh) in - let delegator = Contract.Implicit unregistered_pkh in - Op.transaction ~fee:Tez.zero (B b) bootstrap delegator Tez.one - >>=? fun credit_contract -> - Block.bake ~operation:credit_contract b >>=? fun b -> - (* check no delegate for delegator contract *) - Context.Contract.delegate (B b) delegator >>= fun err -> - Assert.error ~loc:__LOC__ err (function - | Tezos_rpc.Context.Not_found _ -> true - | _ -> false) - >>=? fun () -> - (* delegation to the newly registered key *) - Op.delegation ~force_reveal:true (B b) delegator (Some delegate_account.pkh) - >>=? fun delegation -> - Block.bake ~operation:delegation b >>=? fun b -> - (* check delegation *) - Context.Contract.delegate (B b) delegator >>=? fun delegator_delegate -> - Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh - -(** Create an implicit contract, credits with [amount] - tz. Self-delegates. Create another implicit contract with - bootstrap as delegate. Re-delegate it to the first implicit - contract. *) -let test_valid_delegate_registration_switch_delegation_credit amount () = - (* create an implicit contract *) - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let delegate_account = Account.new_account () in - let delegate_pkh = Account.(delegate_account.pkh) in - let impl_contract = Contract.Implicit delegate_pkh in - (* credit > 0ꜩ + check balance *) - Op.transaction ~force_reveal:true (B b) bootstrap impl_contract amount - >>=? fun create_contract -> - Block.bake ~operation:create_contract b >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract amount >>=? fun () -> - (* self delegation + verification *) - Op.delegation ~force_reveal:true (B b) impl_contract (Some delegate_pkh) - >>=? fun self_delegation -> - Block.bake ~operation:self_delegation b >>=? fun b -> - Context.Contract.delegate (B b) impl_contract >>=? fun delegate -> - Assert.equal_pkh ~loc:__LOC__ delegate delegate_pkh >>=? fun () -> - (* create an implicit contract with bootstrap's account as delegate *) - let unregistered_account = Account.new_account () in - let unregistered_pkh = Account.(unregistered_account.pkh) in - let delegator = Contract.Implicit unregistered_pkh in - Op.transaction ~fee:Tez.zero (B b) bootstrap delegator Tez.one - >>=? fun credit_contract -> - Block.bake ~operation:credit_contract b >>=? fun b -> - Context.Contract.manager (B b) bootstrap >>=? fun bootstrap_manager -> - Op.delegation ~force_reveal:true (B b) delegator (Some bootstrap_manager.pkh) - >>=? fun delegation -> - Block.bake ~operation:delegation b >>=? fun b -> - (* test delegate of new contract is bootstrap *) - Context.Contract.delegate (B b) delegator >>=? fun delegator_delegate -> - Assert.equal_pkh ~loc:__LOC__ delegator_delegate bootstrap_manager.pkh - >>=? fun () -> - (* delegation with newly registered key *) - Op.delegation (B b) delegator (Some delegate_account.pkh) - >>=? fun delegation -> - Block.bake ~operation:delegation b >>=? fun b -> - Context.Contract.delegate (B b) delegator >>=? fun delegator_delegate -> - Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh - -(** Create an implicit contract. *) -let test_valid_delegate_registration_init_delegation_credit_debit amount () = - (* create an implicit contract *) - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let delegate_account = Account.new_account () in - let delegate_pkh = Account.(delegate_account.pkh) in - let impl_contract = Contract.Implicit delegate_pkh in - (* credit > 0ꜩ+ check balance *) - Op.transaction ~force_reveal:true (B b) bootstrap impl_contract amount - >>=? fun create_contract -> - Block.bake ~operation:create_contract b >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract amount >>=? fun () -> - (* self delegation + verification *) - Op.delegation ~force_reveal:true (B b) impl_contract (Some delegate_pkh) - >>=? fun self_delegation -> - Block.bake ~operation:self_delegation b >>=? fun b -> - Context.Contract.delegate (B b) impl_contract >>=? fun delegate -> - Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate >>=? fun () -> - (* empty implicit contracts are usually deleted but they are kept if - they were registered as delegates. we empty the contract in - order to verify this. *) - Op.transaction (B b) impl_contract bootstrap amount >>=? fun empty_contract -> - Block.bake ~operation:empty_contract b >>=? fun b -> - (* impl_contract is empty *) - Assert.balance_is ~loc:__LOC__ (B b) impl_contract Tez.zero >>=? fun () -> - (* verify self-delegation after contract is emptied *) - Context.Contract.delegate (B b) impl_contract >>=? fun delegate -> - Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate >>=? fun () -> - (* create an implicit contract with no delegate *) - let unregistered_account = Account.new_account () in - let unregistered_pkh = Account.(unregistered_account.pkh) in - let delegator = Contract.Implicit unregistered_pkh in - Op.transaction ~fee:Tez.zero (B b) bootstrap delegator Tez.one - >>=? fun credit_contract -> - Block.bake ~operation:credit_contract b >>=? fun b -> - (* check no delegate for delegator contract *) - Context.Contract.delegate (B b) delegator >>= fun err -> - Assert.error ~loc:__LOC__ err (function - | Tezos_rpc.Context.Not_found _ -> true - | _ -> false) - >>=? fun () -> - (* delegation to the newly registered key *) - Op.delegation ~force_reveal:true (B b) delegator (Some delegate_account.pkh) - >>=? fun delegation -> - Block.bake ~operation:delegation b >>=? fun b -> - (* check delegation *) - Context.Contract.delegate (B b) delegator >>=? fun delegator_delegate -> - Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh - -(** A created implicit contract is credited with [amount] tz, then is - self-delegated. It is emptied (fund back into bootstrap), and - should remain existing (as registered as delegate). Another created - implicit contract is delegated to bootstrap, then should be able to - be re-delegated to the latter contract. *) -let test_valid_delegate_registration_switch_delegation_credit_debit amount () = - (* create an implicit contract *) - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let delegate_account = Account.new_account () in - let delegate_pkh = Account.(delegate_account.pkh) in - let impl_contract = Contract.Implicit delegate_pkh in - (* credit > 0ꜩ + check balance *) - Op.transaction ~force_reveal:true (B b) bootstrap impl_contract amount - >>=? fun create_contract -> - Block.bake ~operation:create_contract b >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract amount >>=? fun () -> - (* self delegation + verification *) - Op.delegation ~force_reveal:true (B b) impl_contract (Some delegate_pkh) - >>=? fun self_delegation -> - Block.bake ~operation:self_delegation b >>=? fun b -> - Context.Contract.delegate (B b) impl_contract >>=? fun delegate -> - Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate >>=? fun () -> - (* empty implicit contracts are usually deleted but they are kept if - they were registered as delegates. we empty the contract in - order to verify this. *) - Op.transaction (B b) impl_contract bootstrap amount >>=? fun empty_contract -> - Block.bake ~operation:empty_contract b >>=? fun b -> - (* impl_contract is empty *) - Assert.balance_is ~loc:__LOC__ (B b) impl_contract Tez.zero >>=? fun () -> - (* create an implicit contract with bootstrap's account as delegate *) - let unregistered_account = Account.new_account () in - let unregistered_pkh = Account.(unregistered_account.pkh) in - let delegator = Contract.Implicit unregistered_pkh in - Op.transaction ~fee:Tez.zero (B b) bootstrap delegator Tez.one - >>=? fun credit_contract -> - Block.bake ~operation:credit_contract b >>=? fun b -> - Context.Contract.manager (B b) bootstrap >>=? fun bootstrap_manager -> - Op.delegation ~force_reveal:true (B b) delegator (Some bootstrap_manager.pkh) - >>=? fun delegation -> - Block.bake ~operation:delegation b >>=? fun b -> - (* test delegate of new contract is bootstrap *) - Context.Contract.delegate (B b) delegator >>=? fun delegator_delegate -> - Assert.equal_pkh ~loc:__LOC__ delegator_delegate bootstrap_manager.pkh - >>=? fun () -> - (* delegation with newly registered key *) - Op.delegation ~force_reveal:true (B b) delegator (Some delegate_account.pkh) - >>=? fun delegation -> - Block.bake ~operation:delegation b >>=? fun b -> - Context.Contract.delegate (B b) delegator >>=? fun delegator_delegate -> - Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh - -(* Part C. - A second self-delegation should raise an [Active_delegate] error. *) - -(** Second self-delegation should fail with implicit contract with - some credit. *) -let test_double_registration () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let account = Account.new_account () in - let pkh = Account.(account.pkh) in - let impl_contract = Contract.Implicit pkh in - (* credit 1μꜩ+ check balance *) - Op.transaction ~force_reveal:true (B b) bootstrap impl_contract Tez.one_mutez - >>=? fun create_contract -> - Block.bake ~operation:create_contract b >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract Tez.one_mutez - >>=? fun () -> - (* self-delegation *) - Op.delegation ~force_reveal:true (B b) impl_contract (Some pkh) - >>=? fun self_delegation -> - Block.bake ~operation:self_delegation b >>=? fun b -> - (* second self-delegation *) - Op.delegation (B b) impl_contract (Some pkh) >>=? fun second_registration -> - Incremental.begin_construction b >>=? fun i -> - expect_delegate_already_active_error i second_registration - -(** Second self-delegation should fail with implicit contract emptied - after first self-delegation. *) -let test_double_registration_when_empty () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let account = Account.new_account () in - let pkh = Account.(account.pkh) in - let impl_contract = Contract.Implicit pkh in - (* credit 1μꜩ+ check balance *) - Op.transaction ~force_reveal:true (B b) bootstrap impl_contract Tez.one_mutez - >>=? fun create_contract -> - Block.bake ~operation:create_contract b >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract Tez.one_mutez - >>=? fun () -> - (* self delegation *) - Op.delegation ~force_reveal:true (B b) impl_contract (Some pkh) - >>=? fun self_delegation -> - Block.bake ~operation:self_delegation b >>=? fun b -> - (* empty the delegate account *) - Op.transaction (B b) impl_contract bootstrap Tez.one_mutez - >>=? fun empty_contract -> - Block.bake ~operation:empty_contract b >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract Tez.zero >>=? fun () -> - (* second self-delegation *) - Op.delegation (B b) impl_contract (Some pkh) >>=? fun second_registration -> - Incremental.begin_construction b >>=? fun i -> - expect_delegate_already_active_error i second_registration - -(** Second self-delegation should fail with implicit contract emptied - then credited back after first self-delegation. *) -let test_double_registration_when_recredited () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let account = Account.new_account () in - let pkh = Account.(account.pkh) in - let impl_contract = Contract.Implicit pkh in - (* credit 1μꜩ+ check balance *) - Op.transaction ~force_reveal:true (B b) bootstrap impl_contract Tez.one_mutez - >>=? fun create_contract -> - Block.bake ~operation:create_contract b >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract Tez.one_mutez - >>=? fun () -> - (* self delegation *) - Op.delegation ~force_reveal:true (B b) impl_contract (Some pkh) - >>=? fun self_delegation -> - Block.bake ~operation:self_delegation b >>=? fun b -> - (* empty the delegate account *) - Op.transaction ~force_reveal:true (B b) impl_contract bootstrap Tez.one_mutez - >>=? fun empty_contract -> - Block.bake ~operation:empty_contract b >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract Tez.zero >>=? fun () -> - (* credit 1μꜩ+ check balance *) - Op.transaction (B b) bootstrap impl_contract Tez.one_mutez - >>=? fun create_contract -> - Block.bake ~operation:create_contract b >>=? fun b -> - Assert.balance_is ~loc:__LOC__ (B b) impl_contract Tez.one_mutez - >>=? fun () -> - (* second self-delegation *) - Op.delegation (B b) impl_contract (Some pkh) >>=? fun second_registration -> - Incremental.begin_construction b >>=? fun i -> - expect_delegate_already_active_error i second_registration - -(** Self-delegation on unrevealed contract. *) -let test_unregistered_and_unrevealed_self_delegate_key_init_delegation ~fee () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let {Account.pkh; _} = Account.new_account () in - let {Account.pkh = delegate_pkh; _} = Account.new_account () in - let contract = Alpha_context.Contract.Implicit pkh in - Op.transaction ~force_reveal:true (B b) bootstrap contract (of_int 10) - >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - Op.delegation ~fee ~force_reveal:true (B b) contract (Some delegate_pkh) - >>=? fun op -> - Context.Contract.balance (B b) contract >>=? fun balance -> - Incremental.begin_construction b >>=? fun i -> - if fee > balance then expect_too_low_balance_error i op - else - (* origination did not proceed; fee has been debited *) - Incremental.add_operation - ~expect_apply_failure:(expect_unregistered_key delegate_pkh) - i - op - >>=? fun i -> - Assert.balance_was_debited ~loc:__LOC__ (I i) contract balance fee - -(** Self-delegation on revealed but not registered contract. *) -let test_unregistered_and_revealed_self_delegate_key_init_delegation ~fee () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let {Account.pkh; pk; _} = Account.new_account () in - let {Account.pkh = delegate_pkh; _} = Account.new_account () in - let contract = Alpha_context.Contract.Implicit pkh in - Op.transaction (B b) bootstrap contract (of_int 10) >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - Op.revelation (B b) pk >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - Op.delegation ~fee (B b) contract (Some delegate_pkh) >>=? fun op -> - Context.Contract.balance (B b) contract >>=? fun balance -> - Incremental.begin_construction b >>=? fun i -> - if fee > balance then expect_too_low_balance_error i op - else - (* origination did not proceed; fee has been debited *) - Incremental.add_operation - ~expect_apply_failure:(expect_unregistered_key delegate_pkh) - i - op - >>=? fun i -> - Assert.balance_was_debited ~loc:__LOC__ (I i) contract balance fee - -(** Self-delegation emptying a fresh contract. *) -let test_self_delegation_emptying_contract () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let {Account.pkh; pk; _} = Account.new_account () in - let {Account.pkh = delegate_pkh; _} = Account.new_account () in - let contract = Alpha_context.Contract.Implicit pkh in - let amount = of_int 10 in - Op.transaction (B b) bootstrap contract amount >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - Op.revelation ~fee:Tez.zero (B b) pk >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - Op.delegation ~fee:amount (B b) contract (Some delegate_pkh) >>=? fun op -> - (Context.Contract.is_manager_key_revealed (B b) contract >>=? function - | false -> failwith "contract should exist" - | true -> return_unit) - >>=? fun () -> - Incremental.begin_construction b >>=? fun i -> - (* The delegation operation should be applied and the fees - debited but it is expected to fail in the apply-part. *) - Incremental.add_operation ~expect_apply_failure:(fun _ -> return_unit) i op - >>=? fun i -> - Context.Contract.is_manager_key_revealed (I i) contract >>=? function - | false -> return_unit - | true -> failwith "contract should have been removed" - -(** Self-delegation on revealed and registered contract. *) -let test_registered_self_delegate_key_init_delegation () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let {Account.pkh; _} = Account.new_account () in - let {Account.pkh = delegate_pkh; pk = delegate_pk; _} = - Account.new_account () - in - let contract = Alpha_context.Contract.Implicit pkh in - let delegate_contract = Alpha_context.Contract.Implicit delegate_pkh in - Op.transaction ~force_reveal:true (B b) bootstrap contract (of_int 10) - >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - Op.transaction (B b) bootstrap delegate_contract (of_int 1) - >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - Op.revelation (B b) delegate_pk >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - Op.delegation (B b) delegate_contract (Some delegate_pkh) - >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - Op.delegation ~force_reveal:true (B b) contract (Some delegate_pkh) - >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - Context.Contract.delegate (B b) contract >>=? fun delegate -> - Assert.equal_pkh ~loc:__LOC__ delegate delegate_pkh >>=? fun () -> return_unit - -let test_bls_account_cannot_self_delegate () = - let open Lwt_result_syntax in - let* b, bootstrap = Context.init1 ~consensus_threshold:0 () in - let {Account.pkh = tz4_pkh; pk = tz4_pk; _} = - Account.new_account ~algo:Bls () - in - let tz4_contract = Alpha_context.Contract.Implicit tz4_pkh in - let* operation = - Op.transaction - ~force_reveal:true - (B b) - bootstrap - tz4_contract - (of_int 200_000) - in - let* b = Block.bake ~operation b in - let* operation = Op.revelation (B b) tz4_pk in - let* b = Block.bake ~operation b in - let* operation = Op.delegation (B b) tz4_contract (Some tz4_pkh) in - let* inc = Incremental.begin_construction b in - let tz4_pkh = match tz4_pkh with Bls pkh -> pkh | _ -> assert false in - let expect_failure = function - | [ - Environment.Ecoproto_error - (Contract_delegate_storage.Forbidden_tz4_delegate pkh); - ] - when Signature.Bls.Public_key_hash.(pkh = tz4_pkh) -> - return_unit - | err -> - failwith - "Error trace:@,\ - %a does not match the \ - [Contract_delegate_storage.Forbidden_tz4_delegate] error" - Error_monad.pp_print_trace - err - in - let* (_i : Incremental.t) = - Incremental.validate_operation ~expect_failure inc operation - in - return_unit - -let tests_delegate_registration = - [ - Tztest.tztest "TEST" `Quick test_bls_account_cannot_self_delegate; - (*** unregistered delegate key: no self-delegation ***) - (* no token transfer, no self-delegation *) - Tztest.tztest - "unregistered delegate key (origination, small fee)" - `Quick - (test_unregistered_delegate_key_init_origination ~fee:Tez.one_mutez); - Tztest.tztest - "unregistered delegate key (origination, edge case fee)" - `Quick - (test_unregistered_delegate_key_init_origination ~fee:(of_int 3_999_488)); - Tztest.tztest - "unregistered delegate key (origination, large fee)" - `Quick - (test_unregistered_delegate_key_init_origination ~fee:(of_int 10_000_000)); - Tztest.tztest - "unregistered delegate key (init with delegation, small fee)" - `Quick - (test_unregistered_delegate_key_init_delegation ~fee:Tez.one_mutez); - Tztest.tztest - "unregistered delegate key (init with delegation, max fee)" - `Quick - (test_unregistered_delegate_key_init_delegation ~fee:max_tez); - Tztest.tztest - "unregistered delegate key (switch with delegation, small fee)" - `Quick - (test_unregistered_delegate_key_switch_delegation ~fee:Tez.one_mutez); - Tztest.tztest - "unregistered delegate key (switch with delegation, max fee)" - `Quick - (test_unregistered_delegate_key_switch_delegation ~fee:max_tez); - (* credit/debit 1μꜩ, no self-delegation *) - Tztest.tztest - "unregistered delegate key - credit/debit 1μꜩ (origination, small fee)" - `Quick - (test_unregistered_delegate_key_init_origination_credit_debit - ~fee:Tez.one_mutez - ~amount:Tez.one_mutez); - Tztest.tztest - "unregistered delegate key - credit/debit 1μꜩ (origination, large fee)" - `Quick - (test_unregistered_delegate_key_init_origination_credit_debit - ~fee:max_tez - ~amount:Tez.one_mutez); - Tztest.tztest - "unregistered delegate key - credit/debit 1μꜩ (init with delegation, \ - small fee)" - `Quick - (test_unregistered_delegate_key_init_delegation_credit_debit - ~amount:Tez.one_mutez - ~fee:Tez.one_mutez); - Tztest.tztest - "unregistered delegate key - credit/debit 1μꜩ (init with delegation, \ - large fee)" - `Quick - (test_unregistered_delegate_key_init_delegation_credit_debit - ~amount:Tez.one_mutez - ~fee:max_tez); - Tztest.tztest - "unregistered delegate key - credit/debit 1μꜩ (switch with delegation, \ - small fee)" - `Quick - (test_unregistered_delegate_key_switch_delegation_credit_debit - ~amount:Tez.one_mutez - ~fee:Tez.one_mutez); - Tztest.tztest - "unregistered delegate key - credit/debit 1μꜩ (switch with delegation, \ - large fee)" - `Quick - (test_unregistered_delegate_key_switch_delegation_credit_debit - ~amount:Tez.one_mutez - ~fee:max_tez); - (* credit 1μꜩ, no self-delegation *) - Tztest.tztest - "unregistered delegate key - credit 1μꜩ (origination, small fee)" - `Quick - (test_unregistered_delegate_key_init_origination_credit - ~fee:Tez.one_mutez - ~amount:Tez.one_mutez); - Tztest.tztest - "unregistered delegate key - credit 1μꜩ (origination, edge case fee)" - `Quick - (test_unregistered_delegate_key_init_origination_credit - ~fee:(of_int 3_999_488) - ~amount:Tez.one_mutez); - Tztest.tztest - "unregistered delegate key - credit 1μꜩ (origination, large fee)" - `Quick - (test_unregistered_delegate_key_init_origination_credit - ~fee:(of_int 10_000_000) - ~amount:Tez.one_mutez); - Tztest.tztest - "unregistered delegate key - credit 1μꜩ (init with delegation, small fee)" - `Quick - (test_unregistered_delegate_key_init_delegation_credit - ~amount:Tez.one_mutez - ~fee:Tez.one_mutez); - Tztest.tztest - "unregistered delegate key - credit 1μꜩ (init with delegation, large fee)" - `Quick - (test_unregistered_delegate_key_init_delegation_credit - ~amount:Tez.one_mutez - ~fee:max_tez); - Tztest.tztest - "unregistered delegate key - credit 1μꜩ (switch with delegation, small \ - fee)" - `Quick - (test_unregistered_delegate_key_switch_delegation_credit - ~amount:Tez.one_mutez - ~fee:Tez.one_mutez); - Tztest.tztest - "unregistered delegate key - credit 1μꜩ (switch with delegation, large \ - fee)" - `Quick - (test_unregistered_delegate_key_switch_delegation_credit - ~amount:Tez.one_mutez - ~fee:max_tez); - (* self delegation on unrevealed and unregistered contract *) - Tztest.tztest - "unregistered and unrevealed self-delegation (small fee)" - `Quick - (test_unregistered_and_unrevealed_self_delegate_key_init_delegation - ~fee:Tez.one_mutez); - Tztest.tztest - "unregistered and unrevealed self-delegation (large fee)" - `Quick - (test_unregistered_and_unrevealed_self_delegate_key_init_delegation - ~fee:max_tez); - (* self delegation on unregistered contract *) - Tztest.tztest - "unregistered and revealed self-delegation (small fee)" - `Quick - (test_unregistered_and_revealed_self_delegate_key_init_delegation - ~fee:Tez.one_mutez); - Tztest.tztest - "unregistered and revealed self-delegation large fee)" - `Quick - (test_unregistered_and_revealed_self_delegate_key_init_delegation - ~fee:max_tez); - Tztest.tztest - "unregistered and revealed self-delegation (fee = balance)" - `Quick - test_self_delegation_emptying_contract; - (* self delegation on registered contract *) - Tztest.tztest - "registered and revealed self-delegation" - `Quick - test_registered_self_delegate_key_init_delegation; - (*** unregistered delegate key: failed self-delegation ***) - (* no token transfer, self-delegation *) - Tztest.tztest - "failed self-delegation: no transaction" - `Quick - test_failed_self_delegation_no_transaction; - (* credit 1μtz, debit 1μtz, self-delegation *) - Tztest.tztest - "failed self-delegation: credit & debit 1μꜩ" - `Quick - (test_failed_self_delegation_emptied_implicit_contract Tez.one_mutez); - (* credit 1μtz, delegate, debit 1μtz *) - Tztest.tztest - "empty delegated contract is not deleted: credit 1μꜩ, delegate & debit \ - 1μꜩ" - `Quick - (test_emptying_delegated_implicit_contract_fails Tez.one_mutez); - (*** valid registration ***) - (* valid registration: credit 1 μꜩ, self delegation *) - Tztest.tztest - "valid delegate registration: credit 1μꜩ, self delegation (init with \ - delegation)" - `Quick - (test_valid_delegate_registration_init_delegation_credit Tez.one_mutez); - Tztest.tztest - "valid delegate registration: credit 1μꜩ, self delegation (switch with \ - delegation)" - `Quick - (test_valid_delegate_registration_switch_delegation_credit Tez.one_mutez); - (* valid registration: credit 1 μꜩ, self delegation, debit 1μꜩ *) - Tztest.tztest - "valid delegate registration: credit 1μꜩ, self delegation, debit 1μꜩ \ - (init with delegation)" - `Quick - (test_valid_delegate_registration_init_delegation_credit_debit - Tez.one_mutez); - Tztest.tztest - "valid delegate registration: credit 1μꜩ, self delegation, debit 1μꜩ \ - (switch with delegation)" - `Quick - (test_valid_delegate_registration_switch_delegation_credit_debit - Tez.one_mutez); - (*** double registration ***) - Tztest.tztest "double registration" `Quick test_double_registration; - Tztest.tztest - "double registration when delegate account is emptied" - `Quick - test_double_registration_when_empty; - Tztest.tztest - "double registration when delegate account is emptied and then recredited" - `Quick - test_double_registration_when_recredited; - ] - -(******************************************************************************) -(* Main *) -(******************************************************************************) - -let tests = tests_bootstrap_contracts @ tests_delegate_registration - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("delegation", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_double_baking.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_double_baking.ml deleted file mode 100644 index ba29f86bafa3ac2d98ef7a273f703e117561d9c1..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_double_baking.ml +++ /dev/null @@ -1,466 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (double baking) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/consensus/main.exe \ - -- --file test_double_baking.ml - Subject: A double baking evidence operation may be injected when it has - been observed that a baker baked two different blocks at the - same level and same round. -*) - -open Protocol -open Alpha_context - -(****************************************************************) -(* Utility functions *) -(****************************************************************) - -(** Bake two block at the same level using the same policy (i.e. same - baker). *) -let block_fork ?policy (contract_a, contract_b) b = - Op.transaction (B b) contract_a contract_b Alpha_context.Tez.one_cent - >>=? fun operation -> - Block.bake ?policy ~operation b >>=? fun blk_a -> - Block.bake ?policy b >|=? fun blk_b -> (blk_a, blk_b) - -let order_block_hashes ~correct_order bh1 bh2 = - let hash1 = Block_header.hash bh1 in - let hash2 = Block_header.hash bh2 in - let c = Block_hash.compare hash1 hash2 in - if correct_order then if c < 0 then (bh1, bh2) else (bh2, bh1) - else if c < 0 then (bh2, bh1) - else (bh1, bh2) - -let double_baking ctxt ?(correct_order = true) bh1 bh2 = - let bh1, bh2 = order_block_hashes ~correct_order bh1 bh2 in - Op.double_baking ctxt bh1 bh2 - -(****************************************************************) -(* Tests *) -(****************************************************************) - -(** Simple scenario where two blocks are baked by a same baker and - exposed by a double baking evidence operation. *) -let test_valid_double_baking_evidence () = - Context.init2 ~consensus_threshold:0 () >>=? fun (genesis, contracts) -> - Context.get_constants (B genesis) - >>=? fun Constants.{parametric = {double_baking_punishment; _}; _} -> - Context.get_first_different_bakers (B genesis) >>=? fun (baker1, baker2) -> - block_fork ~policy:(By_account baker1) contracts genesis - >>=? fun (blk_a, blk_b) -> - double_baking (B blk_a) blk_a.header blk_b.header |> fun operation -> - Block.bake ~policy:(By_account baker2) ~operation blk_a >>=? fun blk_final -> - (* Check that the frozen deposits are slashed *) - Context.Delegate.current_frozen_deposits (B blk_a) baker1 - >>=? fun frozen_deposits_before -> - Context.Delegate.current_frozen_deposits (B blk_final) baker1 - >>=? fun frozen_deposits_after -> - let slashed_amount = - Test_tez.(frozen_deposits_before -! frozen_deposits_after) - in - Assert.equal_tez ~loc:__LOC__ slashed_amount double_baking_punishment - >>=? fun () -> - (* Check that the initial frozen deposits has not changed *) - Context.Delegate.initial_frozen_deposits (B blk_final) baker1 - >>=? fun initial_frozen_deposits -> - Assert.equal_tez ~loc:__LOC__ initial_frozen_deposits frozen_deposits_before - -(* auxiliary function used in [double_endorsement] *) -let order_endorsements ~correct_order op1 op2 = - let oph1 = Operation.hash op1 in - let oph2 = Operation.hash op2 in - let c = Operation_hash.compare oph1 oph2 in - if correct_order then if c < 0 then (op1, op2) else (op2, op1) - else if c < 0 then (op2, op1) - else (op1, op2) - -(* auxiliary function used in - [test_valid_double_baking_followed_by_double_endorsing] and - [test_valid_double_endorsing_followed_by_double_baking] *) -let double_endorsement ctxt ?(correct_order = true) op1 op2 = - let e1, e2 = order_endorsements ~correct_order op1 op2 in - Op.double_endorsement ctxt e1 e2 - -let test_valid_double_baking_followed_by_double_endorsing () = - Context.init2 ~consensus_threshold:0 () >>=? fun (genesis, contracts) -> - Context.get_first_different_bakers (B genesis) >>=? fun (baker1, baker2) -> - Block.bake genesis >>=? fun b -> - Context.Delegate.current_frozen_deposits (B b) baker1 - >>=? fun frozen_deposits_before -> - block_fork ~policy:(By_account baker1) contracts b >>=? fun (blk_a, blk_b) -> - double_baking (B blk_a) blk_a.header blk_b.header |> fun operation -> - Block.bake ~policy:(By_account baker2) ~operation blk_a - >>=? fun blk_with_db_evidence -> - Context.get_first_different_endorsers (B blk_a) >>=? fun (e1, e2) -> - let delegate = - if Signature.Public_key_hash.( = ) e1.delegate baker1 then e1.delegate - else e2.delegate - in - Op.raw_endorsement ~delegate blk_a >>=? fun endorsement_a -> - Op.raw_endorsement ~delegate blk_b >>=? fun endorsement_b -> - let operation = double_endorsement (B genesis) endorsement_a endorsement_b in - Block.bake ~policy:(By_account baker1) ~operation blk_with_db_evidence - >>=? fun blk_final -> - Context.Delegate.current_frozen_deposits (B blk_final) baker1 - >>=? fun frozen_deposits_after -> - Context.get_constants (B genesis) >>=? fun csts -> - let r = - csts.parametric.ratio_of_frozen_deposits_slashed_per_double_endorsement - in - let expected_frozen_deposits_after_de = - Test_tez.( - frozen_deposits_before - *! Int64.of_int (r.denominator - r.numerator) - /! Int64.of_int r.denominator) - in - (* the deposit after double baking and double endorsing equals the - expected deposit after double endorsing minus the double baking - punishment *) - Assert.equal_tez - ~loc:__LOC__ - Test_tez.( - expected_frozen_deposits_after_de - -! csts.parametric.double_baking_punishment) - frozen_deposits_after - -(* auxiliary function used in [test_valid_double_endorsing_followed_by_double_baking] *) -let block_fork_diff b = - Context.get_first_different_bakers (B b) >>=? fun (baker_1, baker_2) -> - Block.bake ~policy:(By_account baker_1) b >>=? fun blk_a -> - Block.bake ~policy:(By_account baker_2) b >|=? fun blk_b -> (blk_a, blk_b) - -let test_valid_double_endorsing_followed_by_double_baking () = - Context.init2 ~consensus_threshold:0 () >>=? fun (genesis, contracts) -> - Context.get_first_different_bakers (B genesis) >>=? fun (baker1, baker2) -> - block_fork_diff genesis >>=? fun (blk_1, blk_2) -> - Context.Delegate.current_frozen_deposits (B genesis) baker1 - >>=? fun frozen_deposits_before -> - Block.bake blk_1 >>=? fun blk_a -> - Block.bake blk_2 >>=? fun blk_b -> - Context.get_first_different_endorsers (B blk_a) >>=? fun (e1, e2) -> - let delegate = - if Signature.Public_key_hash.( = ) e1.delegate baker1 then e1.delegate - else e2.delegate - in - Op.raw_endorsement ~delegate blk_a >>=? fun endorsement_a -> - Op.raw_endorsement ~delegate blk_b >>=? fun endorsement_b -> - let operation = double_endorsement (B genesis) endorsement_a endorsement_b in - Block.bake ~policy:(By_account baker1) ~operation blk_a - >>=? fun blk_with_de_evidence -> - block_fork ~policy:(By_account baker1) contracts blk_1 - >>=? fun (blk_a, blk_b) -> - double_baking (B blk_a) blk_a.header blk_b.header |> fun operation -> - Block.bake ~policy:(By_account baker2) ~operation blk_with_de_evidence - >>=? fun blk_with_db_evidence -> - Context.Delegate.current_frozen_deposits (B blk_with_db_evidence) baker1 - >>=? fun frozen_deposits_after -> - Context.get_constants (B genesis) >>=? fun csts -> - let r = - csts.parametric.ratio_of_frozen_deposits_slashed_per_double_endorsement - in - let expected_frozen_deposits_after_de = - Test_tez.( - frozen_deposits_before - *! Int64.of_int (r.denominator - r.numerator) - /! Int64.of_int r.denominator) - in - (* the deposit after double baking and double endorsing equals the - expected deposit after double endorsing minus the double baking - punishment *) - Assert.equal_tez - ~loc:__LOC__ - Test_tez.( - expected_frozen_deposits_after_de - -! csts.parametric.double_baking_punishment) - frozen_deposits_after - -(** Test that the payload producer of the block containing a double - baking evidence (and not the block producer, if different) receives - the reward. *) -let test_payload_producer_gets_evidence_rewards () = - Context.init_n ~consensus_threshold:0 10 () >>=? fun (genesis, contracts) -> - Context.get_constants (B genesis) - >>=? fun Constants. - { - parametric = - {double_baking_punishment; baking_reward_fixed_portion; _}; - _; - } -> - Context.get_first_different_bakers (B genesis) >>=? fun (baker1, baker2) -> - let c1_c2 = - match contracts with c1 :: c2 :: _ -> (c1, c2) | _ -> assert false - in - block_fork ~policy:(By_account baker1) c1_c2 genesis >>=? fun (b1, b2) -> - double_baking (B b1) b1.header b2.header |> fun db_evidence -> - Block.bake ~policy:(By_account baker2) ~operation:db_evidence b1 - >>=? fun b_with_evidence -> - Context.get_endorsers (B b_with_evidence) >>=? fun endorsers -> - List.map_es - (function - | {Plugin.RPC.Validators.delegate; slots; _} -> return (delegate, slots)) - endorsers - >>=? fun preendorsers -> - List.map_ep - (fun (endorser, _slots) -> - Op.preendorsement ~delegate:endorser b_with_evidence) - preendorsers - >>=? fun preendos -> - Block.bake - ~payload_round:(Some Round.zero) - ~locked_round:(Some Round.zero) - ~policy:(By_account baker1) - ~operations:(preendos @ [db_evidence]) - b1 - >>=? fun b' -> - (* the frozen deposits of the double-signer [baker1] are slashed *) - Context.Delegate.current_frozen_deposits (B b1) baker1 - >>=? fun frozen_deposits_before -> - Context.Delegate.current_frozen_deposits (B b') baker1 - >>=? fun frozen_deposits_after -> - let slashed_amount = - Test_tez.(frozen_deposits_before -! frozen_deposits_after) - in - Assert.equal_tez ~loc:__LOC__ slashed_amount double_baking_punishment - >>=? fun () -> - (* [baker2] included the double baking evidence in [b_with_evidence] - and so it receives the reward for the evidence included in [b'] - (besides the reward for proposing the payload). *) - Context.Delegate.full_balance (B b1) baker2 >>=? fun full_balance -> - let evidence_reward = Test_tez.(slashed_amount /! 2L) in - let expected_reward = - Test_tez.(baking_reward_fixed_portion +! evidence_reward) - in - Context.Delegate.full_balance (B b') baker2 - >>=? fun full_balance_with_rewards -> - let real_reward = Test_tez.(full_balance_with_rewards -! full_balance) in - Assert.equal_tez ~loc:__LOC__ expected_reward real_reward >>=? fun () -> - (* [baker1] did not produce the payload, it does not receive the reward for the - evidence *) - Context.Delegate.full_balance (B b1) baker1 >>=? fun full_balance_at_b1 -> - Context.Delegate.full_balance (B b') baker1 >>=? fun full_balance_at_b' -> - Assert.equal_tez - ~loc:__LOC__ - full_balance_at_b' - Test_tez.(full_balance_at_b1 -! double_baking_punishment) - -(****************************************************************) -(* The following test scenarios are supposed to raise errors. *) -(****************************************************************) - -(** Check that a double baking operation fails if it exposes the same two - blocks. *) -let test_same_blocks () = - Context.init2 () >>=? fun (b, _contracts) -> - Block.bake b >>=? fun ba -> - double_baking (B ba) ba.header ba.header |> fun operation -> - Block.bake ~operation ba >>= fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Validate_errors.Anonymous.Invalid_double_baking_evidence _ -> true - | _ -> false) - -(** Check that an double baking operation that is invalid due to - incorrect ordering of the block headers fails. *) -let test_incorrect_order () = - Context.init2 ~consensus_threshold:0 () >>=? fun (genesis, contracts) -> - block_fork ~policy:(By_round 0) contracts genesis >>=? fun (blk_a, blk_b) -> - double_baking (B genesis) ~correct_order:false blk_a.header blk_b.header - |> fun operation -> - Block.bake ~operation genesis >>= fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Validate_errors.Anonymous.Invalid_double_baking_evidence _ -> true - | _ -> false) - -(** Check that a double baking operation exposing two blocks with - different levels fails. *) -let test_different_levels () = - Context.init2 ~consensus_threshold:0 () >>=? fun (b, contracts) -> - block_fork ~policy:(By_round 0) contracts b >>=? fun (blk_a, blk_b) -> - Block.bake blk_b >>=? fun blk_b_2 -> - double_baking (B blk_a) blk_a.header blk_b_2.header |> fun operation -> - Block.bake ~operation blk_a >>= fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Validate_errors.Anonymous.Invalid_double_baking_evidence _ -> true - | _ -> false) - -(** Check that a double baking operation exposing two yet-to-be-baked - blocks fails. *) -let test_too_early_double_baking_evidence () = - Context.init2 ~consensus_threshold:0 () >>=? fun (genesis, contracts) -> - Block.bake_until_cycle_end genesis >>=? fun b -> - block_fork ~policy:(By_round 0) contracts b >>=? fun (blk_a, blk_b) -> - double_baking (B b) blk_a.header blk_b.header |> fun operation -> - Block.bake ~operation genesis >>= fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Validate_errors.Anonymous.Too_early_denunciation {kind; _} - when kind = Validate_errors.Anonymous.Block -> - true - | _ -> false) - -(** Check that after [max_slashing_period * blocks_per_cycle + 1] blocks -- corresponding to 2 cycles - --, it is not possible to create a double baking operation anymore. *) -let test_too_late_double_baking_evidence () = - Context.init2 ~consensus_threshold:0 () >>=? fun (b, contracts) -> - Context.get_constants (B b) - >>=? fun Constants.{parametric = {max_slashing_period; _}; _} -> - block_fork ~policy:(By_round 0) contracts b >>=? fun (blk_a, blk_b) -> - Block.bake_until_n_cycle_end max_slashing_period blk_a >>=? fun blk -> - double_baking (B blk) blk_a.header blk_b.header |> fun operation -> - Block.bake ~operation blk >>= fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Validate_errors.Anonymous.Outdated_denunciation {kind; _} - when kind = Validate_errors.Anonymous.Block -> - true - | _ -> false) - -(** Check that before [max_slashing_period * blocks_per_cycle] blocks - -- corresponding to 2 cycles --, it is still possible to create a - double baking operation. *) -let test_just_in_time_double_baking_evidence () = - Context.init2 ~consensus_threshold:0 () >>=? fun (b, contracts) -> - Context.get_constants (B b) - >>=? fun Constants.{parametric = {blocks_per_cycle; _}; _} -> - block_fork ~policy:(By_round 0) contracts b >>=? fun (blk_a, blk_b) -> - Block.bake_until_cycle_end blk_a >>=? fun blk -> - Block.bake_n Int32.(sub blocks_per_cycle 2l |> to_int) blk >>=? fun blk -> - let operation = double_baking (B blk) blk_a.header blk_b.header in - (* We include the denunciation in the previous to last block of the - cycle. *) - Block.bake ~operation blk >>=? fun (_ : Block.t) -> return_unit - -(** Check that an invalid double baking evidence that exposes two - block baking with same level made by different bakers fails. *) -let test_different_delegates () = - Context.init2 () >>=? fun (b, _contracts) -> - Context.get_first_different_bakers (B b) >>=? fun (baker_1, baker_2) -> - Block.bake ~policy:(By_account baker_1) b >>=? fun blk_a -> - Block.bake ~policy:(By_account baker_2) b >>=? fun blk_b -> - double_baking (B blk_a) blk_a.header blk_b.header |> fun operation -> - Block.bake ~operation blk_a >>= fun e -> - Assert.proto_error ~loc:__LOC__ e (function - | Validate_errors.Anonymous.Invalid_double_baking_evidence _ -> true - | _ -> false) - -(** This test is supposed to mimic that a block cannot be baked by one baker and - signed by another. The way it tries to show this is by using a - Double_baking_evidence operation: - - say [baker_1] bakes block blk_a so blk_a has a header with baker_1's - signature - - say we create an artificial [header_b] for a block b' with timestamp [ts] - at the same level as [blk_a], and the header is created such that it says that - b' is baked by the same [baker_1] and signed by [baker_2] - - because [header_b] says that b' is baked by [baker_0], b' has the same - round as [blk_a], which together with the fact that b' and [blk_a] have the - same level, means that double_baking is valid: we have [blk_a] and b' at the - same level and round, but with different timestamps and signed by different - bakers. - This test fails with an error stating that block is signed by the wrong - baker. *) -let test_wrong_signer () = - let header_custom_signer baker baker_2 timestamp b = - Block.Forge.forge_header ~policy:(By_account baker) ~timestamp b - >>=? fun header -> - Block.Forge.set_baker baker_2 header |> Block.Forge.sign_header - in - Context.init2 () >>=? fun (b, _contracts) -> - Context.get_first_different_bakers (B b) >>=? fun (baker_1, baker_2) -> - Block.bake ~policy:(By_account baker_1) b >>=? fun blk_a -> - let ts = Timestamp.of_seconds_string (Int64.to_string 10L) in - match ts with - | None -> assert false - | Some ts -> - header_custom_signer baker_1 baker_2 ts b >>=? fun header_b -> - double_baking (B blk_a) blk_a.header header_b |> fun operation -> - Block.bake ~operation blk_a >>= fun e -> - Assert.proto_error_with_info ~loc:__LOC__ e "Invalid block signature" - -(** an evidence can only be accepted once (this also means that the - same evidence doesn't lead to slashing the offender twice) *) -let test_double_evidence () = - Context.init3 ~consensus_threshold:0 () >>=? fun (blk, (c1, c2, _c3)) -> - block_fork (c1, c2) blk >>=? fun (blk_a, blk_b) -> - Block.bake_until_cycle_end blk_a >>=? fun blk -> - double_baking (B blk) blk_a.header blk_b.header |> fun evidence -> - Block.bake ~operations:[evidence; evidence] blk >>= fun e -> - Assert.proto_error ~loc:__LOC__ e (function - | Validate_errors.Anonymous.Conflicting_denunciation {kind; _} - when kind = Validate_errors.Anonymous.Block -> - true - | _ -> false) - >>=? fun () -> - Block.bake ~operation:evidence blk >>=? fun blk -> - double_baking (B blk) blk_b.header blk_a.header |> fun evidence -> - Block.bake ~operation:evidence blk >>= fun e -> - Assert.proto_error ~loc:__LOC__ e (function - | Validate_errors.Anonymous.Already_denounced _ -> true - | _ -> false) - -let tests = - [ - Tztest.tztest - "valid double baking evidence" - `Quick - test_valid_double_baking_evidence; - Tztest.tztest - "payload producer receives the rewards for double baking evidence" - `Quick - test_payload_producer_gets_evidence_rewards; - (* Should fail*) - Tztest.tztest "same blocks" `Quick test_same_blocks; - Tztest.tztest "incorrect order" `Quick test_incorrect_order; - Tztest.tztest "different levels" `Quick test_different_levels; - Tztest.tztest - "too early double baking evidence" - `Quick - test_too_early_double_baking_evidence; - Tztest.tztest - "too late double baking evidence" - `Quick - test_too_late_double_baking_evidence; - Tztest.tztest - "just in time double baking evidence" - `Quick - test_just_in_time_double_baking_evidence; - Tztest.tztest "different delegates" `Quick test_different_delegates; - Tztest.tztest "wrong delegate" `Quick test_wrong_signer; - Tztest.tztest - "reject double injection of an evidence" - `Quick - test_double_evidence; - Tztest.tztest - "double baking followed by double endorsing" - `Quick - test_valid_double_baking_followed_by_double_endorsing; - Tztest.tztest - "double endorsing followed by double baking" - `Quick - test_valid_double_endorsing_followed_by_double_baking; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("double baking", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_double_endorsement.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_double_endorsement.ml deleted file mode 100644 index 5cd36103bb10f56ac17e4ba96c4bb995b5530099..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_double_endorsement.ml +++ /dev/null @@ -1,562 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (double endorsement) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/consensus/main.exe \ - -- --file test_double_endorsement.ml - Subject: Double endorsement evidence operation may happen when an - endorser endorsed two different blocks on the same level. -*) - -open Protocol -open Alpha_context - -(****************************************************************) -(* Utility functions *) -(****************************************************************) - -let block_fork b = - Context.get_first_different_bakers (B b) >>=? fun (baker_1, baker_2) -> - Block.bake ~policy:(By_account baker_1) b >>=? fun blk_a -> - Block.bake ~policy:(By_account baker_2) b >|=? fun blk_b -> (blk_a, blk_b) - -(****************************************************************) -(* Tests *) -(****************************************************************) - -let order_endorsements ~correct_order op1 op2 = - let oph1 = Operation.hash op1 in - let oph2 = Operation.hash op2 in - let c = Operation_hash.compare oph1 oph2 in - if correct_order then if c < 0 then (op1, op2) else (op2, op1) - else if c < 0 then (op2, op1) - else (op1, op2) - -let double_endorsement ctxt ?(correct_order = true) op1 op2 = - let e1, e2 = order_endorsements ~correct_order op1 op2 in - Op.double_endorsement ctxt e1 e2 - -let double_preendorsement ctxt ?(correct_order = true) op1 op2 = - let e1, e2 = order_endorsements ~correct_order op1 op2 in - Op.double_preendorsement ctxt e1 e2 - -(** This test verifies that when a "cheater" double endorses and - doesn't have enough tokens to re-freeze of full deposit, we only - freeze what we can (i.e. the remaining balance) but we check that - another denunciation will slash 50% of the initial (expected) amount - of the deposit. *) - -(** Simple scenario where two endorsements are made from the same - delegate and exposed by a double_endorsement operation. Also verify - that punishment is operated. *) -let test_valid_double_endorsement_evidence () = - Context.init2 ~consensus_threshold:0 () >>=? fun (genesis, _contracts) -> - block_fork genesis >>=? fun (blk_1, blk_2) -> - (* from blk_1 we bake blk_a and from blk_2 we bake blk_b so that - the same delegate endorses blk_a and blk_b and these 2 form - a valid double endorsement evidence; - - note that we cannot have double endorsement evidence - at the level of blk_1, blk_2 because both have as parent genesis - and so the endorsements are identical because the blocks blk_1, blk_2 - are identical. *) - Block.bake blk_1 >>=? fun blk_a -> - Block.bake blk_2 >>=? fun blk_b -> - Context.get_endorser (B blk_a) >>=? fun (delegate, _) -> - Op.raw_endorsement blk_a >>=? fun endorsement_a -> - Op.raw_endorsement blk_b >>=? fun endorsement_b -> - let operation = double_endorsement (B genesis) endorsement_a endorsement_b in - Context.get_bakers (B blk_a) >>=? fun bakers -> - let baker = Context.get_first_different_baker delegate bakers in - Context.Delegate.full_balance (B blk_a) baker >>=? fun full_balance -> - Block.bake ~policy:(By_account baker) ~operation blk_a >>=? fun blk_final -> - (* Check that parts of the frozen deposits are slashed *) - Context.Delegate.current_frozen_deposits (B blk_a) delegate - >>=? fun frozen_deposits_before -> - Context.Delegate.current_frozen_deposits (B blk_final) delegate - >>=? fun frozen_deposits_after -> - Context.get_constants (B genesis) >>=? fun csts -> - let r = - csts.parametric.ratio_of_frozen_deposits_slashed_per_double_endorsement - in - let expected_frozen_deposits_after = - Test_tez.( - frozen_deposits_before - *! Int64.of_int (r.denominator - r.numerator) - /! Int64.of_int r.denominator) - in - Assert.equal_tez - ~loc:__LOC__ - expected_frozen_deposits_after - frozen_deposits_after - >>=? fun () -> - (* Check that the initial frozen deposits has not changed *) - Context.Delegate.initial_frozen_deposits (B blk_final) delegate - >>=? fun initial_frozen_deposits -> - Assert.equal_tez ~loc:__LOC__ initial_frozen_deposits frozen_deposits_before - >>=? fun () -> - (* Check that [baker] is rewarded with: - - baking_reward_fixed_portion for baking and, - - half of the frozen_deposits for including the evidence *) - let baking_reward = csts.parametric.baking_reward_fixed_portion in - let evidence_reward = Test_tez.(frozen_deposits_after /! 2L) in - let expected_reward = Test_tez.(baking_reward +! evidence_reward) in - Context.Delegate.full_balance (B blk_final) baker - >>=? fun full_balance_with_rewards -> - let real_reward = Test_tez.(full_balance_with_rewards -! full_balance) in - Assert.equal_tez ~loc:__LOC__ expected_reward real_reward - -(** Check that a double (pre)endorsement evidence with equivalent - endorsements but on different branches succeeds. *) -let test_different_branch () = - Context.init2 ~consensus_threshold:0 () >>=? fun (genesis, _contracts) -> - Block.bake genesis >>=? fun blk -> - Context.get_endorser (B blk) >>=? fun (endorser, _slots) -> - Op.raw_endorsement ~delegate:endorser blk >>=? fun endorsement_a -> - Op.raw_endorsement ~branch:Block_hash.zero ~delegate:endorser blk - >>=? fun endorsement_b -> - let operation = double_endorsement (B blk) endorsement_a endorsement_b in - Block.bake ~operation blk >>=? fun _blk -> - Op.raw_preendorsement ~delegate:endorser blk >>=? fun preendorsement_a -> - Op.raw_preendorsement ~branch:Block_hash.zero ~delegate:endorser blk - >>=? fun preendorsement_b -> - let operation = - double_preendorsement (B blk) preendorsement_a preendorsement_b - in - Block.bake ~operation blk >>=? fun _blk -> return_unit - -(** Check that a double (pre)endorsement evidence succeeds when the - operations have distinct slots (that both belong to the delegate) - and are otherwise identical. *) -let test_different_slots () = - let open Lwt_result_syntax in - let* genesis, _contracts = Context.init2 ~consensus_threshold:0 () in - let* blk = Block.bake genesis in - let* endorsers = Context.get_endorsers (B blk) in - let delegate, slot1, slot2 = - (* Find an endorser with more than 1 slot. *) - WithExceptions.Option.get - ~loc:__LOC__ - (List.find_map - (fun (endorser : RPC.Validators.t) -> - match endorser.slots with - | slot1 :: slot2 :: _ -> Some (endorser.delegate, slot1, slot2) - | _ -> None) - endorsers) - in - let* endorsement1 = Op.raw_endorsement ~delegate ~slot:slot1 blk in - let* endorsement2 = Op.raw_endorsement ~delegate ~slot:slot2 blk in - let doubleA = double_endorsement (B blk) endorsement1 endorsement2 in - let* (_ : Block.t) = Block.bake ~operation:doubleA blk in - let* preendorsement1 = Op.raw_preendorsement ~delegate ~slot:slot1 blk in - let* preendorsement2 = Op.raw_preendorsement ~delegate ~slot:slot2 blk in - let doubleB = double_preendorsement (B blk) preendorsement1 preendorsement2 in - let* (_ : Block.t) = Block.bake ~operation:doubleB blk in - return_unit - -(** Say a delegate double-endorses twice and say the 2 evidences are timely - included. Then the delegate can no longer bake. *) -let test_two_double_endorsement_evidences_leadsto_no_bake () = - Context.init2 ~consensus_threshold:0 () >>=? fun (genesis, _contracts) -> - block_fork genesis >>=? fun (blk_1, blk_2) -> - Block.bake blk_1 >>=? fun blk_a -> - Block.bake blk_2 >>=? fun blk_b -> - Context.get_endorser (B blk_a) >>=? fun (delegate, _) -> - Op.raw_endorsement blk_a >>=? fun endorsement_a -> - Op.raw_endorsement blk_b >>=? fun endorsement_b -> - let operation = double_endorsement (B genesis) endorsement_a endorsement_b in - Context.get_bakers (B blk_a) >>=? fun bakers -> - let baker = Context.get_first_different_baker delegate bakers in - Context.Delegate.full_balance (B blk_a) baker - >>=? fun (_full_balance : Tez.t) -> - Block.bake ~policy:(By_account baker) ~operation blk_a - >>=? fun blk_with_evidence1 -> - block_fork blk_with_evidence1 >>=? fun (blk_30, blk_40) -> - Block.bake blk_30 >>=? fun blk_3 -> - Block.bake blk_40 >>=? fun blk_4 -> - Op.raw_endorsement blk_3 >>=? fun endorsement_3 -> - Op.raw_endorsement blk_4 >>=? fun endorsement_4 -> - let operation = - double_endorsement (B blk_with_evidence1) endorsement_3 endorsement_4 - in - Block.bake ~policy:(By_account baker) ~operation blk_3 - >>=? fun blk_with_evidence2 -> - (* Check that all the frozen deposits are slashed *) - Context.Delegate.current_frozen_deposits (B blk_with_evidence2) delegate - >>=? fun frozen_deposits_after -> - Assert.equal_tez ~loc:__LOC__ Tez.zero frozen_deposits_after >>=? fun () -> - Block.bake ~policy:(By_account delegate) blk_with_evidence2 >>= fun b -> - (* a delegate with 0 frozen deposits cannot bake *) - Assert.proto_error_with_info ~loc:__LOC__ b "Zero frozen deposits" - -(****************************************************************) -(* The following test scenarios are supposed to raise errors. *) -(****************************************************************) - -(** Check that an invalid double endorsement operation that exposes a - valid endorsement fails. *) -let test_invalid_double_endorsement () = - Context.init_n ~consensus_threshold:0 10 () >>=? fun (genesis, _contracts) -> - Block.bake genesis >>=? fun b -> - Op.raw_endorsement b >>=? fun endorsement -> - Block.bake ~operation:(Operation.pack endorsement) b >>=? fun b -> - Op.double_endorsement (B b) endorsement endorsement |> fun operation -> - Block.bake ~operation b >>= fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Validate_errors.Anonymous.Invalid_denunciation kind - when kind = Validate_errors.Anonymous.Endorsement -> - true - | _ -> false) - -(** Check that an double endorsement operation that is invalid due to - incorrect ordering of the endorsements fails. *) -let test_invalid_double_endorsement_variant () = - Context.init2 ~consensus_threshold:0 () >>=? fun (genesis, _contracts) -> - Block.bake_until_cycle_end genesis >>=? fun b -> - block_fork b >>=? fun (blk_1, blk_2) -> - Block.bake blk_1 >>=? fun blk_a -> - Block.bake blk_2 >>=? fun blk_b -> - Op.raw_endorsement blk_a >>=? fun endorsement_a -> - Op.raw_endorsement blk_b >>=? fun endorsement_b -> - double_endorsement - (B genesis) - ~correct_order:false - endorsement_a - endorsement_b - |> fun operation -> - Block.bake ~operation genesis >>= fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Validate_errors.Anonymous.Invalid_denunciation kind - when kind = Validate_errors.Anonymous.Endorsement -> - true - | _ -> false) - -(** Check that a future-cycle double endorsement fails. *) -let test_too_early_double_endorsement_evidence () = - Context.init2 ~consensus_threshold:0 () >>=? fun (genesis, _contracts) -> - Block.bake_until_cycle_end genesis >>=? fun b -> - block_fork b >>=? fun (blk_1, blk_2) -> - Block.bake blk_1 >>=? fun blk_a -> - Block.bake blk_2 >>=? fun blk_b -> - Op.raw_endorsement blk_a >>=? fun endorsement_a -> - Op.raw_endorsement blk_b >>=? fun endorsement_b -> - double_endorsement (B genesis) endorsement_a endorsement_b |> fun operation -> - Block.bake ~operation genesis >>= fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Validate_errors.Anonymous.Too_early_denunciation {kind; _} - when kind = Validate_errors.Anonymous.Endorsement -> - true - | _ -> false) - -(** Check that after [max_slashing_period * blocks_per_cycle + 1], it is not possible - to create a double_endorsement anymore. *) -let test_too_late_double_endorsement_evidence () = - Context.init2 ~consensus_threshold:0 () >>=? fun (genesis, _contracts) -> - Context.get_constants (B genesis) - >>=? fun Constants. - {parametric = {max_slashing_period; blocks_per_cycle; _}; _} -> - block_fork genesis >>=? fun (blk_1, blk_2) -> - Block.bake blk_1 >>=? fun blk_a -> - Block.bake blk_2 >>=? fun blk_b -> - Op.raw_endorsement blk_a >>=? fun endorsement_a -> - Op.raw_endorsement blk_b >>=? fun endorsement_b -> - Block.bake_n ((max_slashing_period * Int32.to_int blocks_per_cycle) + 1) blk_a - >>=? fun blk -> - double_endorsement (B blk) endorsement_a endorsement_b |> fun operation -> - Block.bake ~operation blk >>= fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Validate_errors.Anonymous.Outdated_denunciation {kind; _} - when kind = Validate_errors.Anonymous.Endorsement -> - true - | _ -> false) - -(** Check that an invalid double endorsement evidence that exposes two - endorsements made by two different endorsers fails. *) -let test_different_delegates () = - Context.init2 ~consensus_threshold:0 () >>=? fun (genesis, _contracts) -> - Block.bake genesis >>=? fun genesis -> - block_fork genesis >>=? fun (blk_1, blk_2) -> - Block.bake blk_1 >>=? fun blk_a -> - Block.bake blk_2 >>=? fun blk_b -> - Context.get_first_different_endorsers (B blk_b) - >>=? fun (endorser_a, endorser_b) -> - Op.raw_endorsement ~delegate:endorser_a.delegate blk_a >>=? fun e_a -> - Op.raw_endorsement ~delegate:endorser_b.delegate blk_b >>=? fun e_b -> - Block.bake ~operation:(Operation.pack e_b) blk_b >>=? fun (_ : Block.t) -> - double_endorsement (B blk_b) e_a e_b |> fun operation -> - Block.bake ~operation blk_b >>= fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Validate_errors.Anonymous.Inconsistent_denunciation {kind; _} - when kind = Validate_errors.Anonymous.Endorsement -> - true - | _ -> false) - -(** Check that a double endorsement evidence that exposes a ill-formed - endorsement fails. *) -let test_wrong_delegate () = - Context.init2 ~consensus_threshold:0 () >>=? fun (genesis, _contracts) -> - block_fork genesis >>=? fun (blk_1, blk_2) -> - Block.bake blk_1 >>=? fun blk_a -> - Block.bake blk_2 >>=? fun blk_b -> - Context.get_endorser (B blk_a) >>=? fun (endorser_a, _a_slots) -> - Op.raw_endorsement ~delegate:endorser_a blk_a >>=? fun endorsement_a -> - Context.get_endorser_n (B blk_b) 0 >>=? fun (endorser0, _slots0) -> - Context.get_endorser_n (B blk_b) 1 >>=? fun (endorser1, _slots1) -> - let endorser_b = - if Signature.Public_key_hash.equal endorser_a endorser0 then endorser1 - else endorser0 - in - Op.raw_endorsement ~delegate:endorser_b blk_b >>=? fun endorsement_b -> - double_endorsement (B blk_b) endorsement_a endorsement_b |> fun operation -> - Block.bake ~operation blk_b >>= fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Validate_errors.Anonymous.Inconsistent_denunciation {kind; _} - when kind = Validate_errors.Anonymous.Endorsement -> - true - | _ -> false) - -let test_freeze_more_with_low_balance = - let get_endorsing_slots_for_account ctxt account = - (* Get the slots of the given account in the given context. *) - Context.get_endorsers ctxt >>=? function - | [d1; d2] -> - return - (if Signature.Public_key_hash.equal account d1.delegate then d1 - else if Signature.Public_key_hash.equal account d2.delegate then d2 - else assert false) - .slots - | _ -> assert false - (* there are exactly two endorsers for this test. *) - in - let double_endorse_and_punish b2 account1 = - (* Bake a block on top of [b2] that includes a double-endorsement - denunciation of [account1]. *) - block_fork b2 >>=? fun (blk_d1, blk_d2) -> - Block.bake ~policy:(Block.By_account account1) blk_d1 >>=? fun blk_a -> - Block.bake ~policy:(Block.By_account account1) blk_d2 >>=? fun blk_b -> - get_endorsing_slots_for_account (B blk_a) account1 >>=? fun slots_a -> - let slot = - match List.hd slots_a with None -> assert false | Some s -> s - in - Op.raw_endorsement ~delegate:account1 ~slot blk_a >>=? fun end_a -> - get_endorsing_slots_for_account (B blk_b) account1 >>=? fun slots_b -> - let slot = - match List.hd slots_b with None -> assert false | Some s -> s - in - Op.raw_endorsement ~delegate:account1 ~slot blk_b >>=? fun end_b -> - let denunciation = double_endorsement (B b2) end_a end_b in - Block.bake ~policy:(Excluding [account1]) b2 ~operations:[denunciation] - in - let check_unique_endorser b account2 = - Context.get_endorsers (B b) >>=? function - | [{delegate; _}] when Signature.Public_key_hash.equal account2 delegate -> - return_unit - | _ -> failwith "We are supposed to only have account2 as endorser." - in - fun () -> - let constants = - { - Default_parameters.constants_test with - endorsing_reward_per_slot = Tez.zero; - baking_reward_bonus_per_slot = Tez.zero; - baking_reward_fixed_portion = Tez.zero; - consensus_threshold = 0; - origination_size = 0; - preserved_cycles = 5; - ratio_of_frozen_deposits_slashed_per_double_endorsement = - (* enforce that ratio is 50% is the test's params. *) - {numerator = 1; denominator = 2}; - } - in - Context.init_with_constants2 constants >>=? fun (genesis, (c1, c2)) -> - let account1 = Context.Contract.pkh c1 in - let account2 = Context.Contract.pkh c2 in - (* we empty the available balance of [account1]. *) - Context.Delegate.info (B genesis) account1 >>=? fun info1 -> - Op.transaction - (B genesis) - (Contract.Implicit account1) - (Contract.Implicit account2) - Test_tez.(info1.full_balance -! info1.frozen_deposits) - >>=? fun op -> - Block.bake ~policy:(Block.By_account account2) genesis ~operations:[op] - >>=? fun b2 -> - Context.Delegate.info (B b2) account1 >>=? fun info2 -> - (* after block [b2], the spendable balance of [account1] is 0tz. So, given - that we have the invariant full_balance = spendable balance + - frozen_deposits, in this particular case, full_balance = frozen_deposits - for [account1], and the frozen_deposits didn't change since genesis. *) - Assert.equal_tez ~loc:__LOC__ info2.full_balance info2.frozen_deposits - >>=? fun () -> - Assert.equal_tez ~loc:__LOC__ info1.frozen_deposits info2.frozen_deposits - >>=? fun () -> - double_endorse_and_punish b2 account1 >>=? fun b3 -> - (* Denunciation has happened: we check that the full balance of [account1] - is (still) equal to its deposit. *) - Context.Delegate.info (B b3) account1 >>=? fun info3 -> - Assert.equal_tez - ~loc:__LOC__ - info3.full_balance - info3.current_frozen_deposits - >>=? fun () -> - (* We also check that compared to deposits at block [b2], [account1] lost - 50% of its deposits. *) - let slash_ratio = - constants.ratio_of_frozen_deposits_slashed_per_double_endorsement - in - let expected_frozen_deposits_after = - Test_tez.( - info2.frozen_deposits - *! Int64.of_int (slash_ratio.denominator - slash_ratio.numerator) - /! Int64.of_int slash_ratio.denominator) - in - Assert.equal_tez - ~loc:__LOC__ - expected_frozen_deposits_after - info3.current_frozen_deposits - >>=? fun () -> - (* We now bake until end of cycle only with [account2]: - block of the new cycle are called cX below. *) - Block.bake_until_cycle_end b3 >>=? fun c1 -> - double_endorse_and_punish c1 account1 >>=? fun c2 -> - (* Second denunciation has happened: we check that the full balance of - [account1] reflects the slashing of 50% of the original deposit. Its - current deposits are thus 0tz. *) - Context.Delegate.info (B c2) account1 >>=? fun info4 -> - Assert.equal_tez ~loc:__LOC__ info4.full_balance Tez.zero >>=? fun () -> - Assert.equal_tez ~loc:__LOC__ info4.current_frozen_deposits Tez.zero - >>=? fun () -> - Block.bake c2 ~policy:(By_account account1) >>= fun c3 -> - (* Once the deposits dropped to 0, the baker cannot bake anymore *) - Assert.proto_error_with_info ~loc:__LOC__ c3 "Zero frozen deposits" - >>=? fun () -> - (* We bake [2 * preserved_cycles] additional cycles only with [account2]. - Because [account1] does not bake during this period, it loses its rights. - *) - Block.bake_until_n_cycle_end - ~policy:(By_account account2) - (2 * constants.preserved_cycles) - c2 - >>=? fun d1 -> - Context.Delegate.info (B d1) account1 >>=? fun info5 -> - (* [account1] is only deactivated after 1 + [2 * preserved_cycles] (see - [Delegate_activation_storage.set_active] since the last time it was - active, that is, since the first cycle. Thus the cycle at which - [account1] is deactivated is 2 + [2 * preserved_cycles] from genesis. *) - Assert.equal_bool ~loc:__LOC__ info5.deactivated false >>=? fun () -> - (* account1 is still active, but has no rights. *) - check_unique_endorser d1 account2 >>=? fun () -> - Block.bake_until_cycle_end ~policy:(By_account account2) d1 >>=? fun e1 -> - (* account1 has no rights and furthermore is no longer active. *) - check_unique_endorser e1 account2 >>=? fun () -> - Context.Delegate.info (B e1) account1 >>=? fun info6 -> - Assert.equal_bool ~loc:__LOC__ info6.deactivated true - -(** Injecting a valid double endorsement multiple times raises an error. *) -let test_two_double_endorsement_evidences_leads_to_duplicate_denunciation () = - Context.init2 ~consensus_threshold:0 () >>=? fun (genesis, _contracts) -> - block_fork genesis >>=? fun (blk_1, blk_2) -> - Block.bake blk_1 >>=? fun blk_a -> - Block.bake blk_2 >>=? fun blk_b -> - Context.get_endorser (B blk_a) >>=? fun (delegate, _) -> - Op.raw_endorsement blk_a >>=? fun endorsement_a -> - Op.raw_endorsement blk_b >>=? fun endorsement_b -> - let operation = double_endorsement (B genesis) endorsement_a endorsement_b in - let operation2 = double_endorsement (B genesis) endorsement_b endorsement_a in - Context.get_bakers (B blk_a) >>=? fun bakers -> - let baker = Context.get_first_different_baker delegate bakers in - Context.Delegate.full_balance (B blk_a) baker - >>=? fun (_full_balance : Tez.t) -> - Block.bake - ~policy:(By_account baker) - ~operations:[operation; operation2] - blk_a - >>= fun e -> - Assert.proto_error ~loc:__LOC__ e (function - | Validate_errors.Anonymous.Conflicting_denunciation {kind; _} - when kind = Validate_errors.Anonymous.Endorsement -> - true - | _ -> false) - >>=? fun () -> - Block.bake ~policy:(By_account baker) ~operation blk_a - >>=? fun blk_with_evidence1 -> - Block.bake ~policy:(By_account baker) ~operation blk_with_evidence1 - >>= fun e -> - Assert.proto_error ~loc:__LOC__ e (function - | Validate_errors.Anonymous.Already_denounced {kind; _} - when kind = Validate_errors.Anonymous.Endorsement -> - true - | _ -> false) - -let tests = - [ - Tztest.tztest - "valid double endorsement evidence" - `Quick - test_valid_double_endorsement_evidence; - Tztest.tztest - "valid evidence with same (pre)endorsements on different branches" - `Quick - test_different_branch; - Tztest.tztest - "valid evidence with same (pre)endorsements on different slots" - `Quick - test_different_slots; - Tztest.tztest - "2 valid double endorsement evidences lead to not being able to bake" - `Quick - test_two_double_endorsement_evidences_leadsto_no_bake; - Tztest.tztest - "valid double endorsement injected multiple time" - `Quick - test_two_double_endorsement_evidences_leads_to_duplicate_denunciation; - Tztest.tztest - "invalid double endorsement evidence" - `Quick - test_invalid_double_endorsement; - Tztest.tztest - "another invalid double endorsement evidence" - `Quick - test_invalid_double_endorsement_variant; - Tztest.tztest - "too early double endorsement evidence" - `Quick - test_too_early_double_endorsement_evidence; - Tztest.tztest - "too late double endorsement evidence" - `Quick - test_too_late_double_endorsement_evidence; - Tztest.tztest "different delegates" `Quick test_different_delegates; - Tztest.tztest "wrong delegate" `Quick test_wrong_delegate; - Tztest.tztest - "freeze available balance after slashing" - `Quick - test_freeze_more_with_low_balance; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("double endorsement", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_double_preendorsement.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_double_preendorsement.ml deleted file mode 100644 index 22eab296fbafe68ea0308267bf9f21668ce6cdf2..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_double_preendorsement.ml +++ /dev/null @@ -1,405 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (double preendorsement) in Full_construction & Application modes - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/consensus/main.exe \ - -- --file test_double_preendorsement.ml - Subject: These tests target different cases for double preendorsement *) - -open Protocol -open Alpha_context - -module type MODE = sig - val name : string - - val baking_mode : Block.baking_mode -end - -module BakeWithMode (Mode : MODE) : sig - val tests : unit Alcotest_lwt.test_case trace -end = struct - let name = Mode.name - - let bake = Block.bake ~baking_mode:Mode.baking_mode - - let bake_n = Block.bake_n ~baking_mode:Mode.baking_mode - - (****************************************************************) - (* Utility functions *) - (****************************************************************) - - (** Helper function for illformed denunciations construction *) - - let pick_endorsers ctxt = - let module V = Plugin.RPC.Validators in - Context.get_endorsers ctxt >>=? function - | a :: b :: _ -> - return ((a.V.delegate, a.V.slots), (b.V.delegate, b.V.slots)) - | _ -> assert false - - let invalid_denunciation loc res = - Assert.proto_error ~loc res (function - | Validate_errors.Anonymous.Invalid_denunciation kind - when kind = Validate_errors.Anonymous.Preendorsement -> - true - | _ -> false) - - let malformed_double_preendorsement_denunciation - ?(include_endorsement = false) ?(block_round = 0) - ?(mk_evidence = fun ctxt p1 p2 -> Op.double_preendorsement ctxt p1 p2) - ~loc () = - Context.init_n ~consensus_threshold:0 10 () - >>=? fun (genesis, _contracts) -> - bake genesis >>=? fun b1 -> - bake ~policy:(By_round 0) b1 >>=? fun b2_A -> - Op.endorsement b1 >>=? fun e -> - let operations = if include_endorsement then [e] else [] in - bake ~policy:(By_round block_round) ~operations b1 >>=? fun b2_B -> - Op.raw_preendorsement b2_A >>=? fun op1 -> - Op.raw_preendorsement b2_B >>=? fun op2 -> - let op = mk_evidence (B genesis) op1 op2 in - bake b1 ~operations:[op] >>= fun res -> invalid_denunciation loc res - - let max_slashing_period () = - Context.init1 ~consensus_threshold:0 () >>=? fun (genesis, _contract) -> - Context.get_constants (B genesis) - >>=? fun {parametric = {max_slashing_period; blocks_per_cycle; _}; _} -> - return (max_slashing_period * Int32.to_int blocks_per_cycle) - - let already_denounced loc res = - Assert.proto_error ~loc res (function - | Validate_errors.Anonymous.Already_denounced {kind; _} - when kind = Validate_errors.Anonymous.Preendorsement -> - true - | _ -> false) - - let inconsistent_denunciation loc res = - Assert.proto_error ~loc res (function - | Validate_errors.Anonymous.Inconsistent_denunciation {kind; _} - when kind = Validate_errors.Anonymous.Preendorsement -> - true - | _ -> false) - - let outdated_denunciation loc res = - Assert.proto_error ~loc res (function - | Validate_errors.Anonymous.Outdated_denunciation {kind; _} - when kind = Validate_errors.Anonymous.Preendorsement -> - true - | _ -> false) - - let unexpected_failure loc res = - (* no error is expected *) - Assert.proto_error ~loc res (function _ -> false) - - let unexpected_success loc _ _ _ _ _ = - Alcotest.fail (loc ^ ": Test should not succeed") - - let expected_success _loc baker pred bbad d1 d2 = - (* same preendorsers in case denunciation succeeds*) - Assert.equal_pkh ~loc:__LOC__ d1 d2 >>=? fun () -> - Context.get_constants (B pred) - >>=? fun Constants. - { - parametric = - { - ratio_of_frozen_deposits_slashed_per_double_endorsement = r; - _; - }; - _; - } -> - (* let's bake the block on top of pred without denunciating d1 *) - bake ~policy:(By_account baker) pred >>=? fun bgood -> - (* Checking what the endorser lost *) - Context.Delegate.current_frozen_deposits (B pred) d1 - >>=? fun frozen_deposit -> - Context.Delegate.full_balance (B bgood) d1 >>=? fun bal_good -> - Context.Delegate.full_balance (B bbad) d1 >>=? fun bal_bad -> - (* the diff of the two balances in normal and in denunciation cases *) - let diff_end_bal = Test_tez.(bal_good -! bal_bad) in - (* amount lost due to denunciation *) - let lost_deposit = - Test_tez.( - frozen_deposit *! Int64.of_int r.numerator /! Int64.of_int r.denominator) - in - (* have of the lost deposts will be earned by the baker *) - let denun_reward = Test_tez.(lost_deposit /! 2L) in - (* if the baker is the endorser, he'll only loose half of the deposits *) - let expected_endo_loss = - if Signature.Public_key_hash.equal baker d1 then - Test_tez.(lost_deposit -! denun_reward) - else lost_deposit - in - Assert.equal_tez ~loc:__LOC__ expected_endo_loss diff_end_bal >>=? fun () -> - (* Checking what the baker earned (or lost) *) - Context.Delegate.full_balance (B bgood) baker >>=? fun bal_good -> - Context.Delegate.full_balance (B bbad) baker >>=? fun bal_bad -> - (* if baker = endorser, the baker's balance in the good case is better, - because half of his deposits are burnt in the bad (double-preendorsement) - situation. In case baker <> endorser, bal_bad of the baker gets half of - burnt deposit of d1, so it's higher - *) - let high, low = - if Signature.Public_key_hash.equal baker d1 then (bal_good, bal_bad) - else (bal_bad, bal_good) - in - let diff_baker = Test_tez.(high -! low) in - (* the baker has either earnt or lost (in case baker = d1) half of burnt - endorsement deposits *) - Assert.equal_tez ~loc:__LOC__ denun_reward diff_baker >>=? fun () -> - return_unit - - let order_preendorsements ~correct_order op1 op2 = - let oph1 = Operation.hash op1 in - let oph2 = Operation.hash op2 in - let c = Operation_hash.compare oph1 oph2 in - if correct_order then if c < 0 then (op1, op2) else (op2, op1) - else if c < 0 then (op2, op1) - else (op1, op2) - - (** Helper function for denunciations inclusion *) - let generic_double_preendorsement_denunciation ~nb_blocks_before_double - ~nb_blocks_before_denunciation - ?(test_expected_ok = fun _loc _baker _pred _bbad _d1 _d2 -> return_unit) - ?(test_expected_ko = fun _loc _res -> return_unit) - ?(pick_endorsers = - fun ctxt -> pick_endorsers ctxt >>=? fun (a, _b) -> return (a, a)) ~loc - () = - Context.init_n ~consensus_threshold:0 10 () >>=? fun (genesis, contracts) -> - let addr = - match List.hd contracts with None -> assert false | Some e -> e - in - (* bake `nb_blocks_before_double blocks` before double preendorsing *) - bake_n nb_blocks_before_double genesis >>=? fun blk -> - (* producing two differents blocks and two preendorsements op1 and op2 *) - Op.transaction (B genesis) addr addr Tez.one_mutez >>=? fun trans -> - bake ~policy:(By_round 0) blk >>=? fun head_A -> - bake ~policy:(By_round 0) blk ~operations:[trans] >>=? fun head_B -> - pick_endorsers (B head_A) >>=? fun ((d1, _slots1), (d2, _slots2)) -> - (* default: d1 = d2 *) - Op.raw_preendorsement ~delegate:d1 head_A >>=? fun op1 -> - Op.raw_preendorsement ~delegate:d2 head_B >>=? fun op2 -> - let op1, op2 = order_preendorsements ~correct_order:true op1 op2 in - (* bake `nb_blocks_before_denunciation` before double preend. denunciation *) - bake_n nb_blocks_before_denunciation blk >>=? fun blk -> - let op : Operation.packed = Op.double_preendorsement (B blk) op1 op2 in - Context.get_baker (B blk) ~round:Round.zero >>=? fun baker -> - bake ~policy:(By_account baker) blk ~operations:[op] >>= function - | Ok new_head -> - test_expected_ok loc baker blk new_head d1 d2 >>=? fun () -> - let op : Operation.packed = - Op.double_preendorsement (B new_head) op2 op1 - in - bake new_head ~operations:[op] >>= invalid_denunciation loc - >>=? fun () -> - let op : Operation.packed = - Op.double_preendorsement (B new_head) op1 op2 - in - bake new_head ~operations:[op] >>= already_denounced loc - | Error _ as res -> test_expected_ko loc res - - (****************************************************************) - (* Tests *) - (****************************************************************) - - (** Preendorsing two blocks that are structurally equal is not punished *) - let malformed_double_preendorsement_denunciation_same_payload_hash_1 () = - malformed_double_preendorsement_denunciation ~loc:__LOC__ () - - (** Preendorsing two blocks that are structurally equal up to the endorsements - they include is not punished *) - let malformed_double_preendorsement_denunciation_same_payload_hash_2 () = - malformed_double_preendorsement_denunciation - (* including an endorsement in one of the blocks doesn't change its - payload hash *) - ~include_endorsement:true - ~loc:__LOC__ - () - - (** Denunciation evidence cannot have the same operations *) - let malformed_double_preendorsement_denunciation_same_preendorsement () = - malformed_double_preendorsement_denunciation - (* exactly the same preendorsement operation => illformed *) - ~mk_evidence:(fun ctxt p1 _p2 -> Op.double_preendorsement ctxt p1 p1) - ~loc:__LOC__ - () - - (** Preendorsing two blocks with different rounds is not punished *) - let malformed_double_preendorsement_denunciation_different_rounds () = - malformed_double_preendorsement_denunciation ~loc:__LOC__ ~block_round:1 () - - (** Preendorsing two blocks by two different validators is not punished *) - let malformed_double_preendorsement_denunciation_different_validators () = - generic_double_preendorsement_denunciation - ~nb_blocks_before_double:0 - ~nb_blocks_before_denunciation:2 - ~test_expected_ok:unexpected_success - ~test_expected_ko:inconsistent_denunciation - ~pick_endorsers (* pick different endorsers *) - ~loc:__LOC__ - () - - (** Attempt a denunciation of a double-pre in the first block after genesis *) - let double_preendorsement_just_after_upgrade () = - generic_double_preendorsement_denunciation - ~nb_blocks_before_double:0 - ~nb_blocks_before_denunciation:1 - ~test_expected_ok:expected_success - ~test_expected_ko:unexpected_failure - ~loc:__LOC__ - () - - (** Denunciation of double-pre at level L is injected at level L' = max_slashing_period. - The denunciation is outdated. *) - let double_preendorsement_denunciation_during_slashing_period () = - max_slashing_period () >>=? fun max_slashing_period -> - generic_double_preendorsement_denunciation - ~nb_blocks_before_double:0 - ~nb_blocks_before_denunciation:(max_slashing_period / 2) - ~test_expected_ok:expected_success - ~test_expected_ko:unexpected_failure - ~loc:__LOC__ - () - - (** Denunciation of double-pre at level L is injected 1 block after unfreeze - delay. Too late: denunciation is outdated. *) - let double_preendorsement_denunciation_after_slashing_period () = - max_slashing_period () >>=? fun max_slashing_period -> - generic_double_preendorsement_denunciation - ~nb_blocks_before_double:0 - ~nb_blocks_before_denunciation:(max_slashing_period + 1) - ~test_expected_ok:unexpected_success - ~test_expected_ko:outdated_denunciation - ~loc:__LOC__ - () - - let double_preendorsement ctxt ?(correct_order = true) op1 op2 = - let e1, e2 = order_preendorsements ~correct_order op1 op2 in - Op.double_preendorsement ctxt e1 e2 - - let block_fork b = - Context.get_first_different_bakers (B b) >>=? fun (baker_1, baker_2) -> - Block.bake ~policy:(By_account baker_1) b >>=? fun blk_a -> - Block.bake ~policy:(By_account baker_2) b >|=? fun blk_b -> (blk_a, blk_b) - - (** Injecting a valid double preendorsement multiple time raises an error. *) - let test_two_double_preendorsement_evidences_leads_to_duplicate_denunciation - () = - Context.init2 ~consensus_threshold:0 () >>=? fun (genesis, _contracts) -> - block_fork genesis >>=? fun (blk_1, blk_2) -> - Block.bake blk_1 >>=? fun blk_a -> - Block.bake blk_2 >>=? fun blk_b -> - Context.get_endorser (B blk_a) >>=? fun (delegate, _) -> - Op.raw_preendorsement blk_a >>=? fun preendorsement_a -> - Op.raw_preendorsement blk_b >>=? fun preendorsement_b -> - let operation = - double_preendorsement (B genesis) preendorsement_a preendorsement_b - in - let operation2 = - double_preendorsement (B genesis) preendorsement_b preendorsement_a - in - Context.get_bakers (B blk_a) >>=? fun bakers -> - let baker = Context.get_first_different_baker delegate bakers in - Context.Delegate.full_balance (B blk_a) baker - >>=? fun (_full_balance : Tez.t) -> - Block.bake - ~policy:(By_account baker) - ~operations:[operation; operation2] - blk_a - >>= fun e -> - Assert.proto_error ~loc:__LOC__ e (function - | Validate_errors.Anonymous.Conflicting_denunciation {kind; _} - when kind = Validate_errors.Anonymous.Preendorsement -> - true - | _ -> false) - >>=? fun () -> - Block.bake ~policy:(By_account baker) ~operation blk_a - >>=? fun blk_with_evidence1 -> - Block.bake ~policy:(By_account baker) ~operation blk_with_evidence1 - >>= fun e -> already_denounced __LOC__ e - - let my_tztest title test = - Tztest.tztest (Format.sprintf "%s: %s" name title) test - - let tests = - [ - (* illformed denunciations *) - my_tztest - "ko: malformed_double_preendorsement_denunciation_same_payload_hash_1" - `Quick - malformed_double_preendorsement_denunciation_same_payload_hash_1; - my_tztest - "ko: malformed_double_preendorsement_denunciation_same_payload_hash_2" - `Quick - malformed_double_preendorsement_denunciation_same_payload_hash_2; - my_tztest - "ko: malformed_double_preendorsement_denunciation_different_rounds" - `Quick - malformed_double_preendorsement_denunciation_different_rounds; - my_tztest - "ko: malformed_double_preendorsement_denunciation_same_preendorsement" - `Quick - malformed_double_preendorsement_denunciation_same_preendorsement; - my_tztest - "ko: malformed_double_preendorsement_denunciation_different_validators" - `Quick - malformed_double_preendorsement_denunciation_different_validators; - my_tztest - "double_preendorsement_just_after_upgrade" - `Quick - double_preendorsement_just_after_upgrade; - (* tests for unfreeze *) - my_tztest - "double_preendorsement_denunciation_during_slashing_period" - `Quick - double_preendorsement_denunciation_during_slashing_period; - my_tztest - "double_preendorsement_denunciation_after_slashing_period" - `Quick - double_preendorsement_denunciation_after_slashing_period; - my_tztest - "valid double preendorsement injected multiple times" - `Quick - test_two_double_preendorsement_evidences_leads_to_duplicate_denunciation; - ] -end - -let tests = - let module AppMode = BakeWithMode (struct - let name = "AppMode" - - let baking_mode = Block.Application - end) in - let module ConstrMode = BakeWithMode (struct - let name = "ConstrMode" - - let baking_mode = Block.Baking - end) in - AppMode.tests @ ConstrMode.tests - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("double preendorsement", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_endorsement.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_endorsement.ml deleted file mode 100644 index 4d8f4606b05dcdf5e1c3f7ef824b65f62e4f5388..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_endorsement.ml +++ /dev/null @@ -1,691 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (endorsement) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/consensus/main.exe \ - -- --file test_endorsement.ml - Subject: Endorsing a block adds an extra layer of confidence - to the Tezos' PoS algorithm. The block endorsing - operation must be included in the following block. -*) - -open Protocol -open Alpha_context - -let init_genesis ?policy () = - Context.init_n ~consensus_threshold:0 5 () >>=? fun (genesis, _contracts) -> - Block.bake ?policy genesis >>=? fun b -> return (genesis, b) - -(** {1 Positive tests} *) - -(** Correct endorsement from the slot 0 endorser. *) -let test_simple_endorsement () = - let open Lwt_result_syntax in - let* _genesis, endorsed_block = init_genesis () in - Consensus_helpers.test_consensus_operation_all_modes - ~loc:__LOC__ - ~endorsed_block - Endorsement - -(** Test that the endorsement's branch does not affect its - validity. *) -let test_arbitrary_branch () = - let open Lwt_result_syntax in - let* _genesis, endorsed_block = init_genesis () in - Consensus_helpers.test_consensus_operation_all_modes - ~loc:__LOC__ - ~endorsed_block - ~branch:Block_hash.zero - Endorsement - -(** Correct endorsement with a level and a round that are both - different from {!test_simple_endorsement}. *) -let test_non_zero_round () = - let open Lwt_result_syntax in - let* _genesis, b = init_genesis () in - let* endorsed_block = Block.bake ~policy:(By_round 10) b in - Consensus_helpers.test_consensus_operation_all_modes - ~loc:__LOC__ - ~endorsed_block - Endorsement - -(** Fitness gap: this is a straightforward update from Emmy to Tenderbake, - that is, check that the level is incremented in a child block. *) -let test_fitness_gap () = - let open Lwt_result_syntax in - let* _genesis, pred_b = init_genesis () in - let* operation = Op.endorsement pred_b in - let* b = Block.bake ~operation pred_b in - let fitness = - match Fitness.from_raw b.header.shell.fitness with - | Ok fitness -> fitness - | _ -> assert false - in - let pred_fitness = - match Fitness.from_raw pred_b.header.shell.fitness with - | Ok fitness -> fitness - | _ -> assert false - in - let level = Fitness.level fitness in - let pred_level = Fitness.level pred_fitness in - let level_diff = - Int32.sub (Raw_level.to_int32 level) (Raw_level.to_int32 pred_level) - in - Assert.equal_int32 ~loc:__LOC__ level_diff 1l - -(** Return a delegate and its second smallest slot for the level of [block]. *) -let delegate_and_second_slot block = - let open Lwt_result_syntax in - let* endorsers = Context.get_endorsers (B block) in - let delegate, slots = - (* Find an endorser with more than 1 slot. *) - WithExceptions.Option.get - ~loc:__LOC__ - (List.find_map - (fun {RPC.Validators.delegate; slots; _} -> - if Compare.List_length_with.(slots > 1) then Some (delegate, slots) - else None) - endorsers) - in - (* Check that the slots are sorted and have no duplicates. *) - let rec check_sorted = function - | [] | [_] -> true - | x :: (y :: _ as t) -> Slot.compare x y < 0 && check_sorted t - in - assert (check_sorted slots) ; - let slot = - match slots with [] | [_] -> assert false | _ :: slot :: _ -> slot - in - return (delegate, slot) - -(** Test that the mempool accepts endorsements with a non-normalized - slot (that is, a slot that belongs to the delegate but is not the - delegate's smallest slot) at all three allowed levels for - endorsements (and various rounds). *) -let test_mempool_second_slot () = - let open Lwt_result_syntax in - let* _genesis, grandparent = init_genesis () in - let* predecessor = Block.bake grandparent ~policy:(By_round 3) in - let* future_block = Block.bake predecessor ~policy:(By_round 5) in - let check_non_smallest_slot_ok loc endorsed_block = - let* delegate, slot = delegate_and_second_slot endorsed_block in - Consensus_helpers.test_consensus_operation - ~loc - ~endorsed_block - ~predecessor - ~delegate - ~slot - Endorsement - Mempool - in - let* () = check_non_smallest_slot_ok __LOC__ grandparent in - let* () = check_non_smallest_slot_ok __LOC__ predecessor in - check_non_smallest_slot_ok __LOC__ future_block - -(** {1 Negative tests} - - The following test scenarios are supposed to raise errors. *) - -(** {2 Wrong slot} *) - -(** Apply an endorsement with a negative slot. *) -let test_negative_slot () = - Context.init_n 5 () >>=? fun (genesis, _contracts) -> - Block.bake genesis >>=? fun b -> - Context.get_endorser (B b) >>=? fun (delegate, _slots) -> - Lwt.catch - (fun () -> - Op.endorsement - ~delegate - ~slot:(Slot.of_int_do_not_use_except_for_parameters (-1)) - b - >>=? fun (_ : packed_operation) -> - failwith "negative slot should not be accepted by the binary format") - (function - | Data_encoding.Binary.Write_error _ -> return_unit | e -> Lwt.reraise e) - -(** Endorsement with a non-normalized slot (that is, a slot that - belongs to the delegate but is not the delegate's smallest slot). - It should fail in application and construction modes, but be - accepted in mempool mode. *) -let test_not_smallest_slot () = - let open Lwt_result_syntax in - let* _genesis, b = init_genesis () in - let* delegate, slot = delegate_and_second_slot b in - let error_wrong_slot = function - | Validate_errors.Consensus.Wrong_slot_used_for_consensus_operation - {kind; _} - when kind = Validate_errors.Consensus.Endorsement -> - true - | _ -> false - in - Consensus_helpers.test_consensus_operation_all_modes_different_outcomes - ~loc:__LOC__ - ~endorsed_block:b - ~delegate - ~slot - ~application_error:error_wrong_slot - ~construction_error:error_wrong_slot - ?mempool_error:None - Endorsement - -let delegate_and_someone_elses_slot block = - let open Lwt_result_syntax in - let* endorsers = Context.get_endorsers (B block) in - let delegate, other_delegate_slot = - match endorsers with - | [] | [_] -> assert false (* at least two delegates with rights *) - | {delegate; _} :: {slots; _} :: _ -> - (delegate, WithExceptions.Option.get ~loc:__LOC__ (List.hd slots)) - in - return (delegate, other_delegate_slot) - -(** Endorsement with a slot that does not belong to the delegate. *) -let test_not_own_slot () = - let open Lwt_result_syntax in - let* _genesis, b = init_genesis () in - let* delegate, other_delegate_slot = delegate_and_someone_elses_slot b in - Consensus_helpers.test_consensus_operation_all_modes - ~loc:__LOC__ - ~endorsed_block:b - ~delegate - ~slot:other_delegate_slot - ~error:(function - | Alpha_context.Operation.Invalid_signature -> true | _ -> false) - Endorsement - -(** In mempool mode, also test endorsements with a slot that does not - belong to the delegate for various allowed levels and rounds. *) -let test_mempool_not_own_slot () = - let open Lwt_result_syntax in - let* _genesis, grandparent = init_genesis ~policy:(By_round 2) () in - let* predecessor = Block.bake grandparent ~policy:(By_round 1) in - let* future_block = Block.bake predecessor in - let check_not_own_slot_fails loc b = - let* delegate, other_delegate_slot = delegate_and_someone_elses_slot b in - Consensus_helpers.test_consensus_operation - ~loc - ~endorsed_block:b - ~delegate - ~slot:other_delegate_slot - ~error:(function - | Alpha_context.Operation.Invalid_signature -> true | _ -> false) - Endorsement - Mempool - in - let* () = check_not_own_slot_fails __LOC__ grandparent in - let* () = check_not_own_slot_fails __LOC__ predecessor in - check_not_own_slot_fails __LOC__ future_block - -(** {2 Wrong level} *) - -let error_old_level = function - | Validate_errors.Consensus.Consensus_operation_for_old_level {kind; _} - when kind = Validate_errors.Consensus.Endorsement -> - true - | _ -> false - -(** Endorsement that is one level too old, aka grandparent endorsement - (the endorsement is expected to point to the level of the - predecessor of the block/mempool containing the endorsement, but - instead it points to the grandparent's level). - - This endorsement should fail in a block (application or - construction), but be accepted in mempool mode. *) -let test_one_level_too_old () = - let open Lwt_result_syntax in - let* _genesis, grandparent = init_genesis () in - let* predecessor = Block.bake grandparent in - Consensus_helpers.test_consensus_operation_all_modes_different_outcomes - ~loc:__LOC__ - ~endorsed_block:grandparent - ~predecessor - ~application_error:error_old_level - ~construction_error:error_old_level - ?mempool_error:None - Endorsement - -(** Endorsement that is two levels too old (pointing to the - great-grandparent instead of the predecessor). It should fail in - all modes. *) -let test_two_levels_too_old () = - let open Lwt_result_syntax in - let* _genesis, greatgrandparent = init_genesis () in - let* grandparent = Block.bake greatgrandparent in - let* predecessor = Block.bake grandparent in - Consensus_helpers.test_consensus_operation_all_modes - ~loc:__LOC__ - ~endorsed_block:greatgrandparent - ~predecessor - ~error:error_old_level - Endorsement - -let error_future_level = function - | Validate_errors.Consensus.Consensus_operation_for_future_level {kind; _} - when kind = Validate_errors.Consensus.Endorsement -> - true - | _ -> false - -(** Endorsement that is one level in the future (pointing to the same - level as the block/mempool containing the endorsement instead of - its predecessor/head). It should fail in a block (application or - construction) but succeed in a mempool. *) -let test_one_level_in_the_future () = - let open Lwt_result_syntax in - let* _genesis, predecessor = init_genesis () in - let* next_level_block = Block.bake predecessor in - Consensus_helpers.test_consensus_operation_all_modes_different_outcomes - ~loc:__LOC__ - ~endorsed_block:next_level_block - ~predecessor - ~application_error:error_future_level - ~construction_error:error_future_level - ?mempool_error:None - Endorsement - -(** Endorsement that is two levels in the future. It should fail in - all modes. *) -let test_two_levels_future () = - let open Lwt_result_syntax in - let* _genesis, predecessor = init_genesis () in - let* next_level_block = Block.bake predecessor in - let* after_next_level_block = Block.bake next_level_block in - Consensus_helpers.test_consensus_operation_all_modes - ~loc:__LOC__ - ~endorsed_block:after_next_level_block - ~predecessor - ~error:error_future_level - Endorsement - -(** {2 Wrong round} *) - -let error_old_round = function - | Validate_errors.Consensus.Consensus_operation_for_old_round {kind; _} - when kind = Validate_errors.Consensus.Endorsement -> - true - | _ -> false - -(** Endorsement that is one round too old. It should fail in a block - (application or construction) but succeed in a mempool. *) -let test_one_round_too_old () = - let open Lwt_result_syntax in - let* _genesis, b = init_genesis () in - let* round0_block = Block.bake b in - let* predecessor = Block.bake ~policy:(By_round 1) b in - Consensus_helpers.test_consensus_operation_all_modes_different_outcomes - ~loc:__LOC__ - ~endorsed_block:round0_block - ~predecessor - ~application_error:error_old_round - ~construction_error:error_old_round - ?mempool_error:None - Endorsement - -(** Endorsement that is many rounds too old. It should fail in a block - (application or construction) but succeed in a mempool. *) -let test_many_rounds_too_old () = - let open Lwt_result_syntax in - let* _genesis, b = init_genesis () in - let* round5_block = Block.bake ~policy:(By_round 5) b in - let* predecessor = Block.bake ~policy:(By_round 15) b in - Consensus_helpers.test_consensus_operation_all_modes_different_outcomes - ~loc:__LOC__ - ~endorsed_block:round5_block - ~predecessor - ~application_error:error_old_round - ~construction_error:error_old_round - ?mempool_error:None - Endorsement - -let error_future_round = function - | Validate_errors.Consensus.Consensus_operation_for_future_round {kind; _} - when kind = Validate_errors.Consensus.Endorsement -> - true - | _ -> false - -(** Endorsement that is one round in the future. It should fail in a - block (application or construction) but succeed in a mempool. *) -let test_one_round_in_the_future () = - let open Lwt_result_syntax in - let* _genesis, b = init_genesis () in - let* predecessor = Block.bake b in - let* round1_block = Block.bake ~policy:(By_round 1) b in - Consensus_helpers.test_consensus_operation_all_modes_different_outcomes - ~loc:__LOC__ - ~endorsed_block:round1_block - ~predecessor - ~application_error:error_future_round - ~construction_error:error_future_round - ?mempool_error:None - Endorsement - -(** Endorsement that is many rounds in the future. It should fail in a - block (application or construction) but succeed in a mempool. *) -let test_many_rounds_future () = - let open Lwt_result_syntax in - let* _genesis, b = init_genesis () in - let* predecessor = Block.bake ~policy:(By_round 5) b in - let* round15_block = Block.bake ~policy:(By_round 15) b in - Consensus_helpers.test_consensus_operation_all_modes_different_outcomes - ~loc:__LOC__ - ~endorsed_block:round15_block - ~predecessor - ~application_error:error_future_round - ~construction_error:error_future_round - ?mempool_error:None - Endorsement - -(** {2 Wrong payload hash} *) - -(** Endorsement with an incorrect payload hash. It should fail in a - block (application or construction) but succeed in a mempool. *) -let test_wrong_payload_hash () = - let open Lwt_result_syntax in - let* _genesis, endorsed_block = init_genesis () in - let error_wrong_payload_hash = function - | Validate_errors.Consensus.Wrong_payload_hash_for_consensus_operation - {kind; _} - when kind = Validate_errors.Consensus.Endorsement -> - true - | _ -> false - in - Consensus_helpers.test_consensus_operation_all_modes_different_outcomes - ~loc:__LOC__ - ~endorsed_block - ~block_payload_hash:Block_payload_hash.zero - ~application_error:error_wrong_payload_hash - ~construction_error:error_wrong_payload_hash - ?mempool_error:None - Endorsement - -(** {1 Conflict tests} - - Some positive and some negative tests. *) - -let assert_conflict_error ~loc res = - Assert.proto_error ~loc res (function - | Validate_errors.Consensus.Conflicting_consensus_operation {kind; _} - when kind = Validate_errors.Consensus.Endorsement -> - true - | _ -> false) - -(** Test that endorsements conflict with: - - an identical endorsement, and - - an endorsement on the same block with a different branch. - - In mempool mode, also test that they conflict with an endorsement - on the same level and round but with a different payload hash - (such an endorsement is invalid in application and construction modes). *) -let test_conflict () = - let open Lwt_result_syntax in - let* _genesis, b = init_genesis () in - let* op = Op.endorsement b in - let* op_different_branch = Op.endorsement ~branch:Block_hash.zero b in - (* Test in application and construction (aka baking) modes *) - let assert_conflict loc baking_mode tested_op = - Block.bake ~baking_mode ~operations:[op; tested_op] b - >>= assert_conflict_error ~loc - in - let* () = assert_conflict __LOC__ Application op in - let* () = assert_conflict __LOC__ Application op_different_branch in - let* () = assert_conflict __LOC__ Baking op in - let* () = assert_conflict __LOC__ Baking op_different_branch in - (* Test in mempool mode. *) - let* inc = Incremental.begin_construction ~mempool_mode:true b in - let* inc = Incremental.validate_operation inc op in - let assert_mempool_conflict loc tested_op = - Incremental.validate_operation inc tested_op >>= assert_conflict_error ~loc - in - let* () = assert_mempool_conflict __LOC__ op in - let* () = assert_mempool_conflict __LOC__ op_different_branch in - let* op_different_payload_hash = - Op.endorsement ~block_payload_hash:Block_payload_hash.zero b - in - let* () = assert_mempool_conflict __LOC__ op_different_payload_hash in - return_unit - -(** In mempool mode, test that grandparent endorsements conflict with: - - an identical endorsement, - - an endorsement on the same block with a different branch, and - - an endorsement on the same block with a different payload hash. - - This test would make no sense in application or construction modes, - since grandparent endorsements fail anyway (as can be observed in - {!test_one_level_too_old}). *) -let test_grandparent_conflict () = - let open Lwt_result_syntax in - let* _genesis, grandparent = init_genesis () in - let* predecessor = Block.bake grandparent in - let* op = Op.endorsement grandparent in - let* op_different_branch = - Op.endorsement ~branch:Block_hash.zero grandparent - in - let* op_different_payload_hash = - Op.endorsement ~block_payload_hash:Block_payload_hash.zero grandparent - in - let* inc = Incremental.begin_construction ~mempool_mode:true predecessor in - let* inc = Incremental.validate_operation inc op in - let assert_conflict loc tested_op = - Incremental.validate_operation inc tested_op >>= assert_conflict_error ~loc - in - let* () = assert_conflict __LOC__ op in - let* () = assert_conflict __LOC__ op_different_branch in - let* () = assert_conflict __LOC__ op_different_payload_hash in - return_unit - -(** In mempool mode, test that endorsements with the same future level - and same non-zero round conflict. This is not tested in application - and construction modes since such endorsements would be invalid. *) -let test_future_level_conflict () = - let open Lwt_result_syntax in - let* _genesis, predecessor = init_genesis () in - let* future_block = Block.bake ~policy:(By_round 10) predecessor in - let* op = Op.endorsement future_block in - let* op_different_branch = - Op.endorsement ~branch:Block_hash.zero future_block - in - let* op_different_payload_hash = - Op.endorsement ~block_payload_hash:Block_payload_hash.zero future_block - in - let* inc = Incremental.begin_construction ~mempool_mode:true predecessor in - let* inc = Incremental.validate_operation inc op in - let assert_conflict loc tested_op = - Incremental.validate_operation inc tested_op >>= assert_conflict_error ~loc - in - let* () = assert_conflict __LOC__ op in - let* () = assert_conflict __LOC__ op_different_branch in - let* () = assert_conflict __LOC__ op_different_payload_hash in - return_unit - -(** In mempool mode, test that there is no conflict between an - endorsement and a preendorsement for the same slot (here the first - slot), same level, and same round. *) -let test_no_conflict_with_preendorsement_mempool () = - let open Lwt_result_syntax in - let* _genesis, endorsed_block = init_genesis () in - let* op_endo = Op.endorsement endorsed_block in - let* op_preendo = Op.preendorsement endorsed_block in - let* inc = Incremental.begin_construction ~mempool_mode:true endorsed_block in - let* inc = Incremental.add_operation inc op_endo in - let* inc = Incremental.add_operation inc op_preendo in - let* _inc = Incremental.finalize_block inc in - return_unit - -(** In application and construction (aka baking) modes, test that - there is no conflict between an endorsement and a preendorsement - for the same slot (here the first slot). Note that the operations - don't have the same level because the required levels for them to - be valid are different. *) -let test_no_conflict_with_preendorsement_block () = - let open Lwt_result_syntax in - let* _genesis, predecessor = init_genesis () in - let* round0_block = Block.bake predecessor in - let* op_endo = Op.endorsement predecessor in - let* op_preendo = Op.preendorsement round0_block in - let bake_both_ops baking_mode = - Block.bake - ~baking_mode - ~payload_round:(Some Round.zero) - ~locked_round:(Some Round.zero) - ~policy:(By_round 1) - ~operations:[op_endo; op_preendo] - predecessor - in - let* (_ : Block.t) = bake_both_ops Application in - let* (_ : Block.t) = bake_both_ops Baking in - return_unit - -(** In mempool mode, test that there is no conflict between - endorsements for the same slot (here the first slot) with various - allowed levels and rounds. - - There are no similar tests in application and construction modes - because valid endorsements always have the same level and round. *) -let test_no_conflict_various_levels_and_rounds () = - let open Lwt_result_syntax in - let* genesis, grandparent = init_genesis () in - let* predecessor = Block.bake grandparent in - let* future_block = Block.bake predecessor in - let* alt_grandparent = Block.bake ~policy:(By_round 1) genesis in - let* alt_predecessor = Block.bake ~policy:(By_round 1) grandparent in - let* alt_future = Block.bake ~policy:(By_round 10) alt_predecessor in - let* inc = Incremental.begin_construction ~mempool_mode:true predecessor in - let add_endorsement inc endorsed_block = - let* (op : packed_operation) = Op.endorsement endorsed_block in - let (Operation_data protocol_data) = op.protocol_data in - let content = - match protocol_data.contents with - | Single (Endorsement content) -> content - | _ -> assert false - in - Format.eprintf - "level: %ld, round: %ld@." - (Raw_level.to_int32 content.level) - (Round.to_int32 content.round) ; - Incremental.add_operation inc op - in - let* inc = add_endorsement inc grandparent in - let* inc = add_endorsement inc predecessor in - let* inc = add_endorsement inc future_block in - let* inc = add_endorsement inc alt_grandparent in - let* inc = add_endorsement inc alt_predecessor in - let* inc = add_endorsement inc alt_future in - let* _inc = Incremental.finalize_block inc in - return_unit - -(** {1 Consensus threshold tests} - - Both positive and negative tests. *) - -(** Check that: - - a block with not enough endorsement cannot be baked; - - a block with enough endorsement is baked. *) -let test_endorsement_threshold ~sufficient_threshold () = - (* We choose a relative large number of accounts so that the probability that - any delegate has [consensus_threshold] slots is low and most delegates have - about 1 slot so we can get closer to the limit of [consensus_threshold]: we - check that a block with endorsing power [consensus_threshold - 1] won't be - baked. *) - Context.init_n 10 () >>=? fun (genesis, _contracts) -> - Block.bake genesis >>=? fun b -> - Context.get_constants (B b) - >>=? fun {parametric = {consensus_threshold; _}; _} -> - Context.get_endorsers (B b) >>=? fun endorsers_list -> - Block.get_round b >>?= fun round -> - List.fold_left_es - (fun (counter, endos) {Plugin.RPC.Validators.delegate; slots; _} -> - let new_counter = counter + List.length slots in - if - (sufficient_threshold && counter < consensus_threshold) - || ((not sufficient_threshold) && new_counter < consensus_threshold) - then - Op.endorsement ~round ~delegate b >>=? fun endo -> - return (new_counter, endo :: endos) - else return (counter, endos)) - (0, []) - endorsers_list - >>=? fun (_, endos) -> - Block.bake ~operations:endos b >>= fun b -> - if sufficient_threshold then return_unit - else Assert.proto_error_with_info ~loc:__LOC__ b "Not enough endorsements" - -let tests = - [ - (* Positive tests *) - Tztest.tztest "Simple endorsement" `Quick test_simple_endorsement; - Tztest.tztest "Arbitrary branch" `Quick test_arbitrary_branch; - Tztest.tztest "Non-zero round" `Quick test_non_zero_round; - Tztest.tztest "Fitness gap" `Quick test_fitness_gap; - Tztest.tztest "Mempool: non-smallest slot" `Quick test_mempool_second_slot; - (* Negative tests *) - (* Wrong slot *) - Tztest.tztest "Endorsement with slot -1" `Quick test_negative_slot; - Tztest.tztest "Non-normalized slot" `Quick test_not_smallest_slot; - Tztest.tztest "Not own slot" `Quick test_not_own_slot; - Tztest.tztest "Mempool: not own slot" `Quick test_mempool_not_own_slot; - (* Wrong level *) - Tztest.tztest "One level too old" `Quick test_one_level_too_old; - Tztest.tztest "Two levels too old" `Quick test_two_levels_too_old; - Tztest.tztest "One level in the future" `Quick test_one_level_in_the_future; - Tztest.tztest "Two levels in the future" `Quick test_two_levels_future; - (* Wrong round *) - Tztest.tztest "One round too old" `Quick test_one_round_too_old; - Tztest.tztest "Many rounds too old" `Quick test_many_rounds_too_old; - Tztest.tztest "One round in the future" `Quick test_one_round_in_the_future; - Tztest.tztest "Many rounds in the future" `Quick test_many_rounds_future; - (* Wrong payload hash *) - Tztest.tztest "Wrong payload hash" `Quick test_wrong_payload_hash; - (* Conflict tests (some negative, some positive) *) - Tztest.tztest "Conflict" `Quick test_conflict; - Tztest.tztest "Grandparent conflict" `Quick test_grandparent_conflict; - Tztest.tztest "Future level conflict" `Quick test_future_level_conflict; - Tztest.tztest - "No conflict with preendorsement (mempool)" - `Quick - test_no_conflict_with_preendorsement_mempool; - Tztest.tztest - "No conflict with preendorsement (block)" - `Quick - test_no_conflict_with_preendorsement_block; - Tztest.tztest - "No conflict with various levels and rounds" - `Quick - test_no_conflict_various_levels_and_rounds; - (* Consensus threshold tests (one positive and one negative) *) - Tztest.tztest - "sufficient endorsement threshold" - `Quick - (test_endorsement_threshold ~sufficient_threshold:true); - Tztest.tztest - "insufficient endorsement threshold" - `Quick - (test_endorsement_threshold ~sufficient_threshold:false); - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("endorsement", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_frozen_deposits.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_frozen_deposits.ml deleted file mode 100644 index 7763c95d8b762b5e9fa561b9770fdf2ed6a9029b..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_frozen_deposits.ml +++ /dev/null @@ -1,691 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (frozen_deposits) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/consensus/main.exe \ - -- --file test_frozen_deposits.ml - Subject: consistency of frozen deposits and the [set_deposits_limit] operation - *) - -open Protocol -open Alpha_context -open Test_tez - -let constants = - { - Default_parameters.constants_test with - endorsing_reward_per_slot = Tez.zero; - baking_reward_bonus_per_slot = Tez.zero; - baking_reward_fixed_portion = Tez.zero; - consensus_threshold = 0; - origination_size = 0; - } - -let get_first_2_accounts_contracts (a1, a2) = - ((a1, Context.Contract.pkh a1), (a2, Context.Contract.pkh a2)) - -(* Terminology: - - - staking balance = full balance + delegated stake; obtained with - Delegate.staking_balance - - - active stake = the amount of tez with which a delegate participates in - consensus; it must be greater than [minimal_stake] and less or equal the staking - balance; it is computed in [Delegate_sampler.select_distribution_for_cycle] - - - frozen deposits = represents frozen_deposits_percentage of the maximum stake during - preserved_cycles + max_slashing_period cycles; obtained with - Delegate.current_frozen_deposits - - - spendable balance = full balance - frozen deposits; obtained with Contract.balance - - - full balance = spendable balance + frozen deposits; obtained with Delegate.full_balance -*) -let test_invariants () = - Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let (contract1, account1), (contract2, _account2) = - get_first_2_accounts_contracts contracts - in - Context.Delegate.staking_balance (B genesis) account1 - >>=? fun staking_balance -> - Context.Delegate.full_balance (B genesis) account1 >>=? fun full_balance -> - Context.Contract.balance (B genesis) contract1 >>=? fun spendable_balance -> - Context.Delegate.current_frozen_deposits (B genesis) account1 - >>=? fun frozen_deposits -> - (* before delegation *) - Assert.equal_tez ~loc:__LOC__ full_balance staking_balance >>=? fun () -> - Assert.equal_tez - ~loc:__LOC__ - full_balance - Test_tez.(spendable_balance +! frozen_deposits) - >>=? fun () -> - (* to see how delegation plays a role, let's delegate to account1; - N.B. account2 represents a delegate so it cannot delegate to account1; this is - why we go through new_account as an intermediate *) - Context.Contract.balance (B genesis) contract2 >>=? fun spendable_balance2 -> - let new_account = (Account.new_account ()).pkh in - let new_contract = Contract.Implicit new_account in - (* we first put some money in new_account *) - Op.transaction - ~force_reveal:true - (B genesis) - contract2 - new_contract - spendable_balance2 - >>=? fun transfer -> - Block.bake ~operation:transfer genesis >>=? fun b -> - Context.Contract.balance (B b) new_contract >>=? fun new_account_balance -> - Assert.equal_tez ~loc:__LOC__ new_account_balance spendable_balance2 - >>=? fun () -> - Op.delegation ~force_reveal:true (B b) new_contract (Some account1) - >>=? fun delegation -> - Block.bake ~operation:delegation b >>=? fun b1 -> - Block.bake_until_n_cycle_end constants.preserved_cycles b1 >>=? fun b2 -> - Context.Delegate.staking_balance (B b2) account1 - >>=? fun new_staking_balance -> - Context.Delegate.full_balance (B b2) account1 >>=? fun new_full_balance -> - Context.Contract.balance (B b2) contract1 >>=? fun new_spendable_balance -> - Context.Delegate.current_frozen_deposits (B b2) account1 - >>=? fun new_frozen_deposits -> - (* after delegation, we see the delegated stake reflected in the new staking - balance of account1 *) - Assert.equal_tez - ~loc:__LOC__ - new_staking_balance - Test_tez.(new_full_balance +! new_account_balance) - >>=? fun () -> - Assert.equal_tez - ~loc:__LOC__ - new_full_balance - Test_tez.(new_spendable_balance +! new_frozen_deposits) - >>=? fun () -> - let expected_new_frozen_deposits = - Test_tez.( - (* in this particular example, if we follow the calculation of the active - stake, it is precisely the new_staking_balance *) - new_staking_balance /! 100L - *! Int64.of_int constants.frozen_deposits_percentage) - in - Assert.equal_tez ~loc:__LOC__ new_frozen_deposits expected_new_frozen_deposits - -let test_set_limit balance_percentage () = - Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let (contract1, account1), (_contract2, account2) = - get_first_2_accounts_contracts contracts - in - (Context.Delegate.frozen_deposits_limit (B genesis) account1 >>=? function - | Some _ -> Alcotest.fail "unexpected deposits limit" - | None -> return_unit) - >>=? fun () -> - (* Test deposit consistency before and after first cycle *) - Context.Delegate.full_balance (B genesis) account1 >>=? fun full_balance -> - Context.Delegate.current_frozen_deposits (B genesis) account1 - >>=? fun frozen_deposits -> - let expected_deposits = - full_balance *! Int64.of_int constants.frozen_deposits_percentage /! 100L - in - Assert.equal_tez ~loc:__LOC__ frozen_deposits expected_deposits >>=? fun () -> - (* Bake until end of first cycle *) - Block.bake_until_cycle_end genesis >>=? fun b -> - Context.Delegate.full_balance (B genesis) account1 >>=? fun full_balance -> - Context.Delegate.current_frozen_deposits (B genesis) account1 - >>=? fun frozen_deposits -> - let expected_deposits = - full_balance *! Int64.of_int constants.frozen_deposits_percentage /! 100L - in - Assert.equal_tez ~loc:__LOC__ frozen_deposits expected_deposits >>=? fun () -> - (* set deposits limit to balance_percentage out of the balance *) - let limit = - Test_tez.(full_balance *! Int64.of_int balance_percentage /! 100L) - in - Op.set_deposits_limit (B genesis) contract1 (Some limit) >>=? fun operation -> - Block.bake ~policy:(By_account account2) ~operation b >>=? fun b -> - (Context.Delegate.frozen_deposits_limit (B b) account1 >>=? function - | Some set_limit -> Assert.equal_tez ~loc:__LOC__ set_limit limit - | None -> Alcotest.fail "unexpected absence of deposits limit") - >>=? fun () -> - (* the frozen deposits limit affects the active stake for cycles starting with c + - preserved_cycles + 1; the new active stake is taken into account when - computing the frozen deposits for cycle c+1 already, however the user may see - an update to its frozen deposits at cycle c + preserved_cycles + - max_slashing_period at the latest (because up to that cycle the frozen - deposits also depend on the active stake at cycles before cycle c+1). *) - let expected_number_of_cycles_with_previous_deposit = - constants.preserved_cycles + constants.max_slashing_period - in - Block.bake_until_n_cycle_end - ~policy:(By_account account2) - (expected_number_of_cycles_with_previous_deposit - 1) - b - >>=? fun b -> - Context.Delegate.current_frozen_deposits (B b) account1 - >>=? fun frozen_deposits -> - Assert.not_equal_tez ~loc:__LOC__ frozen_deposits Tez.zero >>=? fun () -> - Block.bake_until_cycle_end ~policy:(By_account account2) b >>=? fun b -> - Context.Delegate.current_frozen_deposits (B b) account1 - >>=? fun frozen_deposits -> - Assert.equal_tez ~loc:__LOC__ frozen_deposits limit - -let test_unset_limit () = - Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let (contract1, account1), (_contract2, account2) = - get_first_2_accounts_contracts contracts - in - Context.Delegate.current_frozen_deposits (B genesis) account1 - >>=? fun frozen_deposits_at_genesis -> - (* set the limit to 0 *) - Op.set_deposits_limit (B genesis) contract1 (Some Tez.zero) - >>=? fun operation -> - Block.bake ~policy:(By_account account2) ~operation genesis >>=? fun b -> - (Context.Delegate.frozen_deposits_limit (B b) account1 >>=? function - | Some set_limit -> Assert.equal_tez ~loc:__LOC__ set_limit Tez.zero - | None -> Alcotest.fail "unexpected absence of deposits limit") - >>=? fun () -> - let expected_number_of_cycles_with_previous_deposit = - constants.preserved_cycles + constants.max_slashing_period - in - Block.bake_until_n_cycle_end - ~policy:(By_account account2) - expected_number_of_cycles_with_previous_deposit - b - >>=? fun b -> - Context.Delegate.current_frozen_deposits (B b) account1 - >>=? fun frozen_deposits_at_b -> - (* after [expected_number_of_cycles_with_previous_deposit] cycles - the 0 limit is reflected in the deposit which becomes 0 itself *) - Assert.equal_tez ~loc:__LOC__ frozen_deposits_at_b Tez.zero >>=? fun () -> - (* unset the 0 limit *) - Op.set_deposits_limit (B b) contract1 None >>=? fun operation -> - Block.bake ~policy:(By_account account2) ~operation b >>=? fun b -> - (Context.Delegate.frozen_deposits_limit (B b) account1 >>=? function - | Some _ -> Alcotest.fail "unexpected deposits limit" - | None -> return_unit) - >>=? fun () -> - (* removing the 0 limit is visible once the cycle ends *) - Block.bake_until_cycle_end ~policy:(By_account account2) b >>=? fun bfin -> - Context.Delegate.current_frozen_deposits (B bfin) account1 - >>=? fun frozen_deposits_at_bfin -> - (* without a limit, the new deposit matches the one at genesis; note - that account1 hasn't baked any block so its stake did not change. *) - Assert.equal_tez - ~loc:__LOC__ - frozen_deposits_at_bfin - frozen_deposits_at_genesis - >>=? fun () -> return_unit - -let test_cannot_bake_with_zero_deposits () = - Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let (contract1, account1), (_contract2, account2) = - get_first_2_accounts_contracts contracts - in - (* N.B. there is no non-zero frozen deposits value for which one cannot bake: - even with a small deposit one can still bake, though with a smaller probability - (because the frozen deposits value impacts the active stake and the active - stake is the one used to determine baking/endorsing rights. *) - Op.set_deposits_limit (B genesis) contract1 (Some Tez.zero) - >>=? fun operation -> - Block.bake ~policy:(By_account account2) ~operation genesis >>=? fun b -> - let expected_number_of_cycles_with_previous_deposit = - constants.preserved_cycles + constants.max_slashing_period - 1 - in - Block.bake_until_n_cycle_end - ~policy:(By_account account2) - expected_number_of_cycles_with_previous_deposit - b - >>=? fun b -> - Block.bake ~policy:(By_account account1) b >>= fun b1 -> - (* by now, the active stake of account1 is 0 so it no longer has slots, thus it - cannot be a proposer, thus it cannot bake. Precisely, bake fails because - get_next_baker_by_account fails with "No slots found" *) - Assert.error ~loc:__LOC__ b1 (fun _ -> true) >>=? fun () -> - Block.bake_until_cycle_end ~policy:(By_account account2) b >>=? fun b -> - Context.Delegate.current_frozen_deposits (B b) account1 >>=? fun fd -> - Assert.equal_tez ~loc:__LOC__ fd Tez.zero >>=? fun () -> - Block.bake ~policy:(By_account account1) b >>= fun b1 -> - (* don't know why the zero frozen deposits error is not caught here *) - (* Assert.proto_error_with_info ~loc:__LOC__ b1 "Zero frozen deposits" *) - Assert.error ~loc:__LOC__ b1 (fun _ -> true) - -let test_deposits_after_stake_removal () = - Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let (contract1, account1), (contract2, account2) = - get_first_2_accounts_contracts contracts - in - Context.Delegate.current_frozen_deposits (B genesis) account1 - >>=? fun initial_frozen_deposits_1 -> - Context.Delegate.current_frozen_deposits (B genesis) account2 - >>=? fun initial_frozen_deposits_2 -> - let expected_new_frozen_deposits_2 = - Test_tez.(initial_frozen_deposits_2 *! 3L /! 2L) - in - (* Move half the account1's balance to account2 *) - Context.Delegate.full_balance (B genesis) account1 >>=? fun full_balance -> - let half_balance = Test_tez.(full_balance /! 2L) in - Op.transaction (B genesis) contract1 contract2 half_balance - >>=? fun operation -> - Block.bake ~operation genesis >>=? fun b -> - Context.Delegate.current_frozen_deposits (B b) account1 - >>=? fun frozen_deposits_1 -> - Assert.equal_tez ~loc:__LOC__ frozen_deposits_1 initial_frozen_deposits_1 - >>=? fun () -> - Context.Delegate.current_frozen_deposits (B b) account2 - >>=? fun frozen_deposits_2 -> - Assert.equal_tez ~loc:__LOC__ frozen_deposits_2 initial_frozen_deposits_2 - >>=? fun () -> - (* Bake a cycle to act account2's new frozen deposits *) - Block.bake_until_cycle_end b >>=? fun b -> - let rec loop b n = - if n = 0 then return b - else - Context.Delegate.current_frozen_deposits (B b) account1 - >>=? fun frozen_deposits_1 -> - (* the frozen_deposits is frozen_deposits_percentage of the maximum active stake - during the last preserved_cycles + max_slashing_period cycles; - consequently, though the active stake of account1 has decreased at - cycle c, this decrease makes the frozen deposits smaller only after - preserved cycles + max_slashing_period. *) - Assert.equal_tez ~loc:__LOC__ frozen_deposits_1 initial_frozen_deposits_1 - >>=? fun () -> - (* the active stake of account2 has increased and this increase affects - the frozen_deposits from this cycle as it is greater than previous ones. *) - Context.Delegate.current_frozen_deposits (B b) account2 - >>=? fun frozen_deposits_2 -> - Assert.equal_tez - ~loc:__LOC__ - frozen_deposits_2 - expected_new_frozen_deposits_2 - >>=? fun () -> - Block.bake_until_cycle_end b >>=? fun b -> loop b (pred n) - in - (* the frozen deposits for account1 do not change until [preserved cycles + - max_slashing_period] are baked (-1 because we already baked a cycle) *) - loop b (constants.preserved_cycles + constants.max_slashing_period - 1) - >>=? fun b -> - (* after preserved cycles + max_slashing_period, the frozen_deposits for account1 - reflects the decrease in account1's active stake. *) - Context.Delegate.current_frozen_deposits (B b) account1 - >>=? fun frozen_deposits_1 -> - Assert.equal_tez - ~loc:__LOC__ - frozen_deposits_1 - Test_tez.(initial_frozen_deposits_1 /! 2L) - >>=? fun () -> - Context.Delegate.current_frozen_deposits (B b) account2 - >>=? fun frozen_deposits_2 -> - Assert.equal_tez ~loc:__LOC__ frozen_deposits_2 expected_new_frozen_deposits_2 - -let test_unfreeze_deposits_after_deactivation () = - Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let (contract1, account1), (_contract2, account2) = - get_first_2_accounts_contracts contracts - in - Context.Delegate.full_balance (B genesis) account1 >>=? fun initial_balance -> - (* [account1] will not participate (ie bake/endorse); we set the - expected last cycles at which it is considered active and at - which it has non-zero deposits *) - let last_active_cycle = - 1 + (2 * constants.preserved_cycles) - (* according to [Delegate_storage.set_active] *) - in - let last_cycle_with_deposits = - last_active_cycle + constants.preserved_cycles - + constants.max_slashing_period - (* according to [Delegate_storage.freeze_deposits] *) - in - let cycles_to_bake = last_cycle_with_deposits + constants.preserved_cycles in - let rec loop b n = - if n = 0 then return b - else - Block.bake_until_cycle_end ~policy:(By_account account2) b >>=? fun b -> - Context.Delegate.deactivated (B b) account1 >>=? fun is_deactivated -> - Context.Delegate.current_frozen_deposits (B b) account1 - >>=? fun frozen_deposits -> - (* the spendable balance *) - Context.Contract.balance (B b) contract1 >>=? fun balance -> - let new_cycle = cycles_to_bake - n + 1 in - Assert.equal_bool - ~loc:__LOC__ - is_deactivated - (new_cycle > last_active_cycle) - >>=? fun () -> - Assert.equal_bool - ~loc:__LOC__ - (new_cycle > last_cycle_with_deposits) - (* as soon as frozen_deposits are set to zero from a non-zero value v, v is - returned to the spendable balance of account1; in this particular - case, the spendable balance [balance] updated with v is precisely the - initial_balance.*) - (Tez.(frozen_deposits = zero) && Tez.(balance = initial_balance)) - >>=? fun () -> loop b (pred n) - in - loop genesis cycles_to_bake >>=? fun (_b : Block.t) -> return_unit - -let test_frozen_deposits_with_delegation () = - Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let (_contract1, account1), (contract2, account2) = - get_first_2_accounts_contracts contracts - in - Context.Delegate.staking_balance (B genesis) account1 - >>=? fun initial_staking_balance -> - Context.Delegate.current_frozen_deposits (B genesis) account1 - >>=? fun initial_frozen_deposits -> - Context.Contract.balance (B genesis) contract2 >>=? fun delegated_amount -> - let new_account = Account.new_account () in - let new_contract = Contract.Implicit new_account.pkh in - Op.transaction - ~force_reveal:true - (B genesis) - contract2 - new_contract - delegated_amount - >>=? fun transfer -> - Block.bake ~operation:transfer genesis >>=? fun b -> - Context.Delegate.staking_balance (B b) account2 - >>=? fun new_staking_balance -> - let expected_new_staking_balance = - Test_tez.(initial_staking_balance -! delegated_amount) - in - Assert.equal_tez ~loc:__LOC__ new_staking_balance expected_new_staking_balance - >>=? fun () -> - Op.delegation ~force_reveal:true (B b) new_contract (Some account1) - >>=? fun delegation -> - Block.bake ~operation:delegation b >>=? fun b -> - let expected_new_staking_balance = - Test_tez.(initial_staking_balance +! delegated_amount) - in - Context.Delegate.staking_balance (B b) account1 - >>=? fun new_staking_balance -> - Assert.equal_tez ~loc:__LOC__ new_staking_balance expected_new_staking_balance - >>=? fun () -> - (* Bake one cycle to update the frozen deposits *) - Block.bake_until_cycle_end b >>=? fun b -> - let expected_new_frozen_deposits = - Test_tez.( - initial_frozen_deposits - +! delegated_amount - *! Int64.of_int constants.frozen_deposits_percentage - /! 100L) - in - Context.Delegate.current_frozen_deposits (B b) account1 - >>=? fun new_frozen_deposits -> - Assert.equal_tez ~loc:__LOC__ new_frozen_deposits expected_new_frozen_deposits - >>=? fun () -> - let cycles_to_bake = - 2 * (constants.preserved_cycles + constants.max_slashing_period) - in - let rec loop b n = - if n = 0 then return b - else - Block.bake_until_cycle_end ~policy:(By_account account1) b >>=? fun b -> - Context.Delegate.current_frozen_deposits (B b) account1 - >>=? fun frozen_deposits -> - Assert.equal_tez ~loc:__LOC__ frozen_deposits expected_new_frozen_deposits - >>=? fun () -> loop b (pred n) - in - (* Check that frozen deposits do not change for a sufficient period of - time *) - loop b cycles_to_bake >>=? fun (_b : Block.t) -> return_unit - -let test_frozen_deposits_with_overdelegation () = - Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let (contract1, account1), (contract2, account2) = - get_first_2_accounts_contracts contracts - in - (* - [account1] and [account2] give their spendable balance to [new_account] - - [new_account] overdelegates to [account1] *) - Context.Delegate.staking_balance (B genesis) account1 - >>=? fun initial_staking_balance -> - Context.Delegate.staking_balance (B genesis) account2 - >>=? fun initial_staking_balance' -> - Context.Delegate.current_frozen_deposits (B genesis) account1 - >>=? fun initial_frozen_deposits -> - Context.Contract.balance (B genesis) contract1 >>=? fun amount -> - Context.Contract.balance (B genesis) contract2 >>=? fun amount' -> - let new_account = (Account.new_account ()).pkh in - let new_contract = Contract.Implicit new_account in - Op.transaction ~force_reveal:true (B genesis) contract1 new_contract amount - >>=? fun transfer1 -> - Op.transaction ~force_reveal:true (B genesis) contract2 new_contract amount' - >>=? fun transfer2 -> - Block.bake ~operations:[transfer1; transfer2] genesis >>=? fun b -> - let expected_new_staking_balance = - Test_tez.(initial_staking_balance -! amount) - in - Context.Delegate.staking_balance (B b) account1 - >>=? fun new_staking_balance -> - Assert.equal_tez ~loc:__LOC__ new_staking_balance expected_new_staking_balance - >>=? fun () -> - let expected_new_staking_balance' = - Test_tez.(initial_staking_balance' -! amount') - in - Context.Delegate.staking_balance (B b) account2 - >>=? fun new_staking_balance' -> - Assert.equal_tez - ~loc:__LOC__ - new_staking_balance' - expected_new_staking_balance' - >>=? fun () -> - Op.delegation ~force_reveal:true (B b) new_contract (Some account1) - >>=? fun delegation -> - Block.bake ~operation:delegation b >>=? fun b -> - Context.Delegate.staking_balance (B b) account1 - >>=? fun new_staking_balance -> - let expected_new_staking_balance = - Test_tez.(initial_frozen_deposits +! amount +! amount') - in - Assert.equal_tez ~loc:__LOC__ new_staking_balance expected_new_staking_balance - >>=? fun () -> - (* Finish the cycle to update the frozen deposits *) - Block.bake_until_cycle_end b >>=? fun b -> - Context.Delegate.full_balance (B b) account1 - >>=? fun expected_new_frozen_deposits -> - (* the equality follows from the definition of active stake in - [Delegate_sampler.select_distribution_for_cycle]. *) - assert (initial_frozen_deposits = expected_new_frozen_deposits) ; - Context.Delegate.current_frozen_deposits (B b) account1 - >>=? fun new_frozen_deposits -> - Assert.equal_tez ~loc:__LOC__ new_frozen_deposits expected_new_frozen_deposits - >>=? fun () -> - let cycles_to_bake = - 2 * (constants.preserved_cycles + constants.max_slashing_period) - in - Context.Delegate.current_frozen_deposits (B b) account1 - >>=? fun frozen_deposits -> - Assert.equal_tez ~loc:__LOC__ frozen_deposits expected_new_frozen_deposits - >>=? fun () -> - let rec loop b n = - if n = 0 then return b - else - Block.bake_until_cycle_end ~policy:(By_account account1) b >>=? fun b -> - Context.Delegate.current_frozen_deposits (B b) account1 - >>=? fun frozen_deposits -> - Assert.equal_tez ~loc:__LOC__ frozen_deposits expected_new_frozen_deposits - >>=? fun () -> loop b (pred n) - in - (* Check that frozen deposits do not change for a sufficient period of - time *) - loop b cycles_to_bake >>=? fun (_b : Block.t) -> return_unit - -let test_set_limit_with_overdelegation () = - let constants = {constants with frozen_deposits_percentage = 10} in - Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let (contract1, account1), (contract2, account2) = - get_first_2_accounts_contracts contracts - in - (* - [account1] and [account2] will give 80% of their balance to - [new_account] - - [new_account] will overdelegate to [account1] but [account1] will set - its frozen deposits limit to 15% of its stake *) - Context.Delegate.staking_balance (B genesis) account1 - >>=? fun initial_staking_balance -> - Context.Delegate.staking_balance (B genesis) account2 - >>=? fun initial_staking_balance' -> - let amount = Test_tez.(initial_staking_balance *! 8L /! 10L) in - let amount' = Test_tez.(initial_staking_balance' *! 8L /! 10L) in - let limit = Test_tez.(initial_staking_balance *! 15L /! 100L) in - let new_account = (Account.new_account ()).pkh in - let new_contract = Contract.Implicit new_account in - Op.transaction ~force_reveal:true (B genesis) contract1 new_contract amount - >>=? fun transfer1 -> - Op.transaction ~force_reveal:true (B genesis) contract2 new_contract amount' - >>=? fun transfer2 -> - Block.bake ~operations:[transfer1; transfer2] genesis >>=? fun b -> - Op.set_deposits_limit (B b) contract1 (Some limit) >>=? fun set_deposits -> - Block.bake ~operation:set_deposits b >>=? fun b -> - let expected_new_staking_balance = - Test_tez.(initial_staking_balance -! amount) - in - Context.Delegate.staking_balance (B b) account1 - >>=? fun new_staking_balance -> - Assert.equal_tez ~loc:__LOC__ new_staking_balance expected_new_staking_balance - >>=? fun () -> - let expected_new_staking_balance' = - Test_tez.(initial_staking_balance' -! amount') - in - Context.Delegate.staking_balance (B b) account2 - >>=? fun new_staking_balance' -> - Assert.equal_tez - ~loc:__LOC__ - new_staking_balance' - expected_new_staking_balance' - >>=? fun () -> - Op.delegation ~force_reveal:true (B b) new_contract (Some account1) - >>=? fun delegation -> - Block.bake ~operation:delegation b >>=? fun b -> - (* Finish the cycle to update the frozen deposits *) - Block.bake_until_cycle_end b >>=? fun b -> - let expected_new_frozen_deposits = limit in - Context.Delegate.current_frozen_deposits (B b) account1 - >>=? fun frozen_deposits -> - Assert.equal_tez ~loc:__LOC__ frozen_deposits expected_new_frozen_deposits - >>=? fun () -> - let cycles_to_bake = - 2 * (constants.preserved_cycles + constants.max_slashing_period) - in - let rec loop b n = - if n = 0 then return b - else - Block.bake_until_cycle_end ~policy:(By_account account1) b >>=? fun b -> - Context.Delegate.current_frozen_deposits (B b) account1 - >>=? fun frozen_deposits -> - Assert.equal_tez ~loc:__LOC__ frozen_deposits expected_new_frozen_deposits - >>=? fun () -> loop b (pred n) - in - (* Check that frozen deposits do not change for a sufficient period of - time *) - loop b cycles_to_bake >>=? fun (_b : Block.t) -> return_unit - -(** This test fails when [to_cycle] in [Delegate.freeze_deposits] is smaller than - [new_cycle + preserved_cycles]. *) -let test_error_is_thrown_when_smaller_upper_bound_for_frozen_window () = - Context.init_with_constants2 constants >>=? fun (genesis, contracts) -> - let contract1, contract2 = contracts in - let account1 = Context.Contract.pkh contract1 in - (* [account2] delegates (through [new_account]) to [account1] its spendable - balance. The point is to make [account1] have a lot of staking balance so - that, after [preserved_cycles] when the active stake reflects this increase - in staking balance, its [maximum_stake_to_be_deposited] is bigger than the frozen - deposit which is computed on a smaller window because [to_cycle] is smaller - than [new_cycle + preserved_cycles]. *) - Context.Contract.balance (B genesis) contract2 >>=? fun delegated_amount -> - let new_account = Account.new_account () in - let new_contract = Contract.Implicit new_account.pkh in - Op.transaction - ~force_reveal:true - (B genesis) - contract2 - new_contract - delegated_amount - >>=? fun transfer -> - Block.bake ~operation:transfer genesis >>=? fun b -> - Op.delegation ~force_reveal:true (B b) new_contract (Some account1) - >>=? fun delegation -> - Block.bake ~operation:delegation b >>=? fun b -> - Block.bake_until_cycle_end b >>=? fun b -> - (* After 1 cycle, namely, at cycle 2, [account1] transfers all its spendable - balance. *) - Context.Contract.balance (B b) contract1 >>=? fun balance1 -> - Op.transaction ~force_reveal:true (B b) contract1 contract2 balance1 - >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - Block.bake_until_n_cycle_end constants.preserved_cycles b - >>=? fun (_ : Block.t) -> - (* By this time, after [preserved_cycles] passed after [account1] has emptied - its spendable balance, because [account1] had a big staking balance at - cycle 0, at this cycle it has a big active stake, and so its - [maximum_stake_to_be_deposited] too is bigger than [frozen_deposits.current_amount], - so the variable [to_freeze] in [freeze_deposits] is positive. - Because the spendable balance of [account1] is 0, an error "Underflowing - subtraction" is raised at the end of the cycle when updating the balance by - subtracting [to_freeze] in [freeze_deposits]. - Note that by taking [to_cycle] is [new_cycle + preserved_cycles], - [frozen_deposits.current_amount] can no longer be smaller - than [maximum_stake_to_be_deposited], that is, the invariant - maximum_stake_to_be_deposited <= frozen_deposits + balance is preserved. - *) - return_unit - -let tests = - Tztest. - [ - tztest "invariants" `Quick test_invariants; - tztest "set deposits limit to 0%" `Quick (test_set_limit 0); - tztest "set deposits limit to 5%" `Quick (test_set_limit 5); - tztest "unset deposits limit" `Quick test_unset_limit; - tztest - "cannot bake with zero deposits" - `Quick - test_cannot_bake_with_zero_deposits; - tztest - "deposits after stake removal" - `Quick - test_deposits_after_stake_removal; - tztest - "unfreeze deposits after deactivation" - `Quick - test_unfreeze_deposits_after_deactivation; - tztest - "frozen deposits with delegation" - `Quick - test_frozen_deposits_with_delegation; - tztest - "frozen deposits with overdelegation" - `Quick - test_frozen_deposits_with_overdelegation; - tztest - "set limit with overdelegation" - `Quick - test_set_limit_with_overdelegation; - tztest - "error is thrown when the frozen window is smaller" - `Quick - test_error_is_thrown_when_smaller_upper_bound_for_frozen_window; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("frozen deposits", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_helpers_rpcs.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_helpers_rpcs.ml deleted file mode 100644 index 0933bff5d6193099f233f20031c380533dca5930..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_helpers_rpcs.ml +++ /dev/null @@ -1,68 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020-2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (Helpers RPCs) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/consensus/main.exe \ - -- --file test_helpers_rpcs.ml - Subject: On RPCs. -*) - -(* Test the baking_rights RPC. - Future levels or cycles are not tested because it's hard in this framework, - using only RPCs, to fabricate them. *) -let test_baking_rights () = - Context.init2 () >>=? fun (b, (c1, _c2)) -> - let open Plugin.RPC.Baking_rights in - (* default max_round returns 65 results *) - get Block.rpc_ctxt b ~all:true >>=? fun rights -> - assert (Compare.List_length_with.(rights = 65)) ; - (* arbitrary max_round *) - let max_round = 15 in - get Block.rpc_ctxt b ~all:true ~max_round >>=? fun rights -> - assert (Compare.List_length_with.(rights = max_round + 1)) ; - (* filtering by delegate *) - let d = Context.Contract.pkh c1 in - get Block.rpc_ctxt b ~all:true ~delegates:[d] >>=? fun rights -> - assert (List.for_all (fun {delegate; _} -> delegate = d) rights) ; - (* filtering by cycle *) - Plugin.RPC.current_level Block.rpc_ctxt b >>=? fun {cycle; _} -> - get Block.rpc_ctxt b ~all:true ~cycle >>=? fun rights -> - Plugin.RPC.levels_in_current_cycle Block.rpc_ctxt b >>=? fun (first, last) -> - assert ( - List.for_all (fun {level; _} -> level >= first && level <= last) rights) ; - (* filtering by level *) - Plugin.RPC.current_level Block.rpc_ctxt b >>=? fun {level; _} -> - get Block.rpc_ctxt b ~all:true ~levels:[level] >>=? fun rights -> - let expected_level = level in - assert (List.for_all (fun {level; _} -> level = expected_level) rights) ; - return_unit - -let tests = [Tztest.tztest "baking_rights" `Quick test_baking_rights] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("helpers rpcs", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_participation.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_participation.ml deleted file mode 100644 index f6e8d5e9f46cbc9bd3c5eafaa22c3f484d879410..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_participation.ml +++ /dev/null @@ -1,208 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (participation monitoring) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/consensus/main.exe \ - -- --file test_participation.ml - Subject: Participation monitoring in Tenderbake -*) - -open Protocol -open Alpha_context - -(** [baker] bakes and [endorser] endorses *) -let bake_and_endorse_once (_b_pred, b_cur) baker endorser = - let open Context in - Context.get_endorsers (B b_cur) >>=? fun endorsers_list -> - List.find_map - (function - | {Plugin.RPC.Validators.delegate; slots; _} -> - if Signature.Public_key_hash.equal delegate endorser then - Some (delegate, slots) - else None) - endorsers_list - |> function - | None -> assert false - | Some (delegate, _slots) -> - Block.get_round b_cur >>?= fun round -> - Op.endorsement ~round ~delegate b_cur >>=? fun endorsement -> - Block.bake ~policy:(By_account baker) ~operation:endorsement b_cur - -(** We test that: - - a delegate that participates enough, gets its endorsing rewards at the end of the cycle, - - a delegate that does not participating enough during a cycle, doesn't get rewarded. - - The case distinction is made by the boolean argument [sufficient_participation]. - If [sufficient_participation] is true, - then a validator endorses for as long as the minimal required activity is not reached, - otherwise it does not endorse. - Finally, we check the validator's balance at the end of the cycle. -*) -let test_participation ~sufficient_participation () = - let n_accounts = 2 in - Context.init_n ~consensus_threshold:1 n_accounts () >>=? fun (b0, accounts) -> - Context.get_constants (B b0) >>=? fun csts -> - let blocks_per_cycle = Int32.to_int csts.parametric.blocks_per_cycle in - let mpr = csts.parametric.minimal_participation_ratio in - assert (blocks_per_cycle mod mpr.denominator = 0) ; - (* if this assertion does not hold, then the test might be incorrect *) - let committee_size = csts.parametric.consensus_committee_size in - let expected_nb_slots = blocks_per_cycle * committee_size / n_accounts in - let minimal_nb_active_slots = - mpr.numerator * expected_nb_slots / mpr.denominator - in - let account1, account2 = - match accounts with a1 :: a2 :: _ -> (a1, a2) | _ -> assert false - in - let del1 = Context.Contract.pkh account1 in - let del2 = Context.Contract.pkh account2 in - Block.bake ~policy:(By_account del1) b0 >>=? fun b1 -> - (* To separate concerns, only [del1] bakes: this way, we don't need to - consider baking rewards for [del2]. Delegate [del2] endorses only - if the target [minimal_nb_active_slots] is not reached; for the - rest, it is [del1] that endorses. *) - List.fold_left_es - (fun (b_pred, b_crt, endorsing_power) level -> - let int_level = Int32.of_int level in - Environment.wrap_tzresult (Raw_level.of_int32 int_level) >>?= fun level -> - Context.get_endorsing_power_for_delegate (B b_crt) ~levels:[level] del1 - >>=? fun endorsing_power_for_level -> - let endorser, new_endorsing_power = - if sufficient_participation && endorsing_power < minimal_nb_active_slots - then (del2, endorsing_power + endorsing_power_for_level) - else (del1, endorsing_power) - in - bake_and_endorse_once (b_pred, b_crt) del1 endorser >>=? fun b -> - return (b_crt, b, new_endorsing_power)) - (b0, b1, 0) - (2 -- (blocks_per_cycle - 1)) - >>=? fun (pred_b, b, _) -> - Context.Contract.balance (B pred_b) account2 >|=? Tez.to_mutez - >>=? fun bal2_at_pred_b -> - Context.Contract.balance (B b) account2 >|=? Tez.to_mutez - >>=? fun bal2_at_b -> - (* - If not sufficient_participation, we check that the balance of del2 at b is the - balance of del2 at pred_b; consequently, no rewards could have been given - to del2. - - If sufficient participation, we check that the balance of del2 at b is the - balance of del2 at pred_b plus the endorsing rewards. *) - Context.get_endorsing_reward (B b) ~expected_endorsing_power:expected_nb_slots - >|=? Tez.to_mutez - >>=? fun er -> - let endorsing_rewards = if sufficient_participation then er else 0L in - let expected_bal2_at_b = Int64.add bal2_at_pred_b endorsing_rewards in - Assert.equal_int64 ~loc:__LOC__ bal2_at_b expected_bal2_at_b - -(* We bake and endorse with 1 out of 2 accounts; we monitor the result - returned by the '../delegates//participation' RPC for the - non-participating account. *) -let test_participation_rpc () = - let n_accounts = 2 in - Context.init2 ~consensus_threshold:1 () >>=? fun (b0, (account1, account2)) -> - let del1 = Context.Contract.pkh account1 in - let del2 = Context.Contract.pkh account2 in - Context.get_constants (B b0) >>=? fun csts -> - let blocks_per_cycle = Int32.to_int csts.parametric.blocks_per_cycle in - let Ratio.{numerator; denominator} = - csts.parametric.minimal_participation_ratio - in - let expected_cycle_activity = - blocks_per_cycle * csts.parametric.consensus_committee_size / n_accounts - in - let minimal_cycle_activity = - expected_cycle_activity * numerator / denominator - in - let allowed_missed_slots = expected_cycle_activity - minimal_cycle_activity in - let expected_endorsing_rewards = - Tez.mul_exn - csts.parametric.endorsing_reward_per_slot - expected_cycle_activity - in - Block.bake ~policy:(By_account del1) b0 >>=? fun b1 -> - List.fold_left_es - (fun (b_pred, b_crt, total_endorsing_power) level_int -> - Context.Delegate.participation (B b_crt) del2 >>=? fun info -> - Assert.equal_int - ~loc:__LOC__ - info.expected_cycle_activity - expected_cycle_activity - >>=? fun () -> - Assert.equal_int - ~loc:__LOC__ - info.minimal_cycle_activity - minimal_cycle_activity - >>=? fun () -> - Assert.equal_int ~loc:__LOC__ info.missed_levels (level_int - 1) - >>=? fun () -> - let missed_slots = total_endorsing_power in - Assert.equal_int ~loc:__LOC__ info.missed_slots missed_slots - >>=? fun () -> - let remaining_allowed_missed_slots = - allowed_missed_slots - missed_slots - in - Assert.equal_int - ~loc:__LOC__ - info.remaining_allowed_missed_slots - (max 0 remaining_allowed_missed_slots) - >>=? fun () -> - let endorsing_rewards = - if remaining_allowed_missed_slots >= 0 then expected_endorsing_rewards - else Tez.zero - in - Assert.equal_tez - ~loc:__LOC__ - info.expected_endorsing_rewards - endorsing_rewards - >>=? fun () -> - bake_and_endorse_once (b_pred, b_crt) del1 del1 >>=? fun b -> - (* [level_int] is the level of [b_crt] *) - level_int |> Int32.of_int |> Raw_level.of_int32 - |> Environment.wrap_tzresult - >>?= fun level -> - Context.get_endorsing_power_for_delegate (B b_crt) ~levels:[level] del2 - >>=? fun endorsing_power -> - return (b_crt, b, total_endorsing_power + endorsing_power)) - (b0, b1, 0) - (1 -- (blocks_per_cycle - 2)) - >>=? fun (_, _, _) -> return_unit - -let tests = - [ - Tztest.tztest - "insufficient participation" - `Quick - (test_participation ~sufficient_participation:false); - Tztest.tztest - "minimal participation" - `Quick - (test_participation ~sufficient_participation:true); - Tztest.tztest "participation RPC" `Quick test_participation_rpc; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("participation monitoring", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_preendorsement.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_preendorsement.ml deleted file mode 100644 index f7d622387f23ffad2fc868395d284d3056dcde57..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_preendorsement.ml +++ /dev/null @@ -1,241 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (preendorsement) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/consensus/main.exe \ - -- --file test_preendorsement.ml -*) - -open Protocol -open Alpha_context - -(****************************************************************) -(* Utility functions *) -(****************************************************************) - -let init_genesis ?policy () = - Context.init_n ~consensus_threshold:0 5 () >>=? fun (genesis, _contracts) -> - Block.bake ?policy genesis >>=? fun b -> return (genesis, b) - -(****************************************************************) -(* Tests *) -(****************************************************************) - -(** Test that the preendorsement's branch does not affect its - validity. *) -let test_preendorsement_with_arbitrary_branch () = - Context.init1 () >>=? fun (genesis, _contract) -> - Block.bake genesis >>=? fun blk -> - Op.preendorsement ~branch:Block_hash.zero blk >>=? fun operation -> - Incremental.begin_construction ~mempool_mode:true blk >>=? fun inc -> - Incremental.validate_operation inc operation >>=? fun _inc -> return_unit - -(** Consensus operation for future level : apply a preendorsement with a level in the future *) -let test_consensus_operation_preendorsement_for_future_level () = - init_genesis () >>=? fun (_genesis, pred) -> - let raw_level = Raw_level.of_int32 (Int32.of_int 10) in - let level = match raw_level with Ok l -> l | Error _ -> assert false in - Consensus_helpers.test_consensus_operation - ~loc:__LOC__ - ~endorsed_block:pred - ~level - ~error:(function - | Validate_errors.Consensus.Consensus_operation_for_future_level {kind; _} - when kind = Validate_errors.Consensus.Preendorsement -> - true - | _ -> false) - Preendorsement - Mempool - -(** Consensus operation for old level : apply a preendorsement with a level in the past *) -let test_consensus_operation_preendorsement_for_old_level () = - init_genesis () >>=? fun (_genesis, grandparent) -> - Block.bake grandparent >>=? fun pred -> - let raw_level = Raw_level.of_int32 (Int32.of_int 0) in - let level = match raw_level with Ok l -> l | Error _ -> assert false in - Consensus_helpers.test_consensus_operation - ~loc:__LOC__ - ~endorsed_block:pred - ~level - ~error:(function - | Validate_errors.Consensus.Consensus_operation_for_old_level {kind; _} - when kind = Validate_errors.Consensus.Preendorsement -> - true - | _ -> false) - Preendorsement - Mempool - -(** Consensus operation for future round : apply a preendorsement with a round in the future *) -let test_consensus_operation_preendorsement_for_future_round () = - init_genesis () >>=? fun (_genesis, pred) -> - Environment.wrap_tzresult (Round.of_int 21) >>?= fun round -> - Consensus_helpers.test_consensus_operation - ~loc:__LOC__ - ~endorsed_block:pred - ~round - Preendorsement - Mempool - -(** Consensus operation for old round : apply a preendorsement with a round in the past *) -let test_consensus_operation_preendorsement_for_old_round () = - init_genesis ~policy:(By_round 10) () >>=? fun (_genesis, pred) -> - Environment.wrap_tzresult (Round.of_int 0) >>?= fun round -> - Consensus_helpers.test_consensus_operation - ~loc:__LOC__ - ~endorsed_block:pred - ~round - Preendorsement - Mempool - -(** Consensus operation on competing proposal : apply a preendorsement on a competing proposal *) -let test_consensus_operation_preendorsement_on_competing_proposal () = - init_genesis () >>=? fun (_genesis, pred) -> - Consensus_helpers.test_consensus_operation - ~loc:__LOC__ - ~endorsed_block:pred - ~block_payload_hash:Block_payload_hash.zero - Preendorsement - Mempool - -(** Unexpected preendorsements in block : apply a preendorsement with an incorrect round *) -let test_unexpected_preendorsements_in_blocks () = - init_genesis () >>=? fun (_genesis, pred) -> - Consensus_helpers.test_consensus_operation - ~loc:__LOC__ - ~endorsed_block:pred - ~error:(function - | Validate_errors.Consensus.Unexpected_preendorsement_in_block -> true - | _ -> false) - Preendorsement - Application - -(** Round too high : apply a preendorsement with a too high round *) -let test_too_high_round () = - init_genesis () >>=? fun (_genesis, pred) -> - let raw_level = Raw_level.of_int32 (Int32.of_int 2) in - let level = match raw_level with Ok l -> l | Error _ -> assert false in - Environment.wrap_tzresult (Round.of_int 1) >>?= fun round -> - Consensus_helpers.test_consensus_operation - ~loc:__LOC__ - ~endorsed_block:pred - ~round - ~level - ~error:(function - | Validate_errors.Consensus.Preendorsement_round_too_high _ -> true - | _ -> false) - Preendorsement - Construction - -(** Duplicate preendorsement : apply a preendorsement that has already been applied. *) -let test_duplicate_preendorsement () = - init_genesis () >>=? fun (genesis, _) -> - Block.bake genesis >>=? fun b -> - Incremental.begin_construction ~mempool_mode:true b >>=? fun inc -> - Op.preendorsement b >>=? fun operation -> - Incremental.add_operation inc operation >>=? fun inc -> - Op.preendorsement b >>=? fun operation -> - Incremental.add_operation inc operation >>= fun res -> - Assert.proto_error_with_info - ~loc:__LOC__ - res - "Double inclusion of consensus operation" - -(** Preendorsement for next level *) -let test_preendorsement_for_next_level () = - init_genesis () >>=? fun (genesis, _) -> - Consensus_helpers.test_consensus_op_for_next - ~genesis - ~kind:`Preendorsement - ~next:`Level - -(** Preendorsement for next round *) -let test_preendorsement_for_next_round () = - init_genesis () >>=? fun (genesis, _) -> - Consensus_helpers.test_consensus_op_for_next - ~genesis - ~kind:`Preendorsement - ~next:`Round - -let tests = - let module AppMode = Test_preendorsement_functor.BakeWithMode (struct - let name = "AppMode" - - let baking_mode = Block.Application - end) in - let module ConstrMode = Test_preendorsement_functor.BakeWithMode (struct - let name = "ConstrMode" - - let baking_mode = Block.Baking - end) in - AppMode.tests @ ConstrMode.tests - @ [ - Tztest.tztest - "Preendorsement with arbitrary branch" - `Quick - test_preendorsement_with_arbitrary_branch; - Tztest.tztest - "Preendorsement for future level" - `Quick - test_consensus_operation_preendorsement_for_future_level; - Tztest.tztest - "Preendorsement for old level" - `Quick - test_consensus_operation_preendorsement_for_old_level; - Tztest.tztest - "Preendorsement for future round" - `Quick - test_consensus_operation_preendorsement_for_future_round; - Tztest.tztest - "Preendorsement for old round" - `Quick - test_consensus_operation_preendorsement_for_old_round; - Tztest.tztest - "Preendorsement on competing proposal" - `Quick - test_consensus_operation_preendorsement_on_competing_proposal; - Tztest.tztest - "Unexpected preendorsements in blocks" - `Quick - test_unexpected_preendorsements_in_blocks; - Tztest.tztest "Preendorsements round too high" `Quick test_too_high_round; - Tztest.tztest - "Duplicate preendorsement" - `Quick - test_duplicate_preendorsement; - Tztest.tztest - "Preendorsement for next level" - `Quick - test_preendorsement_for_next_level; - Tztest.tztest - "Preendorsement for next round" - `Quick - test_preendorsement_for_next_round; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("preendorsement", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_preendorsement_functor.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_preendorsement_functor.ml deleted file mode 100644 index 5002e086384c1bcf0eae55a73ec1e889e80aae87..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_preendorsement_functor.ml +++ /dev/null @@ -1,270 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (preendorsement) in Full_construction & Application modes - Subject: preendorsement inclusion in a block -*) - -open Protocol -open Alpha_context - -(****************************************************************) -(* Utility functions *) -(****************************************************************) -module type MODE = sig - val name : string - - val baking_mode : Block.baking_mode -end - -module BakeWithMode (Mode : MODE) : sig - val tests : unit Alcotest_lwt.test_case trace -end = struct - let name = Mode.name - - let bake = Block.bake ~baking_mode:Mode.baking_mode - - let aux_simple_preendorsement_inclusion ?(payload_round = Some Round.zero) - ?(locked_round = Some Round.zero) ?(block_round = 1) - ?(preend_round = Round.zero) - ?(preendorsed_block = fun _predpred _pred curr -> curr) - ?(mk_ops = fun op -> [op]) - ?(get_delegate_and_slot = - fun _predpred _pred _curr -> return (None, None)) - ?(post_process = Ok (fun _ -> return_unit)) ~loc () = - Context.init_n ~consensus_threshold:1 5 () >>=? fun (genesis, _contracts) -> - bake genesis >>=? fun b1 -> - Op.endorsement b1 >>=? fun endo -> - bake b1 ~operations:[endo] >>=? fun b2 -> - let endorsed_block = preendorsed_block genesis b1 b2 in - get_delegate_and_slot genesis b1 b2 >>=? fun (delegate, slot) -> - Op.preendorsement ?delegate ?slot ~round:preend_round endorsed_block - >>=? fun p -> - let operations = endo :: (mk_ops @@ p) in - bake - ~payload_round - ~locked_round - ~policy:(By_round block_round) - ~operations - b1 - >>= fun res -> - match (res, post_process) with - | Ok ok, Ok success_fun -> success_fun ok - | Error _, Error error -> Assert.proto_error ~loc res error - | Ok _, Error _ -> Assert.error ~loc res (fun _ -> false) - | Error _, Ok _ -> Assert.error ~loc res (fun _ -> false) - - (****************************************************************) - (* Tests *) - (****************************************************************) - - (** OK: bake a block "_b2_1" at round 1, containing a PQC and a locked - round of round 0 *) - let include_preendorsement_in_block_with_locked_round () = - aux_simple_preendorsement_inclusion ~loc:__LOC__ () - - (** KO: The same preendorsement injected twice in the PQC *) - let duplicate_preendorsement_in_pqc () = - aux_simple_preendorsement_inclusion (* inject the op twice *) - ~mk_ops:(fun op -> [op; op]) - ~loc:__LOC__ - ~post_process: - (Error - (function - | Validate_errors.Consensus.Conflicting_consensus_operation {kind; _} - when kind = Validate_errors.Consensus.Preendorsement -> - true - | _ -> false)) - () - - (** KO: locked round declared in the block is not smaller than - that block's round *) - let locked_round_not_before_block_round () = - aux_simple_preendorsement_inclusion - (* default locked_round = 0 < block_round = 1 for this aux function *) - ~block_round:0 - ~loc:__LOC__ - ~post_process: - (Error - (function - | Fitness_repr.Locked_round_not_less_than_round _ -> true - | _ -> false)) - () - - (** KO: because we announce a locked_round, but we don't provide the - preendorsement quorum certificate in the operations *) - let with_locked_round_in_block_but_without_any_pqc () = - (* This test only fails in Application mode. If full_construction mode, the - given locked_round is not used / checked. Moreover, the test succeed in - this case. - *) - let post_process = - if Mode.baking_mode == Block.Application then - Error (function Fitness_repr.Wrong_fitness -> true | _ -> false) - else Ok (fun _ -> return_unit) - in - aux_simple_preendorsement_inclusion - (* with declared locked_round but without a PQC in the ops *) - ~mk_ops:(fun _p -> []) - ~loc:__LOC__ - ~post_process - () - - (** KO: The preendorsed block is the pred one, not the current one *) - let preendorsement_has_wrong_level () = - aux_simple_preendorsement_inclusion - (* preendorsement should be for _curr block to be valid *) - ~preendorsed_block:(fun _predpred pred _curr -> pred) - ~loc:__LOC__ - ~post_process: - (Error - (function - | Validate_errors.Consensus.Consensus_operation_for_old_level - {kind; _} - when kind = Validate_errors.Consensus.Preendorsement -> - true - | _ -> false)) - () - - (** OK: explicit the correct endorser and preendorsing slot in the test *) - let preendorsement_in_block_with_good_slot () = - aux_simple_preendorsement_inclusion - ~get_delegate_and_slot:(fun _predpred _pred curr -> - let module V = Plugin.RPC.Validators in - Context.get_endorsers (B curr) >>=? function - | {V.delegate; slots = s :: _; _} :: _ -> return (Some delegate, Some s) - | _ -> assert false - (* there is at least one endorser with a slot *)) - ~loc:__LOC__ - () - - (** KO: the used slot for injecting the endorsement is not the canonical one *) - let preendorsement_in_block_with_wrong_slot () = - aux_simple_preendorsement_inclusion - ~get_delegate_and_slot:(fun _predpred _pred curr -> - let module V = Plugin.RPC.Validators in - Context.get_endorsers (B curr) >>=? function - | {V.delegate; V.slots = _ :: non_canonical_slot :: _; _} :: _ -> - return (Some delegate, Some non_canonical_slot) - | _ -> assert false - (* there is at least one endorser with a slot *)) - ~loc:__LOC__ - ~post_process: - (Error - (function - | Validate_errors.Consensus.Wrong_slot_used_for_consensus_operation - {kind; _} - when kind = Validate_errors.Consensus.Preendorsement -> - true - | _ -> false)) - () - - (** KO: the delegate tries to injects with a canonical slot of another delegate *) - let preendorsement_in_block_with_wrong_signature () = - aux_simple_preendorsement_inclusion - ~get_delegate_and_slot:(fun _predpred _pred curr -> - let module V = Plugin.RPC.Validators in - Context.get_endorsers (B curr) >>=? function - | {V.delegate; _} :: {V.slots = s :: _; _} :: _ -> - (* the canonical slot s is not owned by the delegate "delegate" !*) - return (Some delegate, Some s) - | _ -> assert false - (* there is at least one endorser with a slot *)) - ~loc:__LOC__ - ~post_process: - (Error - (function Operation_repr.Invalid_signature -> true | _ -> false)) - () - - (** KO: cannot have a locked_round higher than attached PQC's round *) - let locked_round_is_higher_than_pqc_round () = - (* This test only fails in Application mode. If full_construction mode, the - given locked_round is not used / checked. Moreover, the test succeed in - this case. - *) - let post_process = - if Mode.baking_mode == Application then - Error - (function - | Validate_errors.Consensus.Consensus_operation_for_old_round - {kind; _} - when kind = Validate_errors.Consensus.Preendorsement -> - true - | _ -> false) - else Ok (fun _ -> return_unit) - in - aux_simple_preendorsement_inclusion - ~preend_round:Round.zero - ~locked_round:(Some (Round.succ Round.zero)) - ~block_round:2 - ~loc:__LOC__ - ~post_process - () - - let my_tztest title test = - Tztest.tztest (Format.sprintf "%s: %s" name title) test - - let tests = - [ - my_tztest - "ok: include_preendorsement_in_block_with_locked_round" - `Quick - include_preendorsement_in_block_with_locked_round; - my_tztest - "ko: duplicate_preendorsement_in_pqc" - `Quick - duplicate_preendorsement_in_pqc; - my_tztest - "ko:locked_round_not_before_block_round" - `Quick - locked_round_not_before_block_round; - my_tztest - "ko: with_locked_round_in_block_but_without_any_pqc" - `Quick - with_locked_round_in_block_but_without_any_pqc; - my_tztest - "ko: preendorsement_has_wrong_level" - `Quick - preendorsement_has_wrong_level; - my_tztest - "ok: preendorsement_in_block_with_good_slot" - `Quick - preendorsement_in_block_with_good_slot; - my_tztest - "ko: preendorsement_in_block_with_wrong_slot" - `Quick - preendorsement_in_block_with_wrong_slot; - my_tztest - "ko: preendorsement_in_block_with_wrong_signature" - `Quick - preendorsement_in_block_with_wrong_signature; - my_tztest - "ko: locked_round_is_higher_than_pqc_round" - `Quick - locked_round_is_higher_than_pqc_round; - ] -end diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_seed.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_seed.ml deleted file mode 100644 index 93df78ac53a62d34a26bde2777ad3146e1fb4d1d..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/consensus/test_seed.ml +++ /dev/null @@ -1,651 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (seed) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/consensus/main.exe \ - -- --file test_seed.ml - Subject: - seed_nonce_hash included in some blocks - - revelation operation of seed_nonce that should correspond - to each seed_nonce_hash -*) - -open Protocol - -(** Checking that, in the absence of nonce revelations and VDF computation, - the seed of each cycle is correctly computed based on the seed of - the previous cycle. *) -let test_seed_no_commitment () = - let open Lwt_result_syntax in - let n_cycles = 15 in - let (Hash initial_seed) = - let empty_bytes = Bytes.(copy empty) in - Tezos_crypto.Hacl.Blake2b.direct empty_bytes Nonce_hash.size - in - let seeds = - (* compute the first `n_cycles` expected seeds *) - let zero_bytes = Bytes.make Nonce_hash.size '\000' in - let rec make_seeds s = function - | 0 -> [] - | n -> - let (Hash h) = - Tezos_crypto.Hacl.Blake2b.direct - (Bytes.cat s zero_bytes) - Nonce_hash.size - in - h :: make_seeds h (n - 1) - in - make_seeds initial_seed n_cycles - in - let check_seed b expected_seed = - let open Alpha_context in - let* s = Context.get_seed (B b) in - let seed_bytes = Data_encoding.Binary.to_bytes_exn Seed.seed_encoding s in - (if expected_seed <> seed_bytes then - let seed_pp = - Hex.show - (Hex.of_string - (Data_encoding.Binary.to_string_exn Seed.seed_encoding s)) - in - let expected_seed_pp = Hex.show (Hex.of_bytes expected_seed) in - Stdlib.failwith - (Format.sprintf "Seed: %s\nExpected: %s\n\n" seed_pp expected_seed_pp)) ; - return b - in - let rec bake_and_check_seed b = function - | [] -> return b - | s :: seeds -> - let* b = Block.bake_until_cycle_end b in - let* b = check_seed b s in - let* b = Block.bake_n 2 b in - bake_and_check_seed b seeds - in - let* b, _delegates = - Context.init3 - ~blocks_per_cycle:8l - ~consensus_threshold:0 - ~nonce_revelation_threshold:2l - () - in - let* b = check_seed b initial_seed in - let* (_ : Block.t) = bake_and_check_seed b seeds in - return_unit - -(** Baking [blocks_per_commitment] blocks without a [seed_nonce_hash] - commitment fails with an "Invalid commitment in block header" error. *) -let test_no_commitment () = - let open Lwt_result_syntax in - let* b, _contracts = Context.init_n ~consensus_threshold:0 5 () in - let* {parametric = {blocks_per_commitment; _}; _} = - Context.get_constants (B b) - in - let blocks_per_commitment = Int32.to_int blocks_per_commitment in - (* Bake normally until before the commitment *) - let* b = Block.bake_n (blocks_per_commitment - 2) b in - (* Forge a block with empty commitment and apply it *) - let* header = Block.Forge.forge_header b in - let* header = - Block.Forge.set_seed_nonce_hash None header |> Block.Forge.sign_header - in - let*! e = Block.apply header b in - Assert.proto_error_with_info - ~loc:__LOC__ - e - "Invalid commitment in block header" - -(** Choose a baker, denote it by id. In the first cycle, make id bake only once. - Check that: - - when id reveals the nonce too early, there's an error - - when id reveals at the right time but the wrong value, there's an error - - when another baker reveals correctly, it receives the tip - - revealing twice produces an error *) -let test_revelation_early_wrong_right_twice () = - let open Lwt_result_syntax in - let open Assert in - let* b, _contracts = Context.init_n ~consensus_threshold:0 5 () in - let* csts = Context.get_constants (B b) in - let tip = csts.parametric.seed_nonce_revelation_tip in - let blocks_per_commitment = - Int32.to_int csts.parametric.blocks_per_commitment - in - let baking_reward_fixed_portion = - csts.parametric.baking_reward_fixed_portion - in - (* get the pkh of a baker *) - let* pkh, _, _, _ = Block.get_next_baker b in - let id = Alpha_context.Contract.Implicit pkh in - let policy = Block.Excluding [pkh] in - (* bake until commitment - 2, excluding id *) - let* b = Block.bake_n ~policy (blocks_per_commitment - 2) b in - let* bal_main = Context.Contract.balance (B b) id in - (* the baker [id] will include a seed_nonce commitment *) - let* b = Block.bake ~policy:(Block.By_account pkh) b in - let*? level_commitment = Context.get_level (B b) in - let* committed_hash = Context.get_seed_nonce_hash (B b) in - (* test that the baking reward is received *) - let* () = - balance_was_credited - ~loc:__LOC__ - (B b) - id - bal_main - baking_reward_fixed_portion - in - (* test that revealing too early produces an error *) - let operation = - Op.seed_nonce_revelation - (B b) - level_commitment - (WithExceptions.Option.to_exn ~none:Not_found @@ Nonce.get committed_hash) - in - let*! e = Block.bake ~policy ~operation b in - let* () = - Assert.proto_error ~loc:__LOC__ e (function - | Nonce_storage.Too_early_revelation -> true - | _ -> false) - in - (* finish the cycle excluding the committing baker, id *) - let* b = Block.bake_until_cycle_end ~policy b in - (* test that revealing at the right time but the wrong value - produces an error *) - let wrong_hash, _ = Nonce.generate () in - let operation = - Op.seed_nonce_revelation - (B b) - level_commitment - (WithExceptions.Option.to_exn ~none:Not_found @@ Nonce.get wrong_hash) - in - let*! e = Block.bake ~operation b in - let* () = - Assert.proto_error ~loc:__LOC__ e (function - | Nonce_storage.Inconsistent_nonce -> true - | _ -> false) - in - (* reveals correctly *) - let operation = - Op.seed_nonce_revelation - (B b) - level_commitment - (WithExceptions.Option.to_exn ~none:Not_found @@ Nonce.get committed_hash) - in - let* baker_pkh, _, _, _ = Block.get_next_baker ~policy b in - let baker = Alpha_context.Contract.Implicit baker_pkh in - let* baker_bal = Context.Contract.balance (B b) baker in - (* test that revealing twice in a block produces an error *) - let*! e = - Block.bake - ~policy:(Block.By_account baker_pkh) - ~operations:[operation; operation] - b - in - let* () = - Assert.proto_error ~loc:__LOC__ e (function - | Validate_errors.Anonymous.Conflicting_nonce_revelation _ -> true - | _ -> false) - in - let* b = Block.bake ~policy:(Block.By_account baker_pkh) ~operation b in - (* test that the baker gets the tip reward plus the baking reward*) - let* () = - balance_was_credited - ~loc:__LOC__ - (B b) - baker - baker_bal - Test_tez.(tip +! baking_reward_fixed_portion) - in - (* test that revealing twice produces an error *) - let operation = - Op.seed_nonce_revelation - (B b) - level_commitment - (WithExceptions.Option.to_exn ~none:Not_found @@ Nonce.get wrong_hash) - in - let*! e = Block.bake ~operation ~policy b in - Assert.proto_error ~loc:__LOC__ e (function - | Nonce_storage.Already_revealed_nonce -> true - | _ -> false) - -(** Test that revealing too late produces an error. Note that a - committer who doesn't reveal at cycle 1 is not punished.*) -let test_revelation_missing_and_late () = - let open Lwt_result_syntax in - let open Context in - let open Assert in - let* b, _contracts = Context.init_n ~consensus_threshold:0 5 () in - let* csts = get_constants (B b) in - let blocks_per_commitment = - Int32.to_int csts.parametric.blocks_per_commitment - in - let nonce_revelation_threshold = - Int32.to_int csts.parametric.nonce_revelation_threshold - in - (* bake until commitment *) - let* b = Block.bake_n (blocks_per_commitment - 2) b in - (* the next baker [id] will include a seed_nonce commitment *) - let* pkh, _, _, _ = Block.get_next_baker b in - let* b = Block.bake b in - let*? level_commitment = Context.get_level (B b) in - let* committed_hash = Context.get_seed_nonce_hash (B b) in - (* finish cycle 0 excluding the committing baker [id] *) - let policy = Block.Excluding [pkh] in - let* b = Block.bake_until_cycle_end ~policy b in - (* test that revealing after revelation period produces an error *) - let* b = Block.bake_n (nonce_revelation_threshold - 1) b in - let operation = - Op.seed_nonce_revelation - (B b) - level_commitment - (WithExceptions.Option.to_exn ~none:Not_found @@ Nonce.get committed_hash) - in - let*! e = Block.bake ~operation ~policy b in - let* () = - Assert.proto_error ~loc:__LOC__ e (function - | Nonce_storage.Too_late_revelation -> true - | _ -> false) - in - (* finish cycle 1 excluding the committing baker [id] *) - let* b = Block.bake_until_cycle_end ~policy b in - (* test that revealing too late after cycle 1 produces an error *) - let operation = - Op.seed_nonce_revelation - (B b) - level_commitment - (WithExceptions.Option.to_exn ~none:Not_found @@ Nonce.get committed_hash) - in - let*! e = Block.bake ~operation b in - Assert.proto_error ~loc:__LOC__ e (function - | Nonce_storage.Too_late_revelation -> true - | _ -> false) - -(** Test that we do not distribute endorsing rewards if the nonce was - not revealed. *) -let test_unrevealed () = - let open Lwt_result_syntax in - let open Alpha_context in - let constants = - { - Default_parameters.constants_test with - endorsing_reward_per_slot = Tez.one_mutez; - baking_reward_bonus_per_slot = Tez.zero; - baking_reward_fixed_portion = Tez.zero; - seed_nonce_revelation_tip = Tez.zero; - consensus_threshold = 0; - minimal_participation_ratio = Ratio.{numerator = 0; denominator = 1}; - } - in - let* b, (_account1, account2) = Context.init_with_constants2 constants in - let delegate2 = Context.Contract.pkh account2 in - (* Delegate 2 will add a nonce but never reveals it *) - let* csts = Context.get_constants (B b) in - let blocks_per_commitment = - Int32.to_int csts.parametric.blocks_per_commitment - in - let bake_and_endorse_block ?policy (_pred_b, b) = - let* slots = Context.get_endorsers (B b) in - let* endorsements = - List.map_es - (fun {Plugin.RPC.Validators.consensus_key; _} -> - Op.endorsement ~delegate:consensus_key b) - slots - in - Block.bake ?policy ~operations:endorsements b - in - (* Bake until commitment *) - let* b = Block.bake_n (blocks_per_commitment - 2) b in - (* Baker delegate 2 will include a seed_nonce commitment *) - let policy = Block.By_account delegate2 in - let* b = Block.bake_until_cycle_end ~policy b in - let* info_before = Context.Delegate.info (B b) delegate2 in - let* b' = Block.bake ~policy b in - let* b = bake_and_endorse_block ~policy (b, b') in - (* Finish cycle 1 excluding the first baker *) - let* b = Block.bake_until_cycle_end ~policy b in - let* info_after = Context.Delegate.info (B b) delegate2 in - (* Assert that we did not received a reward because we didn't - reveal the nonce. *) - let* () = - Assert.equal_tez - ~loc:__LOC__ - info_before.full_balance - info_after.full_balance - in - return_unit - -let test_vdf_status () = - let open Lwt_result_syntax in - let* b, _ = Context.init3 ~consensus_threshold:0 () in - let* b = Block.bake b in - let* status = Context.get_seed_computation (B b) in - assert (status = Alpha_context.Seed.Nonce_revelation_stage) ; - let* constants = Context.get_constants (B b) in - let* b = - Block.bake_n - (Int32.to_int constants.parametric.nonce_revelation_threshold) - b - in - let* status = Context.get_seed_computation (B b) in - assert ( - match status with - | Alpha_context.Seed.Vdf_revelation_stage _ -> true - | _ -> false) ; - return_unit - -(** Choose a baker, denote it by id. In the first cycle, make id bake only once. - Check that: - - when the vdf is revealed too early, there's an error - - when the vdf is revealed at the right time but the wrong value, there's an error - - when the vdf is revealed at the right time and the correct value, - - the baker receives a reward - - the VDF status is updated to "Computation_finished" - - the seed is updated with the vdf solution - - another vdf revelation produces an error *) -let test_early_incorrect_unverified_correct_already_vdf () = - let open Lwt_result_syntax in - let open Assert in - let* b, _ = Context.init3 ~consensus_threshold:0 () in - let* csts = Context.get_constants (B b) in - let blocks_per_commitment = - Int32.to_int csts.parametric.blocks_per_commitment - in - let nonce_revelation_threshold = - Int32.to_int csts.parametric.nonce_revelation_threshold - in - let baking_reward_fixed_portion = - csts.parametric.baking_reward_fixed_portion - in - let seed_nonce_revelation_tip = csts.parametric.seed_nonce_revelation_tip in - let vdf_nonce_revelation_tip = csts.parametric.seed_nonce_revelation_tip in - (* get the pkh of a baker *) - let* pkh, _, _, _ = Block.get_next_baker b in - let id = Alpha_context.Contract.Implicit pkh in - let policy = Block.Excluding [pkh] in - (* bake until commitment - 2, excluding id *) - let* b = Block.bake_n ~policy (blocks_per_commitment - 2) b in - let* bal_main = Context.Contract.balance (B b) id in - (* the baker [id] will include a seed_nonce commitment *) - let* b = Block.bake ~policy:(Block.By_account pkh) b in - let*? level_commitment = Context.get_level (B b) in - let* committed_hash = Context.get_seed_nonce_hash (B b) in - (* test that the baking reward is received *) - let* () = - balance_was_credited - ~loc:__LOC__ - (B b) - id - bal_main - baking_reward_fixed_portion - in - (* finish the cycle excluding the committing baker, id *) - let* b = Block.bake_until_cycle_end ~policy b in - (* reveals correctly *) - let operation = - Op.seed_nonce_revelation - (B b) - level_commitment - (WithExceptions.Option.to_exn ~none:Not_found @@ Nonce.get committed_hash) - in - let* baker_pkh, _, _, _ = Block.get_next_baker ~policy b in - let baker = Alpha_context.Contract.Implicit baker_pkh in - let* baker_bal = Context.Contract.balance (B b) baker in - let* b = Block.bake ~policy:(Block.By_account baker_pkh) ~operation b in - (* test that the baker gets the tip reward plus the baking reward*) - let* () = - balance_was_credited - ~loc:__LOC__ - (B b) - baker - baker_bal - Test_tez.(seed_nonce_revelation_tip +! baking_reward_fixed_portion) - in - (* test that revealing the VDF early produces an error *) - let dummy_solution = - let open Environment.Vdf in - let dummy = Bytes.create Environment.Vdf.form_size_bytes in - let result = Stdlib.Option.get @@ result_of_bytes_opt dummy in - let proof = Stdlib.Option.get @@ proof_of_bytes_opt dummy in - (result, proof) - in - let operation = Op.vdf_revelation (B b) dummy_solution in - let*! e = Block.bake ~operation b in - let* () = - Assert.proto_error ~loc:__LOC__ e (function - | Seed_storage.Too_early_revelation -> true - | _ -> false) - in - (* bake until nonce reveal period finishes *) - let* b = Block.bake_n ~policy nonce_revelation_threshold b in - (* test that revealing non group elements produces an error *) - let operation = Op.vdf_revelation (B b) dummy_solution in - let*! e = Block.bake ~operation b in - let* () = - Assert.proto_error ~loc:__LOC__ e (function - | Seed_storage.Unverified_vdf -> true - | _ -> false) - in - let* seed_status = Context.get_seed_computation (B b) in - match seed_status with - | Nonce_revelation_stage -> assert false - | Computation_finished -> assert false - | Vdf_revelation_stage info -> ( - (* generate the VDF discriminant and challenge *) - let discriminant, challenge = - Alpha_context.Seed.generate_vdf_setup - ~seed_discriminant:info.seed_discriminant - ~seed_challenge:info.seed_challenge - in - (* test that revealing wrong VDF produces an error *) - let wrong_solution = - let open Environment.Vdf in - let f = challenge_to_bytes challenge in - let result = Stdlib.Option.get @@ result_of_bytes_opt f in - let proof = Stdlib.Option.get @@ proof_of_bytes_opt f in - (result, proof) - in - let operation = Op.vdf_revelation (B b) wrong_solution in - let*! e = Block.bake ~operation b in - let* () = - Assert.proto_error ~loc:__LOC__ e (function - | Seed_storage.Unverified_vdf -> true - | _ -> false) - in - (* test with correct input *) - (* compute the VDF solution (the result and the proof ) *) - let solution = - (* generate the result and proof *) - Environment.Vdf.prove - discriminant - challenge - csts.parametric.vdf_difficulty - in - let* baker_bal = Context.Contract.balance (B b) baker in - let operation = Op.vdf_revelation (B b) solution in - let*! e = - Block.bake - ~policy:(Block.By_account baker_pkh) - ~operations:[operation; operation] - b - in - let* () = - Assert.proto_error ~loc:__LOC__ e (function - | Validate_errors.Anonymous.Conflicting_vdf_revelation _ -> true - | _ -> false) - in - (* verify the balance was credited following operation inclusion *) - let* b = Block.bake ~policy:(Block.By_account baker_pkh) ~operation b in - let* () = - balance_was_credited - ~loc:__LOC__ - (B b) - baker - baker_bal - Test_tez.(vdf_nonce_revelation_tip +! baking_reward_fixed_portion) - in - (* verify the seed status has changed *) - let* seed_status = Context.get_seed_computation (B b) in - match seed_status with - | Nonce_revelation_stage -> assert false - | Vdf_revelation_stage _ -> assert false - | Computation_finished -> - (* test than sending another VDF reveal produces an error *) - let operation = Op.vdf_revelation (B b) solution in - let*! e = Block.bake ~operation b in - let* () = - Assert.proto_error ~loc:__LOC__ e (function - | Seed_storage.Already_accepted -> true - | _ -> false) - in - (* verify the stored seed has the expected value *) - let open Data_encoding.Binary in - let open Alpha_context in - (* retrieving & converting seed stored in cycle n + preserved_cycle + 1 *) - let* b = - Block.bake_until_n_cycle_end - ~policy - (csts.parametric.preserved_cycles + 1) - b - in - let* stored_seed = Context.get_seed (B b) in - let vdf_stored_seed = to_bytes_exn Seed.seed_encoding stored_seed in - (* recomputing seed with randao output and vdf solution *) - let vdf_expected_seed = - let randao_seed = - to_bytes_exn Seed.seed_encoding info.seed_challenge - |> of_bytes_exn Seed_repr.seed_encoding - in - Seed_repr.vdf_to_seed randao_seed solution - |> to_bytes_exn Seed_repr.seed_encoding - in - assert (Bytes.(equal vdf_expected_seed vdf_stored_seed)) ; - return_unit) - -(* We check that bounds used in [Seed_storage.for_cycle] are as expected. *) -let test_cycle_bounds () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, _accounts) -> - Context.get_constants (B b) >>=? fun csts -> - let past_offset = csts.parametric.max_slashing_period - 1 in - let future_offset = csts.parametric.preserved_cycles in - let open Alpha_context.Cycle in - let expected_error_message direction current_cycle = - match direction with - | `Past -> - let oldest_cycle = Stdlib.Option.get (sub current_cycle past_offset) in - let older_cycle = Stdlib.Option.get (sub oldest_cycle 1) in - Format.asprintf - "The seed for cycle %a has been cleared from the context (oldest \ - known seed is for cycle %a)" - pp - older_cycle - pp - oldest_cycle - | `Future -> - let latest_cycle = add current_cycle future_offset in - let later_cycle = add latest_cycle 1 in - Format.asprintf - "The seed for cycle %a has not been computed yet (latest known seed \ - is for cycle %a)" - pp - later_cycle - pp - latest_cycle - | `Missing_sampler_state cycle -> - Format.asprintf - "Storage error:\n Missing key 'cycle/%a/delegate_sampler_state'." - pp - cycle - in - let cycle = root in - Context.get_bakers ~cycle:(add cycle future_offset) (B b) - >>=? fun (_ : _ list) -> - let future_cycle = add cycle (future_offset + 1) in - Context.get_bakers ~cycle:future_cycle (B b) >>= fun res -> - (* the first cycle is special *) - Assert.proto_error_with_info - ~loc:__LOC__ - ~error_info_field:`Message - res - (expected_error_message (`Missing_sampler_state future_cycle) cycle) - >>=? fun () -> - Block.bake_until_cycle_end b >>=? fun b -> - let cycle = add cycle 1 in - Context.get_bakers ~cycle:root (B b) >>=? fun (_ : _ list) -> - Context.get_bakers ~cycle:(add cycle future_offset) (B b) - >>=? fun (_ : _ list) -> - Context.get_bakers ~cycle:(add cycle (future_offset + 1)) (B b) >>= fun res -> - Assert.proto_error_with_info - ~loc:__LOC__ - res - ~error_info_field:`Message - (expected_error_message `Future cycle) - >>=? fun () -> - Block.bake_until_n_cycle_end past_offset b >>=? fun b -> - let cycle = add cycle past_offset in - Context.get_bakers ~cycle:(Stdlib.Option.get (sub cycle past_offset)) (B b) - >>=? fun (_ : _ list) -> - Context.get_bakers - ~cycle:(Stdlib.Option.get (sub cycle (past_offset + 1))) - (B b) - >>= fun res -> - Assert.proto_error_with_info - ~loc:__LOC__ - res - ~error_info_field:`Message - (expected_error_message `Past cycle) - >>=? fun () -> - Context.get_bakers ~cycle:(add cycle future_offset) (B b) - >>=? fun (_ : _ list) -> - Context.get_bakers ~cycle:(add cycle (future_offset + 1)) (B b) >>= fun res -> - Assert.proto_error_with_info - ~loc:__LOC__ - res - ~error_info_field:`Message - (expected_error_message `Future cycle) - -let tests = - [ - Tztest.tztest - "seed computation (no commitment)" - `Quick - test_seed_no_commitment; - Tztest.tztest "no commitment" `Quick test_no_commitment; - Tztest.tztest - "revelation_early_wrong_right_twice" - `Quick - test_revelation_early_wrong_right_twice; - Tztest.tztest - "revelation_missing_and_late" - `Quick - test_revelation_missing_and_late; - Tztest.tztest "unrevealed" `Quick test_unrevealed; - Tztest.tztest - "early_incorrect_unverified_correct_already_vdf" - `Quick - test_early_incorrect_unverified_correct_already_vdf; - Tztest.tztest "VDF status" `Quick test_vdf_status; - Tztest.tztest "for_cycle cycle bounds" `Quick test_cycle_bounds; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("seed", tests)] |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/dune b/src/proto_017_PtNairob/lib_protocol/test/integration/dune deleted file mode 100644 index 06c7e892b2152e1c5ad13f87735fdfd0a6dd65ef..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/dune +++ /dev/null @@ -1,59 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name src_proto_017_PtNairob_lib_protocol_test_integration_tezt_lib) - (instrumentation (backend bisect_ppx)) - (libraries - tezt.core - tezt - octez-libs.tezos-context - octez-alcotezt - octez-libs.base - octez-protocol-017-PtNairob-libs.client - tezos-protocol-017-PtNairob.protocol - tezos-protocol-017-PtNairob.parameters - octez-protocol-017-PtNairob-libs.test-helpers - octez-libs.base-test-helpers) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezt_core - -open Tezt_core.Base - -open Octez_alcotezt - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_client_017_PtNairob - -open Tezos_protocol_017_PtNairob - -open Tezos_protocol_017_PtNairob_parameters - -open Tezos_017_PtNairob_test_helpers - -open Tezos_base_test_helpers) - (modules - test_constants - test_frozen_bonds - test_liquidity_baking - test_storage_functions - test_storage - test_token)) - -(executable - (name main) - (instrumentation (backend bisect_ppx --bisect-sigterm)) - (libraries - src_proto_017_PtNairob_lib_protocol_test_integration_tezt_lib - tezt) - (link_flags - (:standard) - (:include %{workspace_root}/macos-link-flags.sexp)) - (modules main)) - -(rule - (alias runtest) - (package tezos-protocol-017-PtNairob-tests) - (deps (glob_files wasm_kernel/*.wasm)) - (enabled_if (<> false %{env:RUNTEZTALIAS=true})) - (action (run %{dep:./main.exe}))) - -(rule - (targets main.ml) - (action (with-stdout-to %{targets} (echo "let () = Tezt.Test.run ()")))) diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/gas/dune b/src/proto_017_PtNairob/lib_protocol/test/integration/gas/dune deleted file mode 100644 index 6151921ca2099189c7134b90fe57a2244deeb4df..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/gas/dune +++ /dev/null @@ -1,46 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name src_proto_017_PtNairob_lib_protocol_test_integration_gas_tezt_lib) - (instrumentation (backend bisect_ppx)) - (libraries - tezt.core - octez-alcotezt - octez-libs.base - tezos-protocol-017-PtNairob.protocol - octez-protocol-017-PtNairob-libs.test-helpers - octez-libs.base-test-helpers) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezt_core - -open Tezt_core.Base - -open Octez_alcotezt - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_protocol_017_PtNairob - -open Tezos_017_PtNairob_test_helpers - -open Tezos_base_test_helpers) - (modules test_gas_costs test_gas_levels)) - -(executable - (name main) - (instrumentation (backend bisect_ppx --bisect-sigterm)) - (libraries - src_proto_017_PtNairob_lib_protocol_test_integration_gas_tezt_lib - tezt) - (link_flags - (:standard) - (:include %{workspace_root}/macos-link-flags.sexp)) - (modules main)) - -(rule - (alias runtest) - (package tezos-protocol-017-PtNairob-tests) - (enabled_if (<> false %{env:RUNTEZTALIAS=true})) - (action (run %{dep:./main.exe}))) - -(rule - (targets main.ml) - (action (with-stdout-to %{targets} (echo "let () = Tezt.Test.run ()")))) diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/gas/test_gas_costs.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/gas/test_gas_costs.ml deleted file mode 100644 index e1d43424324ebb5deb5f5cf7e944e4cde4a6070e..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/gas/test_gas_costs.ml +++ /dev/null @@ -1,289 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020-2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (gas costs) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/gas/main.exe \ - -- --file test_gas_costs.ml - Subject: Gas costs - Current limitations: for maps, sets & compare, we only test - integer comparable keys. -*) - -open Protocol -module S = Saturation_repr - -let dummy_list = Script_list.(cons 42 empty) - -let forty_two = Script_int.of_int 42 - -let forty_two_n = Script_int.abs forty_two - -let dummy_set = - let open Script_set in - update forty_two true (empty Script_typed_ir.int_t) - -let dummy_map = - let open Script_map in - update forty_two (Some forty_two) (empty Script_typed_ir.int_t) - -let dummy_timestamp = Script_timestamp.of_zint (Z.of_int 42) - -let dummy_pk = - Signature.Public_key.of_b58check_exn - "edpkuFrRoDSEbJYgxRtLx2ps82UdaYc1WwfS9sE11yhauZt5DgCHbU" - -let dummy_bytes = Bytes.of_string "dummy" - -let dummy_string = - match Script_string.of_string "dummy" with - | Ok s -> s - | Error _ -> assert false - -let dummy_ty = Script_typed_ir.never_t - -let free = ["balance"; "bool"; "parsing_unit"; "unparsing_unit"] - -(* /!\ The compiler will only complain if costs are _removed_ /!\*) -let all_interpreter_costs = - let open Michelson_v1_gas.Cost_of.Interpreter in - [ - ("drop", drop); - ("dup", dup); - ("swap", swap); - ("cons_some", cons_some); - ("cons_none", cons_none); - ("if_none", if_none); - ("cons_pair", cons_pair); - ("car", car); - ("cdr", cdr); - ("cons_left", cons_left); - ("cons_right", cons_right); - ("if_left", if_left); - ("cons_list", cons_list); - ("nil", nil); - ("if_cons", if_cons); - ("list_map", list_map dummy_list); - ("list_size", list_size); - ("list_iter", list_iter dummy_list); - ("empty_set", empty_set); - ("set_iter", set_iter dummy_set); - ("set_mem", set_mem forty_two dummy_set); - ("set_update", set_update forty_two dummy_set); - ("set_size", set_size); - ("empty_map", empty_map); - ("map_map", map_map dummy_map); - ("map_iter", map_iter dummy_map); - ("map_mem", map_mem forty_two dummy_map); - ("map_get", map_get forty_two dummy_map); - ("map_update", map_update forty_two dummy_map); - ("map_size", map_size); - ("add_seconds_timestamp", add_seconds_timestamp forty_two dummy_timestamp); - ("sub_timestamp_seconds", sub_timestamp_seconds dummy_timestamp forty_two); - ("diff_timestamps", diff_timestamps dummy_timestamp dummy_timestamp); - ("concat_string_pair", concat_string_pair dummy_string dummy_string); - ("slice_string", slice_string dummy_string); - ("string_size", string_size); - ("concat_bytes_pair", concat_bytes_pair dummy_bytes dummy_bytes); - ("slice_bytes", slice_bytes dummy_bytes); - ("bytes_size", bytes_size); - ("add_tez", add_tez); - ("sub_tez", sub_tez); - ("mul_teznat", mul_teznat); - ("bool_or", bool_or); - ("bool_and", bool_and); - ("bool_xor", bool_xor); - ("bool_not", bool_not); - ("is_nat", is_nat); - ("abs_int", abs_int forty_two); - ("int_nat", int_nat); - ("neg", neg forty_two); - ("add_int", add_int forty_two forty_two); - ("sub_int", sub_int forty_two forty_two); - ("mul_int", mul_int forty_two forty_two); - ("ediv_teznat", ediv_teznat Alpha_context.Tez.fifty_cents forty_two); - ("ediv_tez", ediv_tez); - ("ediv_int", ediv_int forty_two (Script_int.of_int 1)); - ("eq", eq); - ("lsl_nat", lsl_nat forty_two); - ("lsr_nat", lsr_nat forty_two); - ("or_nat", or_nat forty_two forty_two); - ("and_nat", and_nat forty_two forty_two); - ("xor_nat", xor_nat forty_two forty_two); - ("not_int", not_int forty_two); - ("if_", if_); - ("loop", loop); - ("loop_left", loop_left); - ("dip", dip); - ("check_signature", check_signature dummy_pk dummy_bytes); - ("blake2b", blake2b dummy_bytes); - ("sha256", sha256 dummy_bytes); - ("sha512", sha512 dummy_bytes); - ("dign", dign 42); - ("dugn", dugn 42); - ("dipn", dipn 42); - ("dropn", dropn 42); - ("neq", neq); - ("compare", compare Script_typed_ir.int_t forty_two forty_two); - ( "concat_string_precheck", - concat_string_precheck Script_list.(cons "42" empty) ); - ("concat_string", concat_string (S.safe_int 42)); - ("concat_bytes", concat_bytes (S.safe_int 42)); - ("exec", exec); - ("apply_rec", apply ~rec_flag:true); - ("apply", apply ~rec_flag:false); - ("lambda", lambda); - ("address", address); - ("contract", contract); - ("transfer_tokens", transfer_tokens); - ("implicit_account", implicit_account); - ("create_contract", create_contract); - ("set_delegate", set_delegate); - (* balance is free *) - ("balance", balance); - ("level", level); - ("now", now); - ("hash_key", hash_key dummy_pk); - ("source", source); - ("sender", sender); - ("self", self); - ("self_address", self_address); - ("amount", amount); - ("chain_id", chain_id); - ("unpack_failed", unpack_failed "dummy"); - ] - -(* /!\ The compiler will only complain if costs are _removed_ /!\*) -let all_parsing_costs = - let open Michelson_v1_gas.Cost_of.Typechecking in - [ - ("public_key_optimized", public_key_optimized); - ("public_key_readable", public_key_readable); - ("key_hash_optimized", key_hash_optimized); - ("key_hash_readable", key_hash_readable); - ("signature_optimized", signature_optimized); - ("signature_readable", signature_readable); - ("chain_id_optimized", chain_id_optimized); - ("chain_id_readable", chain_id_readable); - ("address_optimized", address_optimized); - ("contract_optimized", contract_optimized); - ("contract_readable", contract_readable); - ("check_printable", check_printable "dummy"); - ("merge_cycle", merge_cycle); - ("parse_type_cycle", parse_type_cycle); - ("parse_instr_cycle", parse_instr_cycle); - ("parse_data_cycle", parse_data_cycle); - ("bool", bool); - ("parsing_unit", unit); - ("timestamp_readable", timestamp_readable "dummy"); - ("contract_exists", contract_exists); - ("proof_argument", proof_argument 42); - ] - -(* /!\ The compiler will only complain if costs are _removed_ /!\*) -let all_unparsing_costs = - let open Michelson_v1_gas.Cost_of.Unparsing in - [ - ("public_key_optimized", public_key_optimized); - ("public_key_readable", public_key_readable); - ("key_hash_optimized", key_hash_optimized); - ("key_hash_readable", key_hash_readable); - ("signature_optimized", signature_optimized); - ("signature_readable", signature_readable); - ("chain_id_optimized", chain_id_optimized); - ("chain_id_readable", chain_id_readable); - ("timestamp_readable", timestamp_readable); - ("address_optimized", address_optimized); - ("contract_optimized", contract_optimized); - ("contract_readable", contract_readable); - ("unparse_type", unparse_type dummy_ty); - ("unparse_instr_cycle", unparse_instr_cycle); - ("unparse_data_cycle", unparse_data_cycle); - ("unparsing_unit", unit); - ("operation", operation dummy_bytes); - ] - -(* /!\ The compiler will only complain if costs are _removed_ /!\*) -let all_io_costs = - let open Storage_costs in - [ - ("read_access 0 0", read_access ~path_length:0 ~read_bytes:0); - ("read_access 1 0", read_access ~path_length:1 ~read_bytes:0); - ("read_access 0 1", read_access ~path_length:0 ~read_bytes:1); - ("read_access 1 1", read_access ~path_length:1 ~read_bytes:1); - ("write_access 0", write_access ~written_bytes:0); - ("write_access 1", write_access ~written_bytes:1); - ] - -(* Here we're using knowledge of the internal representation of costs to - cast them to S ... *) -let cast_cost_to_s (c : Alpha_context.Gas.cost) : _ S.t = - Data_encoding.Binary.to_bytes_exn Alpha_context.Gas.cost_encoding c - |> Data_encoding.Binary.of_bytes_exn S.n_encoding - -(** Checks that all costs are positive values. *) -let test_cost_reprs_are_all_positive list () = - List.iter_es - (fun (cost_name, cost) -> - if S.(cost > S.zero) then return_unit - else if S.equal cost S.zero && List.mem ~equal:String.equal cost_name free - then return_unit - else - fail - (Exn - (Failure (Format.asprintf "Gas cost test \"%s\" failed" cost_name)))) - list - -(** Checks that all costs are positive values. *) -let test_costs_are_all_positive list () = - let list = - List.map (fun (cost_name, cost) -> (cost_name, cast_cost_to_s cost)) list - in - test_cost_reprs_are_all_positive list () - -let tests = - [ - Tztest.tztest - "Positivity of interpreter costs" - `Quick - (test_costs_are_all_positive all_interpreter_costs); - Tztest.tztest - "Positivity of typechecking costs" - `Quick - (test_costs_are_all_positive all_parsing_costs); - Tztest.tztest - "Positivity of unparsing costs" - `Quick - (test_costs_are_all_positive all_unparsing_costs); - Tztest.tztest - "Positivity of io costs" - `Quick - (test_cost_reprs_are_all_positive all_io_costs); - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("gas cost functions", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/gas/test_gas_levels.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/gas/test_gas_levels.ml deleted file mode 100644 index abaa01b81a1533ce582eeba03bfae446e44f5986..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/gas/test_gas_levels.ml +++ /dev/null @@ -1,572 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (Gas levels) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/gas/main.exe \ - -- --file test_gas_levels.ml - Subject: On gas consumption and exhaustion. -*) - -open Protocol -open Raw_context -module S = Saturation_repr - -(* This value is supposed to be larger than the block gas level limit - but not saturated. *) -let opg = max_int / 10000 - -exception Gas_levels_test_error of string - -let err x = Exn (Gas_levels_test_error x) - -let succeed x = match x with Ok _ -> true | _ -> false - -let failed x = not (succeed x) - -let dummy_context () = - Context.init1 ~consensus_threshold:0 () >>=? fun (block, _contract) -> - Raw_context.prepare - ~level:Int32.zero - ~predecessor_timestamp:Time.Protocol.epoch - ~timestamp:Time.Protocol.epoch - (* ~fitness:[] *) - (block.context : Tezos_protocol_environment.Context.t) - >|= Environment.wrap_tzresult - -let consume_gas_lwt context gas = - Lwt.return (consume_gas context (S.safe_int gas)) - >|= Environment.wrap_tzresult - -let consume_gas_limit_in_block_lwt context gas = - Lwt.return (consume_gas_limit_in_block context gas) - >|= Environment.wrap_tzresult - -let test_detect_gas_exhaustion_in_fresh_context () = - dummy_context () >>=? fun context -> - fail_unless - (consume_gas context (S.safe_int opg) |> succeed) - (err "In a fresh context, gas consumption is unlimited.") - -(** Create a context with a given block gas level, capped at the - hard gas limit per block *) -let make_context remaining_block_gas = - let open Gas_limit_repr in - dummy_context () >>=? fun context -> - let hard_limit = Arith.fp (constants context).hard_gas_limit_per_operation in - let hard_limit_block = - Arith.fp (constants context).hard_gas_limit_per_block - in - let block_gas = Arith.(unsafe_fp (Z.of_int remaining_block_gas)) in - let rec aux context to_consume = - (* Because of saturated arithmetic, [to_consume] should never be negative. *) - assert (Arith.(to_consume >= zero)) ; - if Arith.(to_consume = zero) then return context - else if Arith.(to_consume <= hard_limit) then - consume_gas_limit_in_block_lwt context to_consume - else - consume_gas_limit_in_block_lwt context hard_limit >>=? fun context -> - aux context (Arith.sub to_consume hard_limit) - in - aux context Arith.(sub hard_limit_block block_gas) - -(** Test operation gas exhaustion. Should pass when remaining gas is 0, - and fail when it goes over *) -let test_detect_gas_exhaustion_when_operation_gas_hits_zero () = - let gas_op = 100000 in - dummy_context () >>=? fun context -> - set_gas_limit context (Gas_limit_repr.Arith.unsafe_fp (Z.of_int gas_op)) - |> fun context -> - fail_unless - (consume_gas context (S.safe_int gas_op) |> succeed) - (err "Succeed when consuming exactly the remaining operation gas.") - >>=? fun () -> - fail_unless - (consume_gas context (S.safe_int (gas_op + 1)) |> failed) - (err "Fail when consuming more than the remaining operation gas.") - -(** Test block gas exhaustion *) -let test_detect_gas_exhaustion_when_block_gas_hits_zero () = - let gas k = Gas_limit_repr.Arith.unsafe_fp (Z.of_int k) in - let remaining_gas = gas 100000 and too_much = gas (100000 + 1) in - make_context 100000 >>=? fun context -> - fail_unless - (consume_gas_limit_in_block context remaining_gas |> succeed) - (err "Succeed when consuming exactly the remaining block gas.") - >>=? fun () -> - fail_unless - (consume_gas_limit_in_block context too_much |> failed) - (err "Fail when consuming more than the remaining block gas.") - -(** Test invalid gas limit. Should fail when limit is above the hard gas limit per - operation *) -let test_detect_gas_limit_consumption_above_hard_gas_operation_limit () = - dummy_context () >>=? fun context -> - fail_unless - (consume_gas_limit_in_block - context - (Gas_limit_repr.Arith.unsafe_fp (Z.of_int opg)) - |> failed) - (err - "Fail when consuming gas above the hard limit per operation in the \ - block.") - -(** For a given [context], check if its levels match those given in [block_level] and - [operation_level] *) -let check_context_levels context block_level operation_level = - let op_check = - match gas_level context with - | Unaccounted -> true - | Limited {remaining} -> - Gas_limit_repr.Arith.(unsafe_fp (Z.of_int operation_level) = remaining) - in - let block_check = - Gas_limit_repr.Arith.( - unsafe_fp (Z.of_int block_level) = block_gas_level context) - in - fail_unless - (op_check || block_check) - (err "Unexpected block and operation gas levels") - >>=? fun () -> - fail_unless op_check (err "Unexpected operation gas level") >>=? fun () -> - fail_unless block_check (err "Unexpected block gas level") - -let monitor remaining_block_gas initial_operation_level consumed_gas () = - let op_limit = - Gas_limit_repr.Arith.unsafe_fp (Z.of_int initial_operation_level) - in - make_context remaining_block_gas >>=? fun context -> - consume_gas_limit_in_block_lwt context op_limit >>=? fun context -> - set_gas_limit context op_limit |> fun context -> - consume_gas_lwt context consumed_gas >>=? fun context -> - check_context_levels - context - (remaining_block_gas - initial_operation_level) - (initial_operation_level - consumed_gas) - -let test_monitor_gas_level = monitor 1000 100 10 - -(** Test cas consumption mode switching (limited -> unlimited) *) -let test_set_gas_unlimited () = - let init_block_gas = 100000 in - let op_limit_int = 10000 in - let op_limit = Gas_limit_repr.Arith.unsafe_fp (Z.of_int op_limit_int) in - make_context init_block_gas >>=? fun context -> - set_gas_limit context op_limit |> set_gas_unlimited |> fun context -> - consume_gas_lwt context opg >>=? fun context -> - check_context_levels context init_block_gas (-1) - -(** Test cas consumption mode switching (unlimited -> limited) *) -let test_set_gas_limited () = - let init_block_gas = 100000 in - let op_limit_int = 10000 in - let op_limit = Gas_limit_repr.Arith.unsafe_fp (Z.of_int op_limit_int) in - let op_gas = 100 in - make_context init_block_gas >>=? fun context -> - set_gas_unlimited context |> fun context -> - set_gas_limit context op_limit |> fun context -> - consume_gas_lwt context op_gas >>=? fun context -> - check_context_levels context init_block_gas (op_limit_int - op_gas) - -(*** Tests with blocks ***) - -let begin_validation_and_application ctxt chain_id mode ~predecessor = - let open Lwt_result_syntax in - let* validation_state = begin_validation ctxt chain_id mode ~predecessor in - let* application_state = begin_application ctxt chain_id mode ~predecessor in - return (validation_state, application_state) - -let validate_and_apply_operation (validation_state, application_state) op = - let open Lwt_result_syntax in - let oph = Alpha_context.Operation.hash_packed op in - let* validation_state = validate_operation validation_state oph op in - let* application_state, receipt = apply_operation application_state oph op in - return ((validation_state, application_state), receipt) - -let finalize_validation_and_application (validation_state, application_state) - shell_header = - let open Lwt_result_syntax in - let* () = finalize_validation validation_state in - finalize_application application_state shell_header - -let apply_with_gas header ?(operations = []) (pred : Block.t) = - let open Alpha_context in - (let open Environment.Error_monad in - begin_validation_and_application - pred.context - Chain_id.zero - (Application header) - ~predecessor:pred.header.shell - >>=? fun vstate -> - List.fold_left_es - (fun vstate op -> - validate_and_apply_operation vstate op >|=? fun (state, _result) -> state) - vstate - operations - >>=? fun vstate -> - finalize_validation_and_application vstate (Some header.shell) - >|=? fun (validation, result) -> (validation.context, result.consumed_gas)) - >|= Environment.wrap_tzresult - >|=? fun (context, consumed_gas) -> - let hash = Block_header.hash header in - ({Block.hash; header; operations; context}, consumed_gas) - -let bake_with_gas ?policy ?timestamp ?operation ?operations pred = - let operations = - match (operation, operations) with - | Some op, Some ops -> Some (op :: ops) - | Some op, None -> Some [op] - | None, Some ops -> Some ops - | None, None -> None - in - Block.Forge.forge_header ?timestamp ?policy ?operations pred - >>=? fun header -> - Block.Forge.sign_header header >>=? fun header -> - apply_with_gas header ?operations pred - -let check_consumed_gas consumed expected = - fail_unless - Alpha_context.Gas.Arith.(consumed = expected) - (err - (Format.asprintf - "Gas discrepancy: consumed gas : %a | expected : %a\n" - Alpha_context.Gas.Arith.pp - consumed - Alpha_context.Gas.Arith.pp - expected)) - -let lazy_unit = Alpha_context.Script.lazy_expr (Expr.from_string "Unit") - -let prepare_origination block source script = - let code = Expr.toplevel_from_string script in - let script = - Alpha_context.Script.{code = lazy_expr code; storage = lazy_unit} - in - Op.contract_origination (B block) source ~script - -let originate_contract block source script = - prepare_origination block source script >>=? fun (operation, dst) -> - Block.bake ~operation block >>=? fun block -> return (block, dst) - -let init_block n to_originate = - Context.init_n n ~consensus_threshold:0 () >>=? fun (block, src_list) -> - match src_list with - | [] -> assert false - | src :: _ -> - (*** originate contracts ***) - let rec full_originate block originated = function - | [] -> return (block, List.rev originated) - | h :: t -> - originate_contract block src h >>=? fun (block, ct) -> - full_originate block (ct :: originated) t - in - full_originate block [] to_originate >>=? fun (block, originated) -> - return (block, src_list, originated) - -let nil_contract = - "parameter unit;\n\ - storage unit;\n\ - code {\n\ - \ DROP;\n\ - \ UNIT; NIL operation; PAIR\n\ - \ }\n" - -let fail_contract = "parameter unit; storage unit; code { FAIL }" - -let loop_contract = - "parameter unit;\n\ - storage unit;\n\ - code {\n\ - \ DROP;\n\ - \ PUSH bool True;\n\ - \ LOOP {\n\ - \ PUSH string \"GASGASGAS\";\n\ - \ PACK;\n\ - \ SHA3;\n\ - \ DROP;\n\ - \ PUSH bool True\n\ - \ };\n\ - \ UNIT; NIL operation; PAIR\n\ - \ }\n" - -let block_with_one_origination n contract = - init_block n [contract] >>=? fun (block, srcs, originated) -> - match originated with [dst] -> return (block, srcs, dst) | _ -> assert false - -let full_block n () = - init_block n [nil_contract; fail_contract; loop_contract] - >>=? fun (block, src_list, originated) -> - let dst_nil, dst_fail, dst_loop = - match originated with [c1; c2; c3] -> (c1, c2, c3) | _ -> assert false - in - return (block, src_list, dst_nil, dst_fail, dst_loop) - -(** Combine a list of operations into an operation list. Also returns - the sum of their gas limits.*) -let combine_operations_with_gas block list_dst = - let rec make_op_list src full_gas op_list = function - | [] -> return (src, full_gas, List.rev op_list) - | (src, dst, gas_limit) :: t -> - Op.transaction - ~gas_limit:(Custom_gas gas_limit) - (B block) - src - dst - Alpha_context.Tez.zero - >>=? fun op -> - make_op_list - (Some src) - (Alpha_context.Gas.Arith.add full_gas gas_limit) - (op :: op_list) - t - in - make_op_list None Alpha_context.Gas.Arith.zero [] list_dst - >>=? fun (src, full_gas, op_list) -> - match src with - | None -> assert false - | Some source -> - Op.batch_operations ~recompute_counters:true ~source (B block) op_list - >>=? fun operation -> return (operation, full_gas) - -(** Applies [combine_operations_with_gas] to lists in a list, then bake a block - with this list of operations. Also returns the sum of all gas limits *) -let bake_operations_with_gas block list_list_dst = - let rec make_list full_gas op_list = function - | [] -> return (full_gas, List.rev op_list) - | list_dst :: t -> - combine_operations_with_gas block list_dst >>=? fun (op, gas) -> - make_list (Alpha_context.Gas.Arith.add full_gas gas) (op :: op_list) t - in - make_list Alpha_context.Gas.Arith.zero [] list_list_dst - >>=? fun (gas_limit_total, operations) -> - bake_with_gas ~operations block >>=? fun (block, consumed_gas) -> - return (block, consumed_gas, gas_limit_total) - -(* A sampler for gas limits, the returned value should always be high - enough to apply a simple manager operation but lower than the - operation gas limit. *) -let basic_gas_sampler () = - Alpha_context.Gas.Arith.integral_of_int_exn - (Michelson_v1_gas.Internal_for_tests.int_cost_of_manager_operation + 1000 - + Random.int 900) - -let generic_test_block_one_origination contract gas_sampler structure = - let sources_number = List.length structure in - block_with_one_origination sources_number contract - >>=? fun (block, src_list, dst) -> - let lld = - List.mapi - (fun i t -> - match List.nth src_list i with - | None -> assert false - | Some src -> (List.map (fun _ -> (src, dst, gas_sampler ()))) t) - structure - in - bake_operations_with_gas block lld - >>=? fun (_block, consumed_gas, gas_limit_total) -> - check_consumed_gas consumed_gas gas_limit_total - -let make_batch_test_block_one_origination name contract gas_sampler = - let test = generic_test_block_one_origination contract gas_sampler in - let test_one_operation () = test [[()]] in - let test_one_operation_list () = test [[(); (); ()]] in - let test_many_single_operations () = test [[()]; [()]; [()]] in - let test_mixed_operations () = test [[(); ()]; [()]; [(); (); ()]] in - let app_n = List.map (fun (x, y) -> (x ^ " with contract " ^ name, y)) in - app_n - [ - ("bake one operation", test_one_operation); - ("bake one operation list", test_one_operation_list); - ("multiple single operations", test_many_single_operations); - ("both lists and single operations", test_mixed_operations); - ] - -(** Tests the consumption of all gas in a block, should pass *) -let test_consume_exactly_all_block_gas () = - let number_of_ops = 2 in - block_with_one_origination number_of_ops nil_contract - >>=? fun (block, src_list, dst) -> - (* assumptions: - hard gas limit per operation = 1_040_000 - hard gas limit per block = 2_600_000 - *) - let lld = - List.map - (fun src -> - [(src, dst, Alpha_context.Gas.Arith.integral_of_int_exn 1040000)]) - src_list - in - bake_operations_with_gas block lld >>=? fun (_, _, _) -> return_unit - -(** Tests the consumption of more than the block gas level with many single - operations, should fail *) -let test_malformed_block_max_limit_reached () = - let number_of_ops = 6 in - block_with_one_origination number_of_ops nil_contract - >>=? fun (block, src_list, dst) -> - (* assumptions: - hard gas limit per operation = 1040000 - hard gas limit per block = 5200000 - *) - let lld = - List.mapi - (fun i src -> - [ - ( src, - dst, - Alpha_context.Gas.Arith.integral_of_int_exn - (if i = number_of_ops - 1 then 1 else 1040000) ); - ]) - src_list - in - bake_operations_with_gas block lld >>= function - | Error _ -> return_unit - | Ok _ -> - fail - (err - "Invalid block: sum of operation gas limits exceeds hard gas limit \ - per block") - -(** Tests the consumption of more than the block gas level with one big - operation list, should fail *) -let test_malformed_block_max_limit_reached' () = - let number_of_ops = 6 in - block_with_one_origination number_of_ops nil_contract - >>=? fun (block, src_list, dst) -> - (* assumptions: - hard gas limit per operation = 1040000 - hard gas limit per block = 5200000 - *) - let lld = - List.mapi - (fun i src -> - [ - ( src, - dst, - Alpha_context.Gas.Arith.integral_of_int_exn - (if i = number_of_ops - 1 then 1 else 1040000) ); - ]) - src_list - in - bake_operations_with_gas block lld >>= function - | Error _ -> return_unit - | Ok _ -> - fail - (err - "Invalid block: sum of gas limits in operation list exceeds hard \ - gas limit per block") - -let test_block_mixed_operations () = - let number_of_ops = 4 in - full_block number_of_ops () - >>=? fun (block, src_list, dst_nil, dst_fail, dst_loop) -> - let l = [[dst_nil]; [dst_nil; dst_fail; dst_nil]; [dst_loop]; [dst_nil]] in - List.map2 - ~when_different_lengths:[] - (fun src l -> (List.map (fun x -> (src, x, basic_gas_sampler ()))) l) - src_list - l - >>?= fun lld -> - bake_operations_with_gas block lld - >>=? fun (_block, consumed_gas, gas_limit_total) -> - check_consumed_gas consumed_gas gas_limit_total - -(** Test that emptying an account does not cost extra-gas *) -let test_emptying_account_gas () = - let open Alpha_context in - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap) -> - let bootstrap_pkh = Context.Contract.pkh bootstrap in - let {Account.pkh; pk; _} = Account.new_account () in - let contract = Contract.Implicit pkh in - let amount = Test_tez.of_int 10 in - Op.transaction (B b) bootstrap contract amount >>=? fun op1 -> - Block.bake ~operation:op1 b >>=? fun b -> - Op.revelation ~fee:Tez.zero (B b) pk >>=? fun op2 -> - Block.bake ~operation:op2 b >>=? fun b -> - let gas_limit = Op.Low in - Op.delegation ~fee:amount ~gas_limit (B b) contract (Some bootstrap_pkh) - >>=? fun op -> - Incremental.begin_construction b >>=? fun i -> - (* The delegation operation should be valid as the operation effect - would be to remove [contract] and should not generate any extra - gas cost. *) - let expect_apply_failure = function - | [Environment.Ecoproto_error (Storage_error (Raw_context.Missing_key _))] - -> - (* The delegation is expected to fail in the apply part as the - contract was emptied when fees were retrieved. *) - return_unit - | err -> failwith "got unexpected error: %a" pp_print_trace err - in - Incremental.add_operation ~expect_apply_failure i op - >>=? fun (_i : Incremental.t) -> return_unit - -let quick (what, how) = Tztest.tztest what `Quick how - -let tests = - List.map - quick - ([ - ( "Detect gas exhaustion in fresh context", - test_detect_gas_exhaustion_in_fresh_context ); - ( "Detect gas exhaustion when operation gas as hits zero", - test_detect_gas_exhaustion_when_operation_gas_hits_zero ); - ( "Detect gas exhaustion when block gas as hits zero", - test_detect_gas_exhaustion_when_block_gas_hits_zero ); - ( "Detect gas limit consumption when it is above the hard gas operation \ - limit", - test_detect_gas_limit_consumption_above_hard_gas_operation_limit ); - ( "Each new operation impacts block gas level, each gas consumption \ - impacts operation gas level", - test_monitor_gas_level ); - ( "Switches operation gas consumption from limited to unlimited", - test_set_gas_unlimited ); - ( "Switches operation gas consumption from unlimited to limited", - test_set_gas_limited ); - ( "Accepts a block that consumes all of its gas", - test_consume_exactly_all_block_gas ); - ( "Detect when the sum of all operation gas limits exceeds the hard gas \ - limit per block", - test_malformed_block_max_limit_reached ); - ( "Detect when gas limit of operation list exceeds the hard gas limit \ - per block", - test_malformed_block_max_limit_reached' ); - ("the gas consumption of various operations", test_block_mixed_operations); - ("emptying an account costs gas", test_emptying_account_gas); - ] - @ make_batch_test_block_one_origination "nil" nil_contract basic_gas_sampler - @ make_batch_test_block_one_origination - "fail" - fail_contract - basic_gas_sampler - @ make_batch_test_block_one_origination - "infinite loop" - loop_contract - basic_gas_sampler) - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("gas levels", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/big_interpreter_stack.tz b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/big_interpreter_stack.tz deleted file mode 100644 index 24832df0827f2300f65a71c3472cd266cbfaac3b..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/big_interpreter_stack.tz +++ /dev/null @@ -1,5 +0,0 @@ -{ parameter unit ; - storage unit ; - code { CAR ; - { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { { {} ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; } ; - NIL operation; PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/emit.tz b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/emit.tz deleted file mode 100644 index c8c2da0886d0959cbfda0ecc10aef16563fd5aa7..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/emit.tz +++ /dev/null @@ -1,16 +0,0 @@ -parameter unit; -storage unit; -code { DROP ; - UNIT ; - PUSH string "right" ; - RIGHT nat ; - EMIT %tag1 ; - PUSH nat 2 ; - LEFT string ; - EMIT %tag2 (or (nat %int) (string %str)) ; - NIL operation ; - SWAP ; - CONS ; - SWAP ; - CONS ; - PAIR } diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/fail_rec.tz b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/fail_rec.tz deleted file mode 100644 index cac8886649280e4855955662073fdba00bcd20d6..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/fail_rec.tz +++ /dev/null @@ -1,8 +0,0 @@ -{ parameter unit; - storage unit; - code { CAR; - LAMBDA_REC unit unit { }; - SWAP; - EXEC; - NIL operation; - PAIR}} diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/forbidden_op_in_view_CREATE_CONTRACT.tz b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/forbidden_op_in_view_CREATE_CONTRACT.tz deleted file mode 100644 index e3ee1fd0665a9cd4db8824d6507d587c56a9d546..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/forbidden_op_in_view_CREATE_CONTRACT.tz +++ /dev/null @@ -1,24 +0,0 @@ -# This contract uses CREATE_CONTRACT in a view, which is forbidden. -{ - storage unit ; - parameter unit ; - code { - CAR ; - NIL operation ; - PAIR - } ; - view "v" unit unit { - DROP ; - UNIT ; - PUSH mutez 5 ; - NONE key_hash ; - CREATE_CONTRACT { - storage unit ; - parameter unit ; - code { CAR ; NIL operation ; PAIR } - } ; - DROP ; - DROP ; - UNIT - } -} diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/forbidden_op_in_view_SELF.tz b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/forbidden_op_in_view_SELF.tz deleted file mode 100644 index 79636452d4bff950d281929c3f71f5d2b33da718..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/forbidden_op_in_view_SELF.tz +++ /dev/null @@ -1,11 +0,0 @@ -# This contract uses SELF in a view, which is forbidden. -{ - storage unit ; - parameter unit ; - code { - CAR ; - NIL operation ; - PAIR - } ; - view "v" unit unit { DROP ; SELF ; DROP ; UNIT } -} diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/forbidden_op_in_view_SET_DELEGATE.tz b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/forbidden_op_in_view_SET_DELEGATE.tz deleted file mode 100644 index 7e396e55dab124f89164af22e0535de4c17d9bf0..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/forbidden_op_in_view_SET_DELEGATE.tz +++ /dev/null @@ -1,11 +0,0 @@ -# This contract uses SET_DELEGATE in a view, which is forbidden. -{ - storage unit ; - parameter unit ; - code { - CAR ; - NIL operation ; - PAIR - } ; - view "v" key_hash unit { CAR ; SOME ; SET_DELEGATE ; DROP ; UNIT } -} diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/forbidden_op_in_view_TRANSFER_TOKENS.tz b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/forbidden_op_in_view_TRANSFER_TOKENS.tz deleted file mode 100644 index e6adb07fd31b88756505b3dc8741a2b44305ed0f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/forbidden_op_in_view_TRANSFER_TOKENS.tz +++ /dev/null @@ -1,12 +0,0 @@ -# This contract uses TRANSFER_TOKENS in a view, which is forbidden. -{ - storage unit ; - parameter unit ; - code { - CAR ; - NIL operation ; - PAIR - } ; - view "v" (pair unit mutez (contract unit)) unit - { CAR ; UNPAPAIR ; TRANSFER_TOKENS ; DROP ; UNIT } -} diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/int-store.tz b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/int-store.tz deleted file mode 100644 index acd5104c042bdd5e437864d25d1386ed81b156e9..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/int-store.tz +++ /dev/null @@ -1,3 +0,0 @@ -{ parameter unit ; - storage int ; - code { CDR ; NIL operation; PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/omega.tz b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/omega.tz deleted file mode 100644 index 52adfdf1facc7adeefbe797815339d2d5f43be28..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/omega.tz +++ /dev/null @@ -1,9 +0,0 @@ -{ parameter unit; - storage unit; - code { CAR; - LAMBDA_REC unit unit - { EXEC }; - SWAP; - EXEC; - NIL operation; - PAIR}} diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/rec_fact.tz b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/rec_fact.tz deleted file mode 100644 index b3dd6402f440533399f767ae46efebb81ba2bbfa..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/rec_fact.tz +++ /dev/null @@ -1,19 +0,0 @@ -{ parameter int; - storage int; - code { CAR ; - LAMBDA_REC int int - { DUP; - EQ; - IF { PUSH int 1 } - { DUP; - DUP 3; - PUSH int 1; - DUP 4; - SUB; - EXEC; - MUL}; - DIP { DROP 2 }}; - SWAP; - EXEC; - NIL operation; - PAIR}} diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/rec_fact_apply.tz b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/rec_fact_apply.tz deleted file mode 100644 index 85515df4cde8756e002fd9370278ce62dc1c4b5e..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/rec_fact_apply.tz +++ /dev/null @@ -1,24 +0,0 @@ - {parameter int; - storage int; - code { CAR ; - LAMBDA_REC (pair unit int) int - { UNPAIR; - DUP 2; - EQ; - IF { PUSH int 1 } - { DUP 2; - DUP 4; - DUP 3; - APPLY; - PUSH int 1; - DUP 3; - SUB; - EXEC; - MUL}; - DIP { DROP 3 }}; - UNIT; - APPLY; - SWAP; - EXEC; - NIL operation; - PAIR}} diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/rec_fact_apply_store.tz b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/rec_fact_apply_store.tz deleted file mode 100644 index 8d38ed03bddb76d29d0a10562516b79ea453e0cc..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/rec_fact_apply_store.tz +++ /dev/null @@ -1,27 +0,0 @@ -{ storage (or int (lambda int int)); - parameter (or (unit %gen) (int %exec)); - code { UNPAIR; - IF_LEFT{ DROP 2; - LAMBDA_REC (pair unit int) int - { UNPAIR; - DUP 2; - EQ; - IF { PUSH int 1 } - { DUP 2; - DUP 4; - DUP 3; - APPLY; - PUSH int 1; - DUP 3; - SUB; - EXEC; - MUL}; - DIP { DROP 3 }}; - UNIT; - APPLY; - RIGHT int} - { DIP { ASSERT_RIGHT }; - EXEC; - LEFT (lambda int int)}; - NIL operation; - PAIR}} diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/rec_fact_store.tz b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/rec_fact_store.tz deleted file mode 100644 index c4825db7f6349ccaf10c262f414ba1637b87c17d..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/rec_fact_store.tz +++ /dev/null @@ -1,22 +0,0 @@ -{ storage (or int (lambda int int)); - parameter (or (unit %gen) (int %exec)); - code { UNPAIR; - IF_LEFT{ DROP 2; - LAMBDA_REC int int - { DUP; - EQ; - IF { PUSH int 1 } - { DUP; - DUP 3; - PUSH int 1; - DUP 4; - SUB; - EXEC; - MUL}; - DIP { DROP 2 }}; - RIGHT int} - { DIP { ASSERT_RIGHT }; - EXEC; - LEFT (lambda int int)}; - NIL operation; - PAIR}} diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/sapling_contract.tz b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/sapling_contract.tz deleted file mode 100644 index 0b9e2ff99264da3632fe62f07c95baf9bbf59381..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/sapling_contract.tz +++ /dev/null @@ -1,73 +0,0 @@ -# This contract manages a shielded pool with a 1 to 1 conversion with respect to -# the mutez, updated by a list of Sapling transactions. -# As a convention, all unshield transactions must contain in their `bound_data` -# field a Micheline encoded public_key_hash which is used as the recipient of -# the unshielded tez. - -storage (sapling_state 8); -parameter (list (sapling_transaction 8)); -code { # Stack manipulation - UNPAIR; - NIL operation; - SWAP; - DIP { SWAP}; - AMOUNT ; - SWAP ; - DIP {SWAP} ; - ITER { - # If the transaction is valid, the resulting stack contains the - # bound_data and balance of the transaction and the updated - # state. If the rest of the script goes well, this state - # will be the new state of the smart contract. - SAPLING_VERIFY_UPDATE; - # In the case of an invalid transaction, we stop. - ASSERT_SOME; - UNPAIR; - SWAP; - UNPAIR; - # Convert the balance in mutez, keeping the signed balance on top - # of the stack and the balance in mutez as the second element. - DUP; - DIP { ABS; # in case of negative balance i.e. shielding - PUSH mutez 1; - MUL; }; - # We have three cases now: unshielding, shielding and transfers. - # If the balance is strictly positive (i.e. unshielding), we send - # funds to the given address. - # If we can't unpack an address from the bound_data, we stop. - IFGT { - DIIP {UNPACK key_hash; - ASSERT_SOME; - IMPLICIT_ACCOUNT }; - SWAP; - # The tokens are transferred to the recipient. - DIP { UNIT; - TRANSFER_TOKENS; - SWAP; - DIP {CONS} ;}; - } - # If the balance is negative or 0 (i.e. shielding or transfer), - # we verify the amount transferred in the transaction is - # exactly the balance returned by verify_update. This enforces - # the conversion 1-1 between mutez and shielded token - # as the balance in mutez of the contract will always be - # the same as the number of tokens in the sapling_state. - # No operation is executed. - { - DIIP {SWAP}; - DIP {SWAP}; - SWAP; - SUB_MUTEZ; ASSERT_SOME; - # For a transfer or shield operation, we don't expect an - # implicit account in the `bound_data` field. - # If one is given, we fail as it might be an invalid - # operation or an erroneous call. - DIIP { SIZE; PUSH nat 0; ASSERT_CMPEQ; }; - SWAP; - }; - }; - DIP { - PUSH mutez 0; - ASSERT_CMPEQ;}; - SWAP; - PAIR} diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/sapling_contract_double.tz b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/sapling_contract_double.tz deleted file mode 100644 index b826428db278e0a206bd868e60c060779a00ae0a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/sapling_contract_double.tz +++ /dev/null @@ -1,27 +0,0 @@ -storage (pair (sapling_state :left 8) (sapling_state :right 8) ); -parameter (pair bool (pair (sapling_transaction :left 8) (sapling_transaction :right 8)) ); -code { UNPAIR ; - UNPAIR ; - DIP {UNPAIR} ; - DIIIP {UNPAIR} ; - DIIP {SWAP} ; - IF { SAPLING_VERIFY_UPDATE ; - ASSERT_SOME ; - CDR ; CDR ; - DIP {DIP {DUP}; - SAPLING_VERIFY_UPDATE; - ASSERT_SOME ; - DROP;}; - } - { DIP { DUP}; - SAPLING_VERIFY_UPDATE; - ASSERT_SOME; - DROP ; - DIP { SAPLING_VERIFY_UPDATE ; - ASSERT_SOME ; - CDR ; CDR; - }}; - PAIR; - NIL operation; - PAIR; - } diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/sapling_contract_drop.tz b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/sapling_contract_drop.tz deleted file mode 100644 index b4d4a3a56bc8437ac560d46a5138b90e76c29f4e..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/sapling_contract_drop.tz +++ /dev/null @@ -1,13 +0,0 @@ -storage (unit); -parameter (list (sapling_transaction 8)); -code { UNPAIR ; - SAPLING_EMPTY_STATE 8; - SWAP ; - ITER { SAPLING_VERIFY_UPDATE ; - ASSERT_SOME ; - CDR ; CDR ; - } ; - DROP ; - NIL operation; - PAIR; - } diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/sapling_contract_send.tz b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/sapling_contract_send.tz deleted file mode 100644 index 43a6edba46ec363d19edf4b9651380fbf23a73ff..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/sapling_contract_send.tz +++ /dev/null @@ -1,20 +0,0 @@ -storage (unit); -parameter (pair (contract (or (sapling_transaction 8) (sapling_state 8))) (sapling_transaction 8)); -code { UNPAIR ; - UNPAIR; - SWAP ; - SAPLING_EMPTY_STATE 8; - SWAP ; - SAPLING_VERIFY_UPDATE ; - ASSERT_SOME ; - CDR ; - CDR ; - PUSH mutez 0; - SWAP ; - RIGHT (sapling_transaction 8); - TRANSFER_TOKENS; - NIL operation; - SWAP; - CONS; - PAIR; - } diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/sapling_contract_state_as_arg.tz b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/sapling_contract_state_as_arg.tz deleted file mode 100644 index e8a96df046ee88f93be180d95076451ee166c894..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/sapling_contract_state_as_arg.tz +++ /dev/null @@ -1,18 +0,0 @@ -storage (option (sapling_transaction 8)); -parameter (or (sapling_transaction 8) (sapling_state 8)); -code { UNPAIR ; - IF_LEFT - { - DIP {DROP;}; - SOME; - } - { DIP {ASSERT_SOME;}; - SWAP ; - SAPLING_VERIFY_UPDATE; - ASSERT_SOME; - DROP ; - NONE (sapling_transaction 8) ; - }; - NIL operation; - PAIR; - } diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/sapling_push_sapling_state.tz b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/sapling_push_sapling_state.tz deleted file mode 100644 index 8d1db432bf2ee6ea891c0ccd120fcdbb4618c4b4..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/sapling_push_sapling_state.tz +++ /dev/null @@ -1,11 +0,0 @@ -# Attempt to use `PUSH sapling_state 0` where 0 is the ID of a sapling state. -# sapling_state is not allowed in the instruction PUSH. -parameter unit; -storage unit; -code { DROP; - PUSH (sapling_state 8) 0; - DROP; - PUSH unit Unit; - NIL operation; - PAIR; - } diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/sapling_use_existing_state.tz b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/sapling_use_existing_state.tz deleted file mode 100644 index bc8c46a28d87df52b6a291caa3fdc4146e39eb77..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/sapling_use_existing_state.tz +++ /dev/null @@ -1,12 +0,0 @@ -parameter (pair (sapling_transaction 8) (sapling_state 8)); -storage (sapling_state 8); -code { UNPAIR; - UNPAIR; - DIIP { DROP }; - SAPLING_VERIFY_UPDATE; - ASSERT_SOME; - CDR; - CDR; - NIL operation; - PAIR; - } diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/temp_big_maps.tz b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/temp_big_maps.tz deleted file mode 100644 index 0a9162f8f9826adbec0da6079044ce8a21e9c43c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/contracts/temp_big_maps.tz +++ /dev/null @@ -1,81 +0,0 @@ -# Testing passing/originating with big maps from different sources -# This contract is used by test_temp_big_maps.ml - -# The left member of the parameter is either: -# - (Left True) to use a fresh big map -# - (Left False) to use the stored big map -# - (Right bigmap) to use the passed big map - -# The right member of the parameter is used to decide between: -# - passing the argument (positive value) -# - doing nothing (zero) -# - originating (negative value) - -parameter (pair (or bool (big_map int int)) int); -storage (big_map int int); -code - { # parameter * storage :: [] - UNPAIR; # parameter :: storage :: [] - UNPAIR; # parameter.fst :: parameter.snd :: storage :: [] - DIP { SWAP }; # parameter.fst :: storage :: parameter.snd :: [] - IF_LEFT - { # parameter.fst.Left :: storage :: parameter.snd :: [] - IF - { # storage :: parameter.snd :: [] - DROP; # parameter.snd :: [] - EMPTY_BIG_MAP int int; # empty_big_map :: parameter.snd :: [] - PUSH (option int) (Some 2); # Some 2 :: empty_big_map :: parameter.snd :: [] - PUSH int 1; # 1 :: Some 2 :: empty_big_map :: parameter.snd :: [] - UPDATE; # big_map { 1 -> 2 } :: parameter.snd :: [] - } - { # stored_big_map :: parameter.snd :: [] - } - } - { # parameter.fst.Right :: storage :: parameter.snd :: [] - DIP { DROP } # passed_big_map :: parameter.snd :: [] - }; - DUP; # big_map :: big_map :: parameter.snd :: [] - DIG 2; # parameter.snd :: big_map :: big_map :: [] - DUP; # parameter.snd :: parameter.snd :: big_map :: big_map :: [] - IFGT - { # parameter.snd :: big_map :: big_map :: [] - PUSH int -1; - ADD; # parameter.snd - 1 :: big_map :: big_map :: [] - SWAP; # big_map :: parameter.snd - 1 :: big_map :: [] - RIGHT bool ; # Right big_map :: parameter.snd - 1 :: big_map :: [] - PAIR; # Right big_map * (parameter.snd - 1) :: big_map :: [] - DIP { SELF; PUSH mutez 0; }; # Right big_map * (parameter.snd - 1) :: 0 mutez :: self :: big_map :: [] - TRANSFER_TOKENS; # transfer_tokens :: big_map :: [] - NIL operation; # nil_operation :: transfer_tokens :: big_map :: [] - SWAP; # transfer_tokens :: nil_operation :: big_map :: [] - CONS # list operation :: big_map :: [] - } - { # parameter.snd :: big_map :: big_map :: [] - IFEQ - { # big_map :: big_map :: [] - DROP; # big_map :: [] - NIL operation; # list operation :: big_map :: [] - } - { # big_map :: big_map :: [] - PUSH mutez 0; # 0 mutez :: big_map :: big_map :: [] - NONE key_hash; # None key_hash :: 0 mutez :: big_map :: big_map :: [] - CREATE_CONTRACT - { - parameter unit; - storage (big_map int int); - code - { - UNPAIR; - DROP; - NIL operation; - PAIR - } - }; # create_contract :: address :: big_map :: [] - DIP { DROP }; # create_contract :: big_map :: [] - NIL operation; # nil_operation :: create_contract :: big_map :: [] - SWAP; # create_contract :: nil_operation :: big_map :: [] - CONS # list operation :: big_map :: [] - }; - }; - PAIR # (list operation * big_map) :: [] - } diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/dune b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/dune deleted file mode 100644 index 262c10969ad8331e7c4e83da44ae808b13eb09fb..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/dune +++ /dev/null @@ -1,84 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name - src_proto_017_PtNairob_lib_protocol_test_integration_michelson_tezt_lib) - (instrumentation (backend bisect_ppx)) - (libraries - tezt.core - octez-alcotezt - octez-libs.base - tezos-protocol-017-PtNairob.protocol - octez-protocol-017-PtNairob-libs.test-helpers - octez-libs.base-test-helpers - octez-protocol-017-PtNairob-libs.client - tezos-benchmark - octez-libs.micheline - tezos-benchmark-017-PtNairob - tezos-benchmark-type-inference-017-PtNairob - octez-protocol-017-PtNairob-libs.plugin - tezos-protocol-017-PtNairob.parameters) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezt_core - -open Tezt_core.Base - -open Octez_alcotezt - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_protocol_017_PtNairob - -open Tezos_017_PtNairob_test_helpers - -open Tezos_base_test_helpers - -open Tezos_client_017_PtNairob - -open Tezos_micheline - -open Tezos_benchmark_017_PtNairob - -open Tezos_benchmark_type_inference_017_PtNairob - -open Tezos_protocol_plugin_017_PtNairob) - (modules - test_annotations - test_block_time_instructions - test_contract_event - test_global_constants_storage - test_interpretation - test_lazy_storage_diff - test_patched_contracts - test_sapling - test_script_cache - test_script_typed_ir_size - test_temp_big_maps - test_ticket_accounting - test_ticket_balance_key - test_ticket_balance - test_ticket_lazy_storage_diff - test_ticket_manager - test_ticket_operations_diff - test_ticket_scanner - test_ticket_storage - test_typechecking - test_lambda_normalization)) - -(executable - (name main) - (instrumentation (backend bisect_ppx --bisect-sigterm)) - (libraries - src_proto_017_PtNairob_lib_protocol_test_integration_michelson_tezt_lib - tezt) - (link_flags - (:standard) - (:include %{workspace_root}/macos-link-flags.sexp)) - (modules main)) - -(rule - (alias runtest) - (package tezos-protocol-017-PtNairob-tests) - (deps - (glob_files contracts/*) - (glob_files patched_contracts/*) - (glob_files_rec ../../../../../../michelson_test_scripts/*)) - (enabled_if (<> false %{env:RUNTEZTALIAS=true})) - (action (run %{dep:./main.exe}))) - -(rule - (targets main.ml) - (action (with-stdout-to %{targets} (echo "let () = Tezt.Test.run ()")))) diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_annotations.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_annotations.ml deleted file mode 100644 index 1f930fea1470dd0aa49d53dcf1d918e9174b61b8..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_annotations.ml +++ /dev/null @@ -1,144 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (Michelson annotations) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/michelson/main.exe \ - -- --file test_annotations.ml - Subject: This module tests that Michelson annotations are properly handled. -*) - -open Protocol -open Alpha_context - -let type_with_annotations = - "(option :a (or :b (pair %c :d (int %e :f) (nat :g %h)) (bool %i :j)))" - -let contract_with_annotations = - Printf.sprintf - "{ parameter %s ;\n storage %s ;\n code { FAILWITH } }" - type_with_annotations - type_with_annotations - -let contract_factory_with_annotations = - Printf.sprintf - "{ parameter %s ;\n\ - \ storage (option address) ;\n\ - \ code { CAR ;\n\ - \ AMOUNT ;\n\ - \ NONE key_hash ;\n\ - \ CREATE_CONTRACT %s ;\n\ - \ DIP { SOME ;\n\ - \ NIL operation } ;\n\ - \ CONS ;\n\ - \ PAIR } }" - type_with_annotations - contract_with_annotations - -let lazy_none = Script.lazy_expr (Expr.from_string "None") - -let init_and_originate contract_code_string = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, source) -> - Incremental.begin_construction b >>=? fun inc -> - let code = Expr.toplevel_from_string contract_code_string in - let script = Script.{code = lazy_expr code; storage = lazy_none} in - Op.contract_origination_hash (I inc) source ~script - >>=? fun (operation, addr) -> - Incremental.add_operation inc operation >|=? fun inc -> (inc, source, addr) - -let assert_stored_script_equal inc addr expected_code_string = - Context.Contract.script (I inc) addr >>=? fun stored_script -> - Assert.equal_string - ~loc:__LOC__ - expected_code_string - (Expr.to_string stored_script) - -let get_address_from_storage inc factory_addr = - Context.Contract.storage (I inc) factory_addr >>=? fun factory_storage -> - let ctxt = Incremental.alpha_ctxt inc in - Environment.wrap_tzresult Script_typed_ir.(option_t 0 address_t) - >>?= fun option_address_t -> - Script_ir_translator.parse_data - ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:false ()) - ~allow_forged:false - option_address_t - (Micheline.root factory_storage) - >>= fun res -> - Environment.wrap_tzresult res >>?= fun (factory_storage, _ctxt) -> - match factory_storage with - | Some {entrypoint; _} when not (Entrypoint.is_default entrypoint) -> - failwith "Did not expect non-default entrypoint" - | Some {destination = Tx_rollup _; _} -> - failwith "Did not expect non-contract address" - | Some {destination = Contract (Implicit _); _} -> - failwith "Did not expect implict account" - | Some {destination = Contract (Originated addr); entrypoint = _it_is_default} - -> - return addr - | _ -> - failwith - "The factory contract should have stored the address of the originated \ - contract" - -(* Checks that [contract_with_annotations] once originated is stored as is. *) -let test_external_origination () = - init_and_originate contract_with_annotations >>=? fun (inc, _source, addr) -> - assert_stored_script_equal inc addr contract_with_annotations - -(* Checks that [contract_with_annotations] originated from - [contract_factory_with_annotations] is stored as is. *) -let test_internal_origination () = - init_and_originate contract_factory_with_annotations - >>=? fun (inc, source, factory) -> - Op.transaction - (I inc) - source - (Contract.Originated factory) - ~parameters:lazy_none - Tez.zero - >>=? fun operation -> - Incremental.finalize_block inc >>=? fun b -> - Incremental.begin_construction b >>=? fun inc -> - Incremental.add_operation inc operation >>=? fun inc -> - get_address_from_storage inc factory >>=? fun addr -> - assert_stored_script_equal inc addr contract_with_annotations - -let tests = - [ - Tztest.tztest - "External origination preserves annotations" - `Quick - test_external_origination; - Tztest.tztest - "Internal origination preserves annotations" - `Quick - test_internal_origination; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("annotations", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_block_time_instructions.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_block_time_instructions.ml deleted file mode 100644 index 8480d7babfebe4b98e824a43d4979a4d686dc9e4..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_block_time_instructions.ml +++ /dev/null @@ -1,84 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 TriliTech *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (Michelson block-time instructions) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/michelson/main.exe \ - -- --file test_block_time_instructions.ml - Subject: This module tests that Michelson instructions related to block time are correct. -*) - -open Tezos_protocol_017_PtNairob_parameters -open Protocol -open Alpha_context - -let context_with_constants constants = - let open Lwt_result_syntax in - let* block, _contracts = Context.init_with_constants1 constants in - let+ incremental = Incremental.begin_construction block in - Incremental.alpha_ctxt incremental - -let test_min_block_time () = - let open Lwt_result_syntax in - let* context = context_with_constants Default_parameters.constants_mainnet in - let* result, _ = - Contract_helpers.run_script - context - ~storage:"0" - ~parameter:"Unit" - {| { parameter unit; storage nat; code { DROP; MIN_BLOCK_TIME; NIL operation; PAIR } } |} - () - in - - let expected_value = - Default_parameters.constants_mainnet.minimal_block_delay - |> Period.to_seconds |> Z.of_int64 - in - - match Micheline.root result.storage with - | Int (_, result_storage) when Z.equal result_storage expected_value -> - return_unit - | _ -> - failwith - "Expected storage to be %a, but got %a" - Z.pp_print - expected_value - Micheline_printer.print_expr - (Micheline_printer.printable - Michelson_v1_primitives.string_of_prim - result.storage) - -let tests = - [ - Tztest.tztest - "MIN_BLOCK_TIME gives current minimal block delay" - `Quick - test_min_block_time; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("block time instructions", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_contract_event.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_contract_event.ml deleted file mode 100644 index 16f82977311cf543cdacb94fa3205ba1144f92f6..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_contract_event.ml +++ /dev/null @@ -1,140 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Marigold, *) -(* *) -(* 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 -open Alpha_context - -(** Testing - ------- - Component: Protocol (event logging) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/michelson/main.exe \ - -- --file test_contract_event.ml - Subject: This module tests that the event logs can be written to the receipt - in correct order and expected format. -*) - -(** Parse a Michelson contract from string. *) -let originate_contract file storage src b = - let open Lwt_result_syntax in - let load_file f = - let ic = open_in f in - let res = really_input_string ic (in_channel_length ic) in - close_in ic ; - res - in - let contract_string = load_file file in - let code = Expr.toplevel_from_string contract_string in - let storage = Expr.from_string storage in - let script = - Alpha_context.Script.{code = lazy_expr code; storage = lazy_expr storage} - in - let* operation, dst = - Op.contract_origination (B b) src ~fee:(Test_tez.of_int 10) ~script - in - let* incr = Incremental.begin_construction b in - let* incr = Incremental.add_operation incr operation in - let+ b = Incremental.finalize_block incr in - (dst, b) - -let path = project_root // Filename.dirname __FILE__ - -(** Run emit.tz and assert that both the order of events and data content are correct *) -let contract_test () = - let open Lwt_result_syntax in - let* b, src = Context.init1 ~consensus_threshold:0 () in - let* dst, b = originate_contract (path // "contracts/emit.tz") "Unit" src b in - let fee = Test_tez.of_int 10 in - let parameters = Script.unit_parameter in - let* operation = - Op.transaction ~fee ~parameters (B b) src dst (Test_tez.of_int 0) - in - let* incr = Incremental.begin_construction b in - let* incr = Incremental.add_operation incr operation in - match Incremental.rev_tickets incr with - | [ - Operation_metadata - { - contents = - Single_result - (Manager_operation_result - { - internal_operation_results = - [ - Internal_operation_result - ( { - operation = - Event {tag = tag1; payload = data1; ty = ty1}; - _; - }, - Applied (IEvent_result _) ); - Internal_operation_result - ( { - operation = - Event {tag = tag2; payload = data2; ty = ty2}; - _; - }, - Applied (IEvent_result _) ); - ]; - _; - }); - }; - ] -> - let open Micheline in - ((match root data1 with - | Prim (_, D_Right, [String (_, "right")], _) -> () - | _ -> assert false) ; - - match root data2 with - | Prim (_, D_Left, [Int (_, n)], _) -> assert (Z.to_int n = 2) - | _ -> assert false) ; - assert (Entrypoint.to_string tag1 = "tag1") ; - assert (Entrypoint.to_string tag2 = "tag2") ; - (match root ty1 with - | Prim (_, T_or, [Prim (_, T_nat, [], []); Prim (_, T_string, [], [])], []) - -> - () - | _ -> assert false) ; - (match root ty2 with - | Prim - ( _, - T_or, - [Prim (_, T_nat, [], ["%int"]); Prim (_, T_string, [], ["%str"])], - [] ) -> - () - | _ -> assert false) ; - return_unit - | _ -> assert false - -let tests = - [ - Tztest.tztest - "contract emits event with correct data in proper order" - `Quick - contract_test; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("event logging", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_global_constants_storage.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_global_constants_storage.ml deleted file mode 100644 index 3d986cd31af76544e1170af0f3d94b1972043f71..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_global_constants_storage.ml +++ /dev/null @@ -1,139 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Marigold *) -(* *) -(* 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 -open Alpha_context -open Transfers - -(** Testing - ------- - Component: Protocol (global table of constants) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/michelson/main.exe \ - -- --file test_global_constants_storage.ml - Subject: This module tests that the global table of constants - can be written to and read from across blocks. -*) - -let get_next_context b = - Incremental.begin_construction b >>=? fun b -> - return (Incremental.alpha_ctxt b) - -let assert_proto_error_id loc id result = - let test err = - (Error_monad.find_info_of_error err).id - = "proto." ^ Protocol.name ^ "." ^ id - in - Assert.error ~loc result test - -let expr_to_hash expr = - let lexpr = Script_repr.lazy_expr @@ Expr.from_string expr in - Script_repr.force_bytes lexpr >|? fun b -> Script_expr_hash.hash_bytes [b] - -(* This test has a long wind-up, but is very simple: it just asserts - that values written to the global table of constants persist across - blocks. *) -let get_happy_path () = - Context.init2 ~consensus_threshold:0 () >>=? fun (b, (alice, bob)) -> - Incremental.begin_construction b >>=? fun b -> - let expr_str = "Pair 3 7" in - let expr = Expr.from_string expr_str in - Environment.wrap_tzresult @@ expr_to_hash expr_str >>?= fun hash -> - Op.register_global_constant - (I b) - ~source:alice - ~value:(Script_repr.lazy_expr expr) - >>=? fun op -> - Incremental.add_operation b op >>=? fun b -> - Incremental.finalize_block b >>=? fun b -> - let assert_unchanged b = - get_next_context b >>=? fun context -> - Global_constants_storage.get context hash >|= Environment.wrap_tzresult - >>=? fun (_, result_expr) -> - Test_global_constants.assert_expr_equal __LOC__ expr result_expr - >|=? fun () -> b - in - assert_unchanged b >>=? fun b -> - let do_many_transfers b = - Incremental.begin_construction b >>=? fun b -> - n_transactions 10 b alice bob (Tez.of_mutez_exn 1000L) >>=? fun b -> - Incremental.finalize_block b >>=? fun b -> assert_unchanged b - in - do_many_transfers b >>=? do_many_transfers >>=? do_many_transfers - >>=? fun (_ : Block.t) -> Lwt.return_ok () - -(* Blocks that include a registration of a bad expression should - fail. *) -let test_registration_of_bad_expr_fails () = - Context.init1 () >>=? fun (b, alice) -> - Incremental.begin_construction b >>=? fun b -> - (* To produce the failure, we attempt to register an expression with - a malformed hash. *) - let expr = Expr.from_string "Pair 1 (constant \"foo\")" in - Op.register_global_constant - (I b) - ~source:alice - ~value:(Script_repr.lazy_expr expr) - >>=? fun op -> - Incremental.add_operation b op - >>= assert_proto_error_id __LOC__ "Badly_formed_constant_expression" - -(* You cannot register the same expression twice. *) -let test_no_double_register () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, alice) -> - let expr = Expr.from_string "Pair 1 2" in - Op.register_global_constant - (B b) - ~source:alice - ~value:(Script_repr.lazy_expr expr) - >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - (* Register the same expression again *) - Op.register_global_constant - (B b) - ~source:alice - ~value:(Script_repr.lazy_expr expr) - >>=? fun op -> - Incremental.begin_construction b >>=? fun i -> - Incremental.add_operation i op - >>= assert_proto_error_id __LOC__ "Expression_already_registered" - -let tests = - [ - Tztest.tztest "Multiple blocks happy path" `Quick get_happy_path; - Tztest.tztest - "Bad register global operations fail when added to the block" - `Quick - test_registration_of_bad_expr_fails; - Tztest.tztest - "You cannot register the same expression twice." - `Quick - test_no_double_register; - ] - -let () = - Alcotest_lwt.run - ~__FILE__ - Protocol.name - [("global table of constants", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_interpretation.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_interpretation.ml deleted file mode 100644 index 01315969cd98ba7a6105d3250d6de7918e666187..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_interpretation.ml +++ /dev/null @@ -1,458 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020-2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (interpretation) - Dependencies: src/proto_alpha/lib_protocol/script_interpreter.ml - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/michelson/main.exe \ - -- --file test_interpretation.ml - Subject: Interpretation of Michelson scripts -*) - -open Protocol -open Alpha_context -open Script_interpreter - -let test_context () = - Context.init3 () >>=? fun (b, _cs) -> - Incremental.begin_construction b >>=? fun v -> - return (Incremental.alpha_ctxt v) - -let logger = - Script_interpreter_logging.make - (module struct - let log_interp _ _ _ _ _ = () - - let log_entry _ _ _ _ _ = () - - let log_exit _ _ _ _ _ = () - - let log_control _ = () - - let get_log () = Lwt.return (Ok None) - end) - -let run_step ctxt code accu stack = - let open Script_interpreter in - let open Contract_helpers in - Internals.step_descr None ctxt default_step_constants code accu stack - >>=? fun ((_, _, ctxt') as r) -> - Internals.step_descr (Some logger) ctxt default_step_constants code accu stack - >>=? fun (_, _, ctxt'') -> - if Gas.(remaining_operation_gas ctxt' <> remaining_operation_gas ctxt'') then - Alcotest.failf "Logging should not have an impact on gas consumption." ; - return r - -(** Runs a script with an ill-typed parameter and verifies that a - Bad_contract_parameter error is returned. *) -let test_bad_contract_parameter () = - test_context () >>=? fun ctx -> - (* Run script with a parameter of wrong type *) - Contract_helpers.run_script - ctx - "{parameter unit; storage unit; code { CAR; NIL operation; PAIR }}" - ~storage:"Unit" - ~parameter:"0" - () - >>= function - | Ok _ -> Alcotest.fail "expected an error" - | Error (Environment.Ecoproto_error (Bad_contract_parameter source') :: _) -> - Alcotest.(check Testable.contract) - "incorrect field in Bad_contract_parameter" - (Contract.Originated Contract_helpers.default_self) - source' ; - return_unit - | Error errs -> - Alcotest.failf "Unexpected error: %a" Error_monad.pp_print_trace errs - -let test_multiplication_close_to_overflow_passes () = - test_context () >>=? fun ctx -> - (* Get sure that multiplication deals with numbers between 2^62 and - 2^63 without overflowing *) - Contract_helpers.run_script - ctx - "{parameter unit;storage unit;code {DROP; PUSH mutez 2944023901536524477; \ - PUSH nat 2; MUL; DROP; UNIT; NIL operation; PAIR}}" - ~storage:"Unit" - ~parameter:"Unit" - () - >>= function - | Ok _ -> return_unit - | Error errs -> - Alcotest.failf "Unexpected error: %a" Error_monad.pp_print_trace errs - -let dummy_loc = -1 - -(** The purpose of these two tests is to check that the Michelson interpreter is - stack-safe (because it is tail-recursive). - - This requires to confront it to deep recursions, typically deeper than what - the gas limit allows. Unfortunately we cannot run the interpreter in - unaccounted gas mode because for efficiency it uses a custom gas management - that represents the gas counter as a mere integer. Instead we set the gas - counter to the highest possible value ([Saturation_repr.saturated]); with - the current gas costs and limits this enables more than a million recursive - calls which is larger than the stack size. *) - -let test_stack_overflow () = - let open Script_typed_ir in - test_context () >>=? fun ctxt -> - (* Set the gas counter to the maximum value *) - let ctxt = - Gas.update_remaining_operation_gas ctxt - @@ Gas.fp_of_milligas_int (Saturation_repr.saturated :> int) - in - let stack = Bot_t in - let descr kinstr = {kloc = 0; kbef = stack; kaft = stack; kinstr} in - let enorme_et_seq n = - let rec aux n acc = - if n = 0 then acc - else aux (n - 1) (IPush (dummy_loc, Bool_t, true, IDrop (dummy_loc, acc))) - in - aux n (IHalt dummy_loc) - in - run_step ctxt (descr (enorme_et_seq 1_000_000)) EmptyCell EmptyCell - >>= function - | Ok _ -> return_unit - | Error trace -> - let trace_string = - Format.asprintf "%a" Environment.Error_monad.pp_trace trace - in - Alcotest.failf "Unexpected error (%s) at %s" trace_string __LOC__ - -(** The stack-safety of the interpreter relies a lot on the stack-safety of - Lwt.bind. This second test is similar to the previous one but uses an - instruction (IBig_map_mem) for which the interpreter calls Lwt.bind. *) - -let test_stack_overflow_in_lwt () = - let open Script_typed_ir in - test_context () >>=? fun ctxt -> - let ctxt = - Gas.update_remaining_operation_gas ctxt - @@ Gas.fp_of_milligas_int (Saturation_repr.saturated :> int) - in - let stack = Bot_t in - let descr kinstr = {kloc = 0; kbef = stack; kaft = stack; kinstr} in - let push_empty_big_map k = IEmpty_big_map (dummy_loc, unit_t, unit_t, k) in - let large_mem_seq n = - let rec aux n acc = - if n = 0 then acc - else - aux - (n - 1) - (IDup - ( dummy_loc, - IPush - ( dummy_loc, - Unit_t, - (), - IBig_map_mem (dummy_loc, IDrop (dummy_loc, acc)) ) )) - in - aux n (IDrop (dummy_loc, IHalt dummy_loc)) - in - let script = push_empty_big_map (large_mem_seq 1_000_000) in - run_step ctxt (descr script) EmptyCell EmptyCell >>= function - | Ok _ -> return_unit - | Error trace -> - let trace_string = - Format.asprintf "%a" Environment.Error_monad.pp_trace trace - in - Alcotest.failf "Unexpected error (%s) at %s" trace_string __LOC__ - -(** Test the encoding/decoding of script_interpreter.ml specific errors *) -let test_json_roundtrip name testable enc v = - let v' = - Data_encoding.Json.destruct enc (Data_encoding.Json.construct enc v) - in - Alcotest.check - testable - (Format.asprintf "round trip should not change value of %s" name) - v - v' ; - return_unit - -(** Encoding/decoding of script_interpreter.ml specific errors. *) -let test_json_roundtrip_err name e () = - test_json_roundtrip - name - Testable.protocol_error - Environment.Error_monad.error_encoding - e - -let error_encoding_tests = - let contract_zero = Contract.Implicit Signature.Public_key_hash.zero in - let script_expr_int = Micheline.strip_locations (Micheline.Int (0, Z.zero)) in - List.map - (fun (name, e) -> - Tztest.tztest - (Format.asprintf "test error encoding: %s" name) - `Quick - (test_json_roundtrip_err name e)) - [ - ("Reject", Reject (0, script_expr_int, None)); - ("Overflow", Overflow (0, None)); - ("Runtime_contract_error", Runtime_contract_error Contract_hash.zero); - ("Bad_contract_parameter", Bad_contract_parameter contract_zero); - ("Cannot_serialize_failure", Cannot_serialize_failure); - ("Cannot_serialize_storage", Cannot_serialize_storage); - ] - -module Test_map_instr_on_options = struct - type storage = {prev : int option; total : int} - - (* storage: (last input * total); param replaces the last input and - if some – gets added to the total. *) - let test_map_option_script = - {| { parameter (option int); - storage (pair (option int) int); - code { - UNPAIR ; - DIP { CDR } ; - MAP { - DUP ; - DIP { ADD } ; - } ; - PAIR ; - NIL operation ; - PAIR ; - } - } |} - - let run_test_map_opt_script param {prev; total} = - let storage = - Option.fold - ~none:(Format.sprintf "Pair None %d" total) - ~some:(fun p -> Format.sprintf "Pair (Some %d) %d" p total) - prev - in - let parameter = - Option.fold ~none:"None" ~some:(Format.sprintf "Some %d") param - in - test_context () >>=? fun ctxt -> - Contract_helpers.run_script - ctxt - test_map_option_script - ~storage - ~parameter - () - - let assume_storage_shape = - let open Micheline in - let open Michelson_v1_primitives in - function - | Prim (_, D_Pair, [Prim (_, D_None, [], _); Int (_, total)], _) -> - {prev = None; total = Z.to_int total} - | Prim (_, D_Pair, [Prim (_, D_Some, [Int (_, prev)], _); Int (_, total)], _) - -> - {prev = Some (Z.to_int prev); total = Z.to_int total} - | _ -> QCheck2.assume_fail () - - let assertions storage_before storage_after = function - | None -> - Assert.is_none ~loc:__LOC__ ~pp:Format.pp_print_int storage_after.prev - >>=? fun () -> - Assert.equal_int ~loc:__LOC__ storage_before.total storage_after.total - | Some input -> - Assert.get_some ~loc:__LOC__ storage_after.prev >>=? fun prev_aft -> - Assert.equal_int ~loc:__LOC__ input prev_aft >>=? fun () -> - Assert.equal_int - ~loc:__LOC__ - (storage_before.total + input) - storage_after.total - - let test_mapping (input, prev, total) = - let storage_before = {prev; total} in - run_test_map_opt_script input storage_before >>=? fun ({storage; _}, _) -> - let new_storage = assume_storage_shape (Micheline.root storage) in - assertions storage_before new_storage input -end - -let test_contract path storage param ~entrypoint_str ~ok ~ko = - let entrypoint = - match entrypoint_str with - | None -> Entrypoint.default - | Some str -> Entrypoint.of_string_strict_exn str - in - test_context () >>=? fun ctx -> - let read_file filename = - let ch = open_in filename in - let s = really_input_string ch (in_channel_length ch) in - close_in ch ; - s - in - let script = read_file path in - Contract_helpers.run_script - ctx - script - ~storage - ~parameter:param - ~entrypoint - () - >>= function - | Ok (res, _) -> ok res - | Error t -> ko t - -let fail_with_trace trace = - Alcotest.failf "Unexpected error: %a" Error_monad.pp_print_trace trace - -let test_contract_success path storage param expected_storage_str - ?entrypoint_str () = - let expected_storage = Expr.from_string expected_storage_str in - test_contract - path - storage - param - ~ok:(fun real -> - if real.storage = expected_storage then return_unit - else Alcotest.fail "Unexpected result") - ~ko:fail_with_trace - ~entrypoint_str - -let test_contract_fail path storage param ?entrypoint_str () = - test_contract - path - storage - param - ~ok:(fun _ -> - Alcotest.failf - "Unexpected success: interpreting %s should have failed." - path) - ~ko:(fun _ -> return_unit) - ~entrypoint_str - -let test_store_and_reload path ~init_storage ~entrypoint_str_1 ~param_1 - ~expected_storage_str_1 ~entrypoint_str_2 ~param_2 ~expected_storage_str_2 - () = - let expected_storage_1 = Expr.from_string expected_storage_str_1 in - test_contract - path - init_storage - param_1 - ~entrypoint_str:(Some entrypoint_str_1) - ~ok:(fun real -> - if real.storage = expected_storage_1 then - test_contract_success - path - expected_storage_str_1 - param_2 - expected_storage_str_2 - ~entrypoint_str:entrypoint_str_2 - () - else - Alcotest.failf - "Unexpected result. \n Expected :\n %s \n Real : \n %s \n" - (Expr.to_string expected_storage_1) - (Expr.to_string real.storage)) - ~ko:fail_with_trace - -let path = project_root // Filename.dirname __FILE__ - -let tests = - [ - Tztest.tztest "bad contract error" `Quick test_bad_contract_parameter; - Tztest.tztest "check robustness overflow error" `Slow test_stack_overflow; - Tztest.tztest - "check robustness overflow error in lwt" - `Slow - test_stack_overflow_in_lwt; - Tztest.tztest - "multiplication no illegitimate overflow" - `Quick - test_multiplication_close_to_overflow_passes; - Tztest.tztest "stack overflow error" `Slow test_stack_overflow; - Tztest.tztest_qcheck2 - ~name:"map instr against options" - QCheck2.Gen.( - triple (opt small_signed_int) (opt small_signed_int) small_signed_int) - Test_map_instr_on_options.test_mapping; - Tztest.tztest - "lambda_rec instruction" - `Quick - (test_contract_success (path // "contracts/rec_fact.tz") "0" "5" "120"); - Tztest.tztest - "lambda_rec instruction with apply" - `Quick - (test_contract_success - (path // "contracts/rec_fact_apply.tz") - "0" - "5" - "120"); - Tztest.tztest - "lambda_rec instruction with an infinite recursion" - `Quick - (test_contract_fail (path // "contracts/omega.tz") "Unit" "Unit"); - Tztest.tztest - "lambda_rec instruction storage" - `Quick - (test_store_and_reload - (path // "contracts/rec_fact_store.tz") - ~init_storage:"Left 0" - ~entrypoint_str_1:"gen" - ~param_1:"Unit" - ~expected_storage_str_1: - {|Right - (Lambda_rec - { DUP ; - EQ ; - IF { PUSH int 1 } { DUP ; DUP 3 ; PUSH int 1 ; DUP 4 ; SUB - ; EXEC ; MUL } ; - DIP { DROP 2 } })|} - ~entrypoint_str_2:"exec" - ~param_2:"5" - ~expected_storage_str_2:"Left 120"); - Tztest.tztest - "lambda_rec instruction storage apply store" - `Quick - (test_store_and_reload - (path // "contracts/rec_fact_apply_store.tz") - ~init_storage:"Left 0" - ~entrypoint_str_1:"gen" - ~param_1:"Unit" - ~expected_storage_str_1: - {|Right - { PUSH unit Unit ; - PAIR ; - LAMBDA_REC - (pair unit int) - int - { UNPAIR ; - DUP 2 ; - EQ ; - IF { PUSH int 1 } - { DUP 2 ; DUP 4 ; DUP 3 ; APPLY ; PUSH int 1 ; DUP 3 ; - SUB ; EXEC ; MUL } ; - DIP { DROP 3 } } ; - SWAP ; - EXEC }|} - ~entrypoint_str_2:"exec" - ~param_2:"5" - ~expected_storage_str_2:"Left 120"); - ] - @ error_encoding_tests - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("interpretation", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_lambda_normalization.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_lambda_normalization.ml deleted file mode 100644 index 2bcd8f3eddb7628f2471485897bbdaa4be332380..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_lambda_normalization.ml +++ /dev/null @@ -1,238 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (Michelson) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/michelson/main.exe \ - -- --file test_lambda_normalization.ml - Subject: Test that lambdas are normalized to optimized format at elaboration -*) - -open Protocol -open Alpha_context -open Script_typed_ir - -let new_ctxt () = - let open Lwt_result_wrap_syntax in - let* block, _contract = Context.init1 () in - let+ incr = Incremental.begin_construction block in - Incremental.alpha_ctxt incr - -let parse_and_project (ty : ((_, _) lambda, _) ty) (node : Script.node) = - let open Lwt_result_wrap_syntax in - let* ctxt = new_ctxt () in - let elab_conf = Script_ir_translator_config.make ~legacy:false () in - let*@ lam, _ctxt = - Script_ir_translator.parse_data ~elab_conf ctxt ~allow_forged:false ty node - in - match lam with - | Lam (_kdescr, node) -> return node - | LamRec (_kdescr, node) -> - return - Micheline.( - Prim (dummy_location, Michelson_v1_primitives.D_Lambda_rec, [node], [])) - -let node_of_string str = - let open Lwt_result_wrap_syntax in - let*? parsed = - Micheline_parser.no_parsing_error - @@ Michelson_v1_parser.parse_expression ~check:false str - in - return @@ Micheline.root parsed.expanded - -let node_to_string node = - Format.asprintf - "%a" - Micheline_printer.print_expr - ((Micheline_printer.printable Michelson_v1_primitives.string_of_prim) - (Micheline.strip_locations node)) - -let assert_lambda_normalizes_to ~loc ty str expected = - let open Lwt_result_wrap_syntax in - let* node = node_of_string str in - let* node_normalized = parse_and_project ty node in - let str_normalized = node_to_string node_normalized in - let* expected_node = node_of_string expected in - let expected = node_to_string expected_node in - Assert.equal_string ~loc expected str_normalized - -let assert_normalizes_to ~loc ty str expected = - let open Lwt_result_wrap_syntax in - let* () = assert_lambda_normalizes_to ~loc ty str expected in - let* () = - assert_lambda_normalizes_to - ~loc - ty - ("Lambda_rec " ^ str) - ("Lambda_rec " ^ expected) - in - return_unit - -let test_lambda_normalization () = - let open Lwt_result_wrap_syntax in - let*?@ ty = - Script_typed_ir.(lambda_t Micheline.dummy_location unit_t never_t) - in - let*?@ lam_unit_unit = - Script_typed_ir.(lambda_t Micheline.dummy_location unit_t unit_t) - in - let* () = - (* Empty sequence normalizes to itself. *) - assert_lambda_normalizes_to ~loc:__LOC__ lam_unit_unit "{}" "{}" - in - let* () = - (* Another example normalizing to itself. *) - assert_normalizes_to ~loc:__LOC__ ty "{FAILWITH}" "{FAILWITH}" - in - let* () = - (* Readable address normalizes to optimized. *) - assert_normalizes_to - ~loc:__LOC__ - ty - {|{PUSH address "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"; FAILWITH}|} - {|{PUSH address 0x000002298c03ed7d454a101eb7022bc95f7e5f41ac78; FAILWITH}|} - in - let* () = - (* Binary pair normalizes to itself. *) - assert_normalizes_to - ~loc:__LOC__ - ty - {|{PUSH (pair nat nat) (Pair 0 0); FAILWITH}|} - {|{PUSH (pair nat nat) (Pair 0 0); FAILWITH}|} - in - let* () = - (* Ternary pair normalizes to nested binary pairs. Type is unchanged. *) - assert_normalizes_to - ~loc:__LOC__ - ty - {|{PUSH (pair nat nat nat) (Pair 0 0 0); FAILWITH}|} - {|{PUSH (pair nat nat nat) (Pair 0 (Pair 0 0)); FAILWITH}|} - in - let* () = - (* Same with nested pairs in type. Type is still unchanged. *) - assert_normalizes_to - ~loc:__LOC__ - ty - {|{PUSH (pair nat (pair nat nat)) (Pair 0 0 0); FAILWITH}|} - {|{PUSH (pair nat (pair nat nat)) (Pair 0 (Pair 0 0)); FAILWITH}|} - in - let* () = - (* Quadrary pair normalizes to sequence. Type is unchanged. *) - assert_normalizes_to - ~loc:__LOC__ - ty - {|{PUSH (pair nat nat nat nat) (Pair 0 0 0 0); FAILWITH}|} - {|{PUSH (pair nat nat nat nat) {0; 0; 0; 0}; FAILWITH}|} - in - let* () = - (* Code inside LAMBDA is normalized too. *) - assert_normalizes_to - ~loc:__LOC__ - ty - {|{LAMBDA unit never - {PUSH address "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"; FAILWITH}; - FAILWITH}|} - {|{LAMBDA unit never - {PUSH address 0x000002298c03ed7d454a101eb7022bc95f7e5f41ac78; FAILWITH}; - FAILWITH}|} - in - let* () = - (* Same with LAMBDA replaced by PUSH. *) - assert_normalizes_to - ~loc:__LOC__ - ty - {|{PUSH (lambda unit never) - {PUSH address "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"; FAILWITH}; - FAILWITH}|} - {|{PUSH (lambda unit never) - {PUSH address 0x000002298c03ed7d454a101eb7022bc95f7e5f41ac78; FAILWITH}; - FAILWITH}|} - in - let* () = - (* Code inside LAMBDA_REC is normalized too. *) - assert_normalizes_to - ~loc:__LOC__ - ty - {|{LAMBDA_REC unit never - {PUSH address "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"; - FAILWITH}; - FAILWITH}|} - {|{LAMBDA_REC unit never - {PUSH address 0x000002298c03ed7d454a101eb7022bc95f7e5f41ac78; - FAILWITH}; - FAILWITH}|} - in - let* () = - (* Same with LAMBDA_REC replaced by PUSH. *) - assert_normalizes_to - ~loc:__LOC__ - ty - {|{PUSH (lambda unit never) - (Lambda_rec - {PUSH address "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"; - FAILWITH}); - FAILWITH}|} - {|{PUSH (lambda unit never) - (Lambda_rec - {PUSH address 0x000002298c03ed7d454a101eb7022bc95f7e5f41ac78; - FAILWITH}); - FAILWITH}|} - in - let* () = - (* Code inside CREATE_CONTRACT is normalized too. *) - assert_normalizes_to - ~loc:__LOC__ - ty - {|{PUSH mutez 0; - NONE key_hash; - CREATE_CONTRACT - {parameter unit; - storage unit; - code { PUSH address "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"; FAILWITH}}; - DROP; - FAILWITH}|} - {|{PUSH mutez 0; - NONE key_hash; - CREATE_CONTRACT - {parameter unit; - storage unit; - code { PUSH address 0x000002298c03ed7d454a101eb7022bc95f7e5f41ac78; FAILWITH}}; - DROP; - FAILWITH}|} - in - return_unit - -let tests = - [ - Tztest.tztest - "lambdas are normalized to optimized format during elaboration" - `Quick - test_lambda_normalization; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("lambda normalization", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_lazy_storage_diff.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_lazy_storage_diff.ml deleted file mode 100644 index 7cd63c37976b51670fc3e28aa1d16f6a9723b52c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_lazy_storage_diff.ml +++ /dev/null @@ -1,152 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (Michelson) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/michelson/main.exe \ - -- --file test_lazy_storage_diff.ml - Subject: Test lazy storage -*) - -open Protocol - -(** Generation of input data *) - -let ids = - [|1; 42; 1337; 1984|] |> Array.map Z.of_int - |> Array.map Lazy_storage_kind.Big_map.Id.parse_z - -let strs = [|"0"; "True"; "nat"; "bool"|] - -let exprs = strs |> Array.map Expr.from_string - -let hashes = - strs |> Array.map (fun x -> [x]) |> Array.map Script_expr_hash.hash_string - -let updates_len_existing = [1; 2; 3] - -let updates_len_other = 0 :: updates_len_existing - -let gen_inits idx : - (( Lazy_storage_kind.Big_map.Id.t, - Lazy_storage_kind.Big_map.alloc ) - Lazy_storage_diff.init - * int list) - list = - [ - (Existing, updates_len_existing); - (Copy {src = ids.(idx - 1)}, updates_len_other); - ( Alloc {key_type = exprs.(idx); value_type = exprs.(idx - 1)}, - updates_len_other ); - ] - -let gen_update_list idx : Lazy_storage_kind.Big_map.update list = - [None; Some exprs.(idx)] - |> List.map (fun value -> - Lazy_storage_kind.Big_map. - {key = exprs.(idx); key_hash = hashes.(idx); value}) - -let rec gen_updates updates_len : Lazy_storage_kind.Big_map.updates list = - if updates_len = 0 then [] - else - gen_updates (updates_len - 1) - |> List.map (fun suffix -> - gen_update_list updates_len - |> List.map (fun prefix -> prefix :: suffix)) - |> List.flatten - -let gen_updates_list updates_lens : Lazy_storage_kind.Big_map.updates list = - updates_lens |> List.map gen_updates |> List.flatten - -let gen_diffs idx : - ( Lazy_storage_kind.Big_map.Id.t, - Lazy_storage_kind.Big_map.alloc, - Lazy_storage_kind.Big_map.updates ) - Lazy_storage_diff.diff - list = - let open Lazy_storage_diff in - Remove - :: (gen_inits idx - |> List.map (fun (init, updates_lens) -> - gen_updates_list updates_lens - |> List.map (fun updates -> Update {init; updates})) - |> List.flatten) - -let gen_diffs_items idx : Lazy_storage_diff.diffs_item list = - let id = ids.(idx) in - gen_diffs idx |> List.map (fun diff -> Lazy_storage_diff.make Big_map id diff) - -let rec gen_diffs_list len : Lazy_storage_diff.diffs list = - if len = 0 then [] - else - gen_diffs_list (len - 1) - |> List.map (fun suffix -> - gen_diffs_items len |> List.map (fun prefix -> prefix :: suffix)) - |> List.flatten - -let diffs_list_lens = [0; 1; 2; 3] - -let diffs_list : Lazy_storage_diff.diffs list = - diffs_list_lens |> List.map gen_diffs_list |> List.flatten - -(** Properties to check *) - -let conversion_roundtrip lazy_storage_diff = - let legacy_big_map_diff = - Contract_storage.Legacy_big_map_diff.of_lazy_storage_diff lazy_storage_diff - in - let reconverted = - Contract_storage.Legacy_big_map_diff.to_lazy_storage_diff - legacy_big_map_diff - in - assert (Stdlib.( = ) reconverted lazy_storage_diff) - -let encoding_roundtrip lazy_storage_diff = - let encoded = - Data_encoding.Binary.to_bytes_exn - Lazy_storage_diff.encoding - lazy_storage_diff - in - match Data_encoding.Binary.of_bytes Lazy_storage_diff.encoding encoded with - | Ok decoded -> assert (Stdlib.( = ) decoded lazy_storage_diff) - | Error _ -> Stdlib.failwith "Decoding failed" - -(** Iterator and test definitions *) - -let on_diffs f () = - List.iter f diffs_list ; - return_unit - -(* Marked Slow because they take 5 to 10 seconds and are unlikely to change *) -let tests = - [ - Tztest.tztest "conversion roundtrip" `Slow (on_diffs conversion_roundtrip); - Tztest.tztest "encoding roundtrip" `Slow (on_diffs encoding_roundtrip); - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("lazy storage diff", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_patched_contracts.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_patched_contracts.ml deleted file mode 100644 index 98d194e53b9719c7b6c44b7ed4e3346591f32d9f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_patched_contracts.ml +++ /dev/null @@ -1,222 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol Migration (patched scripts) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/michelson/main.exe \ - -- --file test_patched_contracts.ml - Subject: Migration -*) - -open Tezos_micheline -open Protocol - -module type LEGACY_SCRIPT_PATCHES = sig - type t - - val script_hash : t -> Script_expr_hash.t - - val code : t -> Michelson_v1_primitives.prim Micheline.canonical - - val patches : t list -end - -module type LEGACY_PATCH_TESTS = sig - type t - - val tests : t -> unit Alcotest_lwt.test_case list -end - -let script_hash_testable = - Alcotest.testable Script_expr_hash.pp Script_expr_hash.equal - -(** This functor provides testing for legacy script patches. Patches to - be tested should be placed in a module conformal to the signature - [LEGACY_SCRIPT_PATCHES]. It should contain a list of patches and for - each patch it has to provide a hash of the patched contract and the - new code (as binary-encoded Micheline). - - Additionally for each patch 3 files need to be placed in - [patched_contracts] subdirectory: - * script_hash.original.tz – containing the original version of the - script; - * script_hash.patched.tz - containing the patched version; - * script_hash.diff - containing the diff between the two. - - These files are there so that reviewers of the migration can easily - see what changes are made to each contract and these tests make sure - that the patched code supplied in file is identical to the one - included in the migration; and that the diff is correct. *) -module Legacy_patch_test (Patches : LEGACY_SCRIPT_PATCHES) : - LEGACY_PATCH_TESTS with type t = Patches.t = struct - type t = Patches.t - - let readable_micheline m = - let open Micheline in - map_node (fun _ -> ()) Michelson_v1_primitives.string_of_prim (root m) - - let path = project_root // Filename.dirname __FILE__ - - let contract_path ?(ext = "patched.tz") hash = - Filename.concat "patched_contracts" - @@ Format.asprintf "%a.%s" Script_expr_hash.pp hash ext - - let read_file ?ext hash = - let filename = path // contract_path ?ext hash in - Lwt_io.(with_file ~mode:Input filename read) - - (* Test that the hashes of the scripts in ./patched_contract/.original.tz - match hashes of the contracts being updated by the migration. *) - let test_original_contract legacy_script_hash () = - let open Lwt_result_syntax in - let*! code = read_file ~ext:"original.tz" legacy_script_hash in - let michelson = Michelson_v1_parser.parse_toplevel ~check:true code in - let*? prog = Micheline_parser.no_parsing_error michelson in - let bytes = - Data_encoding.Binary.to_bytes_exn - Alpha_context.Script.expr_encoding - prog.expanded - in - Alcotest.check - script_hash_testable - "Expr hash doesn't match" - legacy_script_hash - (Script_expr_hash.hash_bytes [bytes]) ; - return () - - (* Test that the binary-encoded versions of the patched contracts used during the - migration correspond to the content of the `./patched_contracts/.tz` - files *) - let test_patched_contract patch () = - let open Lwt_result_syntax in - let*! expected_michelson = read_file @@ Patches.script_hash patch in - let*? program = - Micheline_parser.no_parsing_error - @@ Michelson_v1_parser.parse_toplevel ~check:true expected_michelson - in - match - Micheline_diff.diff - ~prev:(readable_micheline @@ Patches.code patch) - ~current:(readable_micheline program.expanded) - () - with - | Some diff -> - let msg = - Format.asprintf - "Patched code for %a different than expected!\n%a" - Script_expr_hash.pp - (Patches.script_hash patch) - Micheline_printer.print_expr - diff - in - Alcotest.fail msg - | None -> return () - - (* Test that the diff files `./patched_contracts/.diff` - are the results of the `diff` command on the corresponding - original and patched files *) - let verify_diff legacy_script_hash () = - let open Lwt_result_syntax in - let*! expected_diff = read_file ~ext:"diff" legacy_script_hash in - let original_code = contract_path ~ext:"original.tz" legacy_script_hash in - (* The other test asserts that this is indeed the patched code. *) - let current_code = contract_path ~ext:"patched.tz" legacy_script_hash in - let diff_cmd = - ( "", - [| - "diff"; - "-u"; - "--label"; - original_code; - "--label"; - current_code; - original_code; - current_code; - |] ) - in - let*! actual_diff = Lwt_process.pread ~cwd:path diff_cmd in - Alcotest.(check string) "same diff" expected_diff actual_diff ; - return () - - let typecheck_patched_script code () = - let open Lwt_result_syntax in - (* Number 3 below controls how many accounts should be - created. This number shouldn't be too small or the context - won't have enough at least [minimal_stake] tokens. *) - let* block, _contracts = Context.init3 () in - let* inc = Incremental.begin_construction block in - let ctxt = Incremental.alpha_ctxt inc in - let* _code, _ctxt = - Lwt.map Environment.wrap_tzresult - @@ Script_ir_translator.parse_code - ~elab_conf:Script_ir_translator_config.(make ~legacy:false ()) - ~code:(Script_repr.lazy_expr code) - ctxt - in - return () - - let tests (patch : Patches.t) = - let script_hash = Patches.script_hash patch in - [ - Tztest.tztest - (Format.asprintf - "check original contract hash %a" - Script_expr_hash.pp - script_hash) - `Quick - (test_original_contract script_hash); - Tztest.tztest - (Format.asprintf - "check patched contract %a" - Script_expr_hash.pp - script_hash) - `Quick - (test_patched_contract patch); - Tztest.tztest - (Format.asprintf "verify patch for %a" Script_expr_hash.pp script_hash) - `Quick - (verify_diff script_hash); - Tztest.tztest - (Format.asprintf "type check %a" Script_expr_hash.pp script_hash) - `Quick - (typecheck_patched_script @@ Patches.code patch); - ] -end - -(* List modules containing patched scripts here: *) -let test_modules : (module LEGACY_SCRIPT_PATCHES) list = - [(module Legacy_script_patches)] - -let tests = - List.concat_map - (fun (module Patches : LEGACY_SCRIPT_PATCHES) -> - let module Test = Legacy_patch_test (Patches) in - List.concat_map Test.tests Patches.patches) - test_modules - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("patched contracts", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_sapling.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_sapling.ml deleted file mode 100644 index 96f4751072622e9f888f0cff8a1461091ca09049..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_sapling.ml +++ /dev/null @@ -1,1232 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020-2022 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (Sapling) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/michelson/main.exe \ - -- --file test_sapling.ml - Subject: On the privacy-preserving library Sapling -*) - -open Protocol -open Alpha_context -open Test_tez - -let ( >>??= ) x y = - match x with - | Ok s -> y s - | Error err -> Lwt.return @@ Error (Environment.wrap_tztrace err) - -module Raw_context_tests = struct - open Sapling_helpers.Common - - (* This test adds to the first 100 positions in the commitments tree the - constant value `uncommitted` for which we know the corresponding root and - tests that the returned root is as expected. *) - let commitments_add_uncommitted () = - Context.init1 () >>=? fun (b, _contract) -> - Raw_context.prepare - b.context - ~level:b.header.shell.level - ~predecessor_timestamp:b.header.shell.timestamp - ~timestamp:b.header.shell.timestamp - >>= wrap - >>=? fun ctx -> - let module H = Tezos_sapling.Core.Client.Hash in - let cm = H.uncommitted ~height:0 in - let expected_root = H.uncommitted ~height:32 in - Lazy_storage_diff.fresh Lazy_storage_kind.Sapling_state ~temporary:false ctx - >>= wrap - >>=? fun (ctx, id) -> - Sapling_storage.init ctx id ~memo_size:0 >>= wrap >>=? fun ctx -> - List.fold_left_es - (fun ctx pos -> - Sapling_storage.Commitments.get_root ctx id >>= wrap - >>=? fun (ctx, root) -> - assert (root = expected_root) ; - Sapling_storage.Commitments.add - ctx - id - [H.to_commitment cm] - (Int64.of_int pos) - >>= wrap - >>=? fun (ctx, _size) -> - Sapling_storage.Commitments.get_root ctx id >>= wrap - >|=? fun (ctx, root) -> - assert (root = expected_root) ; - ctx) - ctx - (0 -- 99) - >>=? fun (_ctx : Raw_context.t) -> return_unit - - (* Nullifiers don't check for duplicates are it's done by verify_update, - however committing to disk twice the same nf causes a storage error by - trying to initialize the same key twice. *) - let nullifier_double () = - Context.init1 () >>=? fun (b, _contract) -> - Raw_context.prepare - b.context - ~level:b.header.shell.level - ~predecessor_timestamp:b.header.shell.timestamp - ~timestamp:b.header.shell.timestamp - >>= wrap - >>=? fun ctx -> - Lazy_storage_diff.fresh Lazy_storage_kind.Sapling_state ~temporary:false ctx - >>= wrap - >>=? fun (ctx, id) -> - Sapling_storage.init ctx id ~memo_size:0 >>= wrap >>=? fun ctx -> - let nf = gen_nf () in - let open Sapling_storage in - let state = - {id = Some id; diff = Sapling_storage.empty_diff; memo_size = 0} - in - let state = nullifiers_add state nf in - let state = nullifiers_add state nf in - assert (Compare.List_length_with.(state.diff.nullifiers = 2)) ; - Sapling_storage.Nullifiers.size ctx id >>= wrap >>=? fun disk_size -> - assert (disk_size = 0L) ; - Sapling_storage.apply_diff ctx id state.diff |> assert_error - - (* In this test we add two lists of nullifiers to the state, one is applied to - the context (committed to disk) and one is kept in kept in a diff (only in - memory). We then check that nullifier_mem answers true for those two lists - and false for a third one. *) - let nullifier_test () = - Context.init1 () >>=? fun (b, _contract) -> - Raw_context.prepare - b.context - ~level:b.header.shell.level - ~predecessor_timestamp:b.header.shell.timestamp - ~timestamp:b.header.shell.timestamp - >>= wrap - >>=? fun ctx -> - Lazy_storage_diff.fresh Lazy_storage_kind.Sapling_state ~temporary:false ctx - >>= wrap - >>=? fun (ctx, id) -> - Sapling_storage.init ctx id ~memo_size:0 >>= wrap >>=? fun ctx -> - let nf_list_ctx = - WithExceptions.List.init ~loc:__LOC__ 10 (fun _ -> gen_nf ()) - in - let state = - List.fold_left - (fun state nf -> Sapling_storage.nullifiers_add state nf) - {id = Some id; diff = Sapling_storage.empty_diff; memo_size = 0} - nf_list_ctx - in - Sapling_storage.apply_diff ctx id state.diff >>= wrap >>=? fun (ctx, _) -> - let nf_list_diff = - WithExceptions.List.init ~loc:__LOC__ 10 (fun _ -> gen_nf ()) - in - let state = - List.fold_left - (fun state nf -> Sapling_storage.nullifiers_add state nf) - state - nf_list_diff - in - List.iter_ep - (fun nf -> - Sapling_storage.nullifiers_mem ctx state nf >>= wrap - >>=? fun (_, bool) -> - assert bool ; - return_unit) - (nf_list_ctx @ nf_list_diff) - >>=? fun () -> - let nf_list_absent = - WithExceptions.List.init ~loc:__LOC__ 10 (fun _ -> gen_nf ()) - in - List.iter_ep - (fun nf -> - Sapling_storage.nullifiers_mem ctx state nf >>= wrap - >>=? fun (_, bool) -> - assert (not bool) ; - return_unit) - nf_list_absent - - (* This test applies a diff with tuples of ciphertext, commitment. Then it - checks the result of get_from with different indexes. *) - let cm_cipher_test () = - Random.self_init () ; - let memo_size = Random.int 200 in - Context.init1 () >>=? fun (b, _contract) -> - Raw_context.prepare - b.context - ~level:b.header.shell.level - ~predecessor_timestamp:b.header.shell.timestamp - ~timestamp:b.header.shell.timestamp - >>= wrap - >>=? fun ctx -> - Lazy_storage_diff.fresh Lazy_storage_kind.Sapling_state ~temporary:false ctx - >>= wrap - >>=? fun (ctx, id) -> - Sapling_storage.init ctx id ~memo_size >>= wrap >>=? fun ctx -> - Sapling_storage.state_from_id ctx id >>= wrap >>=? fun (diff, ctx) -> - let list_added = - WithExceptions.List.init ~loc:__LOC__ 10 (fun _ -> - gen_cm_cipher ~memo_size ()) - in - let state = Sapling_storage.add diff list_added in - Sapling_storage.apply_diff ctx id state.diff >>= wrap >>=? fun (ctx, _) -> - let rec test_from from until expected = - if from > until then return_unit - else - Sapling_storage.Ciphertexts.get_from ctx id from >>= wrap - >>=? fun (ctx, result) -> - let expected_cipher = List.map snd expected in - assert (result = expected_cipher) ; - Sapling_storage.Commitments.get_from ctx id from >>= wrap - >>=? fun result -> - let expected_cm = List.map fst expected in - assert (result = expected_cm) ; - test_from - (Int64.succ from) - until - (WithExceptions.Option.get ~loc:__LOC__ @@ List.tl expected) - in - test_from 0L 9L list_added - - (* This test tests the insertion of a list vs inserting one by one. - It does so by checking the equality of the roots. *) - let list_insertion_test () = - Random.self_init () ; - let memo_size = Random.int 200 in - Context.init1 () >>=? fun (b, _contract) -> - Raw_context.prepare - b.context - ~level:b.header.shell.level - ~predecessor_timestamp:b.header.shell.timestamp - ~timestamp:b.header.shell.timestamp - >>= wrap - >>=? fun ctx -> - Lazy_storage_diff.fresh Lazy_storage_kind.Sapling_state ~temporary:false ctx - >>= wrap - >>=? fun (ctx, id_one_by_one) -> - Sapling_storage.init ctx id_one_by_one ~memo_size >>= wrap >>=? fun ctx -> - let list_to_add = - fst @@ List.split - @@ WithExceptions.List.init ~loc:__LOC__ 33 (fun _ -> - gen_cm_cipher ~memo_size ()) - in - let rec test counter ctx = - if counter >= 32 then return_unit - else - (* add a single cm to the existing tree *) - Sapling_storage.Commitments.add - ctx - id_one_by_one - [ - WithExceptions.Option.get ~loc:__LOC__ - @@ List.nth list_to_add counter; - ] - (Int64.of_int counter) - >>= wrap - (* create a new tree and add a list of cms *) - >>=? fun (ctx, _size) -> - Lazy_storage_diff.fresh - Lazy_storage_kind.Sapling_state - ~temporary:false - ctx - >>= wrap - >>=? fun (ctx, id_all_at_once) -> - Sapling_storage.init ctx id_all_at_once ~memo_size >>= wrap - >>=? fun ctx -> - Sapling_storage.Commitments.add - ctx - id_all_at_once - (WithExceptions.List.init ~loc:__LOC__ (counter + 1) (fun i -> - WithExceptions.Option.get ~loc:__LOC__ @@ List.nth list_to_add i)) - 0L - >>= wrap - >>=? fun (ctx, _size) -> - Sapling_storage.Commitments.get_root ctx id_one_by_one >>= wrap - >>=? fun (ctx, root_one_by_one) -> - Sapling_storage.Commitments.get_root ctx id_all_at_once >>= wrap - >>=? fun (ctx, root_all_at_once) -> - assert (root_all_at_once = root_one_by_one) ; - test (counter + 1) ctx - in - test 0 ctx - - (* This test adds 10 more roots the maximum capacity, all at different - levels, and checks that all but the first 10 are stored. - Then it adds one in the diff and checks it is stored. - Then it adds 10 at the same level and check that only the last one is - stored. *) - let root_test () = - let open Tezos_sapling.Core in - let gen_root () = - Data_encoding.Binary.of_bytes_exn - Validator.Hash.encoding - (Tezos_crypto.Hacl.Rand.gen 32) - in - let roots_ctx = - WithExceptions.List.init - ~loc:__LOC__ - (Int32.to_int Sapling_storage.Roots.size + 10) - (fun _ -> gen_root ()) - in - Context.init1 () >>=? fun (b, _contract) -> - Raw_context.prepare - b.context - ~level:b.header.shell.level - ~predecessor_timestamp:b.header.shell.timestamp - ~timestamp:b.header.shell.timestamp - >>= wrap - >>=? fun ctx -> - Lazy_storage_diff.fresh Lazy_storage_kind.Sapling_state ~temporary:false ctx - >>= wrap - >>=? fun (ctx, id) -> - Sapling_storage.init ctx id ~memo_size:0 >>= wrap >>=? fun ctx -> - (* Add one root per level to the context *) - List.fold_left_es - (fun (ctx, cnt) root -> - Sapling_storage.Roots.add ctx id root >>= wrap >>=? fun ctx -> - (* Very low level way to "bake" a block. It would be better to use the - helpers functions but they complicate the access to the raw_context. *) - Raw_context.prepare - ~level:(Int32.add b.header.shell.level cnt) - ~predecessor_timestamp:b.header.shell.timestamp - ~timestamp:b.header.shell.timestamp - (Raw_context.recover ctx) - >>= wrap - >|=? fun ctx -> (ctx, Int32.succ cnt)) - (ctx, 0l) - roots_ctx - >>=? fun (ctx, _) -> - (* Check mem on all the roots in the context. *) - let state = - Sapling_storage. - {id = Some id; diff = Sapling_storage.empty_diff; memo_size = 0} - in - List.fold_left_es - (fun i root -> - Sapling_storage.root_mem ctx state root >>= wrap >|=? fun bool -> - assert (if i < 10 then not bool else bool) ; - i + 1) - 0 - roots_ctx - >>=? fun (_ : int) -> - (* Add roots w/o increasing the level *) - let roots_same_level = - WithExceptions.List.init ~loc:__LOC__ 10 (fun _ -> gen_root ()) - in - List.fold_left_es - (fun ctx root -> Sapling_storage.Roots.add ctx id root >>= wrap) - ctx - roots_same_level - >>=? fun ctx -> - List.fold_left_es - (fun (i, ctx) root -> - Sapling_storage.root_mem ctx state root >>= wrap >|=? fun bool -> - assert (if i < 9 then not bool else bool) ; - (i + 1, ctx)) - (0, ctx) - roots_same_level - >>=? fun (_, _) -> return_unit - - let test_get_memo_size () = - Context.init1 () >>=? fun (b, _contract) -> - Raw_context.prepare - b.context - ~level:b.header.shell.level - ~predecessor_timestamp:b.header.shell.timestamp - ~timestamp:b.header.shell.timestamp - >>= wrap - >>=? fun ctx -> - Lazy_storage_diff.fresh Lazy_storage_kind.Sapling_state ~temporary:false ctx - >>= wrap - >>=? fun (ctx, id) -> - Sapling_storage.init ctx id ~memo_size:0 >>= wrap >>=? fun ctx -> - Sapling_storage.get_memo_size ctx id >>= wrap >|=? fun memo_size -> - assert (memo_size = 0) -end - -module Alpha_context_tests = struct - open Sapling_helpers.Alpha_context_helpers - - (* Create a transaction with memo_size 1, test that is validates with a newly - created empty_state with memo_size 1 and does not with memo_size 0. *) - let test_verify_memo () = - init () >>=? fun ctx -> - let sk = - Tezos_sapling.Core.Wallet.Spending_key.of_seed - (Tezos_crypto.Hacl.Rand.gen 32) - in - let vt = - let ps = Tezos_sapling.Storage.empty ~memo_size:0 in - (* the dummy output will have memo_size 0 *) - Tezos_sapling.Forge.forge_transaction - ~number_dummy_outputs:1 - [] - [] - sk - "anti-replay" - ~bound_data:"" - ps - in - verify_update ctx vt ~memo_size:0 |> assert_some >>=? fun (_, _) -> - verify_update ctx vt ~memo_size:1 |> assert_none - - (* Bench the proving and validation time of shielding and transferring several - tokens. *) - let test_bench_phases () = - init () >>=? fun ctx -> - let rounds = 5 in - Log.info "\nrounds: %d\n" rounds ; - let w = wallet_gen () in - let cs = Tezos_sapling.Storage.empty ~memo_size:8 in - (* one verify_update to get the id *) - let vt = transfer w cs [] in - verify_update ctx vt |> assert_some >>=? fun (ctx, id) -> - client_state_alpha ctx id >>=? fun cs -> - let start = Unix.gettimeofday () in - let vts = List.map (fun _ -> transfer w cs []) (1 -- rounds) in - let ctime_shields = Unix.gettimeofday () -. start in - Log.info "client_shields %f\n" ctime_shields ; - let start = Unix.gettimeofday () in - List.fold_left_es - (fun ctx vt -> - verify_update ctx ~id vt |> assert_some >|=? fun (ctx, _id) -> ctx) - ctx - vts - >>=? fun ctx -> - let vtime_shields = Unix.gettimeofday () -. start in - Log.info "valdtr_shields %f\n" vtime_shields ; - client_state_alpha ctx id >>=? fun cs -> - let start = Unix.gettimeofday () in - let vts = List.map (fun i -> transfer w cs [i]) (1 -- rounds) in - let ctime_transfers = Unix.gettimeofday () -. start in - Log.info "client_txs %f\n" ctime_transfers ; - let start = Unix.gettimeofday () in - List.fold_left_es - (fun ctx vt -> - verify_update ctx ~id vt |> assert_some >|=? fun (ctx, _id) -> ctx) - ctx - vts - >|=? fun (_ctx : context) -> - let vtime_transfers = Unix.gettimeofday () -. start in - Log.info "valdtr_txs %f\n" vtime_transfers - - (* Same as before but for the legacy instruction. *) - let test_bench_phases_legacy () = - init () >>=? fun ctx -> - let rounds = 5 in - Log.info "\nrounds: %d\n" rounds ; - let w = wallet_gen () in - let cs = Tezos_sapling.Storage.empty ~memo_size:8 in - (* one verify_update to get the id *) - let vt = transfer_legacy w cs [] in - verify_update_legacy ctx vt |> assert_some >>=? fun (ctx, id) -> - client_state_alpha ctx id >>=? fun cs -> - let start = Unix.gettimeofday () in - let vts = List.map (fun _ -> transfer_legacy w cs []) (1 -- rounds) in - let ctime_shields = Unix.gettimeofday () -. start in - Log.info "client_shields %f\n" ctime_shields ; - let start = Unix.gettimeofday () in - List.fold_left_es - (fun ctx vt -> - verify_update_legacy ctx ~id vt |> assert_some >|=? fun (ctx, _id) -> - ctx) - ctx - vts - >>=? fun ctx -> - let vtime_shields = Unix.gettimeofday () -. start in - Log.info "valdtr_shields %f\n" vtime_shields ; - client_state_alpha ctx id >>=? fun cs -> - let start = Unix.gettimeofday () in - let vts = List.map (fun i -> transfer_legacy w cs [i]) (1 -- rounds) in - let ctime_transfers = Unix.gettimeofday () -. start in - Log.info "client_txs %f\n" ctime_transfers ; - let start = Unix.gettimeofday () in - List.fold_left_es - (fun ctx vt -> - verify_update_legacy ctx ~id vt |> assert_some >|=? fun (ctx, _id) -> - ctx) - ctx - vts - >|=? fun (_ctx : context) -> - let vtime_transfers = Unix.gettimeofday () -. start in - Log.info "valdtr_txs %f\n" vtime_transfers - - (* Transfer several times the same token. *) - let test_bench_fold_over_same_token () = - init () >>=? fun ctx -> - let rounds = 5 in - let w = wallet_gen () in - let cs = Tezos_sapling.Storage.empty ~memo_size:8 in - (* one verify_update to get the id *) - let vt = transfer w cs [] in - verify_update ctx vt |> assert_some >>=? fun (ctx, id) -> - let rec loop cnt ctx = - if cnt >= rounds then return_unit - else - (* inefficient: re-synch from scratch at each round *) - client_state_alpha ctx id >>=? fun cs -> - let vt = transfer w cs [cnt] in - verify_update ctx ~id vt |> assert_some >>=? fun (ctx, _id) -> - loop (cnt + 1) ctx - in - loop 0 ctx - - (* - The following tests trigger all the branches of - Sapling_validator.verify_update. - The function performs several checks and returns None in case of failure. - During development the function was modified to throw a different exception - for each of its checks so to be sure that they were reached. - *) - - (* Test that double spending the same input fails the nf check. *) - let test_double_spend_same_input () = - init () >>=? fun ctx -> - let w = wallet_gen () in - let cs = Tezos_sapling.Storage.empty ~memo_size:8 in - (* one verify_update to get the id *) - let vt = transfer w cs [] in - verify_update ctx vt |> assert_some >>=? fun (ctx, id) -> - client_state_alpha ctx id >>=? fun cs -> - let vt = transfer w cs [0] in - verify_update ctx ~id vt |> assert_some >>=? fun (_ctx, id) -> - let vt = transfer w cs [0; 0] in - verify_update ctx ~id vt |> assert_none - - let test_verifyupdate_one_transaction () = - init () >>=? fun ctx -> - let w = wallet_gen () in - let cs = Tezos_sapling.Storage.empty ~memo_size:8 in - let vt = transfer w cs [] in - verify_update ctx vt |> assert_some >>=? fun (ctx, id) -> - client_state_alpha ctx id >>=? fun cs -> - let vt = transfer w cs [0] in - (* fails sig check because of wrong balance *) - let vt_broken = - Tezos_sapling.Core.Validator.UTXO. - {vt with balance = Int64.(succ vt.balance)} - in - verify_update ctx ~id vt_broken |> assert_none >>=? fun () -> - (* randomize one output to fail check outputs *) - (* don't randomize the ciphertext as it is not part of the proof *) - let open Tezos_sapling.Core.Client.UTXO in - let o = WithExceptions.Option.get ~loc:__LOC__ @@ List.hd vt.outputs in - let o_wrong_cm = - { - o with - cm = randomized_byte o.cm Tezos_sapling.Core.Client.Commitment.encoding; - } - in - let vt_broken = - Tezos_sapling.Core.Validator.UTXO.{vt with outputs = [o_wrong_cm]} - in - verify_update ctx ~id vt_broken |> assert_none >>=? fun () -> - (* position inside the cv *) - let pos = Random.int 32 in - let o_wrong_cv = - { - o with - ciphertext = - randomized_byte - ~pos - o.ciphertext - Tezos_sapling.Core.Client.Ciphertext.encoding; - } - in - let vt_broken = - Tezos_sapling.Core.Validator.UTXO.{vt with outputs = [o_wrong_cv]} - in - verify_update ctx ~id vt_broken |> assert_none - - let test_verifyupdate_two_transactions () = - init () >>=? fun ctx -> - let w = wallet_gen () in - let cs = Tezos_sapling.Storage.empty ~memo_size:8 in - (* generate the first storage *) - let vt = transfer w cs [] in - verify_update ctx vt |> assert_some >>=? fun (ctx, id1) -> - client_state_alpha ctx id1 >>=? fun cs1 -> - let vt1 = transfer w cs1 [0] in - (* generate the second storage *) - let vt = transfer w cs [] in - verify_update ctx vt |> assert_some >>=? fun (ctx, id2) -> - client_state_alpha ctx id2 >>=? fun cs2 -> - let vt2 = transfer w cs2 [0] in - (* fail root check *) - verify_update ctx ~id:id1 vt2 |> assert_none >>=? fun () -> - (* Swap the root so that it passes the root_mem check but fails - the input check *) - let vt1_broken = - Tezos_sapling.Core.Validator.UTXO.{vt2 with root = vt1.root} - in - verify_update ctx ~id:id1 vt1_broken |> assert_none >>=? fun () -> - (* fail the sig check *) - let vt1_broken = - Tezos_sapling.Core.Validator.UTXO.{vt1 with outputs = vt2.outputs} - in - verify_update ctx ~id:id1 vt1_broken |> assert_none -end - -module Interpreter_tests = struct - open Sapling_helpers.Interpreter_helpers - - let parameters_of_list transactions = - let string = "{ " ^ String.concat " ; " transactions ^ " }" in - Alpha_context.Script.(lazy_expr (Expr.from_string string)) - - let path = project_root // Filename.dirname __FILE__ - - (* In this test, we use a contract which takes a list of transactions, applies - all of them, and assert all of them are correct. It also enforces a 1-to-1 - conversion with mutez by asking an amount to shield and asking for a pkh to - unshield. - We create 2 keys a and b. We originate the contract, then do two lists of - shield for a, then transfers several outputs to b while unshielding, then - transfer all of b inputs to a while adding dummy inputs and outputs. - At last, we fail by making a faulty transaction. *) - let test_shielded_tez () = - init () >>=? fun (genesis, baker, src0, src1) -> - let memo_size = 8 in - originate_contract_hash - (path // "contracts/sapling_contract.tz") - "{ }" - src0 - genesis - baker - >>=? fun (dst, b1, anti_replay) -> - let wa = wallet_gen () in - let list_transac, total = - shield ~memo_size wa.sk 2 wa.vk (Format.sprintf "0x%s") anti_replay - in - let parameters = parameters_of_list list_transac in - (* a does a list of shield transaction *) - transac_and_sync ~memo_size b1 parameters total src0 dst baker - >>=? fun (b2, _state) -> - (* we shield again on another block, forging with the empty state *) - let list_transac, total' = - shield ~memo_size wa.sk 2 wa.vk (Format.sprintf "0x%s") anti_replay - in - let parameters = parameters_of_list list_transac in - (* a does a list of shield transaction *) - transac_and_sync ~memo_size b2 parameters total' src0 dst baker - >>=? fun (b3, state) -> - (* address that will receive an unshield *) - Context.Contract.balance (B b3) src1 >>=? fun balance_before_shield -> - (* address that will receive an unshield *) - let wb = wallet_gen () in - let list_addr = gen_addr 2 wb.vk in - (* Take the first two inputs *) - let list_forge_input = - List.map - (fun pos_int -> - let pos = Int64.of_int pos_int in - let forge_input = - snd - (Tezos_sapling.Forge.Input.get state pos wa.vk - |> WithExceptions.Option.get ~loc:__LOC__) - in - forge_input) - (0 -- 4) - in - let list_forge_output = - List.map - (fun addr -> Tezos_sapling.Forge.make_output addr 1L (Bytes.create 8)) - list_addr - in - (let src_pkh1 = Context.Contract.pkh src1 in - Incremental.begin_construction b3 >>=? fun incr -> - let alpha_ctxt = Incremental.alpha_ctxt incr in - Script_ir_translator.pack_data - alpha_ctxt - Script_typed_ir.key_hash_t - src_pkh1 - >>= wrap - >>=? fun (bound_data, _alpha_ctxt) -> return bound_data) - >>=? fun bound_data -> - let hex_transac = - to_hex - (Tezos_sapling.Forge.forge_transaction - ~number_dummy_inputs:0 - ~number_dummy_outputs:0 - list_forge_input - list_forge_output - wa.sk - anti_replay - ~bound_data:(Bytes.to_string bound_data) - state) - Tezos_sapling.Core.Client.UTXO.transaction_encoding - in - let string = Format.sprintf "{0x%s}" hex_transac in - let parameters = - Alpha_context.Script.(lazy_expr (Expr.from_string string)) - in - (* a transfers to b and unshield some money to src_1 (the pkh) *) - transac_and_sync ~memo_size b3 parameters 0 src0 dst baker - >>=? fun (b4, state) -> - Context.Contract.balance (B b4) src1 >>=? fun balance_after_shield -> - let diff_due_to_shield = - Int64.sub - (Test_tez.to_mutez balance_after_shield) - (Test_tez.to_mutez balance_before_shield) - in - (* The balance after shield is obtained from the balance before shield by - the shield specific update. *) - (* The inputs total [total] mutez and 2 of those are transfered in shielded tez *) - Assert.equal_int ~loc:__LOC__ (Int64.to_int diff_due_to_shield) (total - 2) - >>=? fun () -> - let list_forge_input = - List.map - (fun i -> - let pos = Int64.of_int (i + 5 + 5) in - let forge_input = - snd - (Tezos_sapling.Forge.Input.get state pos wb.vk - |> WithExceptions.Option.get ~loc:__LOC__) - in - forge_input) - (0 -- 1) - in - let addr_a = - snd - @@ Tezos_sapling.Core.Client.Viewing_key.new_address - wa.vk - Tezos_sapling.Core.Client.Viewing_key.default_index - in - let output = Tezos_sapling.Forge.make_output addr_a 2L (Bytes.create 8) in - let hex_transac = - to_hex - (Tezos_sapling.Forge.forge_transaction - ~number_dummy_inputs:1 - ~number_dummy_outputs:1 - list_forge_input - [output] - wb.sk - anti_replay - ~bound_data:"" - state) - Tezos_sapling.Core.Client.UTXO.transaction_encoding - in - let string = Format.sprintf "{0x%s}" hex_transac in - let parameters = - Alpha_context.Script.(lazy_expr (Expr.from_string string)) - in - (* b transfers to a with dummy inputs and outputs *) - transac_and_sync ~memo_size b4 parameters 0 src0 dst baker - >>=? fun (b, state) -> - (* Here we fail by doing the same transaction again*) - Incremental.begin_construction b >>=? fun incr -> - let fee = Test_tez.of_int 10 in - let dst = Alpha_context.Contract.Originated dst in - Op.transaction ~gas_limit:Max ~fee (B b) src0 dst Tez.zero ~parameters - >>=? fun operation -> - Incremental.add_operation (* TODO make more precise *) - ~expect_apply_failure:(fun _ -> return_unit) - incr - operation - >>=? fun (_incr : Incremental.t) -> - (* Here we fail by changing the field bound_data*) - let orginal_transac = - Tezos_sapling.Forge.forge_transaction - list_forge_input - [output] - wb.sk - anti_replay - ~bound_data:"right" - state - in - let modified_transac = - Tezos_sapling.Core.Validator.UTXO. - {orginal_transac with bound_data = "wrong"} - in - let string = - Format.sprintf - "{0x%s}" - (to_hex - modified_transac - Tezos_sapling.Core.Client.UTXO.transaction_encoding) - in - let parameters = - Alpha_context.Script.(lazy_expr (Expr.from_string string)) - in - Incremental.begin_construction b >>=? fun incr -> - let fee = Test_tez.of_int 10 in - Op.transaction ~gas_limit:Max ~fee (B b) src0 dst Tez.zero ~parameters - >>=? fun operation -> - Incremental.add_operation (* TODO make more precise *) - ~expect_apply_failure:(fun _ -> return_unit) - incr - operation - >>=? fun (_incr : Incremental.t) -> return_unit - - let test_push_sapling_state_should_be_forbidden () = - init () - (* Originating a contract to get a sapling_state with ID 0, used in the next contract *) - >>=? - fun (block, baker, src, _) -> - originate_contract_hash - (path // "contracts/sapling_contract.tz") - "{ }" - src - block - baker - >>=? fun (_, _, _) -> - (* Originating the next contract should fail *) - originate_contract_hash - (path // "contracts/sapling_push_sapling_state.tz") - "{ }" - src - block - baker - >>= function - | Error - [ - Environment.Ecoproto_error (Script_tc_errors.Ill_typed_contract _); - Environment.Ecoproto_error - (Script_tc_errors.Unexpected_lazy_storage _); - ] -> - return_unit - | _ -> assert false - - let test_use_state_from_other_contract_and_transact () = - (* - Attempt to use a sapling state of a contract A in a contract B - *) - init () (* Originating the contracts *) >>=? fun (block, baker, src, _) -> - let memo_size = 8 in - (* originate_contract "contracts/sapling_contract.tz" "{ }" src block baker - >>=? fun (_shielded_pool_contract_address, block, _anti_replay_shielded_pool) - -> *) - originate_contract_hash - (path // "contracts/sapling_use_existing_state.tz") - "{ }" - src - block - baker - >>=? fun (existing_state_contract_address, block, anti_replay_2) -> - (* we create one shielding transaction and transform it in Micheline to use - it as a parameter - *) - let wa = wallet_gen () in - let transactions, _total = - shield - ~memo_size - wa.sk - 1 - wa.vk - (Format.sprintf "(Pair 0x%s 0)") - anti_replay_2 - in - let transaction = - WithExceptions.Option.get ~loc:__LOC__ @@ List.hd transactions - in - let parameters = - Alpha_context.Script.(lazy_expr (Expr.from_string transaction)) - in - transac_and_sync - ~memo_size - block - parameters - 0 - src - existing_state_contract_address - baker - >|= function - | Ok _ -> Alcotest.failf "Unexpected operations success" - | Error errs -> - assert ( - List.exists - (function - | Environment.Ecoproto_error - (Tezos_protocol_017_PtNairob.Protocol.Script_tc_errors - .Unexpected_forged_value _) -> - true - | _ -> false) - errs) ; - Result.return_unit - - (* In this test we do two transactions in one block and same two in two block. - We check that the sate is the same expect for roots. - The second transaction is possible only if the first one is done. *) - let test_transac_and_block () = - init () >>=? fun (b, baker, src, _) -> - let memo_size = 8 in - originate_contract_hash - (path // "contracts/sapling_contract.tz") - "{ }" - src - b - baker - >>=? fun (dst, block_start, anti_replay) -> - let {sk; vk} = wallet_gen () in - let hex_transac_1 = hex_shield ~memo_size {sk; vk} anti_replay in - let string_1 = Format.sprintf "{%s}" hex_transac_1 in - let parameters_1 = - Alpha_context.Script.(lazy_expr (Expr.from_string string_1)) - in - transac_and_sync ~memo_size block_start parameters_1 15 src dst baker - >>=? fun (block_1, state) -> - let intermediary_root = Tezos_sapling.Storage.get_root state in - let addr = - snd - @@ Tezos_sapling.Core.Wallet.Viewing_key.(new_address vk default_index) - in - let output = Tezos_sapling.Forge.make_output addr 15L (Bytes.create 8) in - let hex_transac_2 = - "0x" - ^ to_hex - (Tezos_sapling.Forge.forge_transaction - [ - snd - (Tezos_sapling.Forge.Input.get state 0L vk - |> WithExceptions.Option.get ~loc:__LOC__); - ] - [output] - sk - anti_replay - ~bound_data:"" - state) - Tezos_sapling.Core.Client.UTXO.transaction_encoding - in - let string_2 = Format.sprintf "{%s}" hex_transac_2 in - let parameters_2 = - Alpha_context.Script.(lazy_expr (Expr.from_string string_2)) - in - transac_and_sync ~memo_size block_1 parameters_2 0 src dst baker - >>=? fun (block_1, state_1) -> - let final_root = Tezos_sapling.Storage.get_root state_1 in - Alpha_services.Contract.single_sapling_get_diff - Block.rpc_ctxt - block_1 - dst - ~offset_commitment:0L - ~offset_nullifier:0L - () - >>=? fun (_root, diff_1) -> - let fee = Test_tez.of_int 10 in - Tez.one_mutez *? Int64.of_int 15 >>?= fun amount_tez -> - Op.transaction - ~gas_limit:Max - ~fee - (B block_start) - src - (Contract.Originated dst) - amount_tez - ~parameters:parameters_1 - >>=? fun operation1 -> - Incremental.begin_construction block_start >>=? fun incr -> - (* We need to manually get the counter here *) - let ctx = Incremental.alpha_ctxt incr in - let pkh = Context.Contract.pkh src in - Alpha_context.Contract.get_counter ctx pkh >>= wrap >>=? fun counter -> - Op.transaction - ~gas_limit:Max - ~counter - ~fee - (B block_start) - src - (Contract.Originated dst) - Tez.zero - ~parameters:parameters_2 - >>=? fun operation2 -> - Op.batch_operations - ~recompute_counters:true - ~source:src - (I incr) - [operation1; operation2] - >>=? fun operation -> - Incremental.add_operation incr operation >>=? fun incr -> - Incremental.finalize_block incr >>=? fun block_2 -> - Alpha_services.Contract.single_sapling_get_diff - Block.rpc_ctxt - block_2 - dst - ~offset_commitment:0L - ~offset_nullifier:0L - () - >>=? fun (_root, diff_2) -> - (* We check that the same transactions have passed *) - assert (diff_1 = diff_2) ; - let is_root_in block dst root = - Incremental.begin_construction block >>=? fun incr -> - let ctx_2 = Incremental.alpha_ctxt incr in - Alpha_services.Contract.script Block.rpc_ctxt block dst >>=? fun script -> - let ctx_without_gas_2 = Alpha_context.Gas.set_unlimited ctx_2 in - Script_ir_translator.parse_script - ctx_without_gas_2 - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) - ~allow_forged_in_storage:true - script - >>= wrap - >>=? fun (Ex_script (Script script), ctxt) -> - Script_ir_translator.get_single_sapling_state - ctxt - script.storage_type - script.storage - |> wrap - >>=? fun (id, _ctx_2) -> - let single_id = WithExceptions.Option.get ~loc:__LOC__ id in - let id = - Lazy_storage_kind.Sapling_state.Id.parse_z - @@ Alpha_context.Sapling.Id.unparse_to_z single_id - in - Raw_context.prepare - block.context - ~level:block.header.shell.level - ~predecessor_timestamp:block.header.shell.timestamp - ~timestamp:block.header.shell.timestamp - >>= wrap - >>=? fun raw_ctx -> Sapling_storage.Roots.mem raw_ctx id root >>= wrap - in - (* We check that the second state did not store the root in between - transactions. *) - is_root_in block_2 dst intermediary_root |> assert_false >>=? fun () -> - (* We check that the second state did store the final root. *) - is_root_in block_2 dst final_root |> assert_true >>=? fun () -> - (* We check that the first state did store the final root. *) - is_root_in block_1 dst final_root |> assert_true >>=? fun () -> - (* We check that the first state did store the root in between transactions. *) - is_root_in block_1 dst intermediary_root |> assert_true - - (* In this test we try a contract which creates an empty sapling state on the - fly. It then applies a list of transactions, checks they are correct and - drops the result. We make several shields in the same list (since the state - is drop). *) - let test_drop () = - init () >>=? fun (b, baker, src, _) -> - originate_contract_hash - (path // "contracts/sapling_contract_drop.tz") - "Unit" - src - b - baker - >>=? fun (dst, b, anti_replay) -> - let {sk; vk} = wallet_gen () in - let list_transac, _total = - shield ~memo_size:8 sk 4 vk (Format.sprintf "0x%s") anti_replay - in - let parameters = parameters_of_list list_transac in - let dst = Contract.Originated dst in - Op.transaction - ~gas_limit:Max - ~fee:(Test_tez.of_int 10) - (B b) - src - dst - Tez.zero - ~parameters - >>=? fun operation -> - next_block b operation >>=? fun (_b : Block.t) -> return_unit - - (* We use a contrac with two states. Its parameter is two transactions and a - bool. The two transactions are tested valid against the two states, but - only one state according to the bool is updated. - We do two transactions shielding to different keys in the two states. - At each transactions both are applied but only state is updated. - We then check that the first state is updated in the correct way. *) - let test_double () = - init () >>=? fun (b, baker, src, _) -> - let memo_size = 8 in - originate_contract_hash - (path // "contracts/sapling_contract_double.tz") - "(Pair { } { })" - src - b - baker - >>=? fun (dst, b, anti_replay) -> - let wa = wallet_gen () in - let hex_transac_1 = hex_shield ~memo_size wa anti_replay in - let wb = wallet_gen () in - let hex_transac_2 = hex_shield ~memo_size wb anti_replay in - let str_1 = - "(Pair True (Pair " ^ hex_transac_1 ^ " " ^ hex_transac_2 ^ "))" - in - let str_2 = - "(Pair False (Pair " ^ hex_transac_2 ^ " " ^ hex_transac_1 ^ "))" - in - (* transac 1 is applied to state_1*) - let parameters_1 = - Alpha_context.Script.(lazy_expr (Expr.from_string str_1)) - in - (* tranasc_2 is applied to state_2*) - let parameters_2 = - Alpha_context.Script.(lazy_expr (Expr.from_string str_2)) - in - let fee = Test_tez.of_int 10 in - let cdst = Contract.Originated dst in - Op.transaction - ~gas_limit:Max - ~fee - (B b) - src - cdst - Tez.zero - ~parameters:parameters_1 - >>=? fun operation -> - next_block b operation >>=? fun b -> - Op.transaction - ~gas_limit:Max - ~fee - (B b) - src - cdst - Tez.zero - ~parameters:parameters_2 - >>=? fun operation -> - next_block b operation >>=? fun b -> - Incremental.begin_construction b >>=? fun incr -> - let ctx = Incremental.alpha_ctxt incr in - let ctx_without_gas = Alpha_context.Gas.set_unlimited ctx in - Alpha_services.Contract.storage Block.rpc_ctxt b dst >>=? fun storage -> - let storage_lazy_expr = Alpha_context.Script.lazy_expr storage in - - (let memo_size = memo_size_of_int memo_size in - let open Script_typed_ir in - let state_ty = sapling_state_t ~memo_size in - pair_t (-1) state_ty state_ty) - >>??= fun (Ty_ex_c tytype) -> - Script_ir_translator.parse_storage - ctx_without_gas - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) - ~allow_forged:true - tytype - ~storage:storage_lazy_expr - >>= wrap - >>=? fun ((state_1, state_2), _ctx) -> - (*Only works when diff is empty*) - let local_state_from_disk disk_state ctx = - let id = - Alpha_context.Sapling.(disk_state.id) - |> WithExceptions.Option.get ~loc:__LOC__ - in - Alpha_context.Sapling.get_diff - ctx - id - ~offset_commitment:0L - ~offset_nullifier:0L - () - >>= wrap - >|=? fun diff -> client_state_of_diff ~memo_size diff - in - local_state_from_disk state_1 ctx >>=? fun state_1 -> - local_state_from_disk state_2 ctx >|=? fun state_2 -> - (* we check that first state contains 15 to addr_1 but not 15 to addr_2*) - assert (Option.is_some @@ Tezos_sapling.Forge.Input.get state_1 0L wa.vk) ; - assert (Option.is_some @@ Tezos_sapling.Forge.Input.get state_2 0L wa.vk) ; - assert (Option.is_none @@ Tezos_sapling.Forge.Input.get state_1 0L wb.vk) ; - assert (Option.is_none @@ Tezos_sapling.Forge.Input.get state_2 0L wb.vk) - - let test_state_as_arg () = - init () >>=? fun (b, baker, src, _) -> - originate_contract_hash - (path // "contracts/sapling_contract_state_as_arg.tz") - "None" - src - b - baker - >>=? fun (dst, b, anti_replay) -> - originate_contract_hash - (path // "contracts/sapling_contract_send.tz") - "Unit" - src - b - baker - >>=? fun (dst_2, b, anti_replay_2) -> - let w = wallet_gen () in - let hex_transac_1 = hex_shield ~memo_size:8 w anti_replay in - let string = "Left " ^ hex_transac_1 in - let parameters = - Alpha_context.Script.(lazy_expr (Expr.from_string string)) - in - let fee = Test_tez.of_int 10 in - let dst = Contract.Originated dst in - Op.transaction ~gas_limit:Max ~fee (B b) src dst Tez.zero ~parameters - >>=? fun operation -> - next_block b operation >>=? fun b -> - let contract = "0x" ^ to_hex dst Alpha_context.Contract.encoding in - let hex_transac_2 = hex_shield ~memo_size:8 w anti_replay_2 in - let string = "(Pair " ^ contract ^ " " ^ hex_transac_2 ^ ")" in - let parameters = - Alpha_context.Script.(lazy_expr (Expr.from_string string)) - in - let dst_2 = Contract.Originated dst_2 in - Op.transaction ~gas_limit:Max ~fee (B b) src dst_2 Tez.zero ~parameters - >>=? fun operation -> - next_block b operation >>=? fun (_b : Block.t) -> return_unit -end - -let tests = - [ - Tztest.tztest - "commitments_add_uncommitted" - `Quick - Raw_context_tests.commitments_add_uncommitted; - Tztest.tztest "nullifier_double" `Quick Raw_context_tests.nullifier_double; - Tztest.tztest "nullifier_test" `Quick Raw_context_tests.nullifier_test; - Tztest.tztest "cm_cipher_test" `Quick Raw_context_tests.cm_cipher_test; - Tztest.tztest - "list_insertion_test" - `Quick - Raw_context_tests.list_insertion_test; - Tztest.tztest "root" `Quick Raw_context_tests.root_test; - Tztest.tztest "get_memo_size" `Quick Raw_context_tests.test_get_memo_size; - Tztest.tztest "verify_memo" `Quick Alpha_context_tests.test_verify_memo; - Tztest.tztest "bench_phases" `Slow Alpha_context_tests.test_bench_phases; - Tztest.tztest - "bench_phases_legacy" - `Slow - Alpha_context_tests.test_bench_phases_legacy; - Tztest.tztest - "bench_fold_over_same_token" - `Slow - Alpha_context_tests.test_bench_fold_over_same_token; - Tztest.tztest - "double_spend_same_input" - `Quick - Alpha_context_tests.test_double_spend_same_input; - Tztest.tztest - "verifyupdate_one_transaction" - `Quick - Alpha_context_tests.test_verifyupdate_one_transaction; - Tztest.tztest - "verifyupdate_two_transactions" - `Quick - Alpha_context_tests.test_verifyupdate_two_transactions; - Tztest.tztest "shielded_tez" `Quick Interpreter_tests.test_shielded_tez; - Tztest.tztest - "use state from other contract and transact" - `Quick - Interpreter_tests.test_use_state_from_other_contract_and_transact; - Tztest.tztest - "Instruction PUSH sapling_state 0 should be forbidden" - `Quick - Interpreter_tests.test_push_sapling_state_should_be_forbidden; - Tztest.tztest - "transac_and_block" - `Quick - Interpreter_tests.test_transac_and_block; - Tztest.tztest "drop" `Quick Interpreter_tests.test_drop; - Tztest.tztest "double" `Quick Interpreter_tests.test_double; - Tztest.tztest "state_as_arg" `Quick Interpreter_tests.test_state_as_arg; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("sapling", tests)] |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_script_cache.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_script_cache.ml deleted file mode 100644 index 0c80d333454e966195a6630ae8cd4b34d6fb82fa..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_script_cache.ml +++ /dev/null @@ -1,441 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (cache) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/michelson/main.exe \ - -- --file test_script_cache.ml - Subject: These unit tests check basic behavior of script cache -*) - -open Protocol -open Alpha_context -open Contract_helpers -open Script_ir_translator - -exception Script_cache_test_error of string - -let err x = Exn (Script_cache_test_error x) - -(* - - The following value is hard-coded to detect change in the size - model. It has been computed by a manual run of the test. - -*) -let liquidity_baking_contract_size = 182272 - -let liquidity_baking_contract = - Contract_hash.of_b58check_exn "KT1TxqZ8QtKvLu3V3JH7Gx58n7Co8pgtpQU5" - -let make_block block f = - Incremental.begin_construction block >>=? fun incr -> - f (Incremental.alpha_ctxt incr) >>=? fun (ret, ctxt) -> - let incr = Incremental.set_alpha_ctxt incr ctxt in - Incremental.finalize_block incr >>=? fun block -> - Block.bake block >>=? fun next_block -> return (ret, next_block) - -let ( @! ) f g = - f @@ fun ctxt -> - g ctxt >>=? fun ret -> return (ret, ctxt) - -let throw_block_away (x, _block) = return x - -let equal_scripts (s1 : Script.t) (s2 : Script.t) = - Script_repr.( - force_bytes s1.code >>? fun code1 -> - force_bytes s2.code >>? fun code2 -> - force_bytes s1.storage >>? fun storage1 -> - force_bytes s2.storage >>? fun storage2 -> - ok (Bytes.equal code1 code2 && Bytes.equal storage1 storage2)) - |> Environment.wrap_tzresult - -let find ctxt addr = - Script_cache.find ctxt addr >|= Environment.wrap_tzresult - >>=? fun (ctxt, identifier, result) -> - match result with - | None -> - (* by [find_correctly_looks_up]. *) - assert false - | Some (script, Ex_script ir) -> - return (ctxt, identifier, script, Ex_script ir) - -let value_as_int : - type a ac. (a, ac) Script_typed_ir.ty -> a -> Script_int.z Script_int.num = - fun ty v -> match ty with Int_t -> v | _ -> Stdlib.failwith "value_as_int" - -let path = project_root // Filename.dirname __FILE__ - -let add_some_contracts k src block baker = - ( make_block block @@ fun ctxt -> - find ctxt liquidity_baking_contract >>=? fun (ctxt, id, _, _) -> - return (id, ctxt) ) - >>=? fun (liquidity_baking_contract_id, block) -> - List.fold_left_es - (fun (rev_contracts, block) _ -> - originate_contract_hash - (path // "contracts/int-store.tz") - "31" - src - block - baker - >>=? fun (addr, block) -> - Block.bake block >>=? fun block -> - make_block block @@ fun ctxt -> - find ctxt addr >>=? fun (ctxt, id, _, _) -> - let contract = (id, addr) in - return (contract :: rev_contracts, ctxt)) - ([], block) - (1 -- k) - >>=? fun (rev_contracts, block) -> - let contracts = - (* After each baking [liquidity_baking_contract] is the most - recently used contract. *) - let lb = (liquidity_baking_contract_id, liquidity_baking_contract) in - List.rev (lb :: rev_contracts) - in - return (contracts, block) - -(* - - The following value is hard-coded to detect change in the size - model. It has been computed by a manual run of the test. - -*) -let int_store_contract_size = 592 - -(* - - Check our assumptions regarding the size of reference scripts. - -*) -let assert_cache_size expected_size ctxt = - fail_unless - (Script_cache.size ctxt = expected_size) - (err - (Printf.sprintf - "Invalid script cache size, expecting %d, got %d" - expected_size - (Script_cache.size ctxt))) - -let test_size_of_liquidity_baking_contract () = - init () >>=? fun (block, _, _, _) -> - make_block block @! assert_cache_size liquidity_baking_contract_size - >>=? throw_block_away - -let test_size_of_int_store_contract () = - init () >>=? fun (block, baker, src, _) -> - originate_contract_hash - (path // "contracts/int-store.tz") - "31" - src - block - baker - >>=? fun (addr, block) -> - ( make_block block @! fun ctxt -> - Script_cache.find ctxt addr >|= Environment.wrap_tzresult - >>=? fun (ctxt, _, _) -> - assert_cache_size - (int_store_contract_size + liquidity_baking_contract_size) - ctxt ) - >>=? throw_block_away - -(* - - When a contract is in the context, [find] correctly returns it. - -*) -let test_find_correctly_looks_up () = - init () >>=? fun (block, baker, src, _) -> - originate_contract_hash - (path // "contracts/sapling_contract.tz") - "{ }" - src - block - baker - >>=? fun (addr, block) -> - ( make_block block @! fun ctxt -> - (* - Contract is present. - *) - Script_cache.find ctxt addr >|= Environment.wrap_tzresult - >>=? fun (_, _, result) -> - Contract.get_script ctxt addr >|= Environment.wrap_tzresult - >>=? fun (ctxt, script) -> - (match (result, script) with - | None, _ -> ok false - | Some _, None -> - (* because we assume that get_script correctly behaves. *) - assert false - | Some (cached_script, _), Some script -> equal_scripts script cached_script) - >>?= fun cond -> - fail_unless - cond - (err "find should be able to retrieve an originated contract") - (* - Contract is absent. - *) - >>=? fun () -> - let addr = Contract_helpers.fake_KT1 in - Script_cache.find ctxt addr >|= Environment.wrap_tzresult - >>=? fun (_, _, cached_contract) -> - fail_unless - (cached_contract = None) - (err "find should return None for unbound contracts") ) - >>=? throw_block_away - -(* - - [test_update] correctly modifies a cached contract in the context. - -*) -let test_update_modifies_cached_contract () = - init () >>=? fun (block, baker, src, _) -> - originate_contract_hash - (path // "contracts/int-store.tz") - "36" - src - block - baker - >>=? fun (addr, block) -> - ( make_block block @! fun ctxt -> - find ctxt addr >>=? fun (ctxt, identifier, script, Ex_script (Script ir)) -> - match ir.storage_type with - | Int_t -> - let storage' = Script_int.(add ir.storage (Script_int.of_int 1)) in - let cached_contract' = - (script, Ex_script (Script {ir with storage = storage'})) - in - Script_cache.update ctxt identifier cached_contract' 1 - |> Environment.wrap_tzresult - >>?= fun ctxt -> - find ctxt addr >>=? fun (_, _, _, Ex_script (Script ir')) -> - let storage = value_as_int ir'.storage_type ir'.storage in - fail_unless - (Script_int.compare storage storage' = 0) - (err - (Format.sprintf - "Update failed, expecting %s, got %s" - (Script_int.to_string storage') - (Script_int.to_string storage))) - | _ -> - (* by definition of int-store.tz. *) - assert false ) - >>=? throw_block_away - -(* - - [test_entries] returns the list of cached scripts in order of least - modification date. - -*) -let test_entries_returns_the_list_in_correct_order () = - let ncontracts = 10 in - init () >>=? fun (block, baker, src, _) -> - add_some_contracts ncontracts src block baker >>=? fun (contracts, block) -> - let addrs = snd @@ List.split contracts in - ( make_block block @! fun ctxt -> - Script_cache.entries ctxt |> Environment.wrap_tzresult >>?= fun entries -> - let cached_contracts = fst (List.split entries) in - fail_unless - (addrs = cached_contracts) - (err "entries must return cached contracts in order") ) - >>=? throw_block_away - -(* - - [test_contract_rank] correctly computes LRU rank. - -*) -let test_contract_rank_is_lru_rank () = - let ncontracts = 10 in - init () >>=? fun (block, baker, src, _) -> - add_some_contracts ncontracts src block baker >>=? fun (contracts, block) -> - let addrs = snd @@ List.split contracts in - ( make_block block @! fun ctxt -> - let rec check_rank k = function - | [] -> return () - | addr :: addrs -> ( - match Script_cache.contract_rank ctxt addr with - | None -> fail (err "Contract rank should find a cached contract") - | Some rank -> - fail_unless - (k = rank) - (err - (Printf.sprintf - "Invalid contract rank, expecting %d, got %d" - k - rank)) - >>=? fun () -> check_rank (k + 1) addrs) - in - check_rank 0 addrs ) - >>=? throw_block_away - -(* - - [size] correctly returns the sums of the (declared) sizes. - -*) -let test_size_adds_entries_sizes () = - let ncontracts = 10 in - init () >>=? fun (block, baker, src, _) -> - add_some_contracts ncontracts src block baker >>=? fun (_, block) -> - ( make_block block @! fun ctxt -> - let expected_size = - liquidity_baking_contract_size + (ncontracts * int_store_contract_size) - in - fail_unless - (Script_cache.size ctxt = expected_size) - (err - (Printf.sprintf - "Invalid script cache size, expecting %d, got %d" - expected_size - (Script_cache.size ctxt))) ) - >>=? throw_block_away - -(* - - [test_size_limit] is the value found in [Constants_repr.cache_layout]. - -*) -let defined_size_limit = - Tezos_protocol_017_PtNairob_parameters.Default_parameters.constants_mainnet - .cache_script_size - -let test_size_limit_is_in_constants_repr () = - init () >>=? fun (block, _baker, _src, _) -> - ( make_block block @! fun ctxt -> - fail_unless - (Script_cache.size_limit ctxt = defined_size_limit) - (err - (Printf.sprintf - "Invalid size limit, expecting %d, got %d" - defined_size_limit - (Script_cache.size_limit ctxt))) ) - >>=? throw_block_away - -(* - - [test_entries] are conform to an LRU strategy: when the cache is - full the least recently used entries are removed. - -*) -let test_entries_shows_lru () = - let ncontracts = 10 in - init () >>=? fun (block, baker, src, _) -> - add_some_contracts ncontracts src block baker >>=? fun (contracts, block) -> - (* We pretend that the contracts' sizes grow so much that they cannot all - fit into the cache. *) - let new_size = 2 * defined_size_limit / ncontracts in - ( make_block block @@ fun ctxt -> - List.fold_left_es - (fun ctxt (_, addr) -> - find ctxt addr >>=? fun (ctxt, id, script, cached_contract) -> - Lwt.return - @@ (Script_cache.update ctxt id (script, cached_contract) new_size - |> Environment.wrap_tzresult)) - ctxt - contracts - >>=? fun ctxt -> return ((), ctxt) ) - >>=? fun ((), block) -> - (* At this point, the cache should only contain the most recently modified - contracts. *) - ( make_block block @@ fun ctxt -> - Script_cache.entries ctxt |> Environment.wrap_tzresult >>?= fun entries -> - let rev_entries = List.rev entries in - let rev_contracts = List.rev contracts in - let rec aux rev_entries rev_contracts = - Printf.eprintf - "%d %d\n" - (List.length rev_entries) - (List.length rev_contracts) ; - match (rev_entries, rev_contracts) with - | [], _ -> - (* We do not count liquidity baking contract. *) - let removed_contracts = List.length rev_contracts - 1 in - fail_unless - (removed_contracts = ncontracts / 2) - (err - (Printf.sprintf - "Too few contracts have been removed from the cache while it \ - is full, %d remaining while expecting %d" - removed_contracts - (ncontracts / 2))) - | (contract, size) :: rev_entries, (_, contract') :: rev_contracts -> - fail_unless - (size = new_size || contract = liquidity_baking_contract) - (err - (Printf.sprintf - "A contract in the cache has not the right size, expecting \ - %d, got %d" - new_size - size)) - >>=? fun () -> - fail_unless - (contract = contract') - (err - (Printf.sprintf - "entries do not return cached contracts in right order")) - >>=? fun () -> aux rev_entries rev_contracts - | _, [] -> - (* There cannot be more entries than contracts. *) - assert false - in - aux rev_entries rev_contracts >>=? fun () -> return ((), ctxt) ) - >>=? throw_block_away - -let tests = - let open Tztest in - [ - tztest - "assumption about size of liquidity baking holds" - `Quick - test_size_of_liquidity_baking_contract; - tztest - "assumption about size of 'int_store' contract holds" - `Quick - test_size_of_int_store_contract; - tztest "find correctly looks up" `Quick test_find_correctly_looks_up; - tztest - "update correctly modifies" - `Quick - test_update_modifies_cached_contract; - tztest - "entries correctly list contracts in order" - `Quick - test_entries_returns_the_list_in_correct_order; - tztest "contract_rank is LRU rank" `Quick test_contract_rank_is_lru_rank; - tztest "size returns entries size" `Quick test_size_adds_entries_sizes; - tztest - "size limit is a protocol constant" - `Quick - test_size_limit_is_in_constants_repr; - tztest "entries show LRU behavior" `Quick test_entries_shows_lru; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("script cache", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml deleted file mode 100644 index 2e437f1ee0df2c4774fa10a60a98d04229ca0f51..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml +++ /dev/null @@ -1,1053 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (script typed IR size) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/michelson/main.exe \ - -- --file test_script_typed_ir_size.ml - Subject: Script_typed_ir computes good approximation of values' sizes -*) - -open Protocol -open Alpha_context -open Script_typed_ir - -(* - Helpers - ------- -*) - -exception Script_typed_ir_test_error of string - -let err x = Exn (Script_typed_ir_test_error x) - -let dummy_loc = Micheline.dummy_location - -let get = Stdlib.Option.get - -let is_ok m = match m with Ok x -> x | _ -> assert false - -let footprint v = - (* This is to turn every statically allocated data into - heap-allocated data, to consider the worst-case in-memory - representation of values. Note that it does NOT remove sharing.*) - let v' = - try Marshal.(from_bytes (to_bytes v [Closures]) 0) - with _ -> (* Custom blocks are problematic. *) v - in - let size v = Obj.(reachable_words (repr v) * 8) in - max (size v) (size v') - -(** [gen_string s] returns a heap-allocated string. Notice that a - string literal ["foo"] written in the code is statically allocated - and is therefore not counted by [Obj.reachable_words]. *) -let gen_string s = - let s = Bytes.of_string s |> Bytes.to_string in - is_ok @@ Script_string.of_string s - -let boxed_set_elements s = Script_set.fold (fun x s -> x :: s) s [] - -let boxed_map_bindings s = Script_map.fold (fun k v s -> (k, v) :: s) s [] - -let big_map_bindings (Big_map s) = Big_map_overlay.bindings s.diff.map - -let show_script_int fmt x = Z.pp_print fmt (Script_int.to_zint x) - -let show_bool fmt b = Format.fprintf fmt "%B" b - -let show_script_string fmt x = - Format.fprintf fmt "%s" (Script_string.to_string x) - -let show_address fmt Script_typed_ir.{destination; entrypoint} = - Format.fprintf - fmt - "%a(%d):%a(%d)" - Destination.pp - destination - (footprint destination) - Entrypoint.pp - entrypoint - (footprint entrypoint) - -let dont_show _fmt _ = () - -let size = {Tezos_benchmark.Base_samplers.min = 4; max = 32} - -module Crypto_samplers = -Tezos_benchmark.Crypto_samplers.Make_finite_key_pool (struct - let size = 10 - - let algo = `Default -end) - -include - Michelson_samplers.Make - (struct - let parameters : Michelson_samplers.parameters = - { - base_parameters = - { - Michelson_samplers_base.int_size = size; - string_size = size; - bytes_size = size; - }; - list_size = size; - set_size = size; - map_size = size; - } - end) - (Crypto_samplers) - -let random_state = Random.State.make [|37; 73; 17; 71; 42|] - -let sample_ty size = Random_type.m_type ~size random_state - -let sample_value ty = Random_value.value ty random_state - -type ex = Ex : string * ('a, _) Script_typed_ir.ty * 'a * int -> ex [@@boxed] - -let ex ?(error = 0) label ty v = Ex (label, ty, v, error) - -let ex_random ?(error = 0) show ty ?(sample = fun () -> sample_value ty) label = - let v = sample () in - let label = Format.asprintf "@[%a%s@]@." show v label in - ex ~error label ty v - -let exs ?(error = 0) n show ty ?(sample = fun () -> sample_value ty) label = - List.map (fun _ -> ex_random ~error show ty label ~sample) (1 -- n) - -let nsample = 100 - -type ex_kinstr = Kinstr : string * ('a, 'b, 'c, 'd) kinstr -> ex_kinstr -[@@boxed] - -(** [check_value_size ()] covers a finite number of cases of Michelson - values, checking that the cost model is sound with respect to their - memory footprint. - - One could wonder why we do not simply use a single value generator - based on a randomly chosen type. We actually implemented such a - strategy in a previous version of this test but this results in a - flaky test. Indeed, for some types, the values are overapproximated - and it was difficult to correctly handle the accumulation of errors - when types were randomly composed. - - The current strategy requires more code but, in exchange, it - provides a finer control over the overapproximation. As a - consequence, we can check for example that there is no - overapproximation for values for which the model is exact. We can - also check that the overapproximation is at least well understood - on the values for which size model is not exact. *) -let check_value_size () = - let check (Ex (what, ty, v, error)) = - let expected_size = footprint v in - let _, size = Script_typed_ir_size.value_size ty v in - let size = Saturation_repr.to_int size in - fail_when - (expected_size + error < size || size < expected_size) - (err - (Printf.sprintf - "%s was expected to have size %d while the size model answered %d \ - (with +%d accepted over approximation error)" - what - expected_size - size - error)) - in - List.iter_es - check - ((* - Unit_t - ====== - *) - [ex "() : unit" Unit_t ()] - (* - Int_t - ===== - *) - @ (let error = 8 in - [ - ex ~error "0 : int" Int_t Script_int.zero; - ex ~error "2^63 : int" Int_t (Script_int.of_int max_int); - ex - ~error - "37^73 : int" - Int_t - (Script_int.of_zint Z.(pow (of_int 37) 73)); - ex - ~error - "-37^73 : int" - Int_t - (Script_int.of_zint Z.(neg (pow (of_int 37) 73))); - ex - ~error - "13270006022583112970 : int" - Int_t - (get @@ Script_int.of_string "13270006022583112970"); - ] - @ exs ~error nsample show_script_int Int_t ": int") - (* - Nat_t - ===== - *) - @ (let error = 8 in - [ - ex ~error "0 : nat" Nat_t Script_int.zero_n; - ex - ~error - "2^63 : nat" - Nat_t - (get Script_int.(is_nat @@ of_int max_int)); - ex - ~error - "37^73 : int" - Nat_t - (get Script_int.(is_nat @@ of_zint Z.(pow (of_int 37) 73))); - ] - @ exs ~error nsample show_script_int Nat_t ": nat") - (* - Signature_t - =========== - *) - @ (let show fmt (Script_typed_ir.Script_signature.Signature_tag s) = - Signature.pp fmt s - in - exs ~error:8 nsample show Signature_t ": signature") - (* - String_t - ======== - *) - @ (let show fmt s = Format.fprintf fmt "%s" (Script_string.to_string s) in - exs nsample show String_t ": string") - (* - Bytes_t - ======= - *) - @ (let show fmt s = Format.fprintf fmt "%s" (Bytes.to_string s) in - exs nsample show Bytes_t ": bytes") - (* - Mutez_t - ======= - *) - @ (let show fmt t = Format.fprintf fmt "%s" (Tez.to_string t) in - exs nsample show Mutez_t ": mutez") - (* - Key_hash_t - ========== - *) - @ (let show = Signature.Public_key_hash.pp in - exs nsample show Key_hash_t ": key_hash") - (* - Key_t - ===== - *) - @ (let show = Signature.Public_key.pp in - exs nsample show Key_t ": key_t") - (* - Timestamp_t - =========== - *) - @ (let show fmt s = - Format.fprintf fmt "%s" (Script_timestamp.to_string s) - in - exs ~error:8 nsample show Timestamp_t ": timestamp_t") - (* - Address_t - ========= - *) - @ exs nsample show_address Address_t ": address_t" - (* - Bool_t - ====== - *) - @ [ex "true : bool" Bool_t true; ex "false : bool" Bool_t false] - (* - Pair_t - ====== - *) - @ (let module P = struct - type ('a, 'b) f = {apply : 'c. ('a * 'b, 'c) ty -> ex} - end in - let on_pair : type a b. (a, _) ty -> (b, _) ty -> (a, b) P.f -> ex = - fun ty1 ty2 f -> - let (Ty_ex_c ty) = is_ok @@ pair_t dummy_loc ty1 ty2 in - f.apply ty - in - let open Script_int in - [ - (* "int * int" *) - on_pair - int_t - int_t - {apply = (fun ty -> ex "(0, 0) : int * int" ty (of_int 0, of_int 0))}; - (* "string * string" *) - on_pair - string_t - string_t - { - apply = - (fun ty -> - let foo = gen_string "foo" in - let bar = gen_string "bar" in - ex "(foo, bar) : string * string" ty (foo, bar)); - }; - (* "string * int" *) - on_pair - string_t - int_t - { - apply = - (fun ty -> - let foo = gen_string "foo" in - ex "(foo, 0) : string * int" ty (foo, of_int 0)); - }; - (* "int * int * int" *) - on_pair - int_t - int_t - { - apply = - (fun ty -> - on_pair int_t ty - @@ { - apply = - (fun ty -> - ex - "(0, (1, 2)) : int * int * int" - ty - (of_int 0, (of_int 1, of_int 2))); - }); - }; - ]) - (* - Or_t - ======= - *) - @ (let module P = struct - type ('a, 'b) f = {apply : 'c. (('a, 'b) or_, 'c) ty -> ex} - end in - let on_or : type a b. (a, _) ty -> (b, _) ty -> (a, b) P.f -> ex = - fun ty1 ty2 f -> - let (Ty_ex_c ty) = is_ok @@ or_t dummy_loc ty1 ty2 in - f.apply ty - in - let open Script_int in - [ - (* "int + int" *) - on_or - int_t - int_t - {apply = (fun ty -> ex "L 0 : int + int" ty (L (of_int 0)))}; - on_or - int_t - int_t - {apply = (fun ty -> ex "R 0 : int + int" ty (R (of_int 0)))}; - (* "string + string" *) - on_or - string_t - string_t - { - apply = - (fun ty -> - let foo = gen_string "foo" in - ex "L foo : string * string" ty (L foo)); - }; - on_or - string_t - string_t - { - apply = - (fun ty -> - let foo = gen_string "foo" in - ex "R foo : string * string" ty (R foo)); - }; - (* "string + int" *) - on_or - string_t - int_t - { - apply = - (fun ty -> - let foo = gen_string "foo" in - ex "L foo : string * int" ty (L foo)); - }; - (* "int + int + int" *) - on_or - int_t - int_t - { - apply = - (fun ty -> - on_or - int_t - ty - { - apply = - (fun ty -> ex "L 0 : int + int + int" ty (L (of_int 0))); - }); - }; - on_or - int_t - int_t - { - apply = - (fun ty -> - on_or - int_t - ty - { - apply = - (fun ty -> - ex "R (L 0) : int + int + int" ty (R (L (of_int 0)))); - }); - }; - on_or - int_t - int_t - { - apply = - (fun ty -> - on_or - int_t - ty - { - apply = - (fun ty -> - ex "R (R 0) : int + int + int" ty (R (R (of_int 0)))); - }); - }; - ]) - (* - Option_t - ======== - *) - @ (let module P = struct - type 'a f = {apply : 'c. ('a option, 'c) ty -> ex} - end in - let on_option : type a. (a, _) ty -> a P.f -> ex = - fun ty f -> f.apply @@ is_ok @@ option_t dummy_loc ty - in - let open Script_int in - [ - (* "option int" *) - on_option int_t {apply = (fun ty -> ex "None : option int" ty None)}; - on_option - int_t - {apply = (fun ty -> ex "Some 0 : option int" ty (Some (of_int 0)))}; - (* "option string" *) - on_option - string_t - {apply = (fun ty -> ex "None : option string" ty None)}; - on_option - string_t - { - apply = - (fun ty -> - ex "Some \"foo\" : option string" ty (Some (gen_string "foo"))); - }; - ]) - (* - List_t - ====== - *) - @ (let module P = struct - type 'a f = {apply : 'c. ('a Script_list.t, 'c) ty -> ex list} - end in - let on_list : type a. (a, _) ty -> a P.f -> ex list = - fun ty f -> f.apply @@ is_ok @@ list_t dummy_loc ty - in - let check ty show_elt = - on_list - ty - { - apply = - (fun ty -> - let show fmt l = - Format.pp_print_list show_elt fmt @@ Script_list.to_list l - in - exs nsample show ty ": list _"); - } - in - check string_t show_script_string) - (* - Set_t - ====== - *) - @ (let module P = struct - type 'a f = {apply : 'c. ('a set, 'c) ty -> ex list} - end in - let on_set : type a. (a, _) ty -> a P.f -> ex list = - fun ty f -> f.apply @@ is_ok @@ set_t dummy_loc ty - in - let check ty show_elt = - on_set - ty - { - apply = - (fun ty -> - let show fmt s = - Format.fprintf - fmt - "%a / %a" - show_script_int - (Script_set.size s) - (Format.pp_print_list show_elt) - (boxed_set_elements s) - in - exs nsample show ty ": set _"); - } - in - check string_t show_script_string) - (* - Map_t - ====== - *) - @ (let module P = struct - type ('k, 'v) f = {apply : 'c. (('k, 'v) map, 'c) ty -> ex list} - end in - let on_map : type k v. (k, _) ty -> (v, _) ty -> (k, v) P.f -> ex list = - fun kty vty f -> f.apply @@ is_ok @@ map_t dummy_loc kty vty - in - let check kty vty show_key show_value = - on_map - kty - vty - { - apply = - (fun ty -> - let show_binding fmt (k, v) = - Format.fprintf fmt "(%a -> %a)" show_key k show_value v - in - let show fmt s = - Format.pp_print_list show_binding fmt (boxed_map_bindings s) - in - exs nsample show ty ": map _"); - } - in - check string_t string_t show_script_string show_script_string) - (* - Big_map_t - ====== - *) - @ (let module P = struct - type ('k, 'v) f = {apply : 'c. (('k, 'v) big_map, 'c) ty -> ex list} - end in - let on_big_map : type k v. (k, _) ty -> (v, _) ty -> (k, v) P.f -> ex list - = - fun kty vty f -> f.apply @@ is_ok @@ big_map_t dummy_loc kty vty - in - let check kty vty show_key show_value = - on_big_map - kty - vty - { - apply = - (fun ty -> - let show_binding fmt (_, (k, v)) = - match v with - | Some v -> - Format.fprintf fmt "(%a -> %a)" show_key k show_value v - | None -> Format.fprintf fmt "(%a?)" show_key k - in - let show fmt s = - Format.pp_print_list show_binding fmt (big_map_bindings s) - in - exs nsample show ty ": big_map _"); - } - in - check bool_t bool_t show_bool show_bool) - (* - Contract_t - ========= - *) - @ (let show fmt typed_contract = - let destination = Typed_contract.destination typed_contract in - let entrypoint = Typed_contract.entrypoint typed_contract in - show_address fmt {destination; entrypoint} - in - exs - nsample - show - (is_ok @@ contract_t dummy_loc string_t) - ": contract string") - (* - Chain_t - ========= - *) - @ exs nsample dont_show chain_id_t ": chain_id" - (* - Bls12_381_g1_t - ============== - *) - @ exs nsample dont_show bls12_381_g1_t ": bls12_381_g1_t" - (* - Bls12_381_g2_t - ============== - *) - @ exs nsample dont_show bls12_381_g2_t ": bls12_381_g2_t" - (* - Bls12_381_fr_t - ============== - *) - @ exs nsample dont_show bls12_381_fr_t ": bls12_381_fr_t" - (* - Ticket_t - ======== - *) - @ exs - ~error:8 - nsample - dont_show - (is_ok @@ ticket_t dummy_loc bool_t) - ": ticket bool" - (* - Missing by lack of fully functional samplers: - - Sapling_transaction_t ; - - Sapling_transaction_deprecated_t ; - - Sapling_state ; - - Operation_t ; - - Chest_key_t ; - - Chest_t ; - - Lambda_t. - Missing because of language deprecation: - - Tx_rollup_l2_address_t. - *) - ) - -let check_ty_size () = - let check () = - match (sample_ty (Random.int 10 + 1) : ex_ty) with - | Ex_ty ty -> - let expected_size = footprint ty in - let _, size = Script_typed_ir_size.Internal_for_tests.ty_size ty in - let size = Saturation_repr.to_int size in - let what = "some type" in - fail_when - (size <> expected_size) - (err - (Printf.sprintf - "%s was expected to have size %d while the size model answered \ - %d." - what - expected_size - size)) - in - List.iter_es (fun _ -> check ()) (1 -- nsample) - -let check_size ~name ~expected item = - let open Lwt_result_syntax in - let _, e = expected item in - let exp = Saturation_repr.to_int e in - let actual = 8 * Obj.(reachable_words @@ repr item) in - let overapprox = 1_000_000 * (exp - actual) / actual in - let msg verb = - Printf.sprintf - "For %s model predicts the size of %d bytes; while actual measured size \ - is %d bytes. The model %s %d.%04d%%" - name - exp - actual - verb - (abs @@ (overapprox / 10_000)) - (abs @@ (overapprox mod 10_000)) - in - let* () = fail_when (overapprox < 0) (err @@ msg "under-approximates by") in - fail_when (overapprox > 0) (err @@ msg "over-approximates by") -(* We expected the model to always be exact. *) - -(* Test that the model accurately predicts instruction sizes. It tests each - type of instruction separately as much as possible. Tested values are - specifically tailored so that they can't be shared (in particular all - reused values are wrapped in functions to discourage sharing). Thanks - to this the model gives precise predictions for each instruction. In real - life the model will over-approximate due to sharing. It should never under- - approximate though. *) -let check_kinstr_size () = - let open Lwt_result_syntax in - let check (Kinstr (name, instr)) = - check_size - ~name - ~expected:Script_typed_ir_size.Internal_for_tests.kinstr_size - instr - in - (* Location is an immediate value, so we don't care if it's shared. *) - let loc = Micheline.dummy_location in - let str s = - (* It's important to transform the string somehow, or else it will be shared - and thus not reached by Obj.reachable_words. *) - match Script_string.of_string @@ String.uppercase_ascii s with - | Ok ss -> ss - | Error _ -> assert false - in - let entrypoint name = - Entrypoint.of_string_strict_exn @@ String.uppercase_ascii name - in - (* Constants below are wrapped in functions to force recomputation and - discourage sharing. *) - let halt () = IHalt loc in - let drop () = IDrop (loc, halt ()) in - let cdr = ICdr (loc, halt ()) in - let push ty v = IPush (loc, ty, v, halt ()) in - let unit_option_t () = - WithExceptions.Result.get_ok ~loc:__LOC__ @@ option_t loc Unit_t - in - let stack_type () = Item_t (unit_option_t (), Bot_t) in - let id_lambda () = - Lam - ( { - kloc = loc; - kbef = stack_type (); - kaft = stack_type (); - kinstr = halt (); - }, - Micheline.Seq (loc, []) ) - in - (* Following constants are used but once. *) - let zero_memo_size = - WithExceptions.Result.get_ok ~loc:__LOC__ - @@ Alpha_context.Sapling.Memo_size.parse_z Z.zero - in - (* Check size of the lambda alone. *) - let* () = - check_size - ~name:"id lambda" - ~expected:Script_typed_ir_size.lambda_size - (id_lambda ()) - in - (* Testing individual instructions. *) - List.iter_es - check - [ - Kinstr ("IDrop", drop ()); - Kinstr ("IDup", IDup (loc, halt ())); - Kinstr ("ISwap", ISwap (loc, halt ())); - Kinstr ("IPush", push String_t @@ str "tezos"); - Kinstr ("ICons_pair", ICons_pair (loc, halt ())); - Kinstr ("ICar", ICar (loc, halt ())); - Kinstr ("ICdr", cdr); - Kinstr ("IUnpair", IUnpair (loc, halt ())); - Kinstr ("ICons_some", ICons_some (loc, halt ())); - Kinstr ("ICons_none", ICons_none (loc, Int_t, halt ())); - Kinstr - ( "IIf_none", - IIf_none - { - loc; - branch_if_some = drop (); - branch_if_none = halt (); - k = halt (); - } ); - Kinstr ("IOpt_map", IOpt_map {loc; body = halt (); k = halt ()}); - Kinstr ("ICons_left", ICons_left (loc, Nat_t, halt ())); - Kinstr ("ICons_right", ICons_right (loc, Int_t, halt ())); - Kinstr - ( "IIf_left", - IIf_left - { - loc; - branch_if_left = drop (); - branch_if_right = drop (); - k = halt (); - } ); - Kinstr ("ICons_list", ICons_list (loc, halt ())); - Kinstr ("INil", INil (loc, Bytes_t, halt ())); - Kinstr - ( "IIf_cons", - IIf_cons - { - loc; - branch_if_cons = IDrop (loc, drop ()); - branch_if_nil = halt (); - k = halt (); - } ); - Kinstr ("IList_map", IList_map (loc, halt (), None, halt ())); - Kinstr ("IList_iter", IList_iter (loc, None, drop (), halt ())); - Kinstr ("IList_size", IList_size (loc, halt ())); - Kinstr ("IEmpty_set", IEmpty_set (loc, String_t, halt ())); - Kinstr ("ISet_iter", ISet_iter (loc, None, drop (), halt ())); - Kinstr ("ISet_mem", ISet_mem (loc, halt ())); - Kinstr ("ISet_update", ISet_update (loc, halt ())); - Kinstr ("ISet_size", ISet_size (loc, halt ())); - Kinstr ("IEmpty_map", IEmpty_map (loc, Nat_t, None, halt ())); - Kinstr ("IMap_map", IMap_map (loc, None, cdr, halt ())); - Kinstr ("IMap_iter", IMap_iter (loc, None, drop (), halt ())); - Kinstr ("IMap_mem", IMap_mem (loc, halt ())); - Kinstr ("IMap_get", IMap_get (loc, halt ())); - Kinstr ("IMap_update", IMap_update (loc, halt ())); - Kinstr ("IMap_get_and_update", IMap_get_and_update (loc, halt ())); - Kinstr ("IMap_size", IMap_size (loc, halt ())); - Kinstr ("IEmpty_big_map", IEmpty_big_map (loc, Nat_t, String_t, halt ())); - Kinstr ("IBig_map_mem", IBig_map_mem (loc, halt ())); - Kinstr ("IBig_map_get", IBig_map_get (loc, halt ())); - Kinstr ("IBig_map_update", IBig_map_update (loc, halt ())); - Kinstr ("IBig_map_get_and_update", IBig_map_get_and_update (loc, halt ())); - Kinstr ("IConcat_string", IConcat_string (loc, halt ())); - Kinstr ("IConcat_string_pair", IConcat_string_pair (loc, halt ())); - Kinstr ("ISlice_string", ISlice_string (loc, halt ())); - Kinstr ("IString_size", IString_size (loc, halt ())); - Kinstr ("IConcat_bytes", IConcat_bytes (loc, halt ())); - Kinstr ("IConcat_bytes_pair", IConcat_bytes_pair (loc, halt ())); - Kinstr ("ISlice_bytes", ISlice_bytes (loc, halt ())); - Kinstr ("IBytes_size", IBytes_size (loc, halt ())); - Kinstr - ("IAdd_seconds_to_timestamp ", IAdd_seconds_to_timestamp (loc, halt ())); - Kinstr - ("IAdd_timestamp_to_seconds", IAdd_timestamp_to_seconds (loc, halt ())); - Kinstr ("ISub_timestamp_seconds", ISub_timestamp_seconds (loc, halt ())); - Kinstr ("IDiff_timestamps", IDiff_timestamps (loc, halt ())); - Kinstr ("IAdd_tez", IAdd_tez (loc, halt ())); - Kinstr ("ISub_tez", ISub_tez (loc, halt ())); - Kinstr ("ISub_tez_legacy", ISub_tez_legacy (loc, halt ())); - Kinstr ("IMul_tez_nat", IMul_teznat (loc, halt ())); - Kinstr ("IMul_nattez", IMul_nattez (loc, halt ())); - Kinstr ("IEdiv_teznat", IEdiv_teznat (loc, halt ())); - Kinstr ("IEdiv_nattez", IEdiv_tez (loc, halt ())); - Kinstr ("IOr", IOr (loc, halt ())); - Kinstr ("IAnd", IAnd (loc, halt ())); - Kinstr ("IXor", IXor (loc, halt ())); - Kinstr ("INot", INot (loc, halt ())); - Kinstr ("IIs_nat", IIs_nat (loc, halt ())); - Kinstr ("INeg", INeg (loc, halt ())); - Kinstr ("IAbs_int", IAbs_int (loc, halt ())); - Kinstr ("IInt_nat", IInt_nat (loc, halt ())); - Kinstr ("IAdd_int", IAdd_int (loc, halt ())); - Kinstr ("IAdd_nat", IAdd_nat (loc, halt ())); - Kinstr ("ISub_int", ISub_int (loc, halt ())); - Kinstr ("IMul_int", IMul_int (loc, halt ())); - Kinstr ("IMul_nat", IMul_nat (loc, halt ())); - Kinstr ("IEdiv_int", IEdiv_int (loc, halt ())); - Kinstr ("IEdiv_nat", IEdiv_nat (loc, halt ())); - Kinstr ("ILsl_nat", ILsl_nat (loc, halt ())); - Kinstr ("ILsr_nat", ILsr_nat (loc, halt ())); - Kinstr ("IOr_nat", IOr_nat (loc, halt ())); - Kinstr ("IAnd_nat", IAnd_nat (loc, halt ())); - Kinstr ("IAnd_int_nat", IAnd_int_nat (loc, halt ())); - Kinstr ("IXor_nat", IXor_nat (loc, halt ())); - Kinstr ("INot_int", INot_int (loc, halt ())); - Kinstr ("IAnd_bytes", IAnd_bytes (loc, halt ())); - Kinstr ("IOr_bytes", IOr_bytes (loc, halt ())); - Kinstr ("IXor_bytes", IXor_bytes (loc, halt ())); - Kinstr ("INot_bytes", INot_bytes (loc, halt ())); - Kinstr ("ILsl_bytes", ILsl_bytes (loc, halt ())); - Kinstr ("ILsr_bytes", ILsr_bytes (loc, halt ())); - Kinstr - ( "IIf", - IIf - { - loc; - branch_if_true = halt (); - branch_if_false = halt (); - k = halt (); - } ); - Kinstr ("ILoop", ILoop (loc, push Bool_t true, halt ())); - Kinstr ("ILoop_left", ILoop_left (loc, INever loc, halt ())); - Kinstr ("IDip", IDip (loc, halt (), None, halt ())); - Kinstr ("IExec", IExec (loc, None, halt ())); - Kinstr ("IApply", IApply (loc, String_t, halt ())); - Kinstr ("ILambda", ILambda (loc, id_lambda (), halt ())); - Kinstr ("IFailwith", IFailwith (loc, String_t)); - Kinstr ("ICompare", ICompare (loc, String_t, halt ())); - Kinstr ("IEq", IEq (loc, halt ())); - Kinstr ("INeq", INeq (loc, halt ())); - Kinstr ("ILt", ILt (loc, halt ())); - Kinstr ("IGt", IGt (loc, halt ())); - Kinstr ("ILe", ILe (loc, halt ())); - Kinstr ("IGe", IGe (loc, halt ())); - Kinstr ("IAddress", IAddress (loc, halt ())); - Kinstr ("IContract", IContract (loc, Unit_t, entrypoint "entry", halt ())); - Kinstr - ( "IView", - IView - ( loc, - View_signature - { - name = str "myview"; - input_ty = unit_option_t (); - output_ty = unit_option_t (); - }, - None, - halt () ) ); - Kinstr ("ITransfer_tokens", ITransfer_tokens (loc, halt ())); - Kinstr ("IImplicit_account", IImplicit_account (loc, halt ())); - Kinstr - ( "ICreate_contract", - ICreate_contract - { - loc; - storage_type = Unit_t; - code = Micheline.(strip_locations @@ Seq (loc, [])); - k = halt (); - } ); - Kinstr ("ISet_delegate", ISet_delegate (loc, halt ())); - Kinstr ("INow", INow (loc, halt ())); - Kinstr ("IMin_block_time", IMin_block_time (loc, halt ())); - Kinstr ("IBalance", IBalance (loc, halt ())); - Kinstr ("ILevel", ILevel (loc, halt ())); - Kinstr ("ICheck_signature", ICheck_signature (loc, halt ())); - Kinstr ("IHash_key", IHash_key (loc, halt ())); - Kinstr ("IPack", IPack (loc, Int_t, halt ())); - Kinstr ("IUnpack", IUnpack (loc, Int_t, halt ())); - Kinstr ("IBlake2b", IBlake2b (loc, halt ())); - Kinstr ("ISha_256", ISha256 (loc, halt ())); - Kinstr ("ISha512", ISha512 (loc, halt ())); - Kinstr ("ISource", ISource (loc, halt ())); - Kinstr ("ISender", ISender (loc, halt ())); - Kinstr ("ISelf", ISelf (loc, Unit_t, entrypoint "entry", halt ())); - Kinstr ("ISelf_address", ISelf_address (loc, halt ())); - Kinstr ("IAmount", IAmount (loc, halt ())); - Kinstr - ( "ISapling_empty_state", - ISapling_empty_state (loc, zero_memo_size, halt ()) ); - Kinstr ("ISapling_verify_update", ISapling_verify_update (loc, halt ())); - Kinstr - ( "ISapling_verify_update_deprecated", - ISapling_verify_update_deprecated (loc, halt ()) ); - Kinstr ("IDig", IDig (loc, 0, KRest, halt ())); - Kinstr ("IDug", IDug (loc, 0, KRest, halt ())); - Kinstr ("IDipn", IDipn (loc, 0, KRest, halt (), halt ())); - Kinstr ("IDropn", IDropn (loc, 0, KRest, halt ())); - Kinstr ("IChainId", IChainId (loc, halt ())); - Kinstr ("INever", INever loc); - Kinstr ("IVoting_power", IVoting_power (loc, halt ())); - Kinstr ("ITotal_voting_power", ITotal_voting_power (loc, halt ())); - Kinstr ("IKeccak", IKeccak (loc, halt ())); - Kinstr ("ISha3", ISha3 (loc, halt ())); - Kinstr ("IAdd_bls12_381_g1", IAdd_bls12_381_g1 (loc, halt ())); - Kinstr ("IAdd_bls12_381_2g", IAdd_bls12_381_g2 (loc, halt ())); - Kinstr ("IAdd_bls12_381_fr", IAdd_bls12_381_fr (loc, halt ())); - Kinstr ("IMul_bls12_381_g1", IMul_bls12_381_g1 (loc, halt ())); - Kinstr ("IMul_bls12_381_g2", IMul_bls12_381_g2 (loc, halt ())); - Kinstr ("IMul_bls12_381_fr", IMul_bls12_381_fr (loc, halt ())); - Kinstr ("IMul_bls12_381_z_fr", IMul_bls12_381_z_fr (loc, halt ())); - Kinstr ("IMul_bls12_381_fr_z", IMul_bls12_381_fr_z (loc, halt ())); - Kinstr ("IMul_bls12_381_fr_z", IMul_bls12_381_fr_z (loc, halt ())); - Kinstr ("IInt_bls12_381_fr", IInt_bls12_381_fr (loc, halt ())); - Kinstr ("INeg_bls12_381_g1", INeg_bls12_381_g1 (loc, halt ())); - Kinstr ("INeg_bls12_381_g2", INeg_bls12_381_g2 (loc, halt ())); - Kinstr ("INeg_bls12_381_fr", INeg_bls12_381_fr (loc, halt ())); - Kinstr - ("IPairing_check_bls12_381", IPairing_check_bls12_381 (loc, halt ())); - Kinstr ("IComb", IComb (loc, 0, Comb_one, halt ())); - Kinstr ("IUncomb", IUncomb (loc, 0, Uncomb_one, halt ())); - Kinstr ("IComb_get", IComb_get (loc, 0, Comb_get_zero, halt ())); - Kinstr ("IComb_set", IComb_set (loc, 0, Comb_set_zero, halt ())); - Kinstr ("IDup_n", IDup_n (loc, 0, Dup_n_zero, halt ())); - Kinstr ("ITicket", ITicket (loc, None, halt ())); - Kinstr ("IRead_ticket", IRead_ticket (loc, None, halt ())); - Kinstr ("ISplit_ticket", ISplit_ticket (loc, halt ())); - Kinstr ("IJoin_tickets", IJoin_tickets (loc, Unit_t, halt ())); - Kinstr ("IOpen_chest", IOpen_chest (loc, halt ())); - Kinstr - ( "IEmit", - IEmit - { - loc; - tag = entrypoint "entry"; - ty = Unit_t; - unparsed_ty = Micheline.(strip_locations @@ Seq (loc, [])); - k = halt (); - } ); - Kinstr ("IHalt ()", halt ()); - ] - -let check_witness_sizes () = - let loc = Micheline.dummy_location in - let stack_prefix_preservation = - KPrefix - ( loc, - Unit_t, - KPrefix - ( loc, - Unit_t, - KPrefix - ( loc, - Unit_t, - KPrefix - ( loc, - Unit_t, - KPrefix - ( loc, - Unit_t, - KPrefix - ( loc, - Unit_t, - KPrefix (loc, Unit_t, KPrefix (loc, Unit_t, KRest)) - ) ) ) ) ) ) - in - check_size - ~name:"stack_prefix_preservation_witness" - ~expected: - Script_typed_ir_size.Internal_for_tests - .stack_prefix_preservation_witness_size - stack_prefix_preservation - -let check_micheline_sizes () = - let open Michelson_v1_primitives in - let check (name, micheline) = - check_size ~name ~expected:Cache_memory_helpers.node_size micheline - in - let int i = Micheline.(Int (dummy_loc, Z.of_int i)) in - let big_int z = Micheline.(Int (dummy_loc, z)) in - let str s = Micheline.(String (dummy_location, String.lowercase_ascii s)) in - let bytes b = Micheline.(Bytes (dummy_location, Bytes.of_string b)) in - let prim ?(annot = []) p args = - Micheline.(Prim (dummy_location, p, args, annot)) - in - let seq xs = Micheline.(Seq (dummy_location, xs)) in - List.iter_es - check - [ - ("empty micheline", seq []); - ("a single number", int 1024); - ("a large number", big_int Z.(of_int 3 * of_int max_int)); - ("a short string", str "tezostezostezos"); - ("a short bytestring", bytes "tezostezostezos"); - ("a prim with no args", prim I_UNIT []); - ("a seq of prims", seq [prim I_DUP []; prim I_DROP []]); - ("a prim with arg", prim I_DIG [int 2]); - ( "combine everything together", - seq - [ - prim I_UNIT []; - prim I_DUG [int 3] ~annot:[String.lowercase_ascii "@number"]; - prim I_DIP [seq [prim I_DROP [int 2]]]; - prim I_PUSH [prim T_string []; str "tezos"]; - ] ); - ] - -let tests = - let open Tztest in - [ - tztest "value size" `Quick check_value_size; - tztest "ty size" `Quick check_ty_size; - tztest "kinstr size" `Quick check_kinstr_size; - tztest "witness sizes" `Quick check_witness_sizes; - tztest "micheline sizes" `Quick check_micheline_sizes; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("script typed ir size", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_temp_big_maps.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_temp_big_maps.ml deleted file mode 100644 index fe2948beeecdd0bd3d7376f4d2c0c08b1e665d23..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_temp_big_maps.ml +++ /dev/null @@ -1,107 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (temporary big maps) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/michelson/main.exe \ - -- --file test_temp_big_maps.ml - Subject: On temporary big maps. -*) - -open Protocol - -let to_raw_context (b : Block.t) = - Raw_context.prepare - b.context - ~level:b.header.shell.level - ~predecessor_timestamp:b.header.shell.timestamp - ~timestamp:b.header.shell.timestamp - >|= Environment.wrap_tzresult - -let check_no_dangling_temp_big_map b = - to_raw_context b >>=? fun ctxt -> - Storage.Big_map.fold ctxt ~init:() ~order:`Sorted ~f:(fun id () -> - assert (not (Lazy_storage_kind.Big_map.Id.is_temp id)) ; - Lwt.return_unit) - >>= fun () -> - Storage.Big_map.fold ctxt ~init:() ~order:`Undefined ~f:(fun id () -> - assert (not (Lazy_storage_kind.Big_map.Id.is_temp id)) ; - Lwt.return_unit) - >>= fun () -> return_unit - -let call_the_contract b ~baker ~src contract param_left param_right = - let fee = Alpha_context.Tez.one in - let amount = Alpha_context.Tez.zero in - let param = Printf.sprintf "Pair (%s) %s" param_left param_right in - let parameters = Alpha_context.Script.lazy_expr (Expr.from_string param) in - Op.transaction ~fee (B b) src contract amount ~parameters - >>=? fun operation -> - Incremental.begin_construction ~policy:Block.(By_account baker) b - >>=? fun incr -> - Incremental.add_operation incr operation >>=? fun incr -> - Incremental.finalize_block incr - -let path = project_root // Filename.dirname __FILE__ - -(** Originates the contract at contracts/temp_big_maps.tz and calls it with - the pair [(param_left, param_right)]. - An action (originating, storing, passing, passing twice) is done on a big - map (either fresh, passed, or stored). - All combinations are exercised. -*) -let test_temp_big_maps_contract param_left param_right () = - Contract_helpers.init () >>=? fun (b, baker, src, _src2) -> - Contract_helpers.originate_contract - (path // "contracts/temp_big_maps.tz") - "{}" - src - b - baker - >>=? fun (contract, b) -> - check_no_dangling_temp_big_map b >>=? fun () -> - call_the_contract b ~baker ~src contract param_left param_right >>=? fun b -> - check_no_dangling_temp_big_map b - -let param_left_values = ["Left True"; "Left False"; "Right {}"] - -let param_right_values = ["-1"; "0"; "1"; "2"] - -let tests = - List.flatten - (List.map - (fun param_left -> - List.map - (fun param_right -> - Tztest.tztest - (Printf.sprintf "temp_big_maps(%s, %s)" param_left param_right) - `Quick - (test_temp_big_maps_contract param_left param_right)) - param_right_values) - param_left_values) - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("temp big maps", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_accounting.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_accounting.ml deleted file mode 100644 index 96c3e4b1299e371d3c1148531f81e4ba004d5d04..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_accounting.ml +++ /dev/null @@ -1,1445 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (Ticket_scanner) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/michelson/main.exe \ - -- --file test_ticket_accounting.ml - Subject: Ticket scanner tests -*) - -open Protocol -open Alpha_context -open Script_typed_ir - -let assert_equal_string_list ~loc msg = - Assert.assert_equal_list ~loc String.equal msg Format.pp_print_string - -let assert_fail_with ~loc ~msg f = - let open Lwt_result_wrap_syntax in - let*! res = wrap @@ f () in - match res with - | Error [x] -> - let x = Format.asprintf "%a" Error_monad.pp x in - Assert.equal ~loc String.equal "" Format.pp_print_string msg x - | Ok _ -> failwith "Expected an error at %s, but got `Ok'." loc - | Error _ -> failwith "Expected a single error at %s." loc - -let string_list_of_ex_token_diffs ctxt token_diffs = - let open Lwt_result_wrap_syntax in - let accum (xs, ctxt) - (Ticket_token.Ex_token {ticketer; contents_type; contents}, amount) = - let*@ x, ctxt = - Script_ir_unparser.unparse_comparable_data - ctxt - Script_ir_unparser.Readable - contents_type - contents - in - let str = - Format.asprintf - {|{ticketer: "%a"; contents: %a; amount: %a}|} - Contract.pp - ticketer - Michelson_v1_printer.print_expr - x - Z.pp_print - amount - in - return (str :: xs, ctxt) - in - let* xs, ctxt = List.fold_left_es accum ([], ctxt) token_diffs in - return (List.rev xs, ctxt) - -let make_ex_token ctxt ~ticketer ~type_exp ~content_exp = - let open Lwt_result_wrap_syntax in - let*?@ Script_ir_translator.Ex_comparable_ty contents_type, ctxt = - let node = Micheline.root @@ Expr.from_string type_exp in - Script_ir_translator.parse_comparable_ty ctxt node - in - let*?@ ticketer = Contract.of_b58check ticketer in - let*@ contents, ctxt = - let node = Micheline.root @@ Expr.from_string content_exp in - Script_ir_translator.parse_comparable_data ctxt contents_type node - in - return (Ticket_token.Ex_token {ticketer; contents_type; contents}, ctxt) - -let assert_equal_ticket_diffs ~loc ctxt given expected = - let open Lwt_result_syntax in - let* ctxt, tbs1 = - List.fold_left_map_es - (fun ctxt ((ticketer, content), delta) -> - make_ex_token - ctxt - ~ticketer - ~type_exp:"string" - ~content_exp:(Printf.sprintf "%S" content) - >|=? fun (token, ctxt) -> (ctxt, (token, Z.of_int delta))) - ctxt - expected - in - let* tbs1, ctxt = string_list_of_ex_token_diffs ctxt tbs1 in - let* tbs2, _ctxt = string_list_of_ex_token_diffs ctxt given in - assert_equal_string_list - ~loc - "Compare token balances" - (List.sort String.compare tbs1) - (List.sort String.compare tbs2) - -let assert_equal_ticket_receipt ~loc given expected = - let open Lwt_result_wrap_syntax in - let make_receipt_item (ticketer, content, updates) = - let*?@ ticketer = Contract.of_b58check ticketer in - let contents = Expr.from_string (Printf.sprintf "%S" content) in - let contents_type = Expr.from_string "string" in - let ticket_token = Ticket_token.{ticketer; contents_type; contents} in - let updates = - List.map - (fun (account, amount) -> - let account = Destination.Contract account in - let amount = Z.of_int amount in - Ticket_receipt.{account; amount}) - updates - in - return Ticket_receipt.{ticket_token; updates} - in - let* expected = List.map_es make_receipt_item expected in - Assert.equal_with_encoding - ~loc - (Data_encoding.list Ticket_receipt.item_encoding) - expected - given - -let updates_of_key_values ctxt ~key_type ~value_type key_values = - let open Lwt_result_wrap_syntax in - List.fold_right_es - (fun (key, value) (kvs, ctxt) -> - let*@ key_hash, ctxt = - Script_ir_translator.hash_comparable_data ctxt key_type key - in - let*@ key, ctxt = - Script_ir_unparser.unparse_comparable_data - ctxt - Script_ir_unparser.Readable - key_type - key - in - let* value, ctxt = - match value with - | None -> return (None, ctxt) - | Some value -> - let*@ value_node, ctxt = - Script_ir_translator.unparse_data - ctxt - Script_ir_unparser.Readable - value_type - value - in - return (Some value_node, ctxt) - in - return ({Big_map.key; key_hash; value} :: kvs, ctxt)) - key_values - ([], ctxt) - -let make_alloc big_map_id alloc updates = - Lazy_storage.make - Lazy_storage.Kind.Big_map - big_map_id - (Update {init = Lazy_storage.Alloc alloc; updates}) - -let init () = - let open Lwt_result_syntax in - let* block, source = Context.init1 () in - let* operation, originated = - Op.contract_origination_hash (B block) source ~script:Op.dummy_script - in - let* block = Block.bake ~operation block in - let* inc = Incremental.begin_construction block in - return (originated, Incremental.alpha_ctxt inc) - -(** Initializes one address for operations and one baker. *) -let init_for_operation () = - Context.init2 ~consensus_threshold:0 () >|=? fun (block, (src0, src1)) -> - let baker = Context.Contract.pkh src0 in - (baker, src1, block) - -let two_ticketers block = - let open Lwt_result_syntax in - let* ctxt = - Incremental.begin_construction block >|=? Incremental.alpha_ctxt - in - let*! cs = Contract.list ctxt in - match cs with c1 :: c2 :: _ -> return (c1, c2) | _ -> assert false - -let ticket_list_script = - {| - { parameter (list (ticket string)); - storage (list (ticket string)); - code { CAR; NIL operation ; PAIR } } - |} - -let setup ctxt ~key_type ~value_type entries = - let open Lwt_result_wrap_syntax in - let*@ ctxt, big_map_id = Big_map.fresh ~temporary:false ctxt in - let* updates, ctxt = - updates_of_key_values - ctxt - ~key_type - ~value_type - (List.map (fun (k, v) -> (k, Some v)) entries) - in - let*? key_type_node, ctxt = - Environment.wrap_tzresult - @@ Script_ir_unparser.unparse_ty ~loc:Micheline.dummy_location ctxt key_type - in - let*? value_type_node, ctxt = - Environment.wrap_tzresult - @@ Script_ir_unparser.unparse_ty - ~loc:Micheline.dummy_location - ctxt - value_type - in - let key_type = Micheline.strip_locations key_type_node in - let value_type = Micheline.strip_locations value_type_node in - let alloc = make_alloc big_map_id Big_map.{key_type; value_type} updates in - return (alloc, big_map_id, ctxt) - -let new_big_map ctxt contract ~key_type ~value_type entries = - let open Lwt_result_wrap_syntax in - let* alloc, big_map_id, ctxt = setup ctxt ~key_type ~value_type entries in - let storage = Expr.from_string "{}" in - let*@ ctxt = - Contract.update_script_storage ctxt contract storage (Some [alloc]) - in - return (big_map_id, ctxt) - -let alloc_diff ctxt ~key_type ~value_type entries = - let open Lwt_result_syntax in - let* allocations, _, ctxt = setup ctxt ~key_type ~value_type entries in - return (allocations, ctxt) - -let remove_diff ctxt contract ~key_type ~value_type ~existing_entries = - let open Lwt_result_syntax in - let* big_map_id, ctxt = - new_big_map ctxt contract ~key_type ~value_type existing_entries - in - return (Lazy_storage.make Lazy_storage.Kind.Big_map big_map_id Remove, ctxt) - -let copy_diff ctxt contract ~key_type ~value_type ~existing_entries ~updates = - let open Lwt_result_wrap_syntax in - let* big_map_id, ctxt = - new_big_map ctxt contract ~key_type ~value_type existing_entries - in - let* updates, ctxt = - updates_of_key_values ctxt ~key_type ~value_type updates - in - let*@ ctxt, new_big_map_id = Big_map.fresh ctxt ~temporary:false in - return - ( Lazy_storage.make - Lazy_storage.Kind.Big_map - new_big_map_id - (Update {init = Lazy_storage.Copy {src = big_map_id}; updates}), - ctxt ) - -let existing_diff ctxt contract ~key_type ~value_type ~existing_entries ~updates - = - let open Lwt_result_syntax in - let* big_map_id, ctxt = - new_big_map ctxt contract ~key_type ~value_type existing_entries - in - let* updates, ctxt = - updates_of_key_values ctxt ~key_type ~value_type updates - in - return - ( Lazy_storage.make - Lazy_storage.Kind.Big_map - big_map_id - (Update {init = Lazy_storage.Existing; updates}), - ctxt ) - -let empty_big_map ctxt ~key_type ~value_type = - let open Lwt_result_wrap_syntax in - let open Script_typed_ir in - let*@ ctxt, big_map_id = Big_map.fresh ~temporary:false ctxt in - return - ( Big_map - { - id = Some big_map_id; - diff = {map = Big_map_overlay.empty; size = 0}; - key_type; - value_type; - }, - ctxt ) - -let make_big_map ctxt contract ~key_type ~value_type entries = - let open Lwt_result_syntax in - let open Script_typed_ir in - let* big_map_id, ctxt = - new_big_map ctxt contract ~key_type ~value_type entries - in - return - ( Big_map - { - id = Some big_map_id; - diff = {map = Big_map_overlay.empty; size = 0}; - key_type; - value_type; - }, - ctxt ) - -let originate_script block ~script ~storage ~src ~baker ~forges_tickets = - let open Lwt_result_syntax in - let code = Expr.toplevel_from_string script in - let storage = Expr.from_string storage in - let* operation, destination = - let script = - Alpha_context.Script.{code = lazy_expr code; storage = lazy_expr storage} - in - Op.contract_origination_hash (B block) src ~fee:(Test_tez.of_int 10) ~script - in - let* incr = - Incremental.begin_construction ~policy:Block.(By_account baker) block - in - let* incr = - Incremental.add_operation - ?expect_apply_failure: - (if forges_tickets then Some (fun _ -> return ()) else None) - incr - operation - in - let script = (code, storage) in - Incremental.finalize_block incr >|=? fun block -> (destination, script, block) - -let origination_operation ctxt ~src ~script:(code, storage) ~orig_contract = - let open Lwt_result_wrap_syntax in - let script = Script.{code = lazy_expr code; storage = lazy_expr storage} in - let unparsed_storage = storage in - let*@ ( Script_ir_translator.Ex_script - (Script - { - storage_type; - storage; - code = _; - arg_type = _; - views = _; - entrypoints = _; - code_size = _; - }), - ctxt ) = - Script_ir_translator.parse_script - ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) - ~allow_forged_in_storage:true - script - in - let operation = - Internal_operation - { - source = src; - operation = - Origination - { - delegate = None; - code; - unparsed_storage; - credit = Tez.one; - preorigination = orig_contract; - storage_type; - storage; - }; - nonce = 1; - } - in - return (operation, ctxt) - -let originate block ~src ~baker ~script ~storage ~forges_tickets = - let open Lwt_result_syntax in - let* orig_contract, script, block = - originate_script block ~script ~storage ~src ~baker ~forges_tickets - in - let* incr = - Incremental.begin_construction ~policy:Block.(By_account baker) block - in - return (orig_contract, script, incr) - -let transfer_operation ctxt ~src ~destination ~arg_type ~arg = - let open Lwt_result_wrap_syntax in - let*@ params_node, ctxt = - Script_ir_translator.unparse_data - ctxt - Script_ir_unparser.Readable - arg_type - arg - in - return - ( Internal_operation - { - source = src; - operation = - Transaction_to_smart_contract - { - amount = Tez.zero; - unparsed_parameters = params_node; - entrypoint = Entrypoint.default; - destination; - location = Micheline.dummy_location; - parameters_ty = arg_type; - parameters = arg; - }; - nonce = 1; - }, - ctxt ) - -let ticket_string_type = - WithExceptions.Result.get_ok ~loc:__LOC__ - @@ Script_typed_ir.(ticket_t (-1) string_t) - -let ticket_string_list_type = - Result.value_f ~default:(fun _ -> assert false) - @@ Script_typed_ir.list_t (-1) ticket_string_type - -let boxed_list = Script_list.of_list - -let big_map_type ~key_type ~value_type = - Environment.wrap_tzresult - @@ Script_typed_ir.big_map_t (-1) key_type value_type - -let type_has_tickets ctxt ty = - Environment.wrap_tzresult @@ Ticket_scanner.type_has_tickets ctxt ty - -(** Test that adding a ticket to a lazy storage diff is picked up. *) -let assert_ticket_diffs ctxt ~loc ~self_contract ~arg_type ~storage_type ~arg - ~old_storage ~new_storage ~lazy_storage_diff ~expected_diff - ~expected_receipt = - let open Lwt_result_wrap_syntax in - let*? arg_type_has_tickets, ctxt = type_has_tickets ctxt arg_type in - let*? storage_type_has_tickets, ctxt = type_has_tickets ctxt storage_type in - let*@ ticket_diff, ticket_receipt, ctxt = - Ticket_accounting.ticket_diffs - ctxt - ~self_contract:(Originated self_contract) - ~arg_type_has_tickets - ~storage_type_has_tickets - ~arg - ~old_storage - ~new_storage - ~lazy_storage_diff - in - let*? ticket_diffs, ctxt = - Environment.wrap_tzresult @@ Ticket_token_map.to_list ctxt ticket_diff - in - let* () = assert_equal_ticket_diffs ~loc ctxt ticket_diffs expected_diff in - let expected_receipt = - List.map - (fun (contract, contents, amounts) -> - let amounts = - List.map - (fun (contract, amount) -> (Contract.Originated contract, amount)) - amounts - in - (contract, contents, amounts)) - expected_receipt - in - assert_equal_ticket_receipt ~loc ticket_receipt expected_receipt - -let assert_balance = Ticket_helpers.assert_balance - -let string_ticket ticketer contents amount = - let amount = - WithExceptions.Option.get ~loc:__LOC__ - @@ Ticket_amount.of_n @@ Script_int.abs @@ Script_int.of_int amount - in - let ticketer = - Result.value_f ~default:(fun _ -> assert false) - @@ Contract.of_b58check ticketer - in - let contents = - Result.value_f ~default:(fun _ -> assert false) - @@ Script_string.of_string contents - in - Script_typed_ir.{ticketer; contents; amount} - -let string_ticket_token = Ticket_helpers.string_ticket_token - -let test_diffs_empty () = - let open Lwt_result_syntax in - let open Script_typed_ir in - let* contract, ctxt = init () in - let*? int_ticket_big_map_ty = - big_map_type ~key_type:int_t ~value_type:ticket_string_type - in - (* Start with an empty big-map *) - let* empty_big_map, ctxt = - empty_big_map ctxt ~key_type:int_t ~value_type:ticket_string_type - in - assert_ticket_diffs - ctxt - ~loc:__LOC__ - ~self_contract:contract - ~arg_type:unit_t - ~storage_type:int_ticket_big_map_ty - ~arg:() - ~old_storage:empty_big_map - ~new_storage:empty_big_map - ~lazy_storage_diff:[] - ~expected_diff:[] - ~expected_receipt:[] - -(** Test that sending one ticket as an argument, when the new storage is empty - results in: - - Negative diff - - Empty receipt (since no ticket was added/removed from storage) *) -let test_diffs_tickets_in_args () = - let open Lwt_result_syntax in - let open Script_typed_ir in - let* contract, ctxt = init () in - let arg = string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1 in - assert_ticket_diffs - ctxt - ~loc:__LOC__ - ~self_contract:contract - ~arg_type:ticket_string_type - ~storage_type:unit_t - ~arg - ~old_storage:() - ~new_storage:() - ~lazy_storage_diff:[] - ~expected_diff:[(("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), -1)] - ~expected_receipt:[] - -(** Test adding a ticket to the args, which is also accounted for in the new - storage, results in: - - Empty diff - - Receipt with positive update (since one ticket was added to storage) *) -let test_diffs_tickets_in_args_and_storage () = - let open Lwt_result_syntax in - let* contract, ctxt = init () in - let arg = string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1 in - assert_ticket_diffs - ctxt - ~loc:__LOC__ - ~self_contract:contract - ~arg_type:ticket_string_type - ~storage_type:ticket_string_list_type - ~arg - ~old_storage:(boxed_list []) - ~new_storage:(boxed_list [arg]) - ~lazy_storage_diff:[] - ~expected_diff:[(("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), 0)] - ~expected_receipt: - [("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", [(contract, 1)])] - -(** Test that adding two tickets in the args, and only one new ticket in the - storage results in: - - Negative diff - - Receipt with single positive update (since one ticket was added to storage) *) -let test_diffs_drop_one_ticket () = - let open Lwt_result_syntax in - let* contract, ctxt = init () in - let arg = - boxed_list - [ - string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1; - string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 1; - ] - in - let new_storage = - boxed_list [string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1] - in - assert_ticket_diffs - ctxt - ~loc:__LOC__ - ~self_contract:contract - ~arg_type:ticket_string_list_type - ~storage_type:ticket_string_list_type - ~arg - ~old_storage:(boxed_list []) - ~new_storage - ~lazy_storage_diff:[] - ~expected_diff: - [ - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), 0); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue"), -1); - ] - ~expected_receipt: - [("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", [(contract, 1)])] - -(** Test that adding a new ticket to the storage results in: - - Positive diff - - Receipt with single positive update *) -let test_diffs_adding_new_ticket_to_storage () = - let open Lwt_result_syntax in - let* contract, ctxt = init () in - let new_storage = - boxed_list [string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1] - in - assert_ticket_diffs - ctxt - ~loc:__LOC__ - ~self_contract:contract - ~arg_type:Script_typed_ir.unit_t - ~storage_type:ticket_string_list_type - ~arg:() - ~old_storage:(boxed_list []) - ~new_storage - ~lazy_storage_diff:[] - ~expected_diff:[(("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), 1)] - ~expected_receipt: - [("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", [(contract, 1)])] - -(** Test that removing one ticket from the storage results in: - - Negative diff - - Receipt with negative update *) -let test_diffs_remove_from_storage () = - let open Lwt_result_syntax in - let* contract, ctxt = init () in - let old_storage = - boxed_list - [ - string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1; - string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 2; - ] - in - let new_storage = - boxed_list [string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1] - in - assert_ticket_diffs - ctxt - ~loc:__LOC__ - ~self_contract:contract - ~arg_type:Script_typed_ir.unit_t - ~storage_type:ticket_string_list_type - ~arg:() - ~old_storage - ~new_storage - ~lazy_storage_diff:[] - ~expected_diff: - [ - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), 0); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue"), -2); - ] - ~expected_receipt: - [("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue", [(contract, -2)])] - -(* Test adding ticket through lazy-storage diff results in: - - Positive diff - - Receipt with positive update *) -let test_diffs_lazy_storage_alloc () = - let open Lwt_result_syntax in - let open Script_typed_ir in - let* contract, ctxt = init () in - let*? int_ticket_big_map_ty = - big_map_type ~key_type:int_t ~value_type:ticket_string_type - in - (* Start with an empty big-map *) - let* empty_big_map, ctxt = - empty_big_map ctxt ~key_type:int_t ~value_type:ticket_string_type - in - (* We add one ticket to the storage. *) - let* lazy_storage_diff, ctxt = - alloc_diff - ctxt - ~key_type:int_t - ~value_type:ticket_string_type - [ - ( Script_int.of_int 1, - string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1 ); - ] - in - assert_ticket_diffs - ctxt - ~loc:__LOC__ - ~self_contract:contract - ~arg_type:int_ticket_big_map_ty - ~storage_type:int_ticket_big_map_ty - ~arg:empty_big_map - ~old_storage:empty_big_map - ~new_storage:empty_big_map - ~lazy_storage_diff:[lazy_storage_diff] - ~expected_diff:[(("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), 1)] - ~expected_receipt: - [("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", [(contract, 1)])] - -(* Test removing a big map containing a ticket results in: - - Negative diff - - Receipt with negative update *) -let test_diffs_remove_from_big_map () = - let open Lwt_result_syntax in - let open Script_typed_ir in - let* contract, ctxt = init () in - let*? int_ticket_big_map_ty = - big_map_type ~key_type:int_t ~value_type:ticket_string_type - in - (* Start with an empty big-map *) - let* empty_big_map, ctxt = - empty_big_map ctxt ~key_type:int_t ~value_type:ticket_string_type - in - (* Remove one ticket from the lazy storage. *) - let* lazy_storage_diff, ctxt = - remove_diff - ctxt - contract - ~key_type:int_t - ~value_type:ticket_string_type - ~existing_entries: - [ - ( Script_int.of_int 1, - string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1 ); - ] - in - assert_ticket_diffs - ctxt - ~loc:__LOC__ - ~self_contract:contract - ~arg_type:unit_t - ~storage_type:int_ticket_big_map_ty - ~arg:() - ~old_storage:empty_big_map - ~new_storage:empty_big_map - ~lazy_storage_diff:[lazy_storage_diff] - ~expected_diff:[(("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), -1)] - ~expected_receipt: - [("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", [(contract, -1)])] - -(** Test copying a big-map. *) -let test_diffs_copy_big_map () = - let open Lwt_result_syntax in - let open Script_typed_ir in - let* contract, ctxt = init () in - let*? int_ticket_big_map_ty = - big_map_type ~key_type:int_t ~value_type:ticket_string_type - in - (* Start with an empty big-map *) - let* empty_big_map, ctxt = - empty_big_map ctxt ~key_type:int_t ~value_type:ticket_string_type - in - (* We add one ticket to the storage. *) - let* lazy_storage_diff, ctxt = - copy_diff - ctxt - contract - ~key_type:int_t - ~value_type:ticket_string_type - ~existing_entries: - [ - ( Script_int.of_int 1, - string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1 ); - ] - ~updates: - [ - ( Script_int.of_int 2, - Some (string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 1) - ); - ] - in - (* We copy a big-map with one ticket inside (this is illegal in Michelson). - Then we add a new ticket to the map. The result is two new tickets. - *) - assert_ticket_diffs - ctxt - ~loc:__LOC__ - ~self_contract:contract - ~arg_type:unit_t - ~storage_type:int_ticket_big_map_ty - ~arg:() - ~old_storage:empty_big_map - ~new_storage:empty_big_map - ~lazy_storage_diff:[lazy_storage_diff] - ~expected_diff: - [ - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), 1); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue"), 1); - ] - ~expected_receipt: - [ - ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", [(contract, 1)]); - ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue", [(contract, 1)]); - ] - -(** Test that adding and removing items from an existing big-map results - yield corresponding ticket-token diffs. *) -let test_diffs_add_to_existing_big_map () = - let open Lwt_result_syntax in - let open Script_typed_ir in - let* contract, ctxt = init () in - let*? int_ticket_big_map_ty = - big_map_type ~key_type:int_t ~value_type:ticket_string_type - in - let* old_storage, ctxt = - make_big_map - ctxt - contract - ~key_type:int_t - ~value_type:ticket_string_type - [ - (* It doesn't matter what the old entries are. They are never traversed *) - ( Script_int.of_int 1, - string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1 ); - ( Script_int.of_int 2, - string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 1 ); - ( Script_int.of_int 3, - string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 1 ); - ] - in - (* We add one ticket to the storage. *) - let* lazy_storage_diff, ctxt = - existing_diff - ctxt - contract - ~key_type:int_t - ~value_type:ticket_string_type - ~existing_entries: - [ - ( Script_int.of_int 1, - string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1 ); - ] - ~updates: - [ - (* Add one new ticket to the big-map. *) - ( Script_int.of_int 2, - Some (string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 2) - ); - (* Remove a ticket *) - (Script_int.of_int 1, None); - ] - in - (* Even if the old and the new storage are the same (and contains tickets) - we should still detect the diff from the lazy-storage diff. - Since the old and new storage are lazy, they should never be traversed. - *) - assert_ticket_diffs - ctxt - ~loc:__LOC__ - ~self_contract:contract - ~arg_type:unit_t - ~storage_type:int_ticket_big_map_ty - ~arg:() - ~old_storage - ~new_storage:old_storage - ~lazy_storage_diff:[lazy_storage_diff] - ~expected_diff: - [ - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), -1); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue"), 2); - ] - ~expected_receipt: - [ - ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", [(contract, -1)]); - ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue", [(contract, 2)]); - ] - -(** Test a combination of updates. *) -let test_diffs_args_storage_and_lazy_diffs () = - let open Lwt_result_syntax in - let open Script_typed_ir in - let* contract, ctxt = init () in - let*? int_ticket_big_map_ty = - big_map_type ~key_type:int_t ~value_type:ticket_string_type - in - let*? (Ty_ex_c list_big_map_pair_type) = - Environment.wrap_tzresult - @@ pair_t (-1) ticket_string_list_type int_ticket_big_map_ty - in - let* empty_big_map, ctxt = - empty_big_map ctxt ~key_type:int_t ~value_type:ticket_string_type - in - (* We send two tickets in the args. *) - let arg = - boxed_list - [ - string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1; - string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 1; - ] - in - (* We add three tickets to the storage. *) - let* lazy_storage_diff, ctxt = - existing_diff - ctxt - contract - ~key_type:int_t - ~value_type:ticket_string_type - ~existing_entries:[] - ~updates: - [ - ( Script_int.of_int 1, - Some (string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1) - ); - ( Script_int.of_int 2, - Some (string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 1) - ); - ( Script_int.of_int 3, - Some - (string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 1) - ); - ] - in - (* We have three tickets in the old storage. *) - let old_storage = - ( boxed_list - [ - string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1; - string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 1; - string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 1; - ], - empty_big_map ) - in - let new_storage = - ( boxed_list - [ - string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 1; - string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "yellow" 1; - ], - empty_big_map ) - in - (* - Diff: - Before script execution: - - Args: 1 red, 1 blue - - Old storage : 1 red, 1 blue, 1 green - - Total: 2 red, 2 blue, 1 green - After execution: - - New_storage: 1 green, 1 yellow - - Lazy-diff: 1 red, 1 blue, 1 green - - Total: 1 red, 1 blue, 2 green, 1 yellow - Net diff: - - -1 red, -1 blue, +1 green, +1 yellow - Receipt (diff in storage): - Before script execution: - - Old storage : 1 red, 1 blue, 1 green - - Total: 1 red, 1 blue, 1 green - After execution: - - New_storage: 1 green, 1 yellow - - Lazy-diff: 1 red, 1 blue, 1 green - - Total: 1 red, 1 blue, 2 green, 1 yellow - Net diff: - - +1 green, +1 yellow - - *) - assert_ticket_diffs - ctxt - ~loc:__LOC__ - ~self_contract:contract - ~arg_type:ticket_string_list_type - ~storage_type:list_big_map_pair_type - ~arg - ~old_storage - ~new_storage - ~lazy_storage_diff:[lazy_storage_diff] - ~expected_diff: - [ - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), -1); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue"), -1); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "green"), 1); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "yellow"), 1); - ] - ~expected_receipt: - [ - ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "yellow", [(contract, 1)]); - ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "green", [(contract, 1)]); - ] - -(** Test that attempting to transfer a ticket that exceeds the budget fails. *) -let test_update_invalid_transfer () = - let open Lwt_result_syntax in - let* baker, src, block = init_for_operation () in - let* destination, _script, incr = - originate - block - ~src - ~baker - ~script:ticket_list_script - ~storage:"{}" - ~forges_tickets:false - in - let ctxt = Incremental.alpha_ctxt incr in - let arg_type = ticket_string_list_type in - let arg = - boxed_list [string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1] - in - let* operation, ctxt = - transfer_operation ctxt ~src:(Contract src) ~destination ~arg_type ~arg - in - assert_fail_with - ~loc:__LOC__ - ~msg: - "Attempted to send 1 unit(s) of a ticket created by \ - KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq." - (fun () -> - Ticket_accounting.update_ticket_balances - ctxt - ~self_contract:src - ~ticket_diffs:Ticket_token_map.empty - [operation]) - -(** Test that adding more tickets created by the [self] contract is valid and - results in a balance update. *) -let test_update_ticket_self_diff () = - let open Lwt_result_wrap_syntax in - let* baker, src, block = init_for_operation () in - let* self, _script, incr = - originate - block - ~src - ~baker - ~script:ticket_list_script - ~storage:"{}" - ~forges_tickets:false - in - let ticketer = Contract_hash.to_b58check self in - let self = Contract.Originated self in - let ctxt = Incremental.alpha_ctxt incr in - let* red_token = string_ticket_token ticketer "red" in - let*@ ticket_diffs, ctxt = - Ticket_token_map.of_list - ctxt - ~merge_overlap:(fun _ -> assert false) - [(red_token, Z.of_int 10)] - in - let*@ _, ctxt = - Ticket_accounting.update_ticket_balances - ctxt - ~self_contract:self - ~ticket_diffs - [] - in - (* After update, we should have 10 added red tokens. *) - let*@ red_self_token_hash, ctxt = - Ticket_balance_key.of_ex_token - ctxt - ~owner:(Destination.Contract self) - red_token - in - assert_balance ~loc:__LOC__ ctxt red_self_token_hash (Some 10) - -(* Test that sending tickets to self succeed (there are no budget constraints). *) -let test_update_self_ticket_transfer () = - let open Lwt_result_wrap_syntax in - let* baker, self, block = init_for_operation () in - let* ticket_receiver, _script, incr = - originate - block - ~src:self - ~baker - ~script:ticket_list_script - ~storage:"{}" - ~forges_tickets:false - in - (* Ticket is self. That means we can transfer an unlimited amounts of such - ticket-tokens. *) - let ticketer = Contract.to_b58check self in - let ctxt = Incremental.alpha_ctxt incr in - let* red_token = string_ticket_token ticketer "red" in - let* operation, ctxt = - let arg_type = ticket_string_list_type in - let arg = - boxed_list - [ - (* Send a total of 10 units of ticket-tokens. *) - string_ticket ticketer "red" 1; - string_ticket ticketer "red" 2; - string_ticket ticketer "red" 3; - string_ticket ticketer "red" 4; - ] - in - transfer_operation - ctxt - ~src:(Contract self) - ~destination:ticket_receiver - ~arg_type - ~arg - in - let*@ _, ctxt = - Ticket_accounting.update_ticket_balances - ctxt - ~self_contract:self - ~ticket_diffs:Ticket_token_map.empty - [operation] - in - (* Once we're done with the update, we expect ticket-receiver to have been - credited with 10 units of ticket-tokens. *) - let* () = - let*@ red_receiver_token_hash, ctxt = - Ticket_balance_key.of_ex_token - ctxt - ~owner:(Destination.Contract (Originated ticket_receiver)) - red_token - in - assert_balance ~loc:__LOC__ ctxt red_receiver_token_hash (Some 10) - in - return () - -(** Test that transferring a ticket that does not exceed the budget succeeds. *) -let test_update_valid_transfer () = - let open Lwt_result_wrap_syntax in - let* baker, self, block = init_for_operation () in - let* destination, _script, incr = - originate - block - ~src:self - ~baker - ~script:ticket_list_script - ~storage:"{}" - ~forges_tickets:false - in - let ticketer = "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" in - assert (ticketer <> Contract.to_b58check self) ; - let ctxt = Incremental.alpha_ctxt incr in - let* red_token = string_ticket_token ticketer "red" in - let*@ red_self_token_hash, ctxt = - Ticket_balance_key.of_ex_token ctxt ~owner:(Contract self) red_token - in - let*@ red_receiver_token_hash, ctxt = - Ticket_balance_key.of_ex_token - ctxt - ~owner:(Destination.Contract (Originated destination)) - red_token - in - (* Set up the balance so that the self contract owns one ticket. *) - let*@ _, ctxt = - Ticket_balance.adjust_balance ctxt red_self_token_hash ~delta:Z.one - in - let* operation, ctxt = - let arg_type = ticket_string_list_type in - let arg = boxed_list [string_ticket ticketer "red" 1] in - transfer_operation ctxt ~src:(Contract self) ~destination ~arg_type ~arg - in - let* _, ctxt = - let*@ ticket_diffs, ctxt = - Ticket_token_map.of_list - ctxt - ~merge_overlap:(fun _ -> assert false) - [(red_token, Z.of_int (-1))] - in - wrap - (Ticket_accounting.update_ticket_balances - ctxt - ~self_contract:self - ~ticket_diffs - [operation]) - in - (* Once we're done with the update, we expect the balance to have been moved - from [self] to [destination]. *) - let* () = assert_balance ~loc:__LOC__ ctxt red_self_token_hash None in - let* () = assert_balance ~loc:__LOC__ ctxt red_receiver_token_hash (Some 1) in - return () - -(** Test that transferring a ticket to itself is allowed and does not impact - the balance. *) -let test_update_transfer_tickets_to_self () = - let open Lwt_result_wrap_syntax in - let* baker, src, block = init_for_operation () in - let* self_hash, _script, incr = - originate - block - ~src - ~baker - ~script:ticket_list_script - ~storage:"{}" - ~forges_tickets:false - in - let ticketer = "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" in - assert (ticketer <> Contract_hash.to_b58check self_hash) ; - let self = Contract.Originated self_hash in - let ctxt = Incremental.alpha_ctxt incr in - let* red_token = string_ticket_token ticketer "red" in - let*@ red_self_token_hash, ctxt = - Ticket_balance_key.of_ex_token - ctxt - ~owner:(Destination.Contract self) - red_token - in - (* Set up the balance so that the self contract owns ten tickets. *) - let*@ _, ctxt = - Ticket_balance.adjust_balance ctxt red_self_token_hash ~delta:(Z.of_int 10) - in - let* operation, ctxt = - let arg_type = ticket_string_list_type in - let arg = boxed_list [string_ticket ticketer "red" 1] in - transfer_operation - ctxt - ~src:(Contract self) - ~destination:self_hash - ~arg_type - ~arg - in - let*@ _, ctxt = - (* Ticket diff removes 5 tickets. *) - let* ticket_diffs, ctxt = - Ticket_token_map.of_list - ctxt - ~merge_overlap:(fun _ -> assert false) - [(red_token, Z.of_int (-5))] - in - Ticket_accounting.update_ticket_balances - ctxt - ~self_contract:self - ~ticket_diffs - [operation] - in - (* We started with 10 units. Removed 5 from storage and sent one to [self]. - Therefore we expect 10 - 5 + 1 = 6 units remaining. *) - let* () = assert_balance ~loc:__LOC__ ctxt red_self_token_hash (Some 6) in - return () - -(** Test that attempting to originate a contract with tickets that exceed the - budget fails. *) -let test_update_invalid_origination () = - let open Lwt_result_syntax in - let* baker, src, block = init_for_operation () in - let* orig_contract, script, incr = - let storage = - let ticketer = "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" in - Printf.sprintf - {|{ Pair %S "red" 1; Pair %S "green" 1; Pair %S "blue" 1; } |} - ticketer - ticketer - ticketer - in - originate - block - ~src - ~baker - ~script:ticket_list_script - ~storage - ~forges_tickets:true - in - let ctxt = Incremental.alpha_ctxt incr in - let* operation, ctxt = - origination_operation ctxt ~src:(Contract src) ~orig_contract ~script - in - assert_fail_with - ~loc:__LOC__ - ~msg: - "Attempted to send 1 unit(s) of a ticket created by \ - KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq." - (fun () -> - Ticket_accounting.update_ticket_balances - ctxt - ~self_contract:src - ~ticket_diffs:Ticket_token_map.empty - [operation]) - -(** Test update valid origination. *) -let test_update_valid_origination () = - let open Lwt_result_wrap_syntax in - let* baker, self, block = init_for_operation () in - let ticketer = "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" in - assert (ticketer <> Contract.to_b58check self) ; - let* orig_contract, script, incr = - let storage = Printf.sprintf {|{ Pair %S "red" 1; }|} ticketer in - originate - block - ~src:self - ~baker - ~script:ticket_list_script - ~storage - ~forges_tickets:true - in - let ctxt = Incremental.alpha_ctxt incr in - let* red_token = string_ticket_token ticketer "red" in - let*@ red_self_token_hash, ctxt = - Ticket_balance_key.of_ex_token - ctxt - ~owner:(Destination.Contract self) - red_token - in - (* Set up the balance so that the self contract owns one ticket. *) - let*@ _, ctxt = - Ticket_balance.adjust_balance ctxt red_self_token_hash ~delta:Z.one - in - let* operation, ctxt = - origination_operation ctxt ~src:(Contract self) ~orig_contract ~script - in - let*@ _, ctxt = - let* ticket_diffs, ctxt = - Ticket_token_map.of_list - ctxt - ~merge_overlap:(fun _ -> assert false) - [(red_token, Z.of_int (-1))] - in - Ticket_accounting.update_ticket_balances - ctxt - ~self_contract:self - ~ticket_diffs - [operation] - in - (* Once we're done with the update, we expect the balance to have been moved - from [self] to [destination]. *) - let*@ red_originated_token_hash, ctxt = - Ticket_balance_key.of_ex_token - ctxt - ~owner:(Destination.Contract (Originated orig_contract)) - red_token - in - assert_balance ~loc:__LOC__ ctxt red_originated_token_hash (Some 1) - -let test_update_self_origination () = - let open Lwt_result_wrap_syntax in - let* baker, self, block = init_for_operation () in - let ticketer = Contract.to_b58check self in - let* orig_contract, script, incr = - let storage = Printf.sprintf {|{ Pair %S "red" 1; }|} ticketer in - originate - block - ~src:self - ~baker - ~script:ticket_list_script - ~storage - ~forges_tickets:true - in - let ctxt = Incremental.alpha_ctxt incr in - let* red_token = string_ticket_token ticketer "red" in - let*@ red_originated_token_hash, ctxt = - Ticket_balance_key.of_ex_token - ctxt - ~owner:(Destination.Contract (Originated orig_contract)) - red_token - in - let* operation, ctxt = - origination_operation ctxt ~src:(Contract self) ~orig_contract ~script - in - let*@ _, ctxt = - Ticket_accounting.update_ticket_balances - ctxt - ~self_contract:self - ~ticket_diffs:Ticket_token_map.empty - [operation] - in - (* Once we're done with the update, we expect the balance to have been - credited to the originated contract. *) - assert_balance ~loc:__LOC__ ctxt red_originated_token_hash (Some 1) - -(** Test ticket-token map of list with duplicates. *) -let test_ticket_token_map_of_list_with_duplicates () = - let open Lwt_result_wrap_syntax in - let* baker, src, block = init_for_operation () in - let* self, _script, incr = - originate - block - ~src - ~baker - ~script:ticket_list_script - ~storage:"{}" - ~forges_tickets:false - in - let ticketer = Contract_hash.to_b58check self in - let self = Contract.Originated self in - let ctxt = Incremental.alpha_ctxt incr in - let* red_token = string_ticket_token ticketer "red" in - let*@ ticket_diffs, ctxt = - Ticket_token_map.of_list - ctxt - ~merge_overlap:(fun ctxt v1 v2 -> ok (Z.add v1 v2, ctxt)) - [(red_token, Z.of_int 10); (red_token, Z.of_int 5)] - in - let*@ _, ctxt = - Ticket_accounting.update_ticket_balances - ctxt - ~self_contract:self - ~ticket_diffs - [] - in - (* After update, we should have 10 + 5 added red tokens. *) - let*@ red_self_token_hash, ctxt = - Ticket_balance_key.of_ex_token - ctxt - ~owner:(Destination.Contract self) - red_token - in - assert_balance ~loc:__LOC__ ctxt red_self_token_hash (Some 15) - -let tests = - [ - Tztest.tztest "Diffs empty" `Quick test_diffs_empty; - Tztest.tztest "Diffs for tickets in args" `Quick test_diffs_tickets_in_args; - Tztest.tztest - "Diffs for tickets in args and storage" - `Quick - test_diffs_tickets_in_args_and_storage; - Tztest.tztest "Diffs for dropped ticket" `Quick test_diffs_drop_one_ticket; - Tztest.tztest - "Diffs for adding new ticket to storage" - `Quick - test_diffs_adding_new_ticket_to_storage; - Tztest.tztest - "Diffs for removing from storage" - `Quick - test_diffs_remove_from_storage; - Tztest.tztest - "Diffs for lazy storage allocation" - `Quick - test_diffs_lazy_storage_alloc; - Tztest.tztest - "Diffs for removing from big-map" - `Quick - test_diffs_remove_from_big_map; - Tztest.tztest "Diffs for copying a big-map" `Quick test_diffs_copy_big_map; - Tztest.tztest - "Diffs for adding to an existing big-map" - `Quick - test_diffs_add_to_existing_big_map; - Tztest.tztest - "Diffs for args, storage and lazy-diff" - `Quick - test_diffs_args_storage_and_lazy_diffs; - Tztest.tztest - "Update tickets balances with invalid transfer" - `Quick - test_update_invalid_transfer; - Tztest.tztest "Update ticket self diff" `Quick test_update_ticket_self_diff; - Tztest.tztest - "Update ticket balances for valid transfer" - `Quick - test_update_valid_transfer; - Tztest.tztest - "Update ticket balances for transfer with 'self' tickets" - `Quick - test_update_self_ticket_transfer; - Tztest.tztest - "Update transfer tickets to self" - `Quick - test_update_transfer_tickets_to_self; - Tztest.tztest - "Update invalid origination" - `Quick - test_update_invalid_origination; - Tztest.tztest - "Update valid origination" - `Quick - test_update_valid_origination; - Tztest.tztest - "Update valid self origination" - `Quick - test_update_self_origination; - Tztest.tztest - "ticket-token map with duplicate keys" - `Quick - test_ticket_token_map_of_list_with_duplicates; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("ticket accounting", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_balance.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_balance.ml deleted file mode 100644 index 1383c45f2dbf75b1fe8e2a1be06702b638a3d4f4..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_balance.ml +++ /dev/null @@ -1,1791 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (Ticket_balance_key) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/michelson/main.exe \ - -- --file test_ticket_balance.ml - Subject: Ticket balance key hashing -*) - -open Protocol -open Alpha_context - -type init_env = { - block : Block.t; - baker : Signature.public_key_hash; - contract : Contract.t; -} - -let init_env () = - let open Lwt_result_wrap_syntax in - let* block, baker, contract, _src2 = Contract_helpers.init () in - return {block; baker; contract} - -let transaction block ~baker ~sender ~entrypoint ~recipient ~parameters = - let open Lwt_result_wrap_syntax in - let parameters = Script.lazy_expr @@ Expr.from_string parameters in - let* operation = - Op.transaction - (B block) - ~gas_limit:Max - ~entrypoint - ~parameters - ~fee:Tez.one - sender - recipient - (Tez.of_mutez_exn 0L) - in - let* incr = - Incremental.begin_construction ~policy:Block.(By_account baker) block - in - let* incr = Incremental.add_operation incr operation in - Incremental.finalize_block incr - -let originate = Contract_helpers.originate_contract_from_string - -let get_balance ctxt ~token ~owner = - let open Lwt_result_wrap_syntax in - let* key_hash, ctxt = Ticket_balance_key.of_ex_token ctxt ~owner token in - Ticket_balance.get_balance ctxt key_hash - -let get_used_ticket_storage block = - let open Lwt_result_wrap_syntax in - let* incr = Incremental.begin_construction block in - wrap - @@ Ticket_balance.Internal_for_tests.used_storage_space - (Incremental.alpha_ctxt incr) - -let get_paid_ticket_storage block = - let open Lwt_result_wrap_syntax in - let* incr = Incremental.begin_construction block in - wrap - @@ Ticket_balance.Internal_for_tests.paid_storage_space - (Incremental.alpha_ctxt incr) - -let get_used_contract_storage block contract = - let open Lwt_result_wrap_syntax in - let* incr = Incremental.begin_construction block in - let alpha_ctxt = Incremental.alpha_ctxt incr in - wrap @@ Alpha_context.Contract.used_storage_space alpha_ctxt contract - -let get_paid_contract_storage block contract = - let open Lwt_result_wrap_syntax in - let* incr = Incremental.begin_construction block in - let alpha_ctxt = Incremental.alpha_ctxt incr in - wrap - @@ Alpha_context.Contract.Internal_for_tests.paid_storage_space - alpha_ctxt - contract - -let assert_paid_contract_storage ~loc block contract expected = - let open Lwt_result_wrap_syntax in - let* storage = get_paid_contract_storage block contract in - Assert.equal - ~loc - Z.equal - "Paid contract storage " - Z.pp_print - (Z.of_int expected) - storage - -let assert_used_contract_storage ~loc block contract expected = - let open Lwt_result_wrap_syntax in - let* storage = get_used_contract_storage block contract in - Assert.equal - ~loc - Z.equal - "Used contract storage " - Z.pp_print - (Z.of_int expected) - storage - -let assert_paid_ticket_storage ~loc block expected = - let open Lwt_result_wrap_syntax in - let* storage = get_paid_ticket_storage block in - Assert.equal - ~loc - Z.equal - "Paid ticket storage " - Z.pp_print - (Z.of_int expected) - storage - -let assert_used_ticket_storage ~loc block expected = - let open Lwt_result_wrap_syntax in - let* storage = get_used_ticket_storage block in - Assert.equal - ~loc - Z.equal - "Used ticket storage " - Z.pp_print - (Z.of_int expected) - storage - -let assert_token_balance ~loc block token owner expected = - let open Lwt_result_wrap_syntax in - let* incr = Incremental.begin_construction block in - let ctxt = Incremental.alpha_ctxt incr in - let*@ balance, _ = - get_balance ctxt ~token ~owner:(Destination.Contract owner) - in - match (balance, expected) with - | Some b, Some e -> Assert.equal_int ~loc (Z.to_int b) e - | Some b, None -> - failwith "%s: Expected no balance but got some %d" loc (Z.to_int b) - | None, Some b -> failwith "%s: Expected balance %d but got none" loc b - | None, None -> return () - -let string_token ~ticketer content = - let contents = - WithExceptions.Result.get_ok ~loc:__LOC__ @@ Script_string.of_string content - in - Ticket_token.Ex_token - {ticketer; contents_type = Script_typed_ir.string_t; contents} - -let unit_ticket ~ticketer = - Ticket_token.Ex_token - {ticketer; contents_type = Script_typed_ir.unit_t; contents = ()} - -let new_contracts ~before ~after = - let open Lwt_result_wrap_syntax in - let all_contracts current_block = - let* ctxt = - Incremental.begin_construction current_block >|=? Incremental.alpha_ctxt - in - Lwt.map Result.ok (Contract.list ctxt) - in - let* cs1 = all_contracts before in - let* cs2 = all_contracts after in - let not_in_cs1 = - let module S = Set.Make (String) in - let set = S.of_list @@ List.map Contract.to_b58check cs1 in - fun c -> not @@ S.mem (Contract.to_b58check c) set - in - return (List.filter not_in_cs1 cs2) - -let get_new_contract before f = - let open Lwt_result_wrap_syntax in - let* after = f before in - let* contracts = new_contracts ~before ~after in - match contracts with - | c :: _ -> return (c, after) - | _ -> failwith "Expected one new contracts" - -(** Test adding a ticket to a strict storage. *) -let test_add_strict () = - let open Lwt_result_wrap_syntax in - let* {block; baker; contract = source_contract} = init_env () in - (* Originate *) - let* contract, _script, block = - originate - ~baker - ~source_contract - ~script: - {| - { parameter unit; - storage (list (ticket string)); - code - { CDR; - PUSH nat 1; - PUSH string "Red"; - TICKET; - ASSERT_SOME; - CONS; - NIL operation ; - PAIR } } - |} - ~storage:"{}" - block - in - let token_red = string_token ~ticketer:contract "Red" in - (* Before calling the contract the balance should be empty. *) - let* () = assert_token_balance ~loc:__LOC__ block token_red contract None in - (* Run the script *) - let* block = - transaction - ~entrypoint:Entrypoint.default - ~baker - ~sender:source_contract - block - ~recipient:contract - ~parameters:"Unit" - in - (* After calling the contract, one ticket is added and balance is one. *) - let* () = - assert_token_balance ~loc:__LOC__ block token_red contract (Some 1) - in - (* Calling the contract again should increase the balance once more. *) - let* block = - transaction - ~entrypoint:Entrypoint.default - ~baker - ~sender:source_contract - block - ~recipient:contract - ~parameters:"Unit" - in - assert_token_balance ~loc:__LOC__ block token_red contract (Some 2) - -(** Test adding and removing tickets from a list in the storage. *) -let test_add_remove () = - let open Lwt_result_wrap_syntax in - let* {block; baker; contract = source_contract} = init_env () in - (* Originate *) - let* contract, _script, block = - originate - ~baker - ~source_contract - ~script: - {| - { parameter (or (unit %add) (unit %remove)); - storage (list (ticket string)) ; - code { UNPAIR ; - IF_LEFT - { DROP ; - PUSH nat 1 ; - PUSH string "Red" ; - TICKET ; - ASSERT_SOME ; - CONS ; - NIL operation ; - PAIR } - { DROP 2 ; NIL (ticket string) ; NIL operation ; PAIR } } } - |} - ~storage:"{}" - block - in - let add_one block = - transaction - ~entrypoint:Entrypoint.default - ~baker - ~sender:source_contract - block - ~recipient:contract - ~parameters:"Left Unit" - in - let clear block = - transaction - ~entrypoint:Entrypoint.default - ~baker - ~sender:source_contract - block - ~recipient:contract - ~parameters:"Right Unit" - in - let token_red = string_token ~ticketer:contract "Red" in - (* Before calling the contract the balance should be empty *) - let* () = assert_token_balance ~loc:__LOC__ block token_red contract None in - (* Call the contract twice *) - let* block = add_one block in - let* block = add_one block in - let* () = - assert_token_balance ~loc:__LOC__ block token_red contract (Some 2) - in - (* Remove tickets from the contract *) - let* block = clear block in - assert_token_balance ~loc:__LOC__ block token_red contract None - -(** Test adding multiple tickets to a big-map. *) -let test_add_to_big_map () = - let open Lwt_result_wrap_syntax in - let* {block; baker; contract = source_contract} = init_env () in - let* contract, _script, block = - originate - ~baker - ~source_contract - ~script: - {| - { parameter int ; - storage (big_map int (ticket string)) ; - code { LEFT (big_map int (ticket string)) ; - LOOP_LEFT - { UNPAIR ; - PUSH int 0 ; - SWAP ; - DUP ; - DUG 2 ; - COMPARE ; - LE ; - IF { DROP ; RIGHT (pair int (big_map int (ticket string))) } - { SWAP ; - PUSH nat 1 ; - PUSH string "Red" ; - TICKET ; - ASSERT_SOME ; - SOME ; - DUP 3 ; - GET_AND_UPDATE ; - DROP ; - PUSH int 1 ; - DIG 2 ; - SUB ; - PAIR ; - LEFT (big_map int (ticket string)) } } ; - NIL operation ; - PAIR } } - |} - ~storage:"{}" - block - in - let* block = - transaction - ~entrypoint:Entrypoint.default - ~baker - ~sender:source_contract - block - ~recipient:contract - ~parameters:"100" - in - let token_red = string_token ~ticketer:contract "Red" in - assert_token_balance ~loc:__LOC__ block token_red contract (Some 100) - -(** Test adding, swapping and clearing big-maps from storage. - The script contains in its storage two big-maps: - - pair - (big_map %map1 int (ticket string)) - (big_map %map2 int (ticket string))) - - And takes three actions: - 1) Add one ticket to map1 - 2) Swap map1 and map2 - 3) Clear map1 - *) -let test_swap_big_map () = - let open Lwt_result_wrap_syntax in - let* {block; baker; contract = source_contract} = init_env () in - let* contract, _script, block = - originate - ~baker - ~source_contract - ~script: - {| - { parameter (or (or (int %add) (unit %clear)) (unit %swap)) ; - storage (pair (big_map %map1 int (ticket string)) (big_map %map2 int (ticket string))) ; - code { UNPAIR ; - NIL operation ; - SWAP ; - IF_LEFT - { IF_LEFT - { DIG 2 ; - UNPAIR ; - PUSH nat 1 ; - PUSH string "Red" ; - TICKET ; - ASSERT_SOME ; - SOME ; - DIG 3 ; - GET_AND_UPDATE ; - DROP ; - PAIR ; - SWAP ; - PAIR } - { DROP ; SWAP ; CDR ; EMPTY_BIG_MAP int (ticket string) ; - PAIR ; SWAP ; PAIR } } - { DROP ; SWAP ; UNPAIR ; SWAP ; PAIR ; SWAP ; PAIR } } } - |} - ~storage:"Pair {} {}" - block - in - let add_to_index block ix = - transaction - ~entrypoint:Entrypoint.default - ~baker - ~sender:source_contract - block - ~recipient:contract - ~parameters:(Printf.sprintf "Left (Left %d)" ix) - in - let swap_big_maps block = - transaction - ~entrypoint:Entrypoint.default - ~baker - ~sender:source_contract - block - ~recipient:contract - ~parameters:"Right Unit" - in - let clear_left_big_map block = - transaction - ~entrypoint:Entrypoint.default - ~baker - ~sender:source_contract - block - ~recipient:contract - ~parameters:"Left (Right Unit)" - in - (* Add three tickets to [map1] *) - let* block = add_to_index block 1 in - let* block = add_to_index block 2 in - let* block = add_to_index block 3 in - let token_red = string_token ~ticketer:contract "Red" in - let* () = - assert_token_balance ~loc:__LOC__ block token_red contract (Some 3) - in - (* Swap [map1] and [map2]. This should not impact the ticket balance. *) - let* block = swap_big_maps block in - let* () = - assert_token_balance ~loc:__LOC__ block token_red contract (Some 3) - in - (* Remove all tickets from [map1] (which is empty). *) - let* block = clear_left_big_map block in - let* () = - assert_token_balance ~loc:__LOC__ block token_red contract (Some 3) - in - (* Swap [map1] and [map2]. Now, [map1] contains three tickets. *) - let* block = swap_big_maps block in - (* Clear all tickets from [map1]. *) - let* block = clear_left_big_map block in - assert_token_balance ~loc:__LOC__ block token_red contract None - -(* Test sending a ticket to an address *) -let test_send_tickets () = - let open Lwt_result_wrap_syntax in - let* {block; baker; contract = source_contract} = init_env () in - (* A contract that can receive a ticket and store it in a list. *) - let* ticket_receiver, _script, block = - originate - ~baker - ~source_contract - ~script: - {| - { parameter (ticket string) ; - storage (list (ticket string)) ; - code { UNPAIR ; CONS ; NIL operation ; PAIR } } - |} - ~storage:"{}" - block - in - (* A contract that, given an address to a contract that receives tickets, - mints a ticket and sends it over. *) - let* ticket_sender, _script, block = - originate - ~baker - ~source_contract - ~script: - {| - { parameter address ; - storage unit ; - code { CAR ; - CONTRACT (ticket string) ; - IF_NONE - { PUSH string "Contract of type `ticket(string)' not found" ; - FAILWITH } - { PUSH mutez 0 ; - PUSH nat 1 ; - PUSH string "Red" ; - TICKET ; - ASSERT_SOME ; - TRANSFER_TOKENS ; - PUSH unit Unit ; - NIL operation ; - DIG 2 ; - CONS ; - PAIR } } } - |} - ~storage:"Unit" - block - in - let mint_and_send block = - transaction - ~entrypoint:Entrypoint.default - ~baker - ~sender:source_contract - block - ~recipient:ticket_sender - ~parameters: - (Printf.sprintf {|"%s"|} @@ Contract.to_b58check ticket_receiver) - in - (* Call ticket-sender twice in order to transfer tickets to ticket-receiver *) - let* block = mint_and_send block in - let* block = mint_and_send block in - let token_red = string_token ~ticketer:ticket_sender "Red" in - assert_token_balance ~loc:__LOC__ block token_red ticket_receiver (Some 2) - -(** Test sending and storing tickets with amount zero. *) -let test_send_and_store_zero_amount_tickets () = - let open Lwt_result_wrap_syntax in - let* {block; baker; contract = source_contract} = init_env () in - (* A contract that, given an address to a contract that receives tickets, - mints a ticket and sends it over. *) - let* ticket_minter, _script, block = - originate - ~baker - ~source_contract - ~script: - {| - { parameter (pair address nat) ; - storage unit ; - code { CAR ; - UNPAIR ; - CONTRACT (ticket string) ; - IF_NONE - { DROP ; - PUSH string "Contract of type `ticket(string)` not found" ; - FAILWITH } - { PUSH mutez 0 ; - DIG 2 ; - PUSH string "Red" ; - TICKET ; - ASSERT_SOME ; - TRANSFER_TOKENS ; - PUSH unit Unit ; - NIL operation ; - DIG 2 ; - CONS ; - PAIR } } } - |} - ~storage:"Unit" - block - in - (* A contract with two entrypoints: - - Store (ticket): stores the received ticket. - - Send (address) sends the last received tickets to the given address. - *) - let ticket_storer_script = - {| - { parameter (or (address %send) (ticket %store string)) ; - storage (list (ticket string)) ; - code { UNPAIR ; - IF_LEFT - { CONTRACT (ticket string) ; - IF_NONE - { DROP ; - PUSH string "Contract of type `ticket(string)` not found" ; - FAILWITH } - { SWAP ; - IF_CONS - { DIG 2 ; - PUSH mutez 0 ; - DIG 2 ; - TRANSFER_TOKENS ; - SWAP ; - NIL operation ; - DIG 2 ; - CONS ; - PAIR } - { DROP ; PUSH string "Empty storage" ; FAILWITH } } } - { CONS ; NIL operation ; PAIR } } } - |} - in - let* ticket_store_1, _script, block = - originate - ~baker - ~source_contract - ~script:ticket_storer_script - ~storage:"{}" - block - in - let* ticket_store_2, _script, block = - originate - ~baker - ~source_contract - ~script:ticket_storer_script - ~storage:"{}" - block - in - let mint_and_send_to_storer_1 block amount = - transaction - ~entrypoint:Entrypoint.default - ~baker - ~sender:source_contract - block - ~recipient:ticket_minter - ~parameters: - (Printf.sprintf - {|Pair "%s%s" %d|} - (Contract.to_b58check ticket_store_1) - "%store" - amount) - in - let send_from_store_1_to_store_2 block = - transaction - ~entrypoint:(Entrypoint.of_string_strict_exn "send") - ~baker - ~sender:source_contract - block - ~recipient:ticket_store_1 - ~parameters: - (Printf.sprintf - {|"%s%s"|} - (Contract.to_b58check ticket_store_2) - "%store") - in - let token_red = string_token ~ticketer:ticket_minter "Red" in - (* Mint and send a ticket with amount 0 to [ticket_store_1], which fails. - After the transaction: - - [ticket_store_1]: - [ ] - *) - let*! result = mint_and_send_to_storer_1 block 0 in - assert (Result.is_error result) ; - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_store_1 None - in - (* Mint and send a ticket with amount 10 to [ticket_store_1]. After - the transaction: - - [ticket_store_1]: - [ - (TM, "Red", 10) - ] - *) - let* block = mint_and_send_to_storer_1 block 10 in - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_store_1 (Some 10) - in - (* Send the top of [ticket_storer_1]'s list to [ticket_store_2]. That is the - ticket (TM, "Red", 10). After the transaction: - - ticket_store_1: - [ ] - ticket_store_2: - [ - (TM, "Red", 10) - ] - *) - let* block = send_from_store_1_to_store_2 block in - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_store_1 None - in - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_store_2 (Some 10) - in - (* Send the top of [ticket_store_1]'s stack to [ticket_store_2]. - However, this fails because [ticket_store_1]'s stack is empty. - Now, [ticket_store_2] holds both tickets. - - ticket_store_1: - [ ] - [ticket_store_2]: - [ - (TM, "Red", 10) - ] - *) - let*! result = send_from_store_1_to_store_2 block in - assert (Result.is_error result) ; - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_store_1 None - in - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_store_2 (Some 10) - in - (* Mint and send a ticket with amount 5 to [ticket_store_1]. After the - transaction: - - [ticket_store_1]: - [ - (TM, "Red", 5) - ] - [ticket_store_2]: - [ - (TM, "Red", 10) - ] - *) - let* block = mint_and_send_to_storer_1 block 5 in - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_store_1 (Some 5) - in - (* Send the top of [ticket_store_1]'s stack to [ticket_store_2]. That is the - ticket (TM, "Red", 5). After the transaction, [ticket_store_2] holds three - tickets: - - ticket_store_1: - [ ] - [ticket_store_2]: - [ - (TM, "Red", 5) - (TM, "Red", 10) - ] - *) - let* block = send_from_store_1_to_store_2 block in - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_store_1 None - in - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_store_2 (Some 15) - in - return_unit - -(** Test sending tickets to an implicit account. *) -let test_send_tickets_to_implicit_account () = - let open Lwt_result_wrap_syntax in - let* block, baker, contract, contract2 = Contract_helpers.init () in - let () = - match (contract, contract2) with - | Contract.Implicit _, Contract.Implicit _ -> () - | _ -> assert false - in - (* A contract that receives an address and mints and sends a ticket to it. *) - let* ticketer, _script, block = - originate - ~baker - ~source_contract:contract - ~script: - {| - { parameter address; - storage unit; - code { CAR ; - CONTRACT (ticket string) ; - IF_NONE - { PUSH string "Contract of type `ticket(string)` not found" ; - FAILWITH } - { PUSH mutez 0; - PUSH nat 1 ; - PUSH string "Ticket" ; - TICKET ; - ASSERT_SOME ; - TRANSFER_TOKENS ; - PUSH unit Unit ; - NIL operation ; - DIG 2 ; - CONS ; - PAIR }}} - |} - ~storage:"Unit" - block - in - let* block = - transaction - ~entrypoint:Entrypoint.default - ~baker - ~sender:contract - block - ~recipient:ticketer - ~parameters:(Printf.sprintf {|"%s"|} (Contract.to_b58check contract2)) - in - let token = string_token ~ticketer "Ticket" in - assert_token_balance ~loc:__LOC__ block token contract2 (Some 1) - -(** Test sending tickets in a big-map. *) -let test_send_tickets_in_big_map () = - let open Lwt_result_wrap_syntax in - let* {block; baker; contract = source_contract} = init_env () in - (* A contract that can receive a big-map with tickets. *) - let* ticket_receiver, _script, block = - originate - ~baker - ~source_contract - ~script: - {| - { parameter (big_map int (ticket string)) ; - storage (big_map int (ticket string)) ; - code { CAR ; NIL operation ; PAIR } } - |} - ~storage:"{}" - block - in - (* A contract with two actions: - - [mint_and_save(key, content)] for creating and saving a new ticket in - a big-map. - - [send (address)] for transferring the big-map to the given address. - *) - let* ticket_manager, _script, block = - originate - ~baker - ~source_contract - ~script: - {| - { parameter (or (pair %mint_and_save int string) (address %send)) ; - storage (big_map int (ticket string)) ; - code { UNPAIR ; - IF_LEFT - { UNPAIR ; - DIG 2 ; - PUSH nat 1 ; - DIG 3 ; - TICKET ; - ASSERT_SOME ; - SOME ; - DIG 2 ; - GET_AND_UPDATE ; - DROP ; - NIL operation ; - PAIR } - { CONTRACT (big_map int (ticket string)) ; - IF_NONE - { PUSH string "Contract of type `ticket(string)` not found" ; - FAILWITH } - { PUSH mutez 0 ; - DIG 2 ; - TRANSFER_TOKENS ; - EMPTY_BIG_MAP int (ticket string) ; - NIL operation ; - DIG 2 ; - CONS ; - PAIR } } } } - |} - ~storage:"{}" - block - in - let mint_and_save key content block = - transaction - ~entrypoint:Entrypoint.default - ~baker - ~sender:source_contract - block - ~recipient:ticket_manager - ~parameters:(Printf.sprintf {|Left (Pair %d "%s")|} key content) - in - let send block = - transaction - ~entrypoint:Entrypoint.default - ~baker - ~sender:source_contract - block - ~recipient:ticket_manager - ~parameters: - (Printf.sprintf {|Right "%s"|} @@ Contract.to_b58check ticket_receiver) - in - let token_red = string_token ~ticketer:ticket_manager "Red" in - let token_blue = string_token ~ticketer:ticket_manager "Blue" in - let token_yellow = string_token ~ticketer:ticket_manager "Yellow" in - (* Call ticket manager to mint and save three tickets in a big-map. *) - let* block = mint_and_save 1 "Red" block in - let* block = mint_and_save 2 "Blue" block in - let* block = mint_and_save 3 "Yellow" block in - (* Verify that all three tickets are accounted for and belong to - ticket-manager. *) - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_manager (Some 1) - in - let* () = - assert_token_balance ~loc:__LOC__ block token_blue ticket_manager (Some 1) - in - let* () = - assert_token_balance ~loc:__LOC__ block token_yellow ticket_manager (Some 1) - in - (* Send over the big-map with tickets to ticket-receiver. *) - let* block = send block in - (* Verify that all three tickets now belong to the ticket-receiver contract. *) - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_receiver (Some 1) - in - let* () = - assert_token_balance ~loc:__LOC__ block token_blue ticket_receiver (Some 1) - in - let* () = - assert_token_balance - ~loc:__LOC__ - block - token_yellow - ticket_receiver - (Some 1) - in - (* Finally test that the ticket-manager no longer holds any of the tickets *) - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_manager None - in - let* () = - assert_token_balance ~loc:__LOC__ block token_blue ticket_manager None - in - assert_token_balance ~loc:__LOC__ block token_yellow ticket_manager None - -(* Test sending tickets in a big-map. *) -let test_modify_big_map () = - let open Lwt_result_wrap_syntax in - let* {block; baker; contract = source_contract} = init_env () in - (* A contract with two actions: - - [Add ((int, string))] for adding a ticket to the big-map. - - [Remove(int)] for removing an index from the big-map. - *) - let* ticket_manager, _script, block = - originate - ~baker - ~source_contract - ~script: - {| - { parameter (or (pair %add int string) (int %remove)) ; - storage (big_map int (ticket string)) ; - code { UNPAIR ; - IF_LEFT - { UNPAIR ; - DIG 2 ; - PUSH nat 1 ; - DIG 3 ; - TICKET ; - ASSERT_SOME ; - SOME ; - DIG 2 ; - GET_AND_UPDATE ; - DROP ; - NIL operation ; - PAIR } - { SWAP ; - NONE (ticket string) ; - DIG 2 ; - GET_AND_UPDATE ; - DROP ; - NIL operation ; - PAIR } } } - |} - ~storage:"{}" - block - in - let add key content block = - transaction - ~entrypoint:Entrypoint.default - ~baker - ~sender:source_contract - block - ~recipient:ticket_manager - ~parameters:(Printf.sprintf {|Left (Pair %d "%s")|} key content) - in - let remove key block = - transaction - ~entrypoint:Entrypoint.default - ~baker - ~sender:source_contract - block - ~recipient:ticket_manager - ~parameters:(Printf.sprintf {|Right %d|} key) - in - let token_red = string_token ~ticketer:ticket_manager "Red" in - let token_blue = string_token ~ticketer:ticket_manager "Blue" in - let token_yellow = string_token ~ticketer:ticket_manager "Yellow" in - let token_green = string_token ~ticketer:ticket_manager "Green" in - (* Add a red, blue and a yellow ticket *) - let* block = add 1 "Red" block in - let* block = add 2 "Blue" block in - let* block = add 3 "Yellow" block in - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_manager (Some 1) - in - let* () = - assert_token_balance ~loc:__LOC__ block token_blue ticket_manager (Some 1) - in - let* () = - assert_token_balance ~loc:__LOC__ block token_yellow ticket_manager (Some 1) - in - (* Replace the red ticket at index 1 with a green one. *) - let* block = add 1 "Green" block in - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_manager None - in - let* () = - assert_token_balance ~loc:__LOC__ block token_green ticket_manager (Some 1) - in - (* Remove the blue ticket at index 2. *) - let* block = remove 2 block in - let* () = - assert_token_balance ~loc:__LOC__ block token_blue ticket_manager None - in - (* Add one more green ticket at index 4 and verify that the total count is 2. *) - let* block = add 4 "Green" block in - assert_token_balance ~loc:__LOC__ block token_green ticket_manager (Some 2) - -(* Test sending tickets in a big-map to a receiver that drops it. *) -let test_send_tickets_in_big_map_and_drop () = - let open Lwt_result_wrap_syntax in - let* {block; baker; contract = source_contract} = init_env () in - (* A contract that can receive a big-map with tickets but drops it. *) - let* ticket_receiver, _script, block = - originate - ~baker - ~source_contract - ~script: - {| - { parameter (big_map int (ticket string)) ; - storage unit; - code { DROP; PUSH unit Unit; NIL operation ; PAIR } } - |} - ~storage:"Unit" - block - in - (* A contract that, given an address, creates a ticket and sends it to the - corresponding contract in a big-map. *) - let* ticket_sender, _script, block = - originate - ~baker - ~source_contract - ~script: - {| - { parameter address ; - storage unit ; - code { CAR ; - EMPTY_BIG_MAP int (ticket string) ; - PUSH nat 1 ; - PUSH string "Red" ; - TICKET ; - ASSERT_SOME ; - SOME ; - PUSH int 1 ; - GET_AND_UPDATE ; - DROP ; - SWAP ; - CONTRACT (big_map int (ticket string)) ; - IF_NONE - { DROP ; - PUSH string "Contract of type `ticket(string)` not found" ; - FAILWITH } - { PUSH mutez 0 ; - DIG 2 ; - TRANSFER_TOKENS ; - PUSH unit Unit ; - NIL operation ; - DIG 2 ; - CONS ; - PAIR } } } - - |} - ~storage:"Unit" - block - in - let token_red = string_token ~ticketer:ticket_sender "Red" in - (* Call ticket-sender to send a ticket to ticket-receiver. *) - let* block = - transaction - ~entrypoint:Entrypoint.default - ~baker - ~sender:source_contract - block - ~recipient:ticket_sender - ~parameters: - (Printf.sprintf {|"%s"|} @@ Contract.to_b58check ticket_receiver) - in - (* Verify that neither ticket-sender nor ticket-receiver holds any balance - for the ticket. *) - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_sender None - in - assert_token_balance ~loc:__LOC__ block token_red ticket_receiver None - -(* Test create contract with tickets *) -let test_create_contract_with_ticket () = - let open Lwt_result_wrap_syntax in - let* {block; baker; contract = source_contract} = init_env () in - let* ticket_creator, _script, block = - originate - ~baker - ~source_contract - ~script: - {| - { parameter (pair (pair string nat) key_hash) ; - storage unit ; - code { UNPAIR ; - UNPAIR ; - UNPAIR ; - TICKET ; - ASSERT_SOME ; - PUSH mutez 0 ; - DIG 2 ; - SOME ; - CREATE_CONTRACT - { parameter (ticket string) ; - storage (ticket string) ; - code { CAR ; NIL operation ; PAIR } } ; - SWAP ; - DROP ; - SWAP ; - NIL operation ; - DIG 2 ; - CONS ; - PAIR } } - |} - ~storage:"Unit" - block - in - let token_red = string_token ~ticketer:ticket_creator "Red" in - (* Call ticket-creator to originate a new contract with one ticket *) - let* new_contract, block = - get_new_contract block (fun block -> - transaction - ~entrypoint:Entrypoint.default - ~baker - ~sender:source_contract - block - ~recipient:ticket_creator - ~parameters: - (Printf.sprintf - {|Pair (Pair "Red" 1) "%s"|} - (Contract.to_b58check source_contract))) - in - let* () = - assert_token_balance ~loc:__LOC__ block token_red new_contract (Some 1) - in - assert_token_balance ~loc:__LOC__ block token_red ticket_creator None - -let test_join_tickets () = - let open Lwt_result_wrap_syntax in - let* {block; baker; contract = source_contract} = init_env () in - let* ticket_joiner, _script, block = - originate - ~baker - ~source_contract - ~script: - {| - { parameter unit ; - storage (option (ticket string)) ; - code { CDR ; - IF_NONE - { PUSH nat 1 ; PUSH string "Red" ; - TICKET ; ASSERT_SOME ; SOME ; NIL operation ; PAIR } - { PUSH nat 1 ; - PUSH string "Red" ; - TICKET ; - ASSERT_SOME ; - PAIR ; - JOIN_TICKETS ; - NIL operation ; - PAIR } } } - |} - ~storage:"None" - block - in - let token_red = string_token ~ticketer:ticket_joiner "Red" in - (* Call ticket joiner to create and join an additional ticket. *) - let add block = - transaction - ~entrypoint:Entrypoint.default - ~baker - ~sender:source_contract - block - ~recipient:ticket_joiner - ~parameters:"Unit" - in - (* Add three tickets *) - let* block = add block in - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_joiner (Some 1) - in - let* block = add block in - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_joiner (Some 2) - in - let* block = add block in - assert_token_balance ~loc:__LOC__ block token_red ticket_joiner (Some 3) - -(* A simple fungible token contract implemented using tickets of type - [ticket unit]. - parameter: - - burn: ticket unit - - mint: (contract %destination (ticket unit)) x (nat %amount) -*) -let ticket_builder = - {| - - parameter - (or (ticket %burn unit) - (pair %mint (contract %destination (ticket unit)) (nat %amount))); - storage address; - code - { - AMOUNT; PUSH mutez 0; ASSERT_CMPEQ; - - UNPAIR; - IF_LEFT - { - # Burn entrypoint - # Check that the ticket is ticketed by ourselves - READ_TICKET; CAR; SELF_ADDRESS; ASSERT_CMPEQ; - - # Drop the ticket - DROP; - - # Finish - NIL operation - } - { - # Mint entrypoint - # Authenticate SENDER - DUP @manager 2; SENDER; ASSERT_CMPEQ; - - UNPAIR; - SWAP; UNIT; TICKET; ASSERT_SOME; - PUSH mutez 0; SWAP; TRANSFER_TOKENS; - NIL operation; SWAP; CONS - }; - PAIR - } - - |} - -(* A simple wallet for fungible tokens implemented using tickets of - type [ticket unit]. - parameter: - - receive: ticket unit - - send: - * destination: (contract (ticket unit)) - * amount: nat - * ticketer: address -*) -let ticket_wallet = - {| - parameter - (or - (ticket %receive unit) - (pair %send (contract %destination (ticket unit)) (nat %amount) (address %ticketer))); - storage (pair (address %manager) (big_map %tickets address (ticket unit))); - code - { - AMOUNT; PUSH mutez 0; ASSERT_CMPEQ; - - UNPAIR 3; - IF_LEFT - { - # Receive entrypoint - - # Get the ticketer - READ_TICKET; CAR @ticketer; DUP; - - # Extract the associated ticket, if any, from the stored big map - DIG 4; - NONE (ticket unit); - DIG 2; - GET_AND_UPDATE; - - # Join it with the parameter - IF_SOME - { - DIG 3; - PAIR; - JOIN_TICKETS; - ASSERT_SOME - } - { DIG 2 }; - SOME; - DIG 2; - GET_AND_UPDATE; - ASSERT_NONE; - SWAP; - PAIR; - NIL operation - } - { - # Send entrypoints - - # Authenticate SENDER - DUP @manager 2; SENDER; ASSERT_CMPEQ; - - UNPAIR 3; - - # Get the ticket associated to the requested ticketer - DIG 4; - NONE (ticket unit); - DUP @ticketer 5; - GET_AND_UPDATE; - ASSERT_SOME; - - # Substract the requested amount - READ_TICKET; - GET @total_amount 4; - DUP @amount 5; - SWAP; SUB; - DUP; EQ; - IF - { - # Drop @remaining_amount because it is zero - DROP; - # Drop @amount because this is now irrelevant - DIG 3; DROP; - # Drop @ticketer because we are not storing any ticket in this wallet - DIG 3; DROP; - # Bring the big map to the stack top since the ticket entry is already striked out - DUG 3 - } - { - ISNAT; ASSERT_SOME @remaining_amount; - - # Split the ticket - DIG 4; PAIR; SWAP; SPLIT_TICKET; - ASSERT_SOME; UNPAIR @to_send @to_keep; - - # Store the ticket to keep - DUG 5; - SOME; - DIG 3; - GET_AND_UPDATE; - ASSERT_NONE; - }; - DIG 2; PAIR; - - # Send the ticket - SWAP; - PUSH mutez 0; - DIG 3; - TRANSFER_TOKENS; - NIL operation; - SWAP; - CONS; - }; - PAIR - } - |} - -(** Test ticket wallet implementation including sending tickets to self. *) -let test_ticket_wallet () = - let open Lwt_result_wrap_syntax in - let* {block; baker; contract = source_contract} = init_env () in - let* ticket_builder, _script, block = - originate - ~baker - ~source_contract - ~script:ticket_builder - ~storage:(Printf.sprintf "%S" @@ Contract.to_b58check source_contract) - block - in - let* ticket_wallet, _script, block = - originate - ~baker - ~source_contract - ~script:ticket_wallet - ~storage: - (Printf.sprintf "Pair %S {}" @@ Contract.to_b58check source_contract) - block - in - (* Call ticket-builder to mint one ticket and send to ticket-wallet. *) - let ticket_builder_token = unit_ticket ~ticketer:ticket_builder in - let send_one block = - transaction - ~entrypoint:(Entrypoint.of_string_strict_exn "mint") - ~baker - ~sender:source_contract - block - ~recipient:ticket_builder - ~parameters: - (Printf.sprintf - {|Pair "%s%sreceive" 1|} - (Contract.to_b58check ticket_wallet) - "%") - in - (* Call ticket wallet to send a ticket to ticket-builder's burn address - entrypoint. *) - let send_to_burn block = - transaction - ~entrypoint:(Entrypoint.of_string_strict_exn "send") - ~baker - ~sender:source_contract - block - ~recipient:ticket_wallet - ~parameters: - (Printf.sprintf - {|Pair "%s%sburn" 1 %S|} - (Contract.to_b58check ticket_builder) - "%" - (Contract.to_b58check ticket_builder)) - in - let send_to_self block = - transaction - ~entrypoint:(Entrypoint.of_string_strict_exn "send") - ~baker - ~sender:source_contract - block - ~recipient:ticket_wallet - ~parameters: - (Printf.sprintf - {|Pair "%s%sreceive" 1 %S|} - (Contract.to_b58check ticket_wallet) - "%" - (Contract.to_b58check ticket_builder)) - in - let assert_balance block balance = - assert_token_balance - ~loc:__LOC__ - block - ticket_builder_token - ticket_wallet - balance - in - (* Mint and send tickets to wallet. *) - let* block = send_one block in - let* () = assert_balance block (Some 1) in - let* block = send_one block in - let* () = assert_balance block (Some 2) in - (* Send to self should not affect the balance. *) - let* block = send_to_self block in - let* () = assert_balance block (Some 2) in - (* Burn tickets by sending to burn address. *) - let* block = send_to_burn block in - let* () = assert_balance block (Some 1) in - let* block = send_to_burn block in - assert_balance block None - -(* Test used ticket storage and paid storage. *) -let test_ticket_storage () = - let open Lwt_result_wrap_syntax in - let* {block; baker; contract = source_contract} = init_env () in - (* A contract that can receive a ticket and store it. Each new ticket it - receives is added to a list. *) - let* ticket_keeper, _script, block = - originate - ~baker - ~source_contract - ~script: - {| - { parameter (ticket string) ; - storage (list (ticket string)) ; - code { UNPAIR ; CONS ; NIL operation ; PAIR } } - |} - ~storage:"{}" - block - in - (* A contract that receives a pair of ticket and address and forwards the - ticket to the given address. The contract does not store any tickets. *) - let* ticket_forwarder, _script, block = - originate - ~baker - ~source_contract - ~script: - {| - { parameter (pair (ticket string) address) ; - storage unit ; - code { CAR ; - UNPAIR ; - SWAP ; - CONTRACT (ticket string) ; - IF_NONE - { DROP ; - PUSH string "Contract of type `ticket(string)` not found" ; - FAILWITH } - { PUSH mutez 0 ; - DIG 2 ; - TRANSFER_TOKENS ; - PUSH unit Unit ; - NIL operation ; - DIG 2 ; - CONS ; - PAIR } } } - |} - ~storage:"Unit" - block - in - (* A contract that takes two addresses: one to a ticket-forward contract and - one to a ticket-receiver contract, mints and sends the ticket to a - ticket-forward address along with the address of the ticket-receiver. - - Altogether we have: - - [ticket_minter] ----> [ticket_forwarder] ----> [ticket_receiver] - *) - let* ticket_minter, _script, block = - originate - ~baker - ~source_contract - ~script: - {| - { parameter (pair address address) ; storage unit ; - code { CAR ; - UNPAIR ; - CONTRACT (pair (ticket string) address) ; - IF_NONE - { DROP ; - PUSH string "Contract of type `ticket(string)` not found" ; - FAILWITH } - { PUSH mutez 0 ; - DIG 2 ; - PUSH nat 1 ; - PUSH string "Red" ; - TICKET ; - ASSERT_SOME ; - PAIR ; - TRANSFER_TOKENS ; - PUSH unit Unit ; - NIL operation ; - DIG 2 ; - CONS ; - PAIR } } } |} - ~storage:"Unit" - block - in - let mint_and_send block = - transaction - ~entrypoint:Entrypoint.default - ~baker - ~sender:source_contract - block - ~recipient:ticket_minter - ~parameters: - (Printf.sprintf - {|Pair %S %S|} - (Contract.to_b58check ticket_forwarder) - (Contract.to_b58check ticket_keeper)) - in - let* block = mint_and_send block in - let token_red = string_token ~ticketer:ticket_minter "Red" in - (* Verify that the ticket is accredited to the ticket keeper and no one else. - The ticket table now looks like: - *) - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_minter None - in - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_forwarder None - in - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_keeper (Some 1) - in - (* Both ticket paid and used storage should now be 65 bytes for the key and - one for the value. Ticket table looks like: - - | Owner x Ticket-token | Amount | - |--------------------------|--------| - | ticket_keeper x Red | 1 | - - Used storage: 65 + 1 = 66 - - Paid storage: 66 - *) - let* () = assert_used_ticket_storage ~loc:__LOC__ block 66 in - let* () = assert_paid_ticket_storage ~loc:__LOC__ block 66 in - (* Send another ticket that uses the same slot. That does not increase used - storage. The first call from [ticket_minter] to ticket-forwarder results in - a table: - - | Owner x Ticket-token | Amount | - |--------------------------|--------| - | ticket_forwarder x Red | 1 | - | ticket_keeper x Red | 1 | - - Used storage: 132 - - The call from ticket-forwarder to [ticket_keeper] results in: - - | Owner x Ticket-token | Amount | - |--------------------------|--------| - | ticket_keeper x Red | 2 | - - Used storage: 66 - - Noted that the paid-storage "water-marker" was pushed up to 132. - *) - let* block = mint_and_send block in - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_keeper (Some 2) - in - let* () = assert_used_ticket_storage ~loc:__LOC__ block 66 in - let* () = assert_paid_ticket_storage ~loc:__LOC__ block 132 in - (* Send yet another ticket that uses the same slot. That does not increase used - storage and it's using already paid storage. The first call from - [ticket_minter] to ticket-forwarder results in a table: - - | Owner x Ticket-token | Amount | - |--------------------------|--------| - | ticket_forwarder x Red | 1 | - | ticket_keeper x Red | 2 | - - Used storage: 132 - - The call from ticket-forwarder to [ticket_keeper] results in: - - | Owner x Ticket-token | Amount | - |--------------------------|--------| - | ticket_keeper x Red | 3 | - - Used storage: 66 - - Here, the paid_storage "water-mark" is not pushed up. - *) - let* block = mint_and_send block in - let* () = - assert_token_balance ~loc:__LOC__ block token_red ticket_keeper (Some 3) - in - let* () = assert_used_ticket_storage ~loc:__LOC__ block 66 in - let* () = assert_paid_ticket_storage ~loc:__LOC__ block 132 in - return () - -(* Test used ticket storage and paid storage. *) -let test_storage_for_create_and_remove_tickets () = - let open Lwt_result_wrap_syntax in - let* {block; baker; contract = source_contract} = init_env () in - (* A contract with two endpoints: - - Create n tickets and add to its storage - - Remove all tickets - *) - let* ticket_manager, _script, block = - originate - ~baker - ~source_contract - ~script: - {| - { parameter (or (pair %add nat string) (unit %clear)) ; - storage (list (ticket string)) ; - code { UNPAIR ; - IF_LEFT - { UNPAIR ; DIG 2 ; SWAP ; DIG 2 ; TICKET ; ASSERT_SOME ; CONS ; NIL operation ; PAIR } - { DROP 2 ; NIL (ticket string) ; NIL operation ; PAIR } } } - |} - ~storage:"{}" - block - in - let add block n content = - transaction - ~entrypoint:(Entrypoint.of_string_strict_exn "add") - ~baker - ~sender:source_contract - block - ~recipient:ticket_manager - ~parameters:(Printf.sprintf "Pair %d %S" n content) - in - let clear block = - transaction - ~entrypoint:(Entrypoint.of_string_strict_exn "clear") - ~baker - ~sender:source_contract - block - ~recipient:ticket_manager - ~parameters:"Unit" - in - (* Initially the used and paid contract storage size is 141. *) - let* () = - assert_used_contract_storage ~loc:__LOC__ block ticket_manager 141 - in - let* () = - assert_paid_contract_storage ~loc:__LOC__ block ticket_manager 141 - in - (* Add 1000 units of "A" tickets. *) - let* block = add block 1000 "A" in - (* After adding one block the new used and paid storage grows to accommodate - for the new ticket. The size is 141 + 40 (size of ticket) = 181. *) - let* () = - assert_used_contract_storage ~loc:__LOC__ block ticket_manager 181 - in - let* () = - assert_paid_contract_storage ~loc:__LOC__ block ticket_manager 181 - in - (* The size of used and paid-for ticket storage is 67 bytes. (65 for hash - and 2 for amount). *) - let* () = assert_used_ticket_storage ~loc:__LOC__ block 67 in - let* () = assert_paid_ticket_storage ~loc:__LOC__ block 67 in - (* Add 1000 units of "B" tickets. *) - let* block = add block 1000 "B" in - (* The new used and paid for contract storage grow to 155 + 40 = 195. *) - let* () = - assert_used_contract_storage ~loc:__LOC__ block ticket_manager 221 - in - let* () = - assert_paid_contract_storage ~loc:__LOC__ block ticket_manager 221 - in - (* The new used and paid for ticket storage doubles (2 * 67 = 134). *) - let* () = assert_used_ticket_storage ~loc:__LOC__ block 134 in - let* () = assert_paid_ticket_storage ~loc:__LOC__ block 134 in - (* Clear all tickets. *) - let* block = clear block in - (* We're back to 115 base-line for the used contract storage and keep 195 for - paid. *) - let* () = - assert_used_contract_storage ~loc:__LOC__ block ticket_manager 141 - in - let* () = - assert_paid_contract_storage ~loc:__LOC__ block ticket_manager 221 - in - (* Since the ticket-table is empty it does not take up any space. However, - we've already paid for 134 bytes. *) - let* () = assert_used_ticket_storage ~loc:__LOC__ block 0 in - let* () = assert_paid_ticket_storage ~loc:__LOC__ block 134 in - (* Add one unit of "C" tickets. *) - let* block = add block 1 "C" in - (* The new used storage is 141 + 39 (size of ticket) = 180. The size is 39 - rather than 40 because it carries a smaller amount payload. *) - let* () = - assert_used_contract_storage ~loc:__LOC__ block ticket_manager 180 - in - (* We still have paid for 221 contract storage. *) - let* () = - assert_paid_contract_storage ~loc:__LOC__ block ticket_manager 221 - in - (* There is one row in the ticket table with size 65 (for the hash) + 1 - (for the amount) = 65 bytes. *) - let* () = assert_used_ticket_storage ~loc:__LOC__ block 66 in - (* We've still paid for 134 bytes however. *) - let* () = assert_paid_ticket_storage ~loc:__LOC__ block 134 in - (* Add yet another "C" ticket. *) - let* block = add block 1 "C" in - (* The new used storage is 180 + 39 (size of ticket) = 219. *) - let* () = - assert_used_contract_storage ~loc:__LOC__ block ticket_manager 219 - in - (* We still have paid for 221 contract storage. *) - let* () = - assert_paid_contract_storage ~loc:__LOC__ block ticket_manager 221 - in - (* There is still only one row in the ticket table with size 66. *) - let* () = assert_used_ticket_storage ~loc:__LOC__ block 66 in - (* And we've still paid for 134 bytes. *) - let* () = assert_paid_ticket_storage ~loc:__LOC__ block 134 in - (* Add a "D" ticket. *) - let* block = add block 1 "D" in - (* The new used storage is 219 + 39 (size of ticket) = 258. *) - let* () = - assert_used_contract_storage ~loc:__LOC__ block ticket_manager 258 - in - (* The paid storage also increases to 258. *) - let* () = - assert_paid_contract_storage ~loc:__LOC__ block ticket_manager 258 - in - (* There are now two rows in the ticket table: 2 x 66 = 132 *) - let* () = assert_used_ticket_storage ~loc:__LOC__ block 132 in - (* And we've still paid for 134 bytes. *) - let* () = assert_paid_ticket_storage ~loc:__LOC__ block 134 in - let* block = add block 1 "E" in - (* The new used storage is 258 + 39 (size of ticket) = 297. *) - let* () = - assert_used_contract_storage ~loc:__LOC__ block ticket_manager 297 - in - (* The paid storage also increases to 297. *) - let* () = - assert_paid_contract_storage ~loc:__LOC__ block ticket_manager 297 - in - (* There are now three rows in the ticket table: 3 x 66 = 198. *) - let* () = assert_used_ticket_storage ~loc:__LOC__ block 198 in - (* And the paid storage has increased. *) - assert_paid_ticket_storage ~loc:__LOC__ block 198 - -let tests = - [ - Tztest.tztest "add strict" `Quick test_add_strict; - Tztest.tztest "add and remove" `Quick test_add_remove; - Tztest.tztest "add to big-map" `Quick test_add_to_big_map; - Tztest.tztest "swap big-map" `Quick test_swap_big_map; - Tztest.tztest "send ticket" `Quick test_send_tickets; - Tztest.tztest - "send ticket to implicit" - `Quick - test_send_tickets_to_implicit_account; - Tztest.tztest - "send and store tickets with amount 0" - `Quick - test_send_and_store_zero_amount_tickets; - Tztest.tztest "send tickets in big-map" `Quick test_send_tickets_in_big_map; - Tztest.tztest "modify big-map" `Quick test_modify_big_map; - Tztest.tztest "send drop" `Quick test_send_tickets_in_big_map_and_drop; - Tztest.tztest - "create contract with ticket" - `Quick - test_create_contract_with_ticket; - Tztest.tztest "join" `Quick test_join_tickets; - Tztest.tztest "wallet" `Quick test_ticket_wallet; - Tztest.tztest "ticket storage" `Quick test_ticket_storage; - Tztest.tztest - "storage for create and remove tickets" - `Quick - test_storage_for_create_and_remove_tickets; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("ticket balance", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_balance_key.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_balance_key.ml deleted file mode 100644 index a9604351a557c57211401a1aaaea4443ee5ce13a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_balance_key.ml +++ /dev/null @@ -1,453 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (Ticket_balance_key) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/michelson/main.exe \ - -- --file test_ticket_balance_key.ml - Subject: Ticket balance key hashing -*) - -open Protocol -open Alpha_context - -let new_ctxt () = - let open Lwt_result_wrap_syntax in - let* block, _contract = Context.init1 () in - let* incr = Incremental.begin_construction block in - return @@ Incremental.alpha_ctxt incr - -let make_contract ticketer = - let open Lwt_result_wrap_syntax in - let*?@ x = Contract.of_b58check ticketer in - return x - -let make_ex_token ctxt ~ticketer ~ty ~content = - let open Lwt_result_wrap_syntax in - let*?@ Script_ir_translator.Ex_comparable_ty cty, ctxt = - let node = Micheline.root @@ Expr.from_string ty in - Script_ir_translator.parse_comparable_ty ctxt node - in - let* ticketer = make_contract ticketer in - let*@ contents, ctxt = - let node = Micheline.root @@ Expr.from_string content in - Script_ir_translator.parse_comparable_data ctxt cty node - in - return (Ticket_token.Ex_token {contents_type = cty; ticketer; contents}, ctxt) - -let make_key ctxt ~ticketer ~ty ~content ~owner = - let open Lwt_result_wrap_syntax in - let* ex_token, ctxt = make_ex_token ctxt ~ticketer ~ty ~content in - let* owner = make_contract owner in - let*@ key, ctxt = - Ticket_balance_key.of_ex_token - ctxt - ~owner:(Destination.Contract owner) - ex_token - in - return (key, ctxt) - -let equal_script_hash ~loc msg key1 key2 = - Assert.equal ~loc Ticket_hash.equal msg Ticket_hash.pp key1 key2 - -let not_equal_script_hash ~loc msg key1 key2 = - Assert.not_equal ~loc Ticket_hash.equal msg Ticket_hash.pp key1 key2 - -let assert_keys ~ticketer1 ~ticketer2 ~ty1 ~ty2 ~amount1 ~amount2 ~content1 - ~content2 ~owner1 ~owner2 assert_condition = - let open Lwt_result_wrap_syntax in - let* ctxt = new_ctxt () in - let* key1, ctxt = - make_key ctxt ~ticketer:ticketer1 ~ty:ty1 ~content:content1 ~owner:owner1 - in - let* key2, _ = - make_key ctxt ~ticketer:ticketer2 ~ty:ty2 ~content:content2 ~owner:owner2 - in - assert_condition (key1, amount1) (key2, amount2) - -let assert_keys_not_equal ~loc = - assert_keys (fun (key1, _) (key2, _) -> - not_equal_script_hash ~loc "Assert that keys are not equal" key1 key2) - -let assert_keys_equal ~loc = - assert_keys (fun (key1, _) (key2, _) -> - equal_script_hash ~loc "Assert that keys are equal" key1 key2) - -(** Test that tickets with two different amounts map to the same hash. - The amount is not part of the ticket balance key. *) -let test_different_amounts () = - assert_keys_equal - ~loc:__LOC__ - ~ticketer1:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ticketer2:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ty1:"unit" - ~ty2:"unit" - ~content1:"Unit" - ~content2:"Unit" - ~amount1:1 - ~amount2:2 - ~owner1:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - ~owner2:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - -(** Test that two tickets with different ticketers map to different hashes. *) -let test_different_ticketers () = - assert_keys_not_equal - ~loc:__LOC__ - ~ticketer1:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ticketer2:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - ~ty1:"nat" - ~ty2:"nat" - ~content1:"1" - ~content2:"1" - ~amount1:1 - ~amount2:1 - ~owner1:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - ~owner2:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - -(** Test that two tickets with different owners map to different hashes. *) -let test_different_owners () = - assert_keys_not_equal - ~loc:__LOC__ - ~ticketer1:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ticketer2:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ty1:"nat" - ~ty2:"nat" - ~content1:"1" - ~content2:"1" - ~amount1:1 - ~amount2:1 - ~owner1:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - ~owner2:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - -(** Test that two tickets with different contents map to different hashes. *) -let test_different_content () = - assert_keys_not_equal - ~loc:__LOC__ - ~ticketer1:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ticketer2:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ty1:"nat" - ~ty2:"nat" - ~content1:"1" - ~content2:"2" - ~amount1:1 - ~amount2:1 - ~owner1:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - ~owner2:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - -(** Test that a ticket of type nat and a ticket of type int, with the same - content, map to different hashes. *) -let test_nat_int () = - assert_keys_not_equal - ~loc:__LOC__ - ~ticketer1:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ticketer2:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ty1:"nat" - ~ty2:"int" - ~content1:"1" - ~content2:"1" - ~amount1:1 - ~amount2:1 - ~owner1:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - ~owner2:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - -(** Test that a ticket of type nat and a ticket of type mutez, with the same - content, map to different hashes. *) -let test_nat_mutez () = - assert_keys_not_equal - ~loc:__LOC__ - ~ticketer1:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ticketer2:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ty1:"nat" - ~ty2:"mutez" - ~content1:"1" - ~content2:"1" - ~amount1:1 - ~amount2:1 - ~owner1:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - ~owner2:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - -(** Test that a ticket of type nat and a ticket of type bool, with the - contents (False/0), map to different hashes. *) -let test_bool_nat () = - assert_keys_not_equal - ~loc:__LOC__ - ~ticketer1:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ticketer2:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ty1:"bool" - ~ty2:"nat" - ~content1:"False" - ~content2:"0" - ~amount1:1 - ~amount2:1 - ~owner1:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - ~owner2:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - -(** Test that a ticket of type nat and a ticket of type bytes, with the - contents (0/0x), map to different hashes. *) -let test_nat_bytes () = - assert_keys_not_equal - ~loc:__LOC__ - ~ticketer1:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ticketer2:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ty1:"nat" - ~ty2:"bytes" - ~content1:"0" - ~content2:"0x" - ~amount1:1 - ~amount2:1 - ~owner1:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - ~owner2:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - -(** Test that a ticket of type string and a chain_id with same content - map to different hashes. *) -let test_string_chain_id () = - assert_keys_not_equal - ~loc:__LOC__ - ~ticketer1:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ticketer2:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ty1:"string" - ~ty2:"chain_id" - ~content1:{|"NetXynUjJNZm7wi"|} - ~content2:{|"NetXynUjJNZm7wi"|} - ~amount1:1 - ~amount2:1 - ~owner1:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - ~owner2:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - -(** Test that a ticket of type string and a key_hash with same content - map to different hashes. *) -let test_string_key_hash () = - assert_keys_not_equal - ~loc:__LOC__ - ~ticketer1:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ticketer2:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ty1:"string" - ~ty2:"key_hash" - ~content1:{|"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"|} - ~content2:{|"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"|} - ~amount1:1 - ~amount2:1 - ~owner1:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - ~owner2:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - -(** Test that a ticket of type string and a key with same content - map to different hashes. *) -let test_string_key () = - assert_keys_not_equal - ~loc:__LOC__ - ~ticketer1:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ticketer2:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ty1:"string" - ~ty2:"key" - ~content1:{|"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav"|} - ~content2:{|"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav"|} - ~amount1:1 - ~amount2:1 - ~owner1:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - ~owner2:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - -(** Test that a ticket of type string and a timestamp with same content - map to different hashes. *) -let test_string_timestamp () = - assert_keys_not_equal - ~loc:__LOC__ - ~ticketer1:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ticketer2:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ty1:"string" - ~ty2:"timestamp" - ~content1:{|"2019-09-26T10:59:51Z"|} - ~content2:{|"2019-09-26T10:59:51Z"|} - ~amount1:1 - ~amount2:1 - ~owner1:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - ~owner2:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - -(** Test that a ticket of type string and a address with same content - map to different hashes. *) -let test_string_address () = - assert_keys_not_equal - ~loc:__LOC__ - ~ticketer1:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ticketer2:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ty1:"string" - ~ty2:"address" - ~content1:{|"KT1BEqzn5Wx8uJrZNvuS9DVHmLvG9td3fDLi%entrypoint"|} - ~content2:{|"KT1BEqzn5Wx8uJrZNvuS9DVHmLvG9td3fDLi%entrypoint"|} - ~amount1:1 - ~amount2:1 - ~owner1:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - ~owner2:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - -(** Test that a ticket of type string and a signature with same content - map to different hashes. *) -let test_string_signature () = - let signature = - {|"edsigthTzJ8X7MPmNeEwybRAvdxS1pupqcM5Mk4uCuyZAe7uEk68YpuGDeViW8wSXMrCi5CwoNgqs8V2w8ayB5dMJzrYCHhD8C7"|} - in - assert_keys_not_equal - ~loc:__LOC__ - ~ticketer1:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ticketer2:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ty1:"string" - ~ty2:"signature" - ~content1:signature - ~content2:signature - ~amount1:1 - ~amount2:1 - ~owner1:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - ~owner2:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - -(** Tests that annotations are not taken into account when hashing keys. - Two comparable types that only differ in their annotations should - map to to the same hash. Here, the type [pair int string] is identical to - [pair (int %id) (string %name)]. - *) -let test_annotation_pair () = - assert_keys_equal - ~loc:__LOC__ - ~ticketer1:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ticketer2:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ty1:"(pair int string)" - ~ty2:{|(pair (int %id) (string %name))|} - ~content1:{|Pair 1 "hello"|} - ~content2:{|Pair 1 "hello"|} - ~amount1:1 - ~amount2:1 - ~owner1:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - ~owner2:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - -(** Tests that annotations are not taken into account when hashing keys. - Here the types [or int string] and [or (int %id) (string %name)] - should hash to the same key. - *) -let test_annotation_or () = - assert_keys_equal - ~loc:__LOC__ - ~ticketer1:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ticketer2:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ty1:"(or int string)" - ~ty2:{|(or (int %id) (string %name))|} - ~content1:{|Left 1|} - ~content2:{|Left 1|} - ~amount1:1 - ~amount2:1 - ~owner1:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - ~owner2:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - -(** Tests that annotations are not taken into account when hashing keys. - Here the types [int] and [(int :int_alias)] should hash to the same key. - *) -let test_annotation_type_alias () = - assert_keys_equal - ~loc:__LOC__ - ~ticketer1:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ticketer2:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ty1:"int" - ~ty2:"(int :int_alias)" - ~content1:"0" - ~content2:"0" - ~amount1:1 - ~amount2:1 - ~owner1:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - ~owner2:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - -(** Tests that annotations are not taken into account when hashing keys. - Here the types [pair (or int string) int] and - [pair (or (int %id) (string %name)) int] should hash to the same key. - *) -let test_annotation_pair_or () = - assert_keys_equal - ~loc:__LOC__ - ~ticketer1:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ticketer2:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ty1:"pair (or int string) int" - ~ty2:{|pair (or (int %id) (string %name)) int|} - ~content1:{|Pair (Left 1) 2|} - ~content2:{|Pair (Left 1) 2|} - ~amount1:1 - ~amount2:1 - ~owner1:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - ~owner2:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - -(** Test that a ticket of type [option int] and [option nat] with the same - content, [None], don't map to the same hash. *) -let test_option_none () = - assert_keys_not_equal - ~loc:__LOC__ - ~ticketer1:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ticketer2:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ty1:"option int" - ~ty2:"option nat" - ~content1:{|None|} - ~content2:{|None|} - ~amount1:1 - ~amount2:1 - ~owner1:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - ~owner2:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - -(** Test that a ticket of type [option int] and [option nat] with the same - content, [Some 0], don't map to the same hash. *) -let test_option_some () = - assert_keys_not_equal - ~loc:__LOC__ - ~ticketer1:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ticketer2:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~ty1:"option int" - ~ty2:"option nat" - ~content1:{|Some 0|} - ~content2:{|Some 0|} - ~amount1:1 - ~amount2:1 - ~owner1:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - ~owner2:"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - -let tests = - [ - Tztest.tztest "different ticketers" `Quick test_different_ticketers; - Tztest.tztest "different owners" `Quick test_different_owners; - Tztest.tztest "different content" `Quick test_different_content; - Tztest.tztest "different amounts" `Quick test_different_amounts; - Tztest.tztest "nat int" `Quick test_nat_int; - Tztest.tztest "nat mutez" `Quick test_nat_mutez; - Tztest.tztest "not bool" `Quick test_bool_nat; - Tztest.tztest "nat bytes" `Quick test_nat_bytes; - Tztest.tztest "string chain_id" `Quick test_string_chain_id; - Tztest.tztest "string key_hash" `Quick test_string_key_hash; - Tztest.tztest "string timestamp" `Quick test_string_timestamp; - Tztest.tztest "string address" `Quick test_string_address; - Tztest.tztest "string key" `Quick test_string_key; - Tztest.tztest "string signature" `Quick test_string_signature; - Tztest.tztest "annotations for pair" `Quick test_annotation_pair; - Tztest.tztest "annotations for or" `Quick test_annotation_or; - Tztest.tztest "annotations for type alias" `Quick test_annotation_type_alias; - Tztest.tztest "annotations for paired ors" `Quick test_annotation_pair_or; - Tztest.tztest "option none" `Quick test_option_none; - Tztest.tztest "option some" `Quick test_option_some; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("ticket balance key", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml deleted file mode 100644 index efb7cc9d67b035797155ffb6c6220511ae6cf37c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml +++ /dev/null @@ -1,696 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Trili Tech, *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (Ticket_scanner) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/michelson/main.exe \ - -- --file test_ticket_lazy_storage_diff.ml - Subject: Ticket scanner tests -*) - -open Protocol -open Alpha_context - -let assert_equal_string_list ~loc msg = - Assert.assert_equal_list ~loc String.equal msg Format.pp_print_string - -let string_list_of_ex_token_diffs ctxt token_diffs = - let open Lwt_result_wrap_syntax in - let accum (xs, ctxt) - (Ticket_token.Ex_token {ticketer; contents_type; contents}, amount) = - let*@ x, ctxt = - Script_ir_unparser.unparse_comparable_data - ctxt - Script_ir_unparser.Readable - contents_type - contents - in - let str = - Format.asprintf - "((%a, %a), %a)" - Contract.pp - ticketer - Michelson_v1_printer.print_expr - x - Z.pp_print - amount - in - return (str :: xs, ctxt) - in - let* xs, ctxt = List.fold_left_es accum ([], ctxt) token_diffs in - return (List.rev xs, ctxt) - -let make_ex_token ctxt ~ticketer ~type_exp ~content_exp = - let open Lwt_result_wrap_syntax in - let*?@ Script_ir_translator.Ex_comparable_ty contents_type, ctxt = - let node = Micheline.root @@ Expr.from_string type_exp in - Script_ir_translator.parse_comparable_ty ctxt node - in - let*@ ticketer = Lwt.return @@ Contract.of_b58check ticketer in - let*@ contents, ctxt = - let node = Micheline.root @@ Expr.from_string content_exp in - Script_ir_translator.parse_comparable_data ctxt contents_type node - in - return (Ticket_token.Ex_token {ticketer; contents_type; contents}, ctxt) - -let assert_equal_balances ~loc ctxt given expected = - let open Lwt_result_wrap_syntax in - let* ctxt, tbs1 = - List.fold_left_map_es - (fun ctxt ((ticketer, content), delta) -> - make_ex_token - ctxt - ~ticketer - ~type_exp:"string" - ~content_exp:(Printf.sprintf "%S" content) - >|=? fun (token, ctxt) -> (ctxt, (token, Z.of_int delta))) - ctxt - expected - in - let* tbs1, ctxt = string_list_of_ex_token_diffs ctxt tbs1 in - let* tbs2, _ctxt = string_list_of_ex_token_diffs ctxt given in - assert_equal_string_list - ~loc - "Compare token balances" - (List.sort String.compare tbs1) - (List.sort String.compare tbs2) - -let updates_of_key_values ctxt key_values = - let open Lwt_result_wrap_syntax in - List.fold_right_es - (fun (key, value) (kvs, ctxt) -> - let*@ key_hash, ctxt = - Script_ir_translator.hash_comparable_data - ctxt - Script_typed_ir.int_t - (Script_int.of_int key) - in - return - ( { - Big_map.key = Expr.from_string @@ string_of_int key; - key_hash; - value = Option.map Expr.from_string value; - } - :: kvs, - ctxt )) - key_values - ([], ctxt) - -let make_alloc big_map_id alloc updates = - Lazy_storage.make - Lazy_storage.Kind.Big_map - big_map_id - (Update {init = Lazy_storage.Alloc alloc; updates}) - -let init () = - let open Lwt_result_wrap_syntax in - let* block, source = Context.init1 () in - let* operation, originated = - Op.contract_origination_hash (B block) source ~script:Op.dummy_script - in - let* block = Block.bake ~operation block in - let* inc = Incremental.begin_construction block in - return (originated, Incremental.alpha_ctxt inc) - -let setup ctxt contract ~key_type ~value_type entries = - let open Lwt_result_wrap_syntax in - let*@ ctxt, big_map_id = Big_map.fresh ~temporary:false ctxt in - let key_type = Expr.from_string key_type in - let value_type = Expr.from_string value_type in - let* updates, ctxt = updates_of_key_values ctxt entries in - let alloc = make_alloc big_map_id Big_map.{key_type; value_type} updates in - return (alloc, big_map_id, contract, ctxt) - -let new_big_map ctxt contract ~key_type ~value_type entries = - let open Lwt_result_wrap_syntax in - let* alloc, big_map_id, contract, ctxt = - setup ctxt contract ~key_type ~value_type - @@ List.map (fun (k, v) -> (k, Some v)) entries - in - let storage = Expr.from_string "{}" in - let*@ ctxt = - Contract.update_script_storage ctxt contract storage (Some [alloc]) - in - return (big_map_id, ctxt) - -let alloc_diff ctxt contract ~key_type ~value_type entries = - let open Lwt_result_wrap_syntax in - let* allocations, _, _, ctxt = - setup - ctxt - contract - ~key_type - ~value_type - (List.map (fun (k, v) -> (k, Some v)) entries) - in - return (allocations, ctxt) - -let remove_diff ctxt contract ~key_type ~value_type ~existing_entries = - let open Lwt_result_wrap_syntax in - let* big_map_id, ctxt = - new_big_map ctxt contract ~key_type ~value_type existing_entries - in - return (Lazy_storage.make Lazy_storage.Kind.Big_map big_map_id Remove, ctxt) - -let copy_diff ctxt contract ~key_type ~value_type ~existing_entries ~updates = - let open Lwt_result_wrap_syntax in - let* big_map_id, ctxt = - new_big_map ctxt contract ~key_type ~value_type existing_entries - in - let* updates, ctxt = updates_of_key_values ctxt updates in - let*@ ctxt, new_big_map_id = Big_map.fresh ctxt ~temporary:false in - return - ( Lazy_storage.make - Lazy_storage.Kind.Big_map - new_big_map_id - (Update {init = Lazy_storage.Copy {src = big_map_id}; updates}), - ctxt ) - -let existing_diff ctxt contract ~key_type ~value_type ~existing_entries ~updates - = - let open Lwt_result_wrap_syntax in - let* big_map_id, ctxt = - new_big_map ctxt contract ~key_type ~value_type existing_entries - in - let* updates, ctxt = updates_of_key_values ctxt updates in - return - ( Lazy_storage.make - Lazy_storage.Kind.Big_map - big_map_id - (Update {init = Lazy_storage.Existing; updates}), - ctxt ) - -(** Test that no ticket-tokens are extracted from a diff for allocating an empty - big-map. *) -let test_allocate_new_empty () = - let open Lwt_result_wrap_syntax in - let* contract, ctxt = init () in - let* diff, ctxt = - alloc_diff ctxt contract ~key_type:"int" ~value_type:"ticket string" [] - in - let*@ diff, ctxt = - Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff] - in - assert_equal_balances ~loc:__LOC__ ctxt diff [] - -(** Test that no ticket-tokens are extracted from a lazy-diff of a big-map - that does not contain tickets. *) -let test_allocate_new_no_tickets () = - let open Lwt_result_wrap_syntax in - let* contract, ctxt = init () in - let* diff, ctxt = - alloc_diff - ctxt - contract - ~key_type:"int" - ~value_type:"string" - [(1, {|"A"|}); (2, {|"B"|}); (3, {|"C"|})] - in - let*@ diff, ctxt = - Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff] - in - assert_equal_balances ~loc:__LOC__ ctxt diff [] - -(** Test that ticket-tokens can be extracted from a lazy-diff for allocating a - new big-map. *) -let test_allocate_new () = - let open Lwt_result_wrap_syntax in - let* contract, ctxt = init () in - let* diff, ctxt = - alloc_diff - ctxt - contract - ~key_type:"int" - ~value_type:"ticket string" - [ - (1, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1|}); - (2, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2|}); - (3, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 3|}); - ] - in - let*@ diff, ctxt = - Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff] - in - assert_equal_balances - ~loc:__LOC__ - ctxt - diff - [ - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), 1); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "green"), 2); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue"), 3); - ] - -(** Test that ticket-tokens with negative balances are extracted from a - lazy-diff that removes a big-map. *) -let test_remove_big_map () = - let open Lwt_result_wrap_syntax in - let* contract, ctxt = init () in - let* diff, ctxt = - remove_diff - ctxt - contract - ~key_type:"int" - ~value_type:"ticket string" - ~existing_entries: - [ - (1, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1|}); - (2, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2|}); - (3, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 3|}); - ] - in - let*@ diff, ctxt = - Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff] - in - assert_equal_balances - ~loc:__LOC__ - ctxt - diff - [ - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), -1); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "green"), -2); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue"), -3); - ] - -(** Test that there are no ticket-token balance deltas extracted from a - lazy-diff that applies no updates. *) -let test_no_updates_to_existing_big_map () = - let open Lwt_result_wrap_syntax in - let* contract, ctxt = init () in - let* diff, ctxt = - existing_diff - ctxt - contract - ~key_type:"int" - ~value_type:"ticket string" - ~existing_entries: - [ - (1, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1|}); - (2, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2|}); - (3, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 3|}); - ] - ~updates:[] - in - let*@ diff, ctxt = - Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff] - in - assert_equal_balances ~loc:__LOC__ ctxt diff [] - -(** Test that ticket-tokens extracted reflect the balance diffs that are - extracted from a lazy-diff that modifies an existing big-map. - *) -let test_update_existing_big_map () = - let open Lwt_result_wrap_syntax in - let* contract, ctxt = init () in - let* diff, ctxt = - existing_diff - ctxt - contract - ~key_type:"int" - ~value_type:"ticket string" - ~existing_entries: - [ - (1, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1|}); - (2, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2|}); - (3, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 3|}); - ] - ~updates: - [ - (* Replace entry at index 1 *) - (1, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "yellow" 4|}); - (* Remove entry at index 2 *) - (2, None); - (* Add new entry at index 4 *) - (4, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "pink" 5|}); - ] - in - let*@ diff, ctxt = - Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff] - in - assert_equal_balances - ~loc:__LOC__ - ctxt - diff - [ - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), -1); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "green"), -2); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "yellow"), 4); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "pink"), 5); - ] - -(** Test that ticket-tokens extracted reflect the balance diffs that are - extracted from a lazy-diff that modifies an existing big-map and with - multiple updates to the same key. - *) -let test_update_same_key_multiple_times_existing_big_map () = - let open Lwt_result_wrap_syntax in - let* contract, ctxt = init () in - let* diff, ctxt = - existing_diff - ctxt - contract - ~key_type:"int" - ~value_type:"ticket string" - ~existing_entries: - [(1, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1|})] - ~updates: - [ - (* Replace entry at index 1 *) - (1, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "yellow" 1|}); - (* Replace entry at index 1 *) - (1, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 1|}); - ] - in - let*@ diff, ctxt = - Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff] - in - assert_equal_balances - ~loc:__LOC__ - ctxt - diff - [ - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "green"), 1); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), -1); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "yellow"), 1); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "yellow"), -1); - ] - -(** Test that ticket-tokens extracted reflect the balance diffs that are - extracted from a lazy-diff that modifies an existing big-map and with - multiple removals of the same item. - *) -let test_remove_same_key_multiple_times_existing_big_map () = - let open Lwt_result_wrap_syntax in - let* contract, ctxt = init () in - let* diff, ctxt = - existing_diff - ctxt - contract - ~key_type:"int" - ~value_type:"ticket string" - ~existing_entries: - [(1, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1|})] - ~updates: - [ - (* Remove entry at index 1 *) - (1, None); - (* Remove entry at index 1 again *) - (1, None); - ] - in - let*@ diff, ctxt = - Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff] - in - assert_equal_balances - ~loc:__LOC__ - ctxt - diff - [(("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), -1)] - -(** Test that ticket-tokens extracted reflect the balance diffs that are - extracted from a lazy-diff that modifies an existing big-map and with - multiple additions and removals of the same item. - *) -let test_update_and_remove_same_key_multiple_times_existing_big_map () = - let open Lwt_result_wrap_syntax in - let* contract, ctxt = init () in - let* diff, ctxt = - existing_diff - ctxt - contract - ~key_type:"int" - ~value_type:"ticket string" - ~existing_entries: - [(1, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1|})] - ~updates: - [ - (* Remove entry at index 1 *) - (1, None); - (* Add a yellow ticket at index 1. *) - (1, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "yellow" 1|}); - (* Remove entry at index 1 again *) - (1, None); - (* Add a green ticket at index 1. *) - (1, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 1|}); - ] - in - let*@ diff, ctxt = - Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff] - in - assert_equal_balances - ~loc:__LOC__ - ctxt - diff - [ - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), -1); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "yellow"), -1); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "yellow"), 1); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "green"), 1); - ] - -(** Test that the extracted ticket-tokens from a lazy diff for copying a big-map - reflects the tokens of the source as well as the updates. *) -let test_copy_big_map () = - let open Lwt_result_wrap_syntax in - let* contract, ctxt = init () in - let* diff, ctxt = - copy_diff - ctxt - contract - ~key_type:"int" - ~value_type:"ticket string" - ~existing_entries: - [ - (1, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1|}); - (2, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2|}); - (3, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 3|}); - ] - ~updates:[] - in - let*@ diff, ctxt = - Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff] - in - assert_equal_balances - ~loc:__LOC__ - ctxt - diff - [ - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), 1); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "green"), 2); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue"), 3); - ] - -(** Test that the extracted ticket-tokens from a lazy diff for copying a big-map - reflects the tokens of the source as well as the updates. *) -let test_copy_big_map_with_updates () = - let open Lwt_result_wrap_syntax in - let* contract, ctxt = init () in - let* diff, ctxt = - copy_diff - ctxt - contract - ~key_type:"int" - ~value_type:"ticket string" - ~existing_entries: - [ - (1, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1|}); - (2, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2|}); - (3, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 3|}); - ] - ~updates: - [ - (* Remove element at index 1*) - (1, None); - (* Replace element at index 3 *) - (3, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "yellow" 4|}); - (* Add a new element at index 4 *) - (4, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "pink" 5|}); - ] - in - let*@ diff, ctxt = - Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff] - in - assert_equal_balances - ~loc:__LOC__ - ctxt - diff - [ - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), 1); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), -1); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "green"), 2); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue"), 3); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue"), -3); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "yellow"), 4); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "pink"), 5); - ] - -(** Test that the extracted ticket-tokens from a lazy diff for copying a big-map - with multiple updates to the same key reflects the tokens of the source as - well as the updates. *) -let test_copy_big_map_with_updates_to_same_key () = - let open Lwt_result_wrap_syntax in - let* contract, ctxt = init () in - let* diff, ctxt = - copy_diff - ctxt - contract - ~key_type:"int" - ~value_type:"ticket string" - ~existing_entries: - [(1, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1|})] - ~updates: - [ - (* Remove element at index 1 *) - (1, None); - (* Add element at index 1 *) - (1, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "yellow" 2|}); - (* Remove again *) - (1, None); - ] - in - let*@ diff, ctxt = - Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt [diff] - in - assert_equal_balances - ~loc:__LOC__ - ctxt - diff - [ - (* From the copy of the big-map *) - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), 1); - (* From removing the element from the copied big-map *) - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), -1); - (* From adding to the copied big-map. *) - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "yellow"), 2); - (* From removing from the copied big-map *) - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "yellow"), -2); - ] - -(** Test combinations of lazy-diffs. *) -let test_mix_lazy_diffs () = - let open Lwt_result_wrap_syntax in - let* contract, ctxt = init () in - let* diff_copy, ctxt = - copy_diff - ctxt - contract - ~key_type:"int" - ~value_type:"ticket string" - ~existing_entries: - [(1, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1|})] - ~updates: - [ - (* Remove element at index 1 *) - (1, None); - (* Replace element at index 2 *) - (2, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2|}); - ] - in - let* diff_existing, ctxt = - existing_diff - ctxt - contract - ~key_type:"int" - ~value_type:"ticket string" - ~existing_entries: - [(1, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1|})] - ~updates: - [ - (* Remove entry at index 2 *) - (2, None); - (* Add new entry at index 3 *) - (3, Some {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 3|}); - ] - in - let* diff_remove, ctxt = - remove_diff - ctxt - contract - ~key_type:"int" - ~value_type:"ticket string" - ~existing_entries: - [ - (1, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "white" 1|}); - (2, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "black" 1|}); - ] - in - let*@ diff, ctxt = - Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff - ctxt - [diff_copy; diff_existing; diff_remove] - in - assert_equal_balances - ~loc:__LOC__ - ctxt - diff - [ - (* From the copy *) - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "green"), 2); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), -1); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red"), 1); - (* From updating an existing *) - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue"), 3); - (* From the remove *) - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "white"), -1); - (("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "black"), -1); - ] - -let tests = - [ - Tztest.tztest "allocate new empty" `Quick test_allocate_new_empty; - Tztest.tztest "allocate new" `Quick test_allocate_new; - Tztest.tztest "allocate new no tickets" `Quick test_allocate_new_no_tickets; - Tztest.tztest "Remove" `Quick test_remove_big_map; - Tztest.tztest - "no updates to existing" - `Quick - test_no_updates_to_existing_big_map; - Tztest.tztest "update existing big-map" `Quick test_update_existing_big_map; - Tztest.tztest - "update same key multiple times on existing big-map" - `Quick - test_update_same_key_multiple_times_existing_big_map; - Tztest.tztest - "remove same key multiple times on existing big-map" - `Quick - test_remove_same_key_multiple_times_existing_big_map; - Tztest.tztest - "update and remove same key multiple times on existing big-map" - `Quick - test_update_and_remove_same_key_multiple_times_existing_big_map; - Tztest.tztest "copy" `Quick test_copy_big_map; - Tztest.tztest "copy with updates" `Quick test_copy_big_map_with_updates; - Tztest.tztest - "copy with multiple updates to same key" - `Quick - test_copy_big_map_with_updates_to_same_key; - Tztest.tztest "mix lazy diffs" `Quick test_mix_lazy_diffs; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("ticket lazy storage diff", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_manager.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_manager.ml deleted file mode 100644 index 0cbe158dd967db996a9f94e3e323623c3cbeffcf..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_manager.ml +++ /dev/null @@ -1,817 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (Ticket_balance_key) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/michelson/main.exe \ - -- --file test_ticket_manager.ml - Subject: Tests that compare the ticket-balance table against tickets in the - contract storages. The tests include a lot of operations that - sends and store tickets. After each operation we check that the - ticket balance table reflects the actual tickets stored. - This relies on the invariant that any ticket-token referenced by - the table corresponds to a ticket in a storage. Currently, storage - is the only place to actually keep existing tickets. -*) - -open Protocol -open Alpha_context - -type init_env = { - block : Block.t; - baker : Signature.public_key_hash; - contract : Contract.t; -} - -let init_env () = - let open Lwt_result_wrap_syntax in - let* block, baker, contract, _src2 = Contract_helpers.init () in - return {block; baker; contract} - -let collect_token_amounts ctxt tickets = - let accum (tokens, ctxt) ticket = - let token, amount = - Ticket_scanner.ex_token_and_amount_of_ex_ticket ticket - in - let tokens = (token, Script_int.(to_zint (amount :> n num))) :: tokens in - return (tokens, ctxt) - in - List.fold_left_es accum ([], ctxt) tickets - -let tokens_of_value ~include_lazy ctxt ty x = - let open Lwt_result_wrap_syntax in - let*? has_tickets, ctxt = Ticket_scanner.type_has_tickets ctxt ty in - let* tickets, ctxt = - Ticket_scanner.tickets_of_value ~include_lazy ctxt has_tickets x - in - let* tas, ctxt = collect_token_amounts ctxt tickets in - let* bm, ctxt = - Ticket_token_map.of_list - ctxt - ~merge_overlap:(fun ctxt v1 v2 -> ok (Z.add v1 v2, ctxt)) - tas - in - Lwt.return @@ Ticket_token_map.to_list ctxt bm - -(* Extract ticket-token balance of storage *) -let ticket_balance_of_storage ctxt (contract : Alpha_context.Contract.t) = - let open Lwt_result_wrap_syntax in - match contract with - | Implicit _ -> return ([], ctxt) - | Originated contract_hash -> ( - let*@ ctxt, script = - Alpha_context.Contract.get_script ctxt contract_hash - in - match script with - | None -> return ([], ctxt) - | Some script -> - let*@ ( Script_ir_translator.Ex_script - (Script {storage; storage_type; _}), - ctxt ) = - Script_ir_translator.parse_script - ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) - ~allow_forged_in_storage:true - script - in - let*@ tokens, ctxt = - tokens_of_value ~include_lazy:true ctxt storage_type storage - in - let*@ tokens, ctxt = - List.fold_left_es - (fun (acc, ctxt) (ex_token, amount) -> - let* key, ctxt = - Ticket_balance_key.of_ex_token - ctxt - ~owner:(Contract contract) - ex_token - in - let acc = (key, amount) :: acc in - return (acc, ctxt)) - ([], ctxt) - tokens - in - return (tokens, ctxt)) - -let transaction block ~sender ~recipient ~amount ~parameters = - let open Lwt_result_wrap_syntax in - let parameters = Script.lazy_expr @@ Expr.from_string parameters in - let* block = Incremental.begin_construction block in - let* operation = - Op.transaction - (I block) - ~gas_limit:Max - ~entrypoint:Entrypoint.default - ~parameters - ~fee:Tez.zero - sender - recipient - (Tez.of_mutez_exn amount) - in - let* block = Incremental.add_operation block operation in - Incremental.finalize_block block - -let all_contracts current_block = - let open Lwt_result_wrap_syntax in - let* ctxt = - Incremental.begin_construction current_block >|=? Incremental.alpha_ctxt - in - Lwt.map Result.ok @@ Contract.list ctxt - -(* Fetch all added contracts between [before] and [after]. *) -let new_contracts ~before ~after = - let open Lwt_result_wrap_syntax in - let* cs1 = all_contracts before in - let* cs2 = all_contracts after in - let not_in_cs1 = - let module S = Set.Make (String) in - let set = S.of_list @@ List.map Contract.to_b58check cs1 in - fun c -> not @@ S.mem (Contract.to_b58check c) set - in - return @@ List.filter not_in_cs1 cs2 - -let get_first_two_new_contracts before f = - let open Lwt_result_wrap_syntax in - let* after = f before in - let* c = new_contracts ~before ~after in - match c with - | c1 :: c2 :: _ -> return (c1, c2, after) - | _ -> failwith "Expected two new contracts" - -let show_key_balance key balance = - let key = String.escaped @@ Format.asprintf "%a" Ticket_hash.pp key in - let balance = Z.to_string balance in - (key, balance) - -let compare_key_balance (k1, b1) (k2, b2) = - match String.compare k1 k2 with - | n when n <> 0 -> n - | _ -> String.compare b1 b2 - -let normalize_balances key_balances = - List.filter_map - (fun (key, balance) -> - if Z.equal balance Z.zero then None - else Some (show_key_balance key balance)) - key_balances - |> List.sort compare_key_balance - -let equal_key_balances kb1 kb2 = - let compare x y = compare_key_balance x y = 0 in - List.for_all2 - ~when_different_lengths:"Length of key-balances don't match" - compare - kb1 - kb2 - -let show_balance_table kvs = - let show_rows kvs = - let key_col_length = - List.fold_left (fun mx (s, _) -> max mx (String.length s)) 0 kvs - in - let column align col_length s = - let space = - Stdlib.List.init (col_length - String.length s) (fun _ -> " ") - |> String.concat "" - in - match align with - | `Left -> Printf.sprintf "%s%s" s space - | `Right -> Printf.sprintf "%s%s" space s - in - List.map - (fun (k, v) -> - Printf.sprintf - "| %s | %s |" - (column `Left key_col_length k) - (column `Right 8 v)) - kvs - |> String.concat "\n" - in - show_rows (("Token x Content x Owner", "Balance") :: kvs) - -let validate_ticket_balances block = - let open Lwt_result_wrap_syntax in - let* contracts = all_contracts block in - let* incr = Incremental.begin_construction block in - let ctxt = Incremental.alpha_ctxt incr in - let* kvs_storage, ctxt = - List.fold_left_es - (fun (acc, ctxt) contract -> - let* lists, ctxt = ticket_balance_of_storage ctxt contract in - return (lists @ acc, ctxt)) - ([], ctxt) - contracts - in - let*@ kvs_balance, _ctxt = - List.fold_left_es - (fun (acc, ctxt) (key, _) -> - let* balance, ctxt = Ticket_balance.get_balance ctxt key in - let acc = - match balance with None -> acc | Some b -> (key, b) :: acc - in - return (acc, ctxt)) - ([], ctxt) - kvs_storage - in - let kvs_storage = normalize_balances kvs_storage in - let kvs_balance = normalize_balances kvs_balance in - let print_both () = - print_endline "Storage table:" ; - print_endline @@ show_balance_table kvs_storage ; - print_endline "Balance table:" ; - print_endline @@ show_balance_table kvs_balance - in - match equal_key_balances kvs_balance kvs_storage with - | Ok true -> return () - | Ok false -> - print_both () ; - failwith "Storage and balance don't match" - | Error e -> - print_both () ; - failwith "%s" e - -module Ticket_manager = struct - (* A rather complicated script for various ticket operations. - See documentation for [action] below for a list of the params. - *) - let script = - {| - { parameter - (or (or (or (or %add (pair %add_lazy (pair int string) nat) (pair %add_strict string nat)) - (pair %create (pair string nat) key_hash)) - (or (or %remove (or (unit %remove_all_lazy) (int %remove_lazy)) (unit %remove_strict)) - (big_map %replace_big_map int (ticket string)))) - (or %send - (or (pair %send_lazy int address) (pair %send_new (pair string nat) address)) - (or (unit %send_self_replace_big_map) (address %send_strict)))) ; - storage (pair (list %list (ticket string)) (big_map %map int (ticket string))) ; - code { NIL (ticket string) ; - SWAP ; - UNPAIR ; - IF_LEFT - { DIG 2 ; - DROP ; - IF_LEFT - { IF_LEFT - { IF_LEFT - { # `add_lazy` entrypoint - UNPAIR ; - UNPAIR ; - DIG 3 ; - DIG 3 ; - SWAP ; - UNPAIR ; - SWAP ; - DUP 3 ; - DUP 6 ; - TICKET ; - ASSERT_SOME ; - SOME ; - DUP 5 ; - GET_AND_UPDATE ; - DROP ; - DUP 3 ; - DUP 6 ; - TICKET ; - ASSERT_SOME ; - SOME ; - DUP 5 ; - GET_AND_UPDATE ; - DROP ; - DIG 2 ; - DIG 4 ; - TICKET ; - ASSERT_SOME ; - SOME ; - DIG 3 ; - GET_AND_UPDATE ; - DROP ; - SWAP ; - PAIR ; - NIL operation ; - PAIR } - { - # `add_strict` entrypoint - UNPAIR ; - DIG 2 ; - UNPAIR ; - DIG 3 ; - DIG 3 ; - TICKET ; - ASSERT_SOME ; - CONS ; - PAIR ; - NIL operation ; - PAIR } } - { # `create` entrypoint - UNPAIR ; - UNPAIR ; - DUP 3 ; - DUG 2 ; - TICKET ; - ASSERT_SOME ; - PUSH mutez 0 ; - DIG 2 ; - SOME ; - CREATE_CONTRACT - { parameter (ticket string) ; - storage (ticket string) ; - code { JOIN_TICKETS ; - IF_NONE - { PUSH string "Failed to join tickets" ; FAILWITH } - { NIL operation ; PAIR } } } ; - SWAP ; - DROP ; - EMPTY_BIG_MAP int (ticket string) ; - PUSH nat 99 ; - PUSH string "NEW_TICKET_IN_ORIGINATED_CONTRACT" ; - TICKET ; - ASSERT_SOME ; - SOME ; - PUSH int 1 ; - GET_AND_UPDATE ; - DROP ; - PUSH mutez 0 ; - DIG 3 ; - SOME ; - CREATE_CONTRACT - { parameter (ticket string) ; - storage (big_map int (ticket string)) ; - code { UNPAIR ; - SOME ; - PUSH int 1 ; - GET_AND_UPDATE ; - DROP ; - NIL operation ; - PAIR } } ; - SWAP ; - DROP ; - DIG 2 ; - NIL operation ; - DIG 2 ; - CONS ; - DIG 2 ; - CONS ; - PAIR } } - { IF_LEFT - { IF_LEFT - { IF_LEFT - { # `remove_all_lazy` entrypoint - DROP ; - CAR ; - EMPTY_BIG_MAP int (ticket string) ; - SWAP ; - PAIR ; - NIL operation ; - PAIR } - { # `remove` entrypoint - SWAP ; - UNPAIR ; - SWAP ; - NONE (ticket string) ; - DIG 3 ; - GET_AND_UPDATE ; - DROP ; - SWAP ; - PAIR ; - NIL operation ; - PAIR } } - { # `remove_strict` entrypoint - DROP ; CDR ; NIL (ticket string) ; PAIR ; NIL operation ; PAIR } } - { # `replace_big_map` entrypoint - SWAP ; - CAR ; - SWAP ; - NONE (ticket string) ; - PUSH int 1 ; - GET_AND_UPDATE ; - DROP ; - PUSH nat 1 ; - PUSH string "ADDED_BY_REPLACE_BIG_MAP" ; - TICKET ; - ASSERT_SOME ; - SOME ; - PUSH int 11 ; - GET_AND_UPDATE ; - DROP ; - NONE (ticket string) ; - PUSH int 11 ; - GET_AND_UPDATE ; - DROP ; - PUSH nat 1 ; - PUSH string "ADDED_BY_REPLACE_BIG_MAP" ; - TICKET ; - ASSERT_SOME ; - SOME ; - PUSH int 11 ; - GET_AND_UPDATE ; - DROP ; - SWAP ; - PAIR ; - NIL operation ; - PAIR } } } - { IF_LEFT - { DIG 2 ; - DROP ; - IF_LEFT - { # `send_lazy` entrypoint - UNPAIR ; - DIG 2 ; - UNPAIR ; - DIG 3 ; - CONTRACT (ticket string) ; - IF_NONE - { DIG 2 ; - DROP ; - PUSH string "Contract of type `ticket(string)` not found" ; - FAILWITH } - { DIG 2 ; - NONE (ticket string) ; - DIG 4 ; - GET_AND_UPDATE ; - IF_NONE - { SWAP ; DROP ; PUSH string "Could not find ticket" ; FAILWITH } - { DIG 2 ; - PUSH mutez 0 ; - DIG 2 ; - TRANSFER_TOKENS ; - SWAP ; - DIG 2 ; - PAIR ; - NIL operation ; - DIG 2 ; - CONS ; - PAIR } } } - { # `send_new` entrypoint - UNPAIR ; - UNPAIR ; - DIG 3 ; - DIG 3 ; - SWAP ; - UNPAIR ; - DIG 2 ; - CONTRACT (ticket string) ; - IF_NONE - { DIG 2 ; - DROP ; - DIG 2 ; - DROP ; - PUSH string "Contract of type `ticket(string)` not found" ; - FAILWITH } - { PUSH mutez 0 ; - DIG 5 ; - DIG 5 ; - TICKET ; - ASSERT_SOME ; - TRANSFER_TOKENS ; - DUG 2 ; - PAIR ; - NIL operation ; - DIG 2 ; - CONS ; - PAIR } } } - { IF_LEFT - { # `send_self_replace_big_map` entrypoint - DROP ; - SWAP ; - DROP ; - UNPAIR ; - SELF_ADDRESS ; - CONTRACT - (or (or (or (or %add (pair %add_lazy (pair int string) nat) (pair %add_strict string nat)) - (pair %create (pair string nat) key_hash)) - (or (or %remove (or (unit %remove_all_lazy) (int %remove_lazy)) (unit %remove_strict)) - (big_map %replace_big_map int (ticket string)))) - (or %send - (or (pair %send_lazy int address) (pair %send_new (pair string nat) address)) - (or (unit %send_self_replace_big_map) (address %send_strict)))) ; - IF_NONE - { PUSH string "Failed to get self-contract" ; FAILWITH } - { EMPTY_BIG_MAP int (ticket string) ; - DIG 3 ; - PUSH nat 1 ; - PUSH string "ADDED_BY_SEND_SELF_REPLACE" ; - TICKET ; - ASSERT_SOME ; - SOME ; - PUSH int 10 ; - GET_AND_UPDATE ; - DROP ; - NONE (ticket string) ; - PUSH int 2 ; - GET_AND_UPDATE ; - DROP ; - DIG 2 ; - PUSH mutez 0 ; - DIG 2 ; - RIGHT (or (or unit int) unit) ; - RIGHT - (or (or (pair (pair int string) nat) (pair string nat)) (pair (pair string nat) key_hash)) ; - LEFT (or (or (pair int address) (pair (pair string nat) address)) (or unit address)) ; - TRANSFER_TOKENS ; - SWAP ; - PUSH nat 1 ; - PUSH string "ADDED_BY_SEND_SELF_REPLACE_TO_STORAGE" ; - TICKET ; - ASSERT_SOME ; - SOME ; - PUSH int 11 ; - GET_AND_UPDATE ; - DROP ; - DIG 2 ; - PAIR ; - NIL operation ; - DIG 2 ; - CONS ; - PAIR } } - { # `send_strict` entrypoint - SWAP ; - UNPAIR ; - DIG 2 ; - CONTRACT (ticket string) ; - IF_NONE - { DROP ; - PUSH string "Contract of type `ticket(string)` not found" ; - FAILWITH } - { NONE (ticket string) ; - DIG 2 ; - ITER { SWAP ; IF_NONE { SOME } { PAIR ; JOIN_TICKETS } } ; - IF_NONE - { DROP ; PUSH string "Couldn't produce a ticket" ; FAILWITH } - { SWAP ; - PUSH mutez 0 ; - DIG 2 ; - TRANSFER_TOKENS ; - SWAP ; - DIG 2 ; - PAIR ; - NIL operation ; - DIG 2 ; - CONS ; - PAIR } } } } } } } - |} - - type remove_args = Remove_lazy of int | Remove_strict | Remove_all_lazy - - type send_args = - | Send_lazy of {index : int; recipient : Contract.t} - | Send_strict of Contract.t - | Send_new of {content : string; amount : int; recipient : Contract.t} - | Send_self_replace_big_map - - type add_args = - | Add_lazy of {index : int; content : string; amount : int} - | Add_strict of {content : string; amount : int} - - type action = - | Remove of remove_args - | Add of add_args - | Create of {content : string; amount : int; originator : Contract.t} - | Send of send_args - - let remove_lazy ~index = Remove (Remove_lazy index) - - let remove_strict = Remove Remove_strict - - let add_lazy ~index ~content ~amount = Add (Add_lazy {index; content; amount}) - - let add_strict ~content ~amount = Add (Add_strict {content; amount}) - - let create ~content ~amount ~originator = Create {content; amount; originator} - - let send_lazy ~index ~recipient = Send (Send_lazy {index; recipient}) - - let send_strict ~recipient = Send (Send_strict recipient) - - let send_new ~content ~amount ~recipient = - Send (Send_new {content; amount; recipient}) - - let remove_all_lazy = Remove Remove_all_lazy - - let send_self_replace_big_map = Send Send_self_replace_big_map - - let string_args = function - | Remove (Remove_lazy ix) -> - Printf.sprintf "Left (Right (Left (Left (Right %d))))" ix - | Remove Remove_strict -> "Left (Right (Left (Right Unit)))" - | Remove Remove_all_lazy -> "Left (Right (Left (Left (Left Unit))))" - | Add (Add_lazy {index; content; amount}) -> - Printf.sprintf - {|Left (Left (Left (Left (Pair (Pair %d "%s") %d))))|} - index - content - amount - | Add (Add_strict {content; amount}) -> - Printf.sprintf - {|Left (Left (Left (Right (Pair "%s" %d))))|} - content - amount - | Create {content; amount; originator} -> - Printf.sprintf - {|Left (Left (Right (Pair (Pair "%s" %d) "%s")))|} - content - amount - (Contract.to_b58check originator) - | Send (Send_lazy {index; recipient}) -> - Printf.sprintf - {|Right (Left (Left (Pair %d "%s")))|} - index - (Contract.to_b58check recipient) - | Send (Send_strict contract) -> - Printf.sprintf - {|Right (Right (Right "%s"))|} - (Contract.to_b58check contract) - | Send (Send_new {content; amount; recipient}) -> - Printf.sprintf - {|(Right (Left (Right (Pair (Pair "%s" %d) "%s"))))|} - content - amount - (Contract.to_b58check recipient) - | Send Send_self_replace_big_map -> "Right (Right (Left Unit))" - - let originate block ~originator baker = - Contract_helpers.originate_contract_from_string - ~script - ~storage:"Pair {} {}" - ~source_contract:originator - ~baker - block - - let transaction block ~sender ~ticket_manager ~parameters = - let parameters = string_args parameters in - transaction block ~sender ~recipient:ticket_manager ~amount:0L ~parameters -end - -(* Sets up the environment and returns a function for running a transaction - and validating the balance table against tickets in the storage once - completed. *) -let setup_test () = - let open Lwt_result_wrap_syntax in - let module TM = Ticket_manager in - let* {block; baker; contract = originator} = init_env () in - let* ticket_manager, _script, block = TM.originate block ~originator baker in - let test block parameters = - let* b = - TM.transaction block ~sender:originator ~ticket_manager ~parameters - in - let* () = validate_ticket_balances b in - return b - in - return (test, originator, block) - -(** Test create new contracts and send tickets to them. *) -let test_create_contract_and_send_tickets () = - let open Lwt_result_wrap_syntax in - let module TM = Ticket_manager in - let* test, originator, b = setup_test () in - - (* Call the `create` endpoint that creates two new ticket receiver contracts: - - Both contracts accepts a single ticket as an argument. - - The first holds a big-map with tickets in its storage. - - The second holds a ticket in its storage and only accepts "green" tickets. - - The second contract joins all received tickets. - *) - let* ticket_receiver_green_1, ticket_receiver_green_2, b = - get_first_two_new_contracts b @@ fun b -> - test b @@ TM.create ~content:"Green" ~amount:1 ~originator - in - (* - * Invoke the second ticket receiver contract: - - Remove all strict tickets - - Replace them with a list of 2 green ones - - Send all (joined) strict tickets to the ticket receiver - *) - let* b = test b @@ TM.remove_strict in - let* b = test b @@ TM.add_strict ~content:"Green" ~amount:1 in - let* b = test b @@ TM.add_strict ~content:"Green" ~amount:1 in - let* b = test b @@ TM.send_strict ~recipient:ticket_receiver_green_1 in - (* Send a new ticket *) - let* b = - test - b - (TM.send_new - ~content:"Green" - ~amount:10 - ~recipient:ticket_receiver_green_1) - in - (* Add a green ticket to the lazy storage at index 1 and send it to the green - ticket-receiver *) - let* b = test b @@ TM.add_lazy ~index:1 ~content:"Green" ~amount:10 in - let* (_b : Block.t) = - test b @@ TM.send_lazy ~index:1 ~recipient:ticket_receiver_green_2 - in - return () - -(** Tets add and remove tickets from lazy storage. *) -let test_add_remove_from_lazy_storage () = - let open Lwt_result_wrap_syntax in - let module TM = Ticket_manager in - let* tm, _, b = setup_test () in - let* b = tm b @@ TM.add_lazy ~index:1 ~content:"Red" ~amount:10 in - let* b = tm b @@ TM.add_lazy ~index:2 ~content:"Green" ~amount:10 in - let* b = tm b @@ TM.add_lazy ~index:3 ~content:"Blue" ~amount:10 in - (* Remove ticket at index 1. *) - let* b = tm b @@ TM.remove_lazy ~index:1 in - let* b = tm b @@ TM.add_lazy ~index:1 ~content:"Red" ~amount:1 in - let* b = tm b @@ TM.add_lazy ~index:2 ~content:"Green" ~amount:2 in - let* b = tm b @@ TM.add_lazy ~index:3 ~content:"Blue" ~amount:3 in - (* Remove the big-map. *) - let* b = tm b TM.remove_all_lazy in - (* Add back a ticket at index 1. *) - let* (_b : Block.t) = - tm b @@ TM.add_lazy ~index:1 ~content:"Red" ~amount:10 - in - return () - -(** Test send to self and replace big-map. *) -let test_send_self_replace_big_map () = - let open Lwt_result_wrap_syntax in - let module TM = Ticket_manager in - let* tm, _, b = setup_test () in - (* Send self replace bigmap *) - let* b = tm b @@ TM.add_lazy ~index:1 ~content:"Red" ~amount:1 in - let* b = tm b @@ TM.add_lazy ~index:2 ~content:"Green" ~amount:1 in - let* b = tm b @@ TM.add_lazy ~index:3 ~content:"Blue" ~amount:1 in - let* b = tm b @@ TM.send_self_replace_big_map in - let* b = tm b @@ TM.send_self_replace_big_map in - let* (_b : Block.t) = tm b @@ TM.send_self_replace_big_map in - return () - -(** Test add to and remove from strict storage. *) -let test_add_remove_strict () = - let open Lwt_result_wrap_syntax in - let module TM = Ticket_manager in - let* tm, _, b = setup_test () in - (* Add some more strict tickets *) - let* b = tm b @@ TM.add_strict ~content:"Red" ~amount:1 in - let* b = tm b @@ TM.add_strict ~content:"Red" ~amount:2 in - let* b = tm b @@ TM.add_strict ~content:"Red" ~amount:20 in - let* b = tm b @@ TM.add_strict ~content:"Green" ~amount:1 in - let* b = tm b @@ TM.add_strict ~content:"Red" ~amount:1 in - - (* Remove strict tickets *) - let* b = tm b @@ TM.remove_strict in - let* (_b : Block.t) = tm b @@ TM.add_strict ~content:"Red" ~amount:1 in - return () - -(** Test mixed operations. *) -let test_mixed_operations () = - let open Lwt_result_wrap_syntax in - let module TM = Ticket_manager in - let* tm, _, b = setup_test () in - (* Add some more strict tickets *) - let* b = tm b @@ TM.add_strict ~content:"Red" ~amount:1 in - let* b = tm b @@ TM.add_strict ~content:"Green" ~amount:1 in - (* Add some lazy tickets *) - let* b = tm b @@ TM.add_lazy ~index:1 ~content:"Red" ~amount:1 in - let* b = tm b @@ TM.add_lazy ~index:2 ~content:"Green" ~amount:1 in - let* b = tm b @@ TM.add_lazy ~index:3 ~content:"Blue" ~amount:1 in - (* Remove strict and lazy *) - let* b = tm b @@ TM.remove_strict in - let* (_b : Block.t) = tm b @@ TM.remove_all_lazy in - return () - -let tests = - [ - Tztest.tztest "Create contract" `Quick test_create_contract_and_send_tickets; - Tztest.tztest - "Send self replace big-map" - `Quick - test_send_self_replace_big_map; - Tztest.tztest - "Add and remove from strict storage" - `Quick - test_add_remove_strict; - Tztest.tztest - "Add and remove from lazy storage" - `Quick - test_add_remove_from_lazy_storage; - Tztest.tztest "Mix of operations" `Quick test_mixed_operations; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("ticket manager", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml deleted file mode 100644 index bc68ab8577affcb89a5aa60e96a2c93884462153..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml +++ /dev/null @@ -1,1342 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (Ticket_scanner) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/michelson/main.exe \ - -- --file test_ticket_operations_diff.ml - Subject: Ticket scanner tests -*) - -open Protocol -open Alpha_context -open Script_typed_ir - -(** A local non-private type that mirrors - [Ticket_operations_diff.ticket_token_diff]. *) -type ticket_token_diff = { - ticket_token : Ticket_token.ex_token; - total_amount : Script_int.n Script_int.num; - destinations : (Destination.t * ticket_amount) list; -} - -let to_local_ticket_token_diff - {Ticket_operations_diff.ticket_token; total_amount; destinations} = - {ticket_token; total_amount; destinations} - -let assert_fails ~loc ?error m = - let open Lwt_result_syntax in - let*! res = m in - let rec aux err_res = - match (err_res, error) with - | Environment.Ecoproto_error err' :: rest, Some err -> - (* Matched exact error. *) - if err' = err then return_unit else aux rest - | _ :: rest, Some _ -> aux rest - | [], Some _ -> - (* Expected a different error. *) - let msg = - Printf.sprintf "Expected a different error at location %s" loc - in - Stdlib.failwith msg - | _, None -> - (* Any error is ok. *) - return () - in - match res with - | Ok _ -> Stdlib.failwith "Expected failure" - | Error err_res -> aux err_res - -let big_map_updates_of_key_values ctxt key_values = - let open Lwt_result_wrap_syntax in - List.fold_right_es - (fun (key, value) (kvs, ctxt) -> - let*@ key_hash, ctxt = - Script_ir_translator.hash_comparable_data - ctxt - Script_typed_ir.int_t - (Script_int.of_int key) - in - return - ( { - Big_map.key = Expr.from_string @@ string_of_int key; - key_hash; - value = Option.map Expr.from_string value; - } - :: kvs, - ctxt )) - key_values - ([], ctxt) - -let new_int_key_big_map ctxt contract ~value_type entries = - let open Lwt_result_wrap_syntax in - let*@ ctxt, big_map_id = Big_map.fresh ~temporary:false ctxt in - let key_type = Expr.from_string "int" in - let value_type = Expr.from_string value_type in - let* updates, ctxt = - big_map_updates_of_key_values ctxt - @@ List.map (fun (k, v) -> (k, Some v)) entries - in - let alloc = - Lazy_storage.make - Lazy_storage.Kind.Big_map - big_map_id - (Update - {init = Lazy_storage.Alloc Big_map.{key_type; value_type}; updates}) - in - let storage = Expr.from_string "{}" in - let*@ ctxt = - Contract.update_script_storage ctxt contract storage (Some [alloc]) - in - return (big_map_id, ctxt) - -let assert_equal_string_list ~loc msg = - Assert.assert_equal_list ~loc String.equal msg Format.pp_print_string - -let string_of_ticket_token ctxt - (Ticket_token.Ex_token {ticketer; contents_type; contents}) = - let open Lwt_result_wrap_syntax in - let*@ x, _ = - Script_ir_unparser.unparse_comparable_data - ctxt - Script_ir_unparser.Readable - contents_type - contents - in - return - @@ Format.asprintf - {|("%a", %a)|} - Contract.pp - ticketer - Michelson_v1_printer.print_expr - x - -let string_of_destination_and_amounts cas = - Format.asprintf - "[%a]" - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "; ") - (fun fmt (contract, (amount : ticket_amount)) -> - Format.fprintf - fmt - {|("%a", %s)|} - Destination.pp - contract - Script_int.(to_string (amount :> n num)))) - cas - -let string_of_ticket_operations_diff ctxt - {ticket_token; total_amount; destinations} = - let open Lwt_result_wrap_syntax in - let* ticket_token = string_of_ticket_token ctxt ticket_token in - let destinations = string_of_destination_and_amounts destinations in - return - (Printf.sprintf - "(%s, %s, %s)" - ticket_token - (Script_int.to_string total_amount) - destinations) - -let assert_equal_ticket_token_diffs ctxt ~loc ticket_diffs - ~(expected : ticket_token_diff list) = - let open Lwt_result_wrap_syntax in - (* Sort destinations by contract and the strings alphabetically so that order - does not matter for comparison. *) - let sorted_strings ticket_diffs = - List.map - (fun {ticket_token; total_amount; destinations} -> - { - ticket_token; - total_amount; - destinations = - List.sort - (fun (c1, _) (c2, _) -> Destination.compare c1 c2) - destinations; - }) - ticket_diffs - |> List.map_es (string_of_ticket_operations_diff ctxt) - >|=? List.sort String.compare - in - let* exp_str_diffs = sorted_strings expected in - let* str_diffs = - sorted_strings @@ List.map to_local_ticket_token_diff ticket_diffs - in - assert_equal_string_list - ~loc - "Equal ticket-token-diffs" - exp_str_diffs - str_diffs - -let string_token ~ticketer content = - let contents = - Result.value_f ~default:(fun _ -> assert false) - @@ Script_string.of_string content - in - Ticket_token.Ex_token - {ticketer; contents_type = Script_typed_ir.string_t; contents} - -(** Initializes one address for operations and one baker. *) -let init () = - Context.init2 ~consensus_threshold:0 () >|=? fun (block, (src0, src1)) -> - let baker = Context.Contract.pkh src0 in - (baker, src1, block) - -let originate block ~script ~storage ~src ~baker ~forges_tickets = - let open Lwt_result_wrap_syntax in - let code = Expr.toplevel_from_string script in - let storage = Expr.from_string storage in - let* operation, destination = - let script = - Alpha_context.Script.{code = lazy_expr code; storage = lazy_expr storage} - in - Op.contract_origination_hash (B block) src ~fee:(Test_tez.of_int 10) ~script - in - let* incr = - Incremental.begin_construction ~policy:Block.(By_account baker) block - in - let* incr = - Incremental.add_operation - ?expect_apply_failure: - (if forges_tickets then Some (fun _ -> return ()) else None) - incr - operation - in - let script = (code, storage) in - Incremental.finalize_block incr >|=? fun block -> (destination, script, block) - -let two_ticketers block = - let open Lwt_result_wrap_syntax in - let* ctxt = - Incremental.begin_construction block >|=? Incremental.alpha_ctxt - in - let* cs = Lwt.map Result.ok @@ Contract.list ctxt in - match cs with c1 :: c2 :: _ -> return (c1, c2) | _ -> assert false - -let one_ticketer block = two_ticketers block >|=? fst - -let nat n = Script_int.(abs @@ of_int n) - -let origination_operation block ~src ~baker ~script ~storage ~forges_tickets = - let open Lwt_result_wrap_syntax in - let* orig_contract, (code, storage), block = - originate block ~script ~storage ~src ~baker ~forges_tickets - in - let* incr = - Incremental.begin_construction ~policy:Block.(By_account baker) block - in - let ctxt = Incremental.alpha_ctxt incr in - let script = - Alpha_context.Script.{code = lazy_expr code; storage = lazy_expr storage} - in - let unparsed_storage = storage in - let*@ ( Script_ir_translator.Ex_script - (Script - { - storage_type; - storage; - code = _; - arg_type = _; - views = _; - entrypoints = _; - code_size = _; - }), - ctxt ) = - Script_ir_translator.parse_script - ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) - ~allow_forged_in_storage:true - script - in - let operation = - Script_typed_ir.Internal_operation - { - source = Contract src; - operation = - Origination - { - delegate = None; - code; - unparsed_storage; - credit = Tez.one; - preorigination = orig_contract; - storage_type; - storage; - }; - nonce = 1; - } - in - let incr = Incremental.set_alpha_ctxt incr ctxt in - return (Contract.Originated orig_contract, operation, incr) - -let delegation_operation ~src = - Script_typed_ir.Internal_operation - {source = src; operation = Delegation None; nonce = 1} - -let originate block ~src ~baker ~script ~storage ~forges_tickets = - let open Lwt_result_wrap_syntax in - let* orig_contract, _script, block = - originate block ~script ~storage ~src ~baker ~forges_tickets - in - let* incr = - Incremental.begin_construction ~policy:Block.(By_account baker) block - in - return (orig_contract, incr) - -let transfer_operation ~incr ~src ~destination ~parameters_ty ~parameters = - let open Lwt_result_wrap_syntax in - let ctxt = Incremental.alpha_ctxt incr in - let*@ params_node, ctxt = - Script_ir_translator.unparse_data - ctxt - Script_ir_unparser.Readable - parameters_ty - parameters - in - let incr = Incremental.set_alpha_ctxt incr ctxt in - return - ( Script_typed_ir.Internal_operation - { - source = src; - operation = - Transaction_to_smart_contract - { - amount = Tez.zero; - unparsed_parameters = params_node; - entrypoint = Entrypoint.default; - destination; - location = Micheline.dummy_location; - parameters_ty; - parameters; - }; - nonce = 1; - }, - incr ) - -let transfer_operation_to_tx_rollup ~incr ~src ~parameters_ty ~parameters - ~tx_rollup = - let open Lwt_result_wrap_syntax in - let ctxt = Incremental.alpha_ctxt incr in - let*@ params_node, ctxt = - Script_ir_translator.unparse_data - ctxt - Script_ir_unparser.Optimized_legacy - parameters_ty - parameters - in - let incr = Incremental.set_alpha_ctxt incr ctxt in - return - ( Script_typed_ir.Internal_operation - { - source = src; - operation = - Transaction_to_tx_rollup - { - unparsed_parameters = params_node; - destination = tx_rollup; - parameters_ty; - parameters; - }; - nonce = 1; - }, - incr ) - -let ticket_diffs_of_operations incr operations = - Ticket_operations_diff.ticket_diffs_of_operations - (Incremental.alpha_ctxt incr) - operations - -let unit_script = - {| - { parameter unit; - storage unit; - code { CAR; NIL operation ; PAIR } } - |} - -let ticket_list_script = - {| - { parameter (list (ticket string)); - storage (list (ticket string)); - code { CAR; NIL operation ; PAIR } } - |} - -let ticket_big_map_script = - {| - { parameter (big_map int (ticket string)); - storage (big_map int (ticket string)); - code { CAR; NIL operation ; PAIR } } - |} - -let list_ticket_string_ty = - ticket_t Micheline.dummy_location string_t >>? fun ticket_ty -> - list_t Micheline.dummy_location ticket_ty - -let make_ticket (ticketer, contents, amount) = - Script_string.of_string contents >>?= fun contents -> - let amount = nat amount in - Option.value_e - ~error: - (Environment.Error_monad.trace_of_error - Script_tc_errors.Forbidden_zero_ticket_quantity) - @@ Ticket_amount.of_n amount - >>?= fun amount -> return {ticketer; contents; amount} - -let make_tickets ts = - let open Lwt_result_wrap_syntax in - let* elements = List.map_es make_ticket ts in - return @@ Script_list.of_list elements - -let transfer_tickets_operation ~incr ~src ~destination tickets = - let open Lwt_result_wrap_syntax in - let*? parameters_ty = Environment.wrap_tzresult list_ticket_string_ty in - let*@ parameters = make_tickets tickets in - transfer_operation ~incr ~src ~destination ~parameters_ty ~parameters - -(** Test that no tickets are returned for operations that do not contain - tickets. *) -let test_non_ticket_operations () = - let open Lwt_result_wrap_syntax in - let* _baker, src, block = init () in - let* incr = Incremental.begin_construction block in - let operations = [delegation_operation ~src:(Contract src)] in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations incr operations in - assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] - -(** Test transfer to a contract that does not take tickets. *) -let test_transfer_to_non_ticket_contract () = - let open Lwt_result_wrap_syntax in - let* baker, src, block = init () in - let* orig_contract, incr = - originate - block - ~src - ~baker - ~script:unit_script - ~storage:"Unit" - ~forges_tickets:false - in - let* operation, incr = - transfer_operation - ~incr - ~src:(Contract src) - ~destination:orig_contract - ~parameters_ty:unit_t - ~parameters:() - in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in - assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] - -(** Test transfer an empty list of tickets. *) -let test_transfer_empty_ticket_list () = - let open Lwt_result_wrap_syntax in - let* baker, src, block = init () in - let* orig_contract, incr = - originate - block - ~src - ~baker - ~script:ticket_list_script - ~storage:"{}" - ~forges_tickets:false - in - let* operation, incr = - transfer_tickets_operation - ~incr - ~src:(Contract src) - ~destination:orig_contract - [] - in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in - assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] - -let one = Ticket_amount.one - -let two = Ticket_amount.add one one - -let three = Ticket_amount.add two one - -let five = Ticket_amount.add three two - -(** Test transfer a list of one ticket. *) -let test_transfer_one_ticket () = - let open Lwt_result_wrap_syntax in - let* baker, src, block = init () in - let* ticketer = one_ticketer block in - let* orig_contract, incr = - originate - block - ~src - ~baker - ~script:ticket_list_script - ~storage:"{}" - ~forges_tickets:false - in - let* operation, incr = - transfer_tickets_operation - ~incr - ~src:(Contract src) - ~destination:orig_contract - [(ticketer, "white", 1)] - in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in - assert_equal_ticket_token_diffs - ctxt - ~loc:__LOC__ - ticket_diffs - ~expected: - [ - { - ticket_token = string_token ~ticketer "white"; - total_amount = nat 1; - destinations = - [(Destination.Contract (Originated orig_contract), one)]; - }; - ] - -(** Test transferring a list of multiple tickets. This should work when - zero-tickets are disabled as well as when the parameters do not contain any - zero-amount tickets. *) -let test_transfer_multiple_tickets () = - let open Lwt_result_wrap_syntax in - let* baker, src, block = init () in - let* ticketer = one_ticketer block in - let* orig_contract, incr = - originate - block - ~src - ~baker - ~script:ticket_list_script - ~storage:"{}" - ~forges_tickets:false - in - let* operation, incr = - transfer_tickets_operation - ~incr - ~src:(Contract src) - ~destination:orig_contract - [ - (ticketer, "red", 1); - (ticketer, "blue", 2); - (ticketer, "green", 3); - (ticketer, "red", 4); - ] - in - let orig_contract = Contract.Originated orig_contract in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in - assert_equal_ticket_token_diffs - ctxt - ~loc:__LOC__ - ticket_diffs - ~expected: - [ - { - ticket_token = string_token ~ticketer "red"; - total_amount = nat 5; - destinations = [(Destination.Contract orig_contract, five)]; - }; - { - ticket_token = string_token ~ticketer "blue"; - total_amount = nat 2; - destinations = [(Destination.Contract orig_contract, two)]; - }; - { - ticket_token = string_token ~ticketer "green"; - total_amount = nat 3; - destinations = [(Destination.Contract orig_contract, three)]; - }; - ] - -(** Test transfer a list of tickets of different types. *) -let test_transfer_different_tickets () = - let open Lwt_result_wrap_syntax in - let* baker, src, block = init () in - let* ticketer1, ticketer2 = two_ticketers block in - let* destination, incr = - originate - block - ~src - ~baker - ~script:ticket_list_script - ~storage:"{}" - ~forges_tickets:false - in - let* operation, incr = - transfer_tickets_operation - ~incr - ~src:(Contract src) - ~destination - [ - (ticketer1, "red", 1); - (ticketer1, "green", 1); - (ticketer1, "blue", 1); - (ticketer2, "red", 1); - (ticketer2, "green", 1); - (ticketer2, "blue", 1); - (ticketer1, "red", 1); - (ticketer1, "green", 1); - (ticketer1, "blue", 1); - ] - in - let destination = Destination.Contract (Originated destination) in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in - assert_equal_ticket_token_diffs - ctxt - ~loc:__LOC__ - ticket_diffs - ~expected: - [ - { - ticket_token = string_token ~ticketer:ticketer1 "red"; - total_amount = nat 2; - destinations = [(destination, two)]; - }; - { - ticket_token = string_token ~ticketer:ticketer1 "green"; - total_amount = nat 2; - destinations = [(destination, two)]; - }; - { - ticket_token = string_token ~ticketer:ticketer1 "blue"; - total_amount = nat 2; - destinations = [(destination, two)]; - }; - { - ticket_token = string_token ~ticketer:ticketer2 "red"; - total_amount = nat 1; - destinations = [(destination, one)]; - }; - { - ticket_token = string_token ~ticketer:ticketer2 "green"; - total_amount = nat 1; - destinations = [(destination, one)]; - }; - { - ticket_token = string_token ~ticketer:ticketer2 "blue"; - total_amount = nat 1; - destinations = [(destination, one)]; - }; - ] - -(** Test transfer to two contracts with different types of tickets. *) -let test_transfer_to_two_contracts_with_different_tickets () = - let open Lwt_result_wrap_syntax in - let* baker, src, block = init () in - let* ticketer = one_ticketer block in - let parameters = - [(ticketer, "red", 1); (ticketer, "green", 1); (ticketer, "blue", 1)] - in - let* destination1, incr = - originate - block - ~src - ~baker - ~script:ticket_list_script - ~storage:"{}" - ~forges_tickets:false - in - let* operation1, incr = - transfer_tickets_operation - ~incr - ~src:(Contract src) - ~destination:destination1 - parameters - in - let* block = Incremental.finalize_block incr in - let* destination2, incr = - originate - block - ~src - ~baker - ~script:ticket_list_script - ~storage:"{}" - ~forges_tickets:false - in - let* operation2, incr = - transfer_tickets_operation - ~incr - ~src:(Contract src) - ~destination:destination2 - parameters - in - let*@ ticket_diffs, ctxt = - ticket_diffs_of_operations incr [operation1; operation2] - in - let one = Ticket_amount.one in - assert_equal_ticket_token_diffs - ctxt - ~loc:__LOC__ - ticket_diffs - ~expected: - [ - { - ticket_token = string_token ~ticketer "red"; - total_amount = nat 2; - destinations = - [ - (Destination.Contract (Originated destination2), one); - (Destination.Contract (Originated destination1), one); - ]; - }; - { - ticket_token = string_token ~ticketer "green"; - total_amount = nat 2; - destinations = - [ - (Destination.Contract (Originated destination2), one); - (Destination.Contract (Originated destination1), one); - ]; - }; - { - ticket_token = string_token ~ticketer "blue"; - total_amount = nat 2; - destinations = - [ - (Destination.Contract (Originated destination2), one); - (Destination.Contract (Originated destination1), one); - ]; - }; - ] - -(** Test originate a contract that does not contain tickets. *) -let test_originate_non_ticket_contract () = - let open Lwt_result_wrap_syntax in - let* baker, src, block = init () in - let* _orig_contract, operation, incr = - origination_operation - block - ~src - ~baker - ~script:unit_script - ~storage:"Unit" - ~forges_tickets:false - in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in - assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] - -(** Test originate a contract with an empty list of tickets. *) -let test_originate_with_empty_tickets_list () = - let open Lwt_result_wrap_syntax in - let* baker, src, block = init () in - let storage = "{}" in - let* _orig_contract, operation, incr = - origination_operation - block - ~src - ~baker - ~script:ticket_list_script - ~storage - ~forges_tickets:false - in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in - assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] - -(** Test originate a contract with a single ticket. *) -let test_originate_with_one_ticket () = - let open Lwt_result_wrap_syntax in - let* baker, src, block = init () in - let* ticketer = one_ticketer block in - let storage = - Printf.sprintf {|{Pair %S "white" 1}|} (Contract.to_b58check ticketer) - in - let* orig_contract, operation, ctxt = - origination_operation - block - ~src - ~baker - ~script:ticket_list_script - ~storage - ~forges_tickets:true - in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations ctxt [operation] in - assert_equal_ticket_token_diffs - ctxt - ~loc:__LOC__ - ticket_diffs - ~expected: - [ - { - ticket_token = string_token ~ticketer "white"; - total_amount = nat 1; - destinations = [(Destination.Contract orig_contract, one)]; - }; - ] - -(** Test originate a contract with multiple tickets. *) -let test_originate_with_multiple_tickets () = - let open Lwt_result_wrap_syntax in - let* baker, src, block = init () in - let* ticketer = one_ticketer block in - let storage = - let ticketer_addr = Contract.to_b58check ticketer in - Printf.sprintf - {|{ - Pair %S "red" 1; - Pair %S "blue" 2 ; - Pair %S "green" 3; - Pair %S "red" 4;} - |} - ticketer_addr - ticketer_addr - ticketer_addr - ticketer_addr - in - let* orig_contract, operation, ctxt = - origination_operation - block - ~src - ~baker - ~script:ticket_list_script - ~storage - ~forges_tickets:true - in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations ctxt [operation] in - assert_equal_ticket_token_diffs - ctxt - ~loc:__LOC__ - ticket_diffs - ~expected: - [ - { - ticket_token = string_token ~ticketer "red"; - total_amount = nat 5; - destinations = [(Destination.Contract orig_contract, five)]; - }; - { - ticket_token = string_token ~ticketer "blue"; - total_amount = nat 2; - destinations = [(Destination.Contract orig_contract, two)]; - }; - { - ticket_token = string_token ~ticketer "green"; - total_amount = nat 3; - destinations = [(Destination.Contract orig_contract, three)]; - }; - ] - -(** Test originate a contract with multiple tickets of different types. *) -let test_originate_with_different_tickets () = - let open Lwt_result_wrap_syntax in - let* baker, src, block = init () in - let* ticketer1, ticketer2 = two_ticketers block in - let storage = - let ticketer1_addr = Contract.to_b58check ticketer1 in - let ticketer2_addr = Contract.to_b58check ticketer2 in - Printf.sprintf - {|{ - Pair %S "red" 1; - Pair %S "green" 1; - Pair %S "blue" 1; - Pair %S "red" 1; - Pair %S "green" 1; - Pair %S "blue" 1 ; - Pair %S "red" 1; - Pair %S "green" 1; - Pair %S "blue" 1; } - |} - ticketer1_addr - ticketer1_addr - ticketer1_addr - ticketer2_addr - ticketer2_addr - ticketer2_addr - ticketer1_addr - ticketer1_addr - ticketer1_addr - in - let* orig_contract, operation, ctxt = - origination_operation - block - ~src - ~baker - ~script:ticket_list_script - ~storage - ~forges_tickets:true - in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations ctxt [operation] in - assert_equal_ticket_token_diffs - ctxt - ~loc:__LOC__ - ticket_diffs - ~expected: - [ - { - ticket_token = string_token ~ticketer:ticketer1 "red"; - total_amount = nat 2; - destinations = [(Destination.Contract orig_contract, two)]; - }; - { - ticket_token = string_token ~ticketer:ticketer1 "green"; - total_amount = nat 2; - destinations = [(Destination.Contract orig_contract, two)]; - }; - { - ticket_token = string_token ~ticketer:ticketer1 "blue"; - total_amount = nat 2; - destinations = [(Destination.Contract orig_contract, two)]; - }; - { - ticket_token = string_token ~ticketer:ticketer2 "red"; - total_amount = nat 1; - destinations = [(Destination.Contract orig_contract, one)]; - }; - { - ticket_token = string_token ~ticketer:ticketer2 "green"; - total_amount = nat 1; - destinations = [(Destination.Contract orig_contract, one)]; - }; - { - ticket_token = string_token ~ticketer:ticketer2 "blue"; - total_amount = nat 1; - destinations = [(Destination.Contract orig_contract, one)]; - }; - ] - -(** Test originate two contracts with multiple tickets of different types. *) -let test_originate_two_contracts_with_different_tickets () = - let open Lwt_result_wrap_syntax in - let* baker, src, block = init () in - let* ticketer = one_ticketer block in - let storage = - let ticketer_addr = Contract.to_b58check ticketer in - Printf.sprintf - {|{Pair %S "red" 1; Pair %S "green" 1; Pair %S "blue" 1; }|} - ticketer_addr - ticketer_addr - ticketer_addr - in - let* orig_contract1, operation1, incr = - origination_operation - block - ~src - ~baker - ~script:ticket_list_script - ~storage - ~forges_tickets:true - in - let* block = Incremental.finalize_block incr in - let* orig_contract2, operations2, incr = - origination_operation - block - ~src - ~baker - ~script:ticket_list_script - ~storage - ~forges_tickets:true - in - let*@ ticket_diffs, ctxt = - ticket_diffs_of_operations incr [operation1; operations2] - in - assert_equal_ticket_token_diffs - ctxt - ~loc:__LOC__ - ticket_diffs - ~expected: - [ - { - ticket_token = string_token ~ticketer "red"; - total_amount = nat 2; - destinations = - [ - (Destination.Contract orig_contract2, one); - (Destination.Contract orig_contract1, one); - ]; - }; - { - ticket_token = string_token ~ticketer "green"; - total_amount = nat 2; - destinations = - [ - (Destination.Contract orig_contract2, one); - (Destination.Contract orig_contract1, one); - ]; - }; - { - ticket_token = string_token ~ticketer "blue"; - total_amount = nat 2; - destinations = - [ - (Destination.Contract orig_contract2, one); - (Destination.Contract orig_contract1, one); - ]; - }; - ] - -(** Test originate and transfer tickets. *) -let test_originate_and_transfer () = - let open Lwt_result_wrap_syntax in - let* baker, src, block = init () in - let* ticketer = one_ticketer block in - let ticketer_addr = Contract.to_b58check ticketer in - let storage = - Printf.sprintf - {|{Pair %S "red" 1; Pair %S "green" 1; Pair %S "blue" 1; }|} - ticketer_addr - ticketer_addr - ticketer_addr - in - let* orig_contract1, operation1, incr = - origination_operation - block - ~src - ~baker - ~script:ticket_list_script - ~storage - ~forges_tickets:true - in - let* block = Incremental.finalize_block incr in - let* destination2, incr = - originate - block - ~src - ~baker - ~script:ticket_list_script - ~storage:"{}" - ~forges_tickets:false - in - let* operation2, incr = - transfer_tickets_operation - ~incr - ~src:(Contract src) - ~destination:destination2 - [(ticketer, "red", 1); (ticketer, "green", 1); (ticketer, "blue", 1)] - in - let*@ ticket_diffs, ctxt = - ticket_diffs_of_operations incr [operation1; operation2] - in - assert_equal_ticket_token_diffs - ctxt - ~loc:__LOC__ - ticket_diffs - ~expected: - [ - { - ticket_token = string_token ~ticketer "red"; - total_amount = nat 2; - destinations = - [ - (Destination.Contract (Originated destination2), one); - (Destination.Contract orig_contract1, one); - ]; - }; - { - ticket_token = string_token ~ticketer "green"; - total_amount = nat 2; - destinations = - [ - (Destination.Contract (Originated destination2), one); - (Destination.Contract orig_contract1, one); - ]; - }; - { - ticket_token = string_token ~ticketer "blue"; - total_amount = nat 2; - destinations = - [ - (Destination.Contract (Originated destination2), one); - (Destination.Contract orig_contract1, one); - ]; - }; - ] - -(** Test originate a contract with a big-map with tickets inside. *) -let test_originate_big_map_with_tickets () = - let open Lwt_result_wrap_syntax in - let* baker, ticketer, block = init () in - let* operation, originated = - Op.contract_origination_hash (B block) ticketer ~script:Op.dummy_script - in - let* block = Block.bake ~operation block in - let* incr = Incremental.begin_construction block in - let ticketer_addr = Contract.to_b58check ticketer in - let* big_map_id, ctxt = - new_int_key_big_map - (Incremental.alpha_ctxt incr) - originated - ~value_type:"ticket string" - [ - (1, Printf.sprintf {|Pair %S "red" 1|} ticketer_addr); - (2, Printf.sprintf {|Pair %S "green" 1|} ticketer_addr); - (3, Printf.sprintf {|Pair %S "blue" 1|} ticketer_addr); - ] - in - let incr = Incremental.set_alpha_ctxt incr ctxt in - let* block = Incremental.finalize_block incr in - let* orig_contract, operation, incr = - let storage = - Printf.sprintf "%d" @@ Z.to_int (Big_map.Id.unparse_to_z big_map_id) - in - origination_operation - block - ~src:ticketer - ~baker - ~script:ticket_big_map_script - ~storage - ~forges_tickets:true - in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in - assert_equal_ticket_token_diffs - ctxt - ~loc:__LOC__ - ticket_diffs - ~expected: - [ - { - ticket_token = string_token ~ticketer "red"; - total_amount = nat 1; - destinations = [(Destination.Contract orig_contract, one)]; - }; - { - ticket_token = string_token ~ticketer "green"; - total_amount = nat 1; - destinations = [(Destination.Contract orig_contract, one)]; - }; - { - ticket_token = string_token ~ticketer "blue"; - total_amount = nat 1; - destinations = [(Destination.Contract orig_contract, one)]; - }; - ] - -(** Test transfer a big-map with tickets. *) -let test_transfer_big_map_with_tickets () = - let open Lwt_result_wrap_syntax in - let* baker, ticketer_contract, block = init () in - let* operation, originated = - Op.contract_origination_hash - (B block) - ticketer_contract - ~script:Op.dummy_script - in - let* block = Block.bake ~operation block in - let* incr = Incremental.begin_construction block in - let ticketer_addr = Contract.to_b58check ticketer_contract in - let* big_map_id, ctxt = - new_int_key_big_map - (Incremental.alpha_ctxt incr) - originated - ~value_type:"ticket string" - [ - (1, Printf.sprintf {|Pair %S "red" 1|} ticketer_addr); - (2, Printf.sprintf {|Pair %S "green" 1|} ticketer_addr); - (3, Printf.sprintf {|Pair %S "blue" 1|} ticketer_addr); - ] - in - let incr = Incremental.set_alpha_ctxt incr ctxt in - let* block = Incremental.finalize_block incr in - let* orig_contract, incr = - originate - block - ~src:ticketer_contract - ~baker - ~script:ticket_big_map_script - ~storage:"{}" - ~forges_tickets:false - in - let open Lwt_result_syntax in - let*? value_type = - Environment.wrap_tzresult @@ ticket_t Micheline.dummy_location string_t - in - let*? parameters_ty = - Environment.wrap_tzresult - @@ big_map_t Micheline.dummy_location int_t value_type - in - let parameters = - Big_map - { - id = Some big_map_id; - diff = {map = Big_map_overlay.empty; size = 0}; - key_type = int_t; - value_type; - } - in - let* operation, incr = - transfer_operation - ~incr - ~src:(Contract ticketer_contract) - ~destination:orig_contract - ~parameters_ty - ~parameters - in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in - let destination = Destination.Contract (Originated orig_contract) in - assert_equal_ticket_token_diffs - ctxt - ~loc:__LOC__ - ticket_diffs - ~expected: - [ - { - ticket_token = string_token ~ticketer:ticketer_contract "red"; - total_amount = nat 1; - destinations = [(destination, one)]; - }; - { - ticket_token = string_token ~ticketer:ticketer_contract "green"; - total_amount = nat 1; - destinations = [(destination, one)]; - }; - { - ticket_token = string_token ~ticketer:ticketer_contract "blue"; - total_amount = nat 1; - destinations = [(destination, one)]; - }; - ] - -(** Test transferring a list of multiple tickets where two of them have zero - amounts fails. *) -let test_transfer_fails_on_multiple_zero_tickets () = - let open Lwt_result_wrap_syntax in - let* baker, src, block = init () in - let* ticketer = one_ticketer block in - let* orig_contract, incr = - originate - block - ~src - ~baker - ~script:ticket_list_script - ~storage:"{}" - ~forges_tickets:false - in - assert_fails - ~loc:__LOC__ - ~error:Script_tc_errors.Forbidden_zero_ticket_quantity - @@ (* let* operation, incr = *) - transfer_tickets_operation - ~incr - ~src:(Contract src) - ~destination:orig_contract - [ - (ticketer, "red", 1); - (ticketer, "blue", 0); - (ticketer, "green", 2); - (ticketer, "red", 0); - (ticketer, "green", 3); - ] - -(** Test that zero-amount tickets are detected and that an error is yielded. *) -let test_fail_on_zero_amount_tickets () = - let open Lwt_result_wrap_syntax in - let* baker, src, block = init () in - let* ticketer = one_ticketer block in - let storage = - let ticketer_addr = Contract.to_b58check ticketer in - Printf.sprintf - {| - { Pair %S "red" 1; - Pair %S "blue" 2 ; - Pair %S "green" 3; - Pair %S "red" 0; - Pair %S "red" 4; } - |} - ticketer_addr - ticketer_addr - ticketer_addr - ticketer_addr - ticketer_addr - in - assert_fails - ~loc:__LOC__ - ~error:Script_tc_errors.Forbidden_zero_ticket_quantity - @@ origination_operation - block - ~src - ~baker - ~script:ticket_list_script - ~storage - ~forges_tickets:true - -let tests = - [ - Tztest.tztest - "operations that do not involve tickets" - `Quick - test_non_ticket_operations; - Tztest.tztest - "transfer to non-ticket contract" - `Quick - test_transfer_to_non_ticket_contract; - Tztest.tztest - "transfer empty ticket list" - `Quick - test_transfer_empty_ticket_list; - Tztest.tztest "transfer one ticket" `Quick test_transfer_one_ticket; - Tztest.tztest - "transfer multiple tickets" - `Quick - test_transfer_multiple_tickets; - Tztest.tztest - "transfer different tickets" - `Quick - test_transfer_different_tickets; - Tztest.tztest - "transfer to two contracts with different tickets" - `Quick - test_transfer_to_two_contracts_with_different_tickets; - Tztest.tztest - "originate contract that does not contain tickets" - `Quick - test_originate_non_ticket_contract; - Tztest.tztest - "originate with empty ticket list" - `Quick - test_originate_with_empty_tickets_list; - Tztest.tztest - "originate with one ticket" - `Quick - test_originate_with_one_ticket; - Tztest.tztest - "originate with multiple tickets" - `Quick - test_originate_with_multiple_tickets; - Tztest.tztest - "originate with different tickets" - `Quick - test_originate_with_different_tickets; - Tztest.tztest - "originate two contracts with different tickets" - `Quick - test_originate_two_contracts_with_different_tickets; - Tztest.tztest "originate and transfer" `Quick test_originate_and_transfer; - Tztest.tztest - "originate big-map with tickets" - `Quick - test_originate_big_map_with_tickets; - Tztest.tztest - "transfer big-map with tickets" - `Quick - test_transfer_big_map_with_tickets; - Tztest.tztest - "transfer fails on multiple zero tickets" - `Quick - test_transfer_fails_on_multiple_zero_tickets; - Tztest.tztest - "fail in zero-amount tickets" - `Quick - test_fail_on_zero_amount_tickets; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("ticket operations diff", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_scanner.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_scanner.ml deleted file mode 100644 index 8397f187d9fd3d3cf9547f49a103f8e9d753ac20..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_scanner.ml +++ /dev/null @@ -1,699 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Trili Tech, *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (Ticket_scanner) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/michelson/main.exe \ - -- --file test_ticket_scanner.ml - Subject: Ticket scanner tests -*) - -open Protocol -open Alpha_context - -let assert_fails ~loc ?error m = - let open Lwt_result_syntax in - let*! res = m in - let rec aux err_res = - match (err_res, error) with - | Environment.Ecoproto_error err' :: rest, Some err -> - if err = err' then return_unit else aux rest - | _, Some _ -> - (* Expected a different error. *) - let msg = - Printf.sprintf "Expected a different error at location %s" loc - in - Stdlib.failwith msg - | _, None -> - (* Any error is ok. *) - return () - in - match res with - | Ok _ -> Stdlib.failwith "Expected failure" - | Error err_res -> aux err_res - -let new_ctxt () = - let open Lwt_result_wrap_syntax in - let* block, _contract = Context.init1 () in - let* incr = Incremental.begin_construction block in - return @@ Incremental.alpha_ctxt incr - -let assert_equal_string_list ~loc msg = - Assert.assert_equal_list ~loc String.equal msg Format.pp_print_string - -let string_list_of_ex_tickets ctxt tickets = - let open Lwt_result_wrap_syntax in - let accum (xs, ctxt) - (Ticket_scanner.Ex_ticket - (cty, {Script_typed_ir.ticketer; contents; amount})) = - let*@ x, ctxt = - Script_ir_translator.unparse_data - ctxt - Script_ir_unparser.Readable - cty - contents - in - let content = - Format.kasprintf Fun.id "%a" Michelson_v1_printer.print_expr x - in - let str = - Format.kasprintf - Fun.id - "(%a, %s, %a)" - Contract.pp - ticketer - content - Z.pp_print - Script_int.(to_zint (amount :> n num)) - in - return (str :: xs, ctxt) - in - let* xs, ctxt = List.fold_left_es accum ([], ctxt) tickets in - return (List.rev xs, ctxt) - -let make_ex_ticket ctxt ~ticketer ~type_exp ~content_exp ~amount = - let open Lwt_result_wrap_syntax in - let*?@ Script_ir_translator.Ex_comparable_ty cty, ctxt = - let node = Micheline.root @@ Expr.from_string type_exp in - Script_ir_translator.parse_comparable_ty ctxt node - in - let*?@ ticketer = Contract.of_b58check ticketer in - let*@ contents, ctxt = - let node = Micheline.root @@ Expr.from_string content_exp in - Script_ir_translator.parse_comparable_data ctxt cty node - in - let amount = Script_int.(abs @@ of_int amount) in - let amount = - WithExceptions.Option.get ~loc:__LOC__ @@ Ticket_amount.of_n amount - in - let ticket = Script_typed_ir.{ticketer; contents; amount} in - return (Ticket_scanner.Ex_ticket (cty, ticket), ctxt) - -let assert_equals_ex_tickets ctxt ~loc ex_tickets expected = - let open Lwt_result_wrap_syntax in - let* str_tickets, ctxt = string_list_of_ex_tickets ctxt ex_tickets in - let* str_tickets_expected, _ctxt = string_list_of_ex_tickets ctxt expected in - assert_equal_string_list - ~loc - "Compare with expected tickets" - (List.sort String.compare str_tickets) - (List.sort String.compare str_tickets_expected) - -let tickets_of_value ctxt ~include_lazy ~type_exp ~value_exp = - let open Lwt_result_wrap_syntax in - let Script_typed_ir.Ex_ty ty, ctxt = - let node = Micheline.root @@ Expr.from_string type_exp in - Result.value_f - ~default:(fun () -> Stdlib.failwith "Failed to parse") - (Script_ir_translator.parse_any_ty ctxt ~legacy:false node) - in - let node = Micheline.root @@ Expr.from_string value_exp in - let*@ value, ctxt = - Script_ir_translator.parse_data - ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:false ()) - ~allow_forged:true - ty - node - in - let*?@ ht, ctxt = Ticket_scanner.type_has_tickets ctxt ty in - wrap @@ Ticket_scanner.tickets_of_value ctxt ~include_lazy ht value - -let assert_contains_tickets ctxt ~loc ~include_lazy ~type_exp ~value_exp - expected = - let open Lwt_result_wrap_syntax in - let* ex_tickets, _ = - tickets_of_value ctxt ~include_lazy ~type_exp ~value_exp - in - assert_equals_ex_tickets ctxt ~loc ex_tickets expected - -let assert_fail_non_empty_overlay ctxt ~loc ~include_lazy ~type_exp ~value_exp = - tickets_of_value ctxt ~include_lazy ~type_exp ~value_exp >>= fun res -> - match res with - | Error [x] -> - let x = Format.kasprintf Fun.id "%a" Error_monad.pp x in - Assert.equal - ~loc - String.equal - "" - Format.pp_print_string - "Unsupported big-map value with non-empty overlay" - x - | _ -> failwith "Expected an error at %s" loc - -let make_string_tickets ctxt ticketer_amounts = - let open Lwt_result_wrap_syntax in - List.fold_right_es - (fun (ticketer, content, amount) (tickets, ctxt) -> - let* ticket, ctxt = - make_ex_ticket - ctxt - ~ticketer - ~type_exp:"string" - ~content_exp:(Printf.sprintf {|"%s"|} content) - ~amount - in - return (ticket :: tickets, ctxt)) - ticketer_amounts - ([], ctxt) - -let tickets_from_big_map_ref ~pre_populated value_exp = - let open Lwt_result_wrap_syntax in - let* block, source = Context.init1 () in - let* operation, originated = - Op.contract_origination_hash (B block) source ~script:Op.dummy_script - in - let* block = Block.bake ~operation block in - let* inc = Incremental.begin_construction block in - let ctxt = Incremental.alpha_ctxt inc in - let*@ ctxt, big_map_id = Big_map.fresh ~temporary:false ctxt in - let int_ty_expr = Expr.from_string "int" in - let* diffs, ctxt = - let* updates, ctxt = - List.fold_left_es - (fun (kvs, ctxt) (key, value) -> - let*@ key_hash, ctxt = - Script_ir_translator.hash_comparable_data - ctxt - Script_typed_ir.int_t - (Script_int.of_int key) - in - return - ( { - Big_map.key = Expr.from_string @@ string_of_int key; - key_hash; - value = Some (Expr.from_string value); - } - :: kvs, - ctxt )) - ([], ctxt) - pre_populated - in - let alloc = - Big_map. - {key_type = int_ty_expr; value_type = Expr.from_string "ticket string"} - in - return - ( [ - Lazy_storage.make - Lazy_storage.Kind.Big_map - big_map_id - (Update {init = Lazy_storage.Alloc alloc; updates}); - ], - ctxt ) - in - let*@ ctxt = - Contract.update_script_storage ctxt originated int_ty_expr (Some diffs) - in - let value_exp = - value_exp @@ Z.to_string (Big_map.Id.unparse_to_z big_map_id) - in - return (value_exp, ctxt) - -let assert_big_map_int_ticket_string_ref ~loc ~pre_populated ~big_map_exp - ex_tickets = - let open Lwt_result_wrap_syntax in - let* value_exp, ctxt = tickets_from_big_map_ref ~pre_populated big_map_exp in - let* ex_tickets, ctxt = make_string_tickets ctxt ex_tickets in - assert_contains_tickets - ctxt - ~include_lazy:true - ~loc - ~type_exp:"big_map int (ticket string)" - ~value_exp - ex_tickets - -let assert_fail_non_empty_overlay_with_big_map_ref ~loc ~pre_populated - ~big_map_exp = - let open Lwt_result_wrap_syntax in - let* value_exp, ctxt = tickets_from_big_map_ref ~pre_populated big_map_exp in - assert_fail_non_empty_overlay - ctxt - ~include_lazy:true - ~loc - ~type_exp:"big_map int (ticket string)" - ~value_exp - -let assert_string_tickets ~loc ~include_lazy ~type_exp ~value_exp ~expected = - let open Lwt_result_wrap_syntax in - let* ctxt = new_ctxt () in - let* ex_tickets, ctxt = make_string_tickets ctxt expected in - let* () = - assert_contains_tickets - ctxt - ~include_lazy - ~loc - ~type_exp - ~value_exp - ex_tickets - in - assert_contains_tickets - ctxt - ~include_lazy - ~loc - ~type_exp - ~value_exp - ex_tickets - -(** Test that the ticket can be extracted from a a single unit ticket *) -let test_tickets_in_unit_ticket () = - let open Lwt_result_wrap_syntax in - let* ctxt = new_ctxt () in - let type_exp = "ticket(unit)" in - let value_exp = {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" Unit 10|} in - let* ex_ticket, ctxt = - make_ex_ticket - ctxt - ~ticketer:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" - ~type_exp:"unit" - ~content_exp:"Unit" - ~amount:10 - in - assert_contains_tickets - ctxt - ~loc:__LOC__ - ~include_lazy:false - ~type_exp - ~value_exp - [ex_ticket] - -let assert_string_tickets_fail_on_zero_amount ~loc ~include_lazy ~type_exp - ~value_exp = - let open Lwt_result_wrap_syntax in - let* ctxt = new_ctxt () in - assert_fails ~loc ~error:Script_tc_errors.Forbidden_zero_ticket_quantity - @@ tickets_of_value ctxt ~include_lazy ~type_exp ~value_exp - -let test_tickets_in_list_with_zero_amount () = - assert_string_tickets_fail_on_zero_amount - ~loc:__LOC__ - ~include_lazy:false - ~type_exp:"list(ticket(string))" - ~value_exp: - {| - { - Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1; - Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2; - Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 3; - Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "orange" 0; - } - |} - -(** Test that all tickets can be extracted from a list of tickets *) -let test_tickets_in_list () = - assert_string_tickets - ~loc:__LOC__ - ~include_lazy:false - ~type_exp:"list(ticket(string))" - ~value_exp: - {| - { - Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1; - Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2; - Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 3; - } - |} - ~expected: - [ - ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", 1); - ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "green", 2); - ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue", 3); - ] - -let test_tickets_in_pair_with_zero_amount () = - assert_string_tickets_fail_on_zero_amount - ~loc:__LOC__ - ~include_lazy:false - ~type_exp:"pair (ticket string) (ticket string) (ticket string)" - ~value_exp: - {| - Pair - (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1) - (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2) - (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 0) - |} - -(** Test that all tickets can be extracted from a pair of tickets *) -let test_tickets_in_pair () = - assert_string_tickets - ~loc:__LOC__ - ~include_lazy:false - ~type_exp:"pair (ticket string) (ticket string)" - ~value_exp: - {| - Pair - (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1) - (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2) - |} - ~expected: - [ - ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", 1); - ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "green", 2); - ] - -let test_tickets_in_map_with_zero_amount () = - assert_string_tickets_fail_on_zero_amount - ~loc:__LOC__ - ~include_lazy:false - ~type_exp:"map int (ticket string)" - ~value_exp: - {| - { - Elt 1 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1); - Elt 2 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2); - Elt 3 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 0); - } - |} - -(** Test that all tickets from a map can be extracted. *) -let test_tickets_in_map () = - assert_string_tickets - ~loc:__LOC__ - ~include_lazy:false - ~type_exp:"map int (ticket string)" - ~value_exp: - {| - { - Elt 1 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1); - Elt 2 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2); - } - |} - ~expected: - [ - ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", 1); - ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "green", 2); - ] - -(** Test that all tickets from a big-map with non-empty overlay fails. - If we extend the ticket scanner function to support non-empty overlays - this test needs to be adapted. - *) -let test_tickets_in_big_map () = - let open Lwt_result_wrap_syntax in - let* ctxt = new_ctxt () in - assert_fail_non_empty_overlay - ctxt - ~loc:__LOC__ - ~include_lazy:true - ~type_exp:"big_map int (ticket string)" - ~value_exp: - {| - { - Elt 1 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1); - Elt 2 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2); - } - |} - -(** Test that tickets are not extracted from big-map with [include_lazy] set - to false. *) -let test_tickets_in_big_map_strict_only () = - assert_string_tickets - ~loc:__LOC__ - ~include_lazy:false - ~type_exp:"big_map int (ticket string)" - ~value_exp: - {| - { - Elt 1 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1); - Elt 2 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2); - Elt 3 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 3); - } - |} - ~expected:[] - -(** Test that tickets can be extracted from a list of tickets inside a big-map - This fails due to non-empty overlay. If we extend the ticket scanner - function to support non-empty overlays this test needs to be adapted. -*) -let test_tickets_in_list_in_big_map () = - let open Lwt_result_wrap_syntax in - let* ctxt = new_ctxt () in - assert_fail_non_empty_overlay - ctxt - ~loc:__LOC__ - ~include_lazy:true - ~type_exp:"(big_map int (list(ticket string)))" - ~value_exp: - {| - { - Elt 1 { - Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1 ; - Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 1 - }; - Elt 2 { - Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 1 ; - Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "orange" 1 - } - } - |} - -(** Test that tickets can be extracted from a combination of a list and lazy structure - and that only the strict part is considered with [include_lazy] set to fasle *) -let test_tickets_in_pair_big_map_and_list_strict_only () = - assert_string_tickets - ~loc:__LOC__ - ~include_lazy:false - ~type_exp:"pair (big_map int (ticket string)) (list (ticket string))" - ~value_exp: - {| - Pair - { - Elt 1 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1); - Elt 2 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 1) - } - { - Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 1; - Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "orange" 1 - } - |} - ~expected: - [ - ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue", 1); - ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "orange", 1); - ] - -(** Test that tickets can be extracted from the left side of an or-expression. *) -let test_tickets_in_or_left () = - assert_string_tickets - ~loc:__LOC__ - ~include_lazy:false - ~type_exp:"or (ticket string) int" - ~value_exp:{| Left (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1) |} - ~expected:[("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", 1)] - -(** Test that tickets from the left side of an or-expression with zero amount - are rejected. *) -let test_tickets_in_or_left_with_zero_amount () = - assert_string_tickets_fail_on_zero_amount - ~loc:__LOC__ - ~include_lazy:false - ~type_exp:"or (ticket string) int" - ~value_exp:{| Left (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 0) |} - -(** Test that tickets can be extracted from the right side of an or-expression. *) -let test_tickets_in_or_right () = - assert_string_tickets - ~loc:__LOC__ - ~include_lazy:false - ~type_exp:"or int (ticket string)" - ~value_exp:{| Right (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1) |} - ~expected:[("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", 1)] - -(* - Big maps have three possible representations. Either as a list of key-value - pairs, as an identifier (int), or as a pair of identifier and overrides. - Example values: - - 1) { Elt "bar" True ; Elt "foo" False } - 2) 42 - 3) Pair 42 { Elt "foo" (Some False) } - *) - -(** Test tickets from empty big_map when passed by reference. *) -let test_tickets_in_empty_big_map_ref () = - assert_big_map_int_ticket_string_ref - ~loc:__LOC__ - ~pre_populated:[] - ~big_map_exp:(Printf.sprintf "%s") - [] - -(** Test tickets from non-empty big-map when passed by reference. - Here, tickets are scanned from the context. *) -let test_tickets_in_non_empty_big_map_ref () = - assert_big_map_int_ticket_string_ref - ~loc:__LOC__ - ~pre_populated: - [ - (1, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1|}); - (2, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 1|}); - (3, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 1|}); - ] - ~big_map_exp:(Printf.sprintf "%s") - [ - ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", 1); - ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "green", 1); - ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue", 1); - ] - -(** Test tickets from empty big-map when passed as a pair of identifier - and overrides. Here, the scanned tickets are only contained in the overlay - why ticket-scanning fails. - - If we extend the ticket scanner function to support non-empty overlays - this test needs to be adapted. - *) -let test_tickets_overlay_in_empty_big_map_ref () = - assert_fail_non_empty_overlay_with_big_map_ref - ~loc:__LOC__ - ~pre_populated:[] - ~big_map_exp: - (Printf.sprintf - {|Pair %s { Elt 1 (Some (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1))}|}) - -(** Test tickets from non-empty big-map when passed as a pair of identifier - and overrides. The scanned tickets are contained in the context as well as - in the overlay. Since overlay is non-empty is non-empty, ticket scanning - fails. - - If we extend the ticket scanner function to support non-empty overlays - this test needs to be adapted - *) -let test_tickets_overlay_in_non_empty_in_big_map_ref () = - assert_fail_non_empty_overlay_with_big_map_ref - ~loc:__LOC__ - ~pre_populated: - [ - (1, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1|}); - (2, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 1|}); - (3, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 1|}); - ] - ~big_map_exp: - (Printf.sprintf - {| Pair - %s - { Elt 4 (Some (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "orange" 1))} - |}) - -(** Test tickets from non-empty big-map when passed as a pair of identifier - and overrides, and where the override replaces an existing ticket. - Ticket scanning fails due to non-empty overlay. - - If we extend the ticket scanner function to support non-empty overlays - this test needs to be adapted. - *) -let test_tickets_replace_overlay_in_non_empty_in_big_map_ref () = - assert_fail_non_empty_overlay_with_big_map_ref - ~loc:__LOC__ - ~pre_populated: - [(1, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1|})] - ~big_map_exp: - (Printf.sprintf - {| Pair - %s - { Elt 1 (Some (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 1))} - |}) - -(** Test tickets from non-empty big-map when passed as a pair of identifier - and overrides, and where the override removes an existing ticket. - Ticket scanning fails due to non-empty overlay. - - If we extend the ticket scanner function to support non-empty overlays - this test needs to be adapted. - *) -let test_tickets_remove_overlay_in_non_empty_in_big_map_ref () = - assert_fail_non_empty_overlay_with_big_map_ref - ~loc:__LOC__ - ~pre_populated: - [(1, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1|})] - ~big_map_exp:(Printf.sprintf {| Pair %s { Elt 1 None} |}) - -let tests = - [ - Tztest.tztest "tickets in unit ticket" `Quick test_tickets_in_unit_ticket; - Tztest.tztest "tickets in list" `Quick test_tickets_in_list; - Tztest.tztest - "tickets in list with zero amount" - `Quick - test_tickets_in_list_with_zero_amount; - Tztest.tztest "tickets in pair" `Quick test_tickets_in_pair; - Tztest.tztest - "tickets in pair with zero amount" - `Quick - test_tickets_in_pair_with_zero_amount; - Tztest.tztest "tickets in map" `Quick test_tickets_in_map; - Tztest.tztest - "tickets in map with zero amount" - `Quick - test_tickets_in_map_with_zero_amount; - Tztest.tztest "tickets in big map" `Quick test_tickets_in_big_map; - Tztest.tztest - "tickets in big map with include lazy set to false" - `Quick - test_tickets_in_big_map_strict_only; - Tztest.tztest - "tickets in list in big map" - `Quick - test_tickets_in_list_in_big_map; - Tztest.tztest - "tickets in a pair of big-map and list with include lazy set to false" - `Quick - test_tickets_in_pair_big_map_and_list_strict_only; - Tztest.tztest "tickets in or left" `Quick test_tickets_in_or_left; - Tztest.tztest - "tickets in or left with zero amount" - `Quick - test_tickets_in_or_left_with_zero_amount; - Tztest.tztest "tickets in or right" `Quick test_tickets_in_or_right; - Tztest.tztest - "tickets in empty big-map ref" - `Quick - test_tickets_overlay_in_empty_big_map_ref; - Tztest.tztest - "tickets in big-map ref" - `Quick - test_tickets_in_empty_big_map_ref; - Tztest.tztest - "tickets in non-empty big-map ref" - `Quick - test_tickets_in_non_empty_big_map_ref; - Tztest.tztest - "tickets in non-empty big-map ref with overlay" - `Quick - test_tickets_overlay_in_non_empty_in_big_map_ref; - Tztest.tztest - "tickets replace existing value from overlay" - `Quick - test_tickets_replace_overlay_in_non_empty_in_big_map_ref; - Tztest.tztest - "tickets remove existing value from overlay" - `Quick - test_tickets_remove_overlay_in_non_empty_in_big_map_ref; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("ticket scanner", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_storage.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_storage.ml deleted file mode 100644 index 72bc85e3b258267051b0b5fcef7b95d4d9e7e31f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_ticket_storage.ml +++ /dev/null @@ -1,280 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (Alpha_context.Ticket_balance) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/michelson/main.exe \ - -- --file test_ticket_storage.ml - Subject: Ticket storage functions tested using the Ticket_balance module in Alpha_context. -*) - -open Protocol -open Alpha_context - -let make_context () = - let open Lwt_result_wrap_syntax in - let* block, _contract = Context.init1 () in - let* incr = Incremental.begin_construction block in - return (Incremental.alpha_ctxt incr) - -let hash_key ctxt ~ticketer ~ty ~contents ~owner = - let ticketer = Micheline.root @@ Expr.from_string ticketer in - let ty = Micheline.root @@ Expr.from_string ty in - let contents = Micheline.root @@ Expr.from_string contents in - let owner = Micheline.root @@ Expr.from_string owner in - Alpha_context.Ticket_hash.make ctxt ~ticketer ~ty ~contents ~owner - -let assert_balance ctxt ~loc key expected = - let open Lwt_result_wrap_syntax in - let*@ balance, _ = Ticket_balance.get_balance ctxt key in - match balance with - | Some b -> Assert.equal_int ~loc (Z.to_int b) expected - | None -> failwith "Expected balance %d" expected - -let assert_no_balance ctxt key = - let open Lwt_result_wrap_syntax in - let*@ balance, _ = Ticket_balance.get_balance ctxt key in - match balance with - | Some b -> failwith "Expected empty (none) balance but got %d" (Z.to_int b) - | None -> return () - -let adjust_balance ctxt key delta = - Ticket_balance.adjust_balance ctxt key ~delta:(Z.of_int delta) - -let assert_non_overlapping_keys ~loc ~ticketer1 ~ticketer2 ~contents1 ~contents2 - ~ty1 ~ty2 ~owner1 ~owner2 = - let open Lwt_result_wrap_syntax in - let* ctxt = make_context () in - let*?@ k1, ctxt = - hash_key ctxt ~ticketer:ticketer1 ~ty:ty1 ~contents:contents1 ~owner:owner1 - in - let*?@ k2, _ctxt = - hash_key ctxt ~ticketer:ticketer2 ~ty:ty2 ~contents:contents2 ~owner:owner2 - in - Assert.not_equal - ~loc - Ticket_hash.equal - "Keys should not overlap" - Ticket_hash.pp - k1 - k2 - -let make_key ctxt content = - hash_key - ctxt - ~ticketer:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} - ~ty:"string" - ~contents:(Printf.sprintf {|"%s"|} content) - ~owner:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} - -(** Test that key-hashes constructed from different ticketers don't overlap. *) -let test_non_overlapping_keys_ticketer () = - assert_non_overlapping_keys - ~loc:__LOC__ - ~ticketer1:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} - ~ticketer2:{|"KT1PWx2mnDueood7fEmfbBDKx1D9BAnnXitn"|} - ~ty1:"nat" - ~ty2:"int" - ~contents1:{|"1"|} - ~contents2:{|"1"|} - ~owner1:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} - ~owner2:{|"KT1PWx2mnDueood7fEmfbBDKx1D9BAnnXitn"|} - -(** Test that key-hashes constructed from different contents don't overlap. *) -let test_non_overlapping_keys_contents () = - assert_non_overlapping_keys - ~loc:__LOC__ - ~ticketer1:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} - ~ticketer2:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} - ~ty1:"string" - ~ty2:"string" - ~contents1:{|"red"|} - ~contents2:{|"blue"|} - ~owner1:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} - ~owner2:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} - -(** Test that key-hashes constructed from different content-types don't overlap. *) -let test_non_overlapping_keys_type () = - assert_non_overlapping_keys - ~loc:__LOC__ - ~ticketer1:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} - ~ticketer2:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} - ~ty1:"nat" - ~ty2:"int" - ~contents1:{|"1"|} - ~contents2:{|"1"|} - ~owner1:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} - ~owner2:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} - -(** Test that key-hashes constructed from different owners don't overlap. *) -let test_non_overlapping_keys_owner () = - assert_non_overlapping_keys - ~loc:__LOC__ - ~ticketer1:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} - ~ticketer2:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} - ~ty1:"nat" - ~ty2:"int" - ~contents1:{|"1"|} - ~contents2:{|"1"|} - ~owner1:{|"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq"|} - ~owner2:{|"KT1PWx2mnDueood7fEmfbBDKx1D9BAnnXitn"|} - -(** Test that updating the ticket balance table has - the intended effect. - *) -let test_ticket_balance_single_update () = - let open Lwt_result_wrap_syntax in - let* ctxt = make_context () in - let*?@ alice_red, ctxt = make_key ctxt "alice_red" in - let*@ _, ctxt = adjust_balance ctxt alice_red 1 in - assert_balance ctxt ~loc:__LOC__ alice_red 1 - -(** Test that updating the ticket-balance table with different keys - updates both entries. *) -let test_ticket_balance_different_owners () = - let open Lwt_result_wrap_syntax in - let* ctxt = make_context () in - let*?@ alice_red, ctxt = make_key ctxt "alice_red" in - let*?@ alice_blue, ctxt = make_key ctxt "alice_blue" in - let*@ _, ctxt = adjust_balance ctxt alice_red 1 in - let*@ _, ctxt = adjust_balance ctxt alice_blue 1 in - let* () = assert_balance ctxt ~loc:__LOC__ alice_red 1 in - let* () = assert_balance ctxt ~loc:__LOC__ alice_blue 1 in - return () - -(** Test updating the same entry with multiple updates yields - the net result of all balance updates *) -let test_ticket_balance_multiple_updates () = - let open Lwt_result_wrap_syntax in - let* ctxt = make_context () in - let*?@ alice_red, ctxt = make_key ctxt "alice_red" in - let*@ _, ctxt = adjust_balance ctxt alice_red 1 in - let*@ _, ctxt = adjust_balance ctxt alice_red 2 in - let*@ _, ctxt = adjust_balance ctxt alice_red (-1) in - assert_balance ctxt ~loc:__LOC__ alice_red 2 - -(** Test that with no updates to the table, no balance is present in - the table *) -let test_empty_balance () = - let open Lwt_result_wrap_syntax in - let* ctxt = make_context () in - let*?@ alice_red, ctxt = make_key ctxt "alice_red" in - assert_no_balance ctxt alice_red - -(** Test that adding one entry with positive balance and then - updating with a negative balance also removes the entry *) -let test_empty_balance_after_update () = - let open Lwt_result_wrap_syntax in - let* ctxt = make_context () in - let*?@ alice_red, ctxt = make_key ctxt "alice_red" in - let*@ _, ctxt = adjust_balance ctxt alice_red 1 in - let*@ _, ctxt = adjust_balance ctxt alice_red (-1) in - assert_no_balance ctxt alice_red - -(** Test that attempting to update an entry with a negative balance - results in an error. *) -let test_negative_balance () = - let open Lwt_result_wrap_syntax in - let* ctxt = make_context () in - let*?@ alice_red, ctxt = make_key ctxt "alice_red" in - let*! res = wrap @@ adjust_balance ctxt alice_red (-1) in - Assert.proto_error ~loc:__LOC__ res (fun _err -> true) - -(** Test that positive storage spaces are returned for operations - resulting in extra storage space and negative for ones that frees up storage. - *) -let test_storage_space () = - let open Lwt_result_wrap_syntax in - let* ctxt = make_context () in - let*?@ alice_red, ctxt = make_key ctxt "alice_red" in - (* Space for adding an entry is 65 for the key plus 1 for the value. *) - let*@ space, ctxt = adjust_balance ctxt alice_red 1 in - let* () = Assert.equal_int ~loc:__LOC__ 66 (Z.to_int space) in - (* Adding one does not consume additional space. *) - let*@ space, ctxt = adjust_balance ctxt alice_red 1 in - let* () = Assert.equal_int ~loc:__LOC__ 0 (Z.to_int space) in - (* Adding a big balance costs extra. *) - let*@ space, ctxt = adjust_balance ctxt alice_red 1000 in - let* () = Assert.equal_int ~loc:__LOC__ 1 (Z.to_int space) in - (* Reset balance to zero should free up space. - The freed up space is 65 for the key + 2 for the value *) - let*@ b, ctxt = Ticket_balance.get_balance ctxt alice_red in - let*@ space, ctxt = - Ticket_balance.adjust_balance - ctxt - alice_red - ~delta:(Z.neg @@ Option.value ~default:Z.zero b) - in - let* () = Assert.equal_int ~loc:__LOC__ (-67) (Z.to_int space) in - (* Adjusting the space to 0 again should not free anything *) - let*@ space, ctxt = adjust_balance ctxt alice_red 0 in - let* () = Assert.equal_int ~loc:__LOC__ 0 (Z.to_int space) in - (* Adding a balance requiers extra space. *) - let*@ space, _ = adjust_balance ctxt alice_red 10 in - Assert.equal_int ~loc:__LOC__ 66 (Z.to_int space) - -let tests = - [ - Tztest.tztest - "no overlapping keys for ticketer" - `Quick - test_non_overlapping_keys_ticketer; - Tztest.tztest - "no overlapping keys for content" - `Quick - test_non_overlapping_keys_contents; - Tztest.tztest - "no overlapping keys for content type" - `Quick - test_non_overlapping_keys_type; - Tztest.tztest - "no overlapping keys for owner" - `Quick - test_non_overlapping_keys_owner; - Tztest.tztest - "ticket balance single update" - `Quick - test_ticket_balance_single_update; - Tztest.tztest "empty balance" `Quick test_empty_balance; - Tztest.tztest - "empty balance after update" - `Quick - test_empty_balance_after_update; - Tztest.tztest "negative balance" `Quick test_negative_balance; - Tztest.tztest - "ticket balance multiple updates" - `Quick - test_ticket_balance_multiple_updates; - Tztest.tztest - "ticket balance different owners" - `Quick - test_ticket_balance_different_owners; - Tztest.tztest "ticket storage space" `Quick test_storage_space; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("ticket storage", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_typechecking.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_typechecking.ml deleted file mode 100644 index 1f7444fa7a7be0f1770f7e840733f30ff32b1a1e..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/michelson/test_typechecking.ml +++ /dev/null @@ -1,935 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021-2022 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (type-checking) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/michelson/main.exe \ - -- --file test_typechecking.ml - Subject: Type-checking -*) - -open Protocol -open Alpha_context -open Micheline -open Error_monad_operators - -let wrap_error_lwt x = x >>= fun x -> Lwt.return @@ Environment.wrap_tzresult x - -let context_init_with_sc_rollup_enabled tup = - Context.init_with_constants_gen - tup - { - Context.default_test_constants with - consensus_threshold = 0; - sc_rollup = - { - Context.default_test_constants.sc_rollup with - enable = true; - arith_pvm_enable = true; - }; - } - -let sc_originate block contract parameters_ty = - let open Lwt_result_syntax in - let kind = Sc_rollup.Kind.Example_arith in - let* operation, rollup = - Sc_rollup_helpers.origination_op ~parameters_ty (B block) contract kind - in - let* incr = Incremental.begin_construction block in - let* incr = Incremental.add_operation incr operation in - let* block = Incremental.finalize_block incr in - return (block, rollup) - -(* Test for Script_ir_translator.parse_and_unparse_script_unaccounted on a - script declaring views. *) -let test_unparse_view () = - let dummy_contract = - "{parameter unit; storage unit; code { CAR; NIL operation; PAIR }; view \ - \"v0\" unit unit { DROP; UNIT }; view \"v1\" nat nat {CAR}}" - in - let contract_expr = Expr.from_string dummy_contract in - let storage_expr = Expr.from_string "Unit" in - let bef = Script.lazy_expr contract_expr |> Data_encoding.force_bytes in - let script = - Script.{code = lazy_expr contract_expr; storage = lazy_expr storage_expr} - in - Context.init3 () >>=? fun (b, _cs) -> - Incremental.begin_construction b >>=? fun v -> - let ctx = Incremental.alpha_ctxt v in - Script_ir_translator.parse_and_unparse_script_unaccounted - ctx - ~legacy:true - ~allow_forged_in_storage:false - Readable - ~normalize_types:true - script - >>=?? fun (unparsed_script, _ctx) -> - let aft = Data_encoding.force_bytes unparsed_script.code in - Alcotest.(check bytes) "didn't match" bef aft |> return - -let test_context () = - Context.init3 ~consensus_threshold:0 () >>=? fun (b, _cs) -> - Incremental.begin_construction b >>=? fun v -> - return (Incremental.alpha_ctxt v) - -let test_context_with_nat_nat_big_map ?(sc_rollup_enable = false) () = - Context.init_with_constants1 - { - Context.default_test_constants with - sc_rollup = - { - Context.default_test_constants.sc_rollup with - enable = sc_rollup_enable; - }; - } - >>=? fun (b, source) -> - Op.contract_origination_hash (B b) source ~script:Op.dummy_script - >>=? fun (operation, originated) -> - Block.bake ~operation b >>=? fun b -> - Incremental.begin_construction b >>=? fun v -> - let ctxt = Incremental.alpha_ctxt v in - wrap_error_lwt @@ Big_map.fresh ~temporary:false ctxt >>=? fun (ctxt, id) -> - let nat_ty = Script_typed_ir.nat_t in - wrap_error_lwt @@ Lwt.return - @@ Script_ir_unparser.unparse_ty ~loc:() ctxt nat_ty - >>=? fun (nat_ty_node, ctxt) -> - let nat_ty_expr = Micheline.strip_locations nat_ty_node in - let alloc = Big_map.{key_type = nat_ty_expr; value_type = nat_ty_expr} in - let init = Lazy_storage.Alloc alloc in - let diffs = - [ - Lazy_storage.make - Lazy_storage.Kind.Big_map - id - (Update {init; updates = []}); - ] - in - wrap_error_lwt - @@ Contract.update_script_storage ctxt originated nat_ty_expr (Some diffs) - >>=? fun ctxt -> return (ctxt, id) - -let read_file filename = - let ch = open_in filename in - let s = really_input_string ch (in_channel_length ch) in - close_in ch ; - s - -let path = project_root // Filename.dirname __FILE__ - -(** Check that the custom stack overflow exception is triggered when - it should be. *) -let test_typecheck_stack_overflow () = - test_context () >>=? fun ctxt -> - let storage = "Unit" in - let parameter = "Unit" in - let script = read_file (path // "contracts/big_interpreter_stack.tz") in - Contract_helpers.run_script ctxt script ~storage ~parameter () >>= function - | Ok _ -> Alcotest.fail "expected an error" - | Error lst - when List.mem - ~equal:( = ) - (Environment.Ecoproto_error - Script_tc_errors.Typechecking_too_many_recursive_calls) - lst -> - return () - | Error errs -> - Alcotest.failf "Unexpected error: %a" Error_monad.pp_print_trace errs - -(* NOTE: this test fails with an out-of-memory exception. *) -let _test_unparse_stack_overflow () = - test_context () >>=? fun ctxt -> - (* Meme *) - let enorme_et_seq n = - let rec aux n acc = aux (n - 1) @@ Micheline.Seq (0, [acc]) in - aux n (Micheline.Int (0, Z.zero)) - in - Script_ir_translator.(unparse_code ctxt Readable (enorme_et_seq 10_001)) - >>= function - | Ok _ -> Alcotest.fail "expected an error" - | Error trace -> - let trace_string = - Format.asprintf "%a" Environment.Error_monad.pp_trace trace - in - let expect_id = "michelson_v1.unparsing_stack_overflow" in - let expect_descrfiption = - "Too many recursive calls were needed for unparsing" - in - if - Astring.String.is_infix ~affix:expect_id trace_string - && Astring.String.is_infix ~affix:expect_descrfiption trace_string - then return_unit - else - Alcotest.failf - "Unexpected error (%s) at %s" - trace_string - __LOC__ - return_unit - -let location = function - | Prim (loc, _, _, _) - | Int (loc, _) - | String (loc, _) - | Bytes (loc, _) - | Seq (loc, _) -> - loc - -let test_parse_ty (type exp expc) ctxt node - (expected : (exp, expc) Script_typed_ir.ty) = - let legacy = false in - let allow_lazy_storage = true in - let allow_operation = true in - let allow_contract = true in - let allow_ticket = true in - Environment.wrap_tzresult - ( Script_ir_translator.parse_ty - ctxt - ~legacy - ~allow_lazy_storage - ~allow_operation - ~allow_contract - ~allow_ticket - node - >>? fun (Script_typed_ir.Ex_ty actual, ctxt) -> - Gas_monad.run ctxt - @@ Script_ir_translator.ty_eq - ~error_details:(Informative (location node)) - actual - expected - >>? fun (eq, ctxt) -> - eq >|? fun Eq -> ctxt ) - -let test_parse_comb_type () = - let open Script in - let open Script_typed_ir in - let nat_prim = Prim (-1, T_nat, [], []) in - let nat_prim_a = Prim (-1, T_nat, [], ["%a"]) in - let nat_prim_b = Prim (-1, T_nat, [], ["%b"]) in - let nat_prim_c = Prim (-1, T_nat, [], ["%c"]) in - let nat_ty = nat_t in - let pair_prim l = Prim (-1, T_pair, l, []) in - let pair_ty ty1 ty2 = pair_t (-1) ty1 ty2 in - let pair_prim2 a b = pair_prim [a; b] in - let pair_nat_nat_prim = pair_prim2 nat_prim nat_prim in - pair_ty nat_ty nat_ty >>??= fun (Ty_ex_c pair_nat_nat_ty) -> - test_context () >>=? fun ctxt -> - (* pair nat nat *) - test_parse_ty ctxt pair_nat_nat_prim pair_nat_nat_ty >>?= fun ctxt -> - (* pair (pair nat nat) nat *) - pair_ty pair_nat_nat_ty nat_ty >>??= fun (Ty_ex_c pair_pair_nat_nat_nat_ty) -> - test_parse_ty - ctxt - (pair_prim2 pair_nat_nat_prim nat_prim) - pair_pair_nat_nat_nat_ty - >>?= fun ctxt -> - (* pair nat (pair nat nat) *) - pair_ty nat_ty pair_nat_nat_ty >>??= fun (Ty_ex_c pair_nat_pair_nat_nat_ty) -> - test_parse_ty - ctxt - (pair_prim2 nat_prim pair_nat_nat_prim) - pair_nat_pair_nat_nat_ty - >>?= fun ctxt -> - (* pair nat nat nat *) - pair_ty nat_ty pair_nat_nat_ty >>??= fun (Ty_ex_c pair_nat_nat_nat_ty) -> - test_parse_ty - ctxt - (pair_prim [nat_prim; nat_prim; nat_prim]) - pair_nat_nat_nat_ty - >>?= fun ctxt -> - (* pair (nat %a) nat *) - pair_t (-1) nat_ty nat_ty >>??= fun (Ty_ex_c pair_nat_a_nat_ty) -> - test_parse_ty ctxt (pair_prim2 nat_prim_a nat_prim) pair_nat_a_nat_ty - >>?= fun ctxt -> - (* pair nat (nat %b) *) - pair_t (-1) nat_ty nat_ty >>??= fun (Ty_ex_c pair_nat_nat_b_ty) -> - test_parse_ty ctxt (pair_prim2 nat_prim nat_prim_b) pair_nat_nat_b_ty - >>?= fun ctxt -> - (* pair (nat %a) (nat %b) *) - pair_t (-1) nat_ty nat_ty >>??= fun (Ty_ex_c pair_nat_a_nat_b_ty) -> - test_parse_ty ctxt (pair_prim2 nat_prim_a nat_prim_b) pair_nat_a_nat_b_ty - >>?= fun ctxt -> - (* pair (nat %a) (nat %b) (nat %c) *) - pair_t (-1) nat_ty nat_ty >>??= fun (Ty_ex_c pair_nat_b_nat_c_ty) -> - pair_t (-1) nat_ty pair_nat_b_nat_c_ty - >>??= fun (Ty_ex_c pair_nat_a_nat_b_nat_c_ty) -> - test_parse_ty - ctxt - (pair_prim [nat_prim_a; nat_prim_b; nat_prim_c]) - pair_nat_a_nat_b_nat_c_ty - >>?= fun ctxt -> - (* pair (nat %a) (pair %b nat nat) *) - pair_t (-1) nat_ty nat_ty >>??= fun (Ty_ex_c pair_b_nat_nat_ty) -> - pair_t (-1) nat_ty pair_b_nat_nat_ty - >>??= fun (Ty_ex_c pair_nat_a_pair_b_nat_nat_ty) -> - test_parse_ty - ctxt - (pair_prim2 nat_prim_a (Prim (-1, T_pair, [nat_prim; nat_prim], ["%b"]))) - pair_nat_a_pair_b_nat_nat_ty - >>?= fun (_ : context) -> return_unit - -let test_unparse_ty loc ctxt expected ty = - Environment.wrap_tzresult - ( Script_ir_unparser.unparse_ty ~loc:() ctxt ty >>? fun (actual, ctxt) -> - if actual = expected then ok ctxt - else Alcotest.failf "Unexpected error: %s" loc ) - -let test_unparse_comb_type () = - let open Script in - let open Script_typed_ir in - let nat_prim = Prim ((), T_nat, [], []) in - let nat_ty = nat_t in - let pair_prim l = Prim ((), T_pair, l, []) in - let pair_ty ty1 ty2 = pair_t (-1) ty1 ty2 in - let pair_prim2 a b = pair_prim [a; b] in - let pair_nat_nat_prim = pair_prim2 nat_prim nat_prim in - pair_ty nat_ty nat_ty >>??= fun (Ty_ex_c pair_nat_nat_ty) -> - test_context () >>=? fun ctxt -> - (* pair nat nat *) - test_unparse_ty __LOC__ ctxt pair_nat_nat_prim pair_nat_nat_ty - >>?= fun ctxt -> - (* pair (pair nat nat) nat *) - pair_ty pair_nat_nat_ty nat_ty >>??= fun (Ty_ex_c pair_pair_nat_nat_nat_ty) -> - test_unparse_ty - __LOC__ - ctxt - (pair_prim2 pair_nat_nat_prim nat_prim) - pair_pair_nat_nat_nat_ty - >>?= fun ctxt -> - (* pair nat nat nat *) - pair_ty nat_ty pair_nat_nat_ty >>??= fun (Ty_ex_c pair_nat_nat_nat_ty) -> - test_unparse_ty - __LOC__ - ctxt - (pair_prim [nat_prim; nat_prim; nat_prim]) - pair_nat_nat_nat_ty - >>?= fun (_ : context) -> return_unit - -let test_unparse_comparable_ty loc ctxt expected ty = - (* unparse_comparable_ty is not exported, the simplest way to call it is to - call parse_ty on a set type *) - let open Script_typed_ir in - Environment.wrap_tzresult - ( set_t (-1) ty >>? fun set_ty_ty -> - Script_ir_unparser.unparse_ty ~loc:() ctxt set_ty_ty - >>? fun (actual, ctxt) -> - if actual = Prim ((), T_set, [expected], []) then ok ctxt - else Alcotest.failf "Unexpected error: %s" loc ) - -let test_unparse_comb_comparable_type () = - let open Script in - let open Script_typed_ir in - let nat_prim = Prim ((), T_nat, [], []) in - let nat_ty = nat_t in - let pair_prim l = Prim ((), T_pair, l, []) in - let pair_ty ty1 ty2 = comparable_pair_t (-1) ty1 ty2 in - let pair_prim2 a b = pair_prim [a; b] in - let pair_nat_nat_prim = pair_prim2 nat_prim nat_prim in - pair_ty nat_ty nat_ty >>??= fun pair_nat_nat_ty -> - test_context () >>=? fun ctxt -> - (* pair nat nat *) - test_unparse_comparable_ty __LOC__ ctxt pair_nat_nat_prim pair_nat_nat_ty - >>?= fun ctxt -> - (* pair (pair nat nat) nat *) - pair_ty pair_nat_nat_ty nat_ty >>??= fun pair_pair_nat_nat_nat_ty -> - test_unparse_comparable_ty - __LOC__ - ctxt - (pair_prim2 pair_nat_nat_prim nat_prim) - pair_pair_nat_nat_nat_ty - >>?= fun ctxt -> - (* pair nat nat nat *) - pair_ty nat_ty pair_nat_nat_ty >>??= fun pair_nat_nat_nat_ty -> - test_unparse_comparable_ty - __LOC__ - ctxt - (pair_prim [nat_prim; nat_prim; nat_prim]) - pair_nat_nat_nat_ty - >>?= fun (_ : context) -> return_unit - -let test_parse_data ?(equal = Stdlib.( = )) loc ctxt ty node expected = - let elab_conf = Script_ir_translator_config.make ~legacy:false () in - let allow_forged = true in - wrap_error_lwt - ( Script_ir_translator.parse_data ctxt ~elab_conf ~allow_forged ty node - >>=? fun (actual, ctxt) -> - if equal actual expected then return ctxt - else Alcotest.failf "Unexpected error: %s" loc ) - -let test_parse_data_fails loc ctxt ty node = - let elab_conf = Script_ir_translator_config.make ~legacy:false () in - let allow_forged = false in - wrap_error_lwt - (Script_ir_translator.parse_data ctxt ~elab_conf ~allow_forged ty node - >>= function - | Ok _ -> Alcotest.failf "Unexpected typechecking success: %s" loc - | Error trace -> - let trace_string = - Format.asprintf "%a" Environment.Error_monad.pp_trace trace - in - let expect_id = "michelson_v1.invalid_constant" in - let expect_descrfiption = - "A data expression was invalid for its expected type." - in - if - Astring.String.is_infix ~affix:expect_id trace_string - && Astring.String.is_infix ~affix:expect_descrfiption trace_string - then return_unit - else - Alcotest.failf - "Unexpected error (%s) at %s" - trace_string - __LOC__ - return_unit) - -let test_parse_comb_data () = - let open Script in - let open Script_typed_ir in - let z = Script_int.zero_n in - let z_prim = Micheline.Int (-1, Z.zero) in - let nat_ty = nat_t in - let pair_prim l = Prim (-1, D_Pair, l, []) in - let pair_ty ty1 ty2 = pair_t (-1) ty1 ty2 in - pair_ty nat_ty nat_ty >>??= fun (Ty_ex_c pair_nat_nat_ty) -> - let pair_prim2 a b = pair_prim [a; b] in - let pair_z_z_prim = pair_prim2 z_prim z_prim in - list_t (-1) nat_ty >>??= fun list_nat_ty -> - big_map_t (-1) nat_ty nat_ty >>??= fun big_map_nat_nat_ty -> - test_context_with_nat_nat_big_map () >>=? fun (ctxt, big_map_id) -> - (* Pair 0 0 *) - test_parse_data __LOC__ ctxt pair_nat_nat_ty pair_z_z_prim (z, z) - >>=? fun ctxt -> - (* {0; 0} *) - test_parse_data - __LOC__ - ctxt - pair_nat_nat_ty - (Micheline.Seq (-1, [z_prim; z_prim])) - (z, z) - >>=? fun ctxt -> - (* Pair (Pair 0 0) 0 *) - pair_ty pair_nat_nat_ty nat_ty >>??= fun (Ty_ex_c pair_pair_nat_nat_nat_ty) -> - test_parse_data - __LOC__ - ctxt - pair_pair_nat_nat_nat_ty - (pair_prim2 pair_z_z_prim z_prim) - ((z, z), z) - >>=? fun ctxt -> - (* Pair 0 (Pair 0 0) *) - pair_ty nat_ty pair_nat_nat_ty >>??= fun (Ty_ex_c pair_nat_pair_nat_nat_ty) -> - test_parse_data - __LOC__ - ctxt - pair_nat_pair_nat_nat_ty - (pair_prim2 z_prim pair_z_z_prim) - (z, (z, z)) - >>=? fun ctxt -> - (* Pair 0 0 0 *) - test_parse_data - __LOC__ - ctxt - pair_nat_pair_nat_nat_ty - (pair_prim [z_prim; z_prim; z_prim]) - (z, (z, z)) - >>=? fun ctxt -> - (* {0; 0; 0} *) - test_parse_data - __LOC__ - ctxt - pair_nat_pair_nat_nat_ty - (Micheline.Seq (-1, [z_prim; z_prim; z_prim])) - (z, (z, z)) - >>=? fun ctxt -> - (* Should fail: {0} against pair nat (list nat) *) - pair_ty nat_ty list_nat_ty >>??= fun (Ty_ex_c pair_nat_list_nat_ty) -> - test_parse_data_fails - __LOC__ - ctxt - pair_nat_list_nat_ty - (Micheline.Seq (-1, [z_prim])) - >>=? fun () -> - (* Should fail: {0; 0; 0} against pair nat (list nat) *) - test_parse_data_fails - __LOC__ - ctxt - pair_nat_list_nat_ty - (Micheline.Seq (-1, [z_prim; z_prim; z_prim])) - >>=? fun () -> - (* check Pair 0 (Pair 0 {}) against pair nat (big_map nat nat) - so that the following test fails for the good reason and not because - the big map doesn't exist - *) - let id_z = Big_map.Id.unparse_to_z big_map_id in - let id_prim = Int (-1, id_z) in - let expected_big_map = - let open Script_typed_ir in - let diff = {map = Big_map_overlay.empty; size = 0} in - Big_map {id = Some big_map_id; diff; key_type = nat_ty; value_type = nat_ty} - in - let ty_equal : - type a ac1 ac2. - (a, ac1) Script_typed_ir.ty -> (a, ac2) Script_typed_ir.ty -> bool = - fun ty1 ty2 -> - match Script_typed_ir.(is_comparable ty1, is_comparable ty2) with - | Yes, Yes -> ty1 = ty2 - | No, No -> ty1 = ty2 - | Yes, No -> assert false - | No, Yes -> assert false - (* - These last two cases can't happen because the comparable character of a - type is a function of its concrete type. - It is possible to write a function that proves it but it is not needed - in the protocol for the moment. - *) - in - let equal (nat1, Big_map big_map1) (nat2, Big_map big_map2) = - (* Custom equal needed because big maps contain boxed maps containing functional values *) - nat1 = nat2 && big_map1.id = big_map2.id - && big_map1.key_type = big_map2.key_type - && ty_equal big_map1.value_type big_map2.value_type - && big_map1.diff.size = big_map2.diff.size - && Big_map_overlay.bindings big_map1.diff.map - = Big_map_overlay.bindings big_map2.diff.map - in - pair_ty nat_ty big_map_nat_nat_ty - >>??= fun (Ty_ex_c pair_nat_big_map_nat_nat_ty) -> - test_parse_data - ~equal - __LOC__ - ctxt - pair_nat_big_map_nat_nat_ty - (pair_prim2 z_prim (pair_prim2 id_prim (Seq (-1, [])))) - (Script_int.zero_n, expected_big_map) - >>=? fun ctxt -> - (* Should fail: Pair 0 0 {} against pair nat (big_map nat nat) *) - test_parse_data_fails - __LOC__ - ctxt - pair_nat_big_map_nat_nat_ty - (pair_prim [z_prim; id_prim; Seq (-1, [])]) - -let test_parse_address () = - let open Script_typed_ir in - test_context_with_nat_nat_big_map ~sc_rollup_enable:true () - >>=? fun (ctxt, _big_map_id) -> - (* KT1% (empty entrypoint) *) - wrap_error_lwt - (Lwt.return (Contract.of_b58check "KT1FAKEFAKEFAKEFAKEFAKEFAKEFAKGGSE2x")) - >>=? fun kt1fake -> - test_parse_data - __LOC__ - ctxt - address_t - (String (-1, "KT1FAKEFAKEFAKEFAKEFAKEFAKEFAKGGSE2x%")) - {destination = Contract kt1fake; entrypoint = Entrypoint.default} - >>=? fun ctxt -> - (* tz1% (empty entrypoint) *) - wrap_error_lwt - (Lwt.return (Contract.of_b58check "tz1fakefakefakefakefakefakefakcphLA5")) - >>=? fun tz1fake -> - test_parse_data - __LOC__ - ctxt - address_t - (String (-1, "tz1fakefakefakefakefakefakefakcphLA5%")) - {destination = Contract tz1fake; entrypoint = Entrypoint.default} - >>=? fun ctxt -> - (* scr1% (empty entrypoint) *) - wrap_error_lwt - (Lwt.return - (Destination.of_b58check "sr1JPVatbbPoGp4vb6VfQ1jzEPMrYFcKq6VG")) - >>=? fun scr1 -> - test_parse_data - __LOC__ - ctxt - address_t - (String (-1, "sr1JPVatbbPoGp4vb6VfQ1jzEPMrYFcKq6VG")) - {destination = scr1; entrypoint = Entrypoint.default} - >>=? fun ctxt -> - (* scr1% (default entrypoint) *) - test_parse_data - __LOC__ - ctxt - address_t - (String (-1, "sr1JPVatbbPoGp4vb6VfQ1jzEPMrYFcKq6VG%")) - {destination = scr1; entrypoint = Entrypoint.default} - >|=? fun (_ctxt : context) -> () - -let test_unparse_data loc ctxt ty x ~expected_readable ~expected_optimized = - wrap_error_lwt - ( Script_ir_translator.unparse_data ctxt Script_ir_unparser.Readable ty x - >>=? fun (actual_readable, ctxt) -> - (if actual_readable = Micheline.strip_locations expected_readable then - return ctxt - else Alcotest.failf "Error in readable unparsing: %s" loc) - >>=? fun ctxt -> - Script_ir_translator.unparse_data ctxt Script_ir_unparser.Optimized ty x - >>=? fun (actual_optimized, ctxt) -> - if actual_optimized = Micheline.strip_locations expected_optimized then - return ctxt - else Alcotest.failf "Error in optimized unparsing: %s" loc ) - -let test_unparse_comb_data () = - let open Script in - let open Script_typed_ir in - let z = Script_int.zero_n in - let z_prim = Micheline.Int (-1, Z.zero) in - let nat_ty = nat_t in - let pair_prim l = Prim (-1, D_Pair, l, []) in - let pair_ty ty1 ty2 = pair_t (-1) ty1 ty2 in - pair_ty nat_ty nat_ty >>??= fun (Ty_ex_c pair_nat_nat_ty) -> - let pair_prim2 a b = pair_prim [a; b] in - let pair_z_z_prim = pair_prim2 z_prim z_prim in - test_context () >>=? fun ctxt -> - (* Pair 0 0 *) - test_unparse_data - __LOC__ - ctxt - pair_nat_nat_ty - (z, z) - ~expected_readable:pair_z_z_prim - ~expected_optimized:pair_z_z_prim - >>=? fun ctxt -> - (* Pair (Pair 0 0) 0 *) - pair_ty pair_nat_nat_ty nat_ty >>??= fun (Ty_ex_c pair_pair_nat_nat_nat_ty) -> - test_unparse_data - __LOC__ - ctxt - pair_pair_nat_nat_nat_ty - ((z, z), z) - ~expected_readable:(pair_prim2 pair_z_z_prim z_prim) - ~expected_optimized:(pair_prim2 pair_z_z_prim z_prim) - >>=? fun ctxt -> - (* Readable: Pair 0 0 0; Optimized: Pair 0 (Pair 0 0) *) - pair_ty nat_ty pair_nat_nat_ty >>??= fun (Ty_ex_c pair_nat_pair_nat_nat_ty) -> - test_unparse_data - __LOC__ - ctxt - pair_nat_pair_nat_nat_ty - (z, (z, z)) - ~expected_readable:(pair_prim [z_prim; z_prim; z_prim]) - ~expected_optimized:(pair_prim2 z_prim pair_z_z_prim) - >>=? fun ctxt -> - (* Readable: Pair 0 0 0 0; Optimized: {0; 0; 0; 0} *) - pair_ty nat_ty pair_nat_pair_nat_nat_ty - >>??= fun (Ty_ex_c pair_nat_pair_nat_pair_nat_nat_ty) -> - test_unparse_data - __LOC__ - ctxt - pair_nat_pair_nat_pair_nat_nat_ty - (z, (z, (z, z))) - ~expected_readable:(pair_prim [z_prim; z_prim; z_prim; z_prim]) - ~expected_optimized:(Micheline.Seq (-1, [z_prim; z_prim; z_prim; z_prim])) - >>=? fun (_ : context) -> return_unit - -(* Generate all the possible syntaxes for pairs *) -let gen_pairs left right = - [Prim ((), Script.D_Pair, [left; right], []); Seq ((), [left; right])] - -(* Generate all the possible syntaxes for combs *) -let rec gen_combs leaf arity = - assert (arity >= 2) ; - if arity = 2 then gen_pairs leaf leaf - else - gen_combs leaf (arity - 1) - |> List.map (fun smaller -> - (match smaller with - | Prim (loc, Script.D_Pair, vs, []) -> - Prim (loc, Script.D_Pair, leaf :: vs, []) - | Seq (loc, vs) -> Seq (loc, leaf :: vs) - | _ -> assert false) - :: gen_pairs leaf smaller) - |> List.flatten - -(* Checks the optimality of the Optimized Micheline representation for combs *) -let test_optimal_comb () = - let open Script_typed_ir in - let leaf_ty = nat_t in - let leaf_mich = Int ((), Z.zero) in - let leaf_v = Script_int.zero_n in - let size_of_micheline mich = - let canonical = Micheline.strip_locations mich in - ( canonical, - Bytes.length - @@ Data_encoding.Binary.to_bytes_exn Script.expr_encoding canonical ) - in - let check_optimal_comb loc ctxt ty v arity = - wrap_error_lwt - ( Script_ir_translator.unparse_data ctxt Script_ir_unparser.Optimized ty v - >>=? fun (unparsed, ctxt) -> - let unparsed_canonical, unparsed_size = - size_of_micheline (Micheline.root unparsed) - in - List.iter_es (fun other_repr -> - let other_repr_canonical, other_repr_size = - size_of_micheline other_repr - in - if other_repr_size < unparsed_size then - Alcotest.failf - "At %s, for comb of arity %d, representation %a (size %d \ - bytes) is shorter than representation %a (size %d bytes) \ - returned by unparse_data in Optimized mode" - loc - arity - Michelson_v1_printer.print_expr - other_repr_canonical - other_repr_size - Michelson_v1_printer.print_expr - unparsed_canonical - unparsed_size - else return_unit) - @@ gen_combs leaf_mich arity - >>=? fun () -> return ctxt ) - in - let pair_ty ty1 ty2 = pair_t (-1) ty1 ty2 in - test_context () >>=? fun ctxt -> - pair_ty leaf_ty leaf_ty >>??= fun (Ty_ex_c comb2_ty) -> - let comb2_v = (leaf_v, leaf_v) in - check_optimal_comb __LOC__ ctxt comb2_ty comb2_v 2 >>=? fun ctxt -> - pair_ty leaf_ty comb2_ty >>??= fun (Ty_ex_c comb3_ty) -> - let comb3_v = (leaf_v, comb2_v) in - check_optimal_comb __LOC__ ctxt comb3_ty comb3_v 3 >>=? fun ctxt -> - pair_ty leaf_ty comb3_ty >>??= fun (Ty_ex_c comb4_ty) -> - let comb4_v = (leaf_v, comb3_v) in - check_optimal_comb __LOC__ ctxt comb4_ty comb4_v 4 >>=? fun ctxt -> - pair_ty leaf_ty comb4_ty >>??= fun (Ty_ex_c comb5_ty) -> - let comb5_v = (leaf_v, comb4_v) in - check_optimal_comb __LOC__ ctxt comb5_ty comb5_v 5 >>=? fun (_ : context) -> - return_unit - -(* Check that UNPACK on contract is forbidden. - See https://gitlab.com/tezos/tezos/-/issues/301 for the motivation - behind this restriction. -*) -let test_contract_not_packable () = - let elab_conf = Script_ir_translator_config.make ~legacy:false () in - let contract_unit = - Prim (0, Script.T_contract, [Prim (0, T_unit, [], [])], []) - in - test_context () >>=? fun ctxt -> - (* Test that [contract_unit] is parsable *) - (match Script_ir_translator.parse_any_ty ctxt ~legacy:false contract_unit with - | Ok _ -> return_unit - | Error _ -> Alcotest.failf "Could not parse (contract unit)") - >>=? fun () -> - (* Test that [contract_unit] is not packable *) - (match - Script_ir_translator.parse_packable_ty ctxt ~legacy:false contract_unit - with - | Ok _ -> - Alcotest.failf - "(contract unit) should not be packable, see \ - https://gitlab.com/tezos/tezos/-/issues/301" - | Error _ -> return_unit) - >>=? fun () -> - (* Test that elaboration of the [UNPACK unit] instruction succeeds *) - (Script_ir_translator.parse_instr - Script_tc_context.data - ctxt - ~elab_conf - (Prim (0, I_UNPACK, [Prim (0, T_unit, [], [])], [])) - (Item_t (Script_typed_ir.bytes_t, Bot_t)) - >>= function - | Ok _ -> return_unit - | Error _ -> Alcotest.failf "Could not parse UNPACK unit") - >>=? fun () -> - (* Test that elaboration of the [UNPACK (contract unit)] instruction fails *) - Script_ir_translator.parse_instr - Script_tc_context.data - ctxt - ~elab_conf - (Prim (0, I_UNPACK, [contract_unit], [])) - (Item_t (Script_typed_ir.bytes_t, Bot_t)) - >>= function - | Ok _ -> - Alcotest.failf - "UNPACK (contract unit) should not be allowed, see \ - https://gitlab.com/tezos/tezos/-/issues/301" - | Error _ -> return_unit - -(* This test function is used to checks forbidden operations in views. *) -let test_forbidden_op_in_view op () = - let prefix = path // "contracts/forbidden_op_in_view_" in - let script = read_file (prefix ^ op ^ ".tz") in - let contract_expr = Expr.from_string script in - test_context () >>=? fun ctxt -> - Script_ir_translator.typecheck_code - ~legacy:false - ~show_types:false - ctxt - contract_expr - >>= function - | Ok _ -> - Alcotest.failf - "%s should not be allowed in views, see \ - https://gitlab.com/tezos/tezos/-/issues/1922" - op - | Error _ -> return_unit - -(** Test [parse_contract_data] for rollup with unit type. *) -let test_parse_contract_data_for_unit_rollup () = - let open Lwt_result_syntax in - let* block, (contract, _) = context_init_with_sc_rollup_enabled T2 in - let* block, rollup = sc_originate block contract "unit" in - let* incr = Incremental.begin_construction block in - let ctxt = Incremental.alpha_ctxt incr in - let* _ctxt, typed_contract = - wrap_error_lwt - @@ Script_ir_translator.parse_contract_data - ctxt - (-1) - Script_typed_ir.unit_t - (Destination.Sc_rollup rollup) - ~entrypoint:Entrypoint.default - in - let (Ty_ex_c Script_typed_ir.Unit_t) = - Script_typed_ir.Typed_contract.arg_ty typed_contract - in - let destination = Script_typed_ir.Typed_contract.destination typed_contract in - let entrypoint = Script_typed_ir.Typed_contract.entrypoint typed_contract in - (* Check that the destinations match. *) - let* () = - Assert.equal_string - ~loc:__LOC__ - (Destination.to_b58check destination) - (Sc_rollup.Address.to_b58check rollup) - in - (* Check that entrypoints match. *) - let* () = - Assert.equal_string ~loc:__LOC__ (Entrypoint.to_string entrypoint) "default" - in - return () - -(** Test that [parse_contract_data] for rollup with invalid type fails. *) -let test_parse_contract_data_for_rollup_with_invalid_type () = - let open Lwt_result_syntax in - let* block, (contract, _) = context_init_with_sc_rollup_enabled T2 in - let* block, rollup = sc_originate block contract "string" in - let* incr = Incremental.begin_construction block in - let ctxt = Incremental.alpha_ctxt incr in - let entrypoint = Entrypoint.of_string_strict_exn "add" in - let*! res = - wrap_error_lwt - @@ Script_ir_translator.parse_contract_data - ctxt - (-1) - Script_typed_ir.unit_t - (Destination.Sc_rollup rollup) - ~entrypoint - in - Assert.proto_error - ~loc:__LOC__ - res - (( = ) (Script_tc_errors.No_such_entrypoint entrypoint)) - -let test_contract path ~ok ~ko () = - let contract = path in - let script = read_file contract in - let contract_expr = Expr.from_string script in - test_context () >>=? fun ctxt -> - Script_ir_translator.typecheck_code - ~legacy:false - ~show_types:false - ctxt - contract_expr - >>= function - | Ok _ -> ok () - | Error t -> ko t - -let test_contract_success path = - test_contract path ~ok:return ~ko:(fun t -> - Alcotest.failf "Unexpected error: %a" Environment.Error_monad.pp_trace t) - -let test_contract_failure path = - test_contract - path - ~ok:(fun () -> - Alcotest.failf - "Unexpected success: typechecking %s should have failed" - path) - ~ko:(fun _ -> return_unit) - -let tests = - [ - Tztest.tztest "unparse view" `Quick test_unparse_view; - Tztest.tztest - "typecheck stack overflow error" - `Quick - test_typecheck_stack_overflow; - Tztest.tztest "comb type parsing" `Quick test_parse_comb_type; - Tztest.tztest "comb type unparsing" `Quick test_unparse_comb_type; - Tztest.tztest - "comb comparable type unparsing" - `Quick - test_unparse_comb_comparable_type; - Tztest.tztest "comb data parsing" `Quick test_parse_comb_data; - Tztest.tztest "comb data unparsing" `Quick test_unparse_comb_data; - Tztest.tztest "optimal comb data unparsing" `Quick test_optimal_comb; - Tztest.tztest "parse address" `Quick test_parse_address; - Tztest.tztest - "test unpackability of the contract type" - `Quick - test_contract_not_packable; - Tztest.tztest - "forbidden SELF in view" - `Quick - (test_forbidden_op_in_view "SELF"); - Tztest.tztest - "forbidden SET_DELEGATE in view" - `Quick - (test_forbidden_op_in_view "SET_DELEGATE"); - Tztest.tztest - "forbidden TRANSFER_TOKENS in view" - `Quick - (test_forbidden_op_in_view "TRANSFER_TOKENS"); - Tztest.tztest - "forbidden CREATE_CONTRACT in view" - `Quick - (test_forbidden_op_in_view "CREATE_CONTRACT"); - Tztest.tztest - "parse contract data for rollup" - `Quick - test_parse_contract_data_for_unit_rollup; - Tztest.tztest - "parse contract data for rollup with entrypoint invalid type" - `Quick - test_parse_contract_data_for_rollup_with_invalid_type; - Tztest.tztest - "lambda_rec instruction" - `Quick - (test_contract_success (path // "contracts/rec_fact.tz")); - Tztest.tztest - "lambda_rec instruction with apply" - `Quick - (test_contract_success (path // "contracts/rec_fact_apply.tz")); - Tztest.tztest - "lambda_rec with type error" - `Quick - (test_contract_failure (path // "contracts/fail_rec.tz")); - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("typechecking", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/dune b/src/proto_017_PtNairob/lib_protocol/test/integration/operations/dune deleted file mode 100644 index 0aadf08a0dddcd8527d8a022c57bf0bd4b318f8c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/dune +++ /dev/null @@ -1,64 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name - src_proto_017_PtNairob_lib_protocol_test_integration_operations_tezt_lib) - (instrumentation (backend bisect_ppx)) - (libraries - tezt.core - octez-alcotezt - octez-libs.base - tezos-protocol-017-PtNairob.protocol - octez-protocol-017-PtNairob-libs.client - octez-protocol-017-PtNairob-libs.test-helpers - octez-libs.base-test-helpers - octez-protocol-017-PtNairob-libs.plugin) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezt_core - -open Tezt_core.Base - -open Octez_alcotezt - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_protocol_017_PtNairob - -open Tezos_client_017_PtNairob - -open Tezos_017_PtNairob_test_helpers - -open Tezos_base_test_helpers - -open Tezos_protocol_plugin_017_PtNairob) - (modules - test_activation - test_combined_operations - test_failing_noop - test_origination - test_paid_storage_increase - test_reveal - test_sc_rollup_transfer - test_sc_rollup - test_transfer - test_voting - test_zk_rollup - test_transfer_ticket)) - -(executable - (name main) - (instrumentation (backend bisect_ppx --bisect-sigterm)) - (libraries - src_proto_017_PtNairob_lib_protocol_test_integration_operations_tezt_lib - tezt) - (link_flags - (:standard) - (:include %{workspace_root}/macos-link-flags.sexp)) - (modules main)) - -(rule - (alias runtest) - (package tezos-protocol-017-PtNairob-tests) - (deps (glob_files contracts/*)) - (enabled_if (<> false %{env:RUNTEZTALIAS=true})) - (action (run %{dep:./main.exe}))) - -(rule - (targets main.ml) - (action (with-stdout-to %{targets} (echo "let () = Tezt.Test.run ()")))) diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_activation.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_activation.ml deleted file mode 100644 index 0e415f400cfb052a528acc7633404687c34840a7..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_activation.ml +++ /dev/null @@ -1,578 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (activation) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/operations/main.exe \ - -- --file test_activation.ml - Subject: The activation operation creates an implicit contract from a - registered commitment present in the context. It is - parametrized by a public key hash (pkh) and a secret. - - The commitments are composed of : - - a blinded pkh that can be revealed by the secret ; - - an amount. - - The commitments and the secrets are generated from - /scripts/create_genesis/create_genesis.py and should be - coherent. -*) - -open Protocol -open Alpha_context -open Test_tez - -(* Generated commitments and secrets *) - -let commitments = - List.map - (fun (bpkh, a) -> - Commitment. - { - blinded_public_key_hash = Blinded_public_key_hash.of_b58check_exn bpkh; - amount = Tez.of_mutez_exn (Int64.of_string a); - }) - [ - ("btz1bRL4X5BWo2Fj4EsBdUwexXqgTf75uf1qa", "23932454669343"); - ("btz1SxjV1syBgftgKy721czKi3arVkVwYUFSv", "72954577464032"); - ("btz1LtoNCjiW23txBTenALaf5H6NKF1L3c1gw", "217487035428349"); - ("btz1SUd3mMhEBcWudrn8u361MVAec4WYCcFoy", "4092742372031"); - ("btz1MvBXf4orko1tsGmzkjLbpYSgnwUjEe81r", "17590039016550"); - ("btz1LoDZ3zsjgG3k3cqTpUMc9bsXbchu9qMXT", "26322312350555"); - ("btz1RMfq456hFV5AeDiZcQuZhoMv2dMpb9hpP", "244951387881443"); - ("btz1Y9roTh4A7PsMBkp8AgdVFrqUDNaBE59y1", "80065050465525"); - ("btz1Q1N2ePwhVw5ED3aaRVek6EBzYs1GDkSVD", "3569618927693"); - ("btz1VFFVsVMYHd5WfaDTAt92BeQYGK8Ri4eLy", "9034781424478"); - ] - -type secret_account = { - account : public_key_hash; - activation_code : Blinded_public_key_hash.activation_code; - amount : Tez.t; -} - -let secrets () = - (* Exported from proto_alpha client - TODO : remove when relocated to lib_crypto *) - let read_key mnemonic email password = - match Tezos_client_base.Bip39.of_words mnemonic with - | None -> assert false - | Some t -> - (* TODO: unicode normalization (NFKD)... *) - let passphrase = Bytes.(cat (of_string email) (of_string password)) in - let sk = Tezos_client_base.Bip39.to_seed ~passphrase t in - let sk = Bytes.sub sk 0 32 in - let sk : Signature.Secret_key.t = - Ed25519 - (Data_encoding.Binary.of_bytes_exn - Signature.Ed25519.Secret_key.encoding - sk) - in - let pk = Signature.Secret_key.to_public_key sk in - let pkh = Signature.Public_key.hash pk in - (pkh, pk, sk) - in - List.map - (fun (mnemonic, secret, amount, pkh, password, email) -> - let pkh', pk, sk = read_key mnemonic email password in - let pkh = Signature.Public_key_hash.of_b58check_exn pkh in - assert (Signature.Public_key_hash.equal pkh pkh') ; - let account = Account.{pkh; pk; sk} in - Account.add_account account ; - { - account = account.pkh; - activation_code = - Stdlib.Option.get - (Blinded_public_key_hash.activation_code_of_hex secret); - amount = - WithExceptions.Option.to_exn - ~none:(Invalid_argument "tez conversion") - (Tez.of_mutez (Int64.of_string amount)); - }) - [ - ( [ - "envelope"; - "hospital"; - "mind"; - "sunset"; - "cancel"; - "muscle"; - "leisure"; - "thumb"; - "wine"; - "market"; - "exit"; - "lucky"; - "style"; - "picnic"; - "success"; - ], - "0f39ed0b656509c2ecec4771712d9cddefe2afac", - "23932454669343", - "tz1MawerETND6bqJqx8GV3YHUrvMBCDasRBF", - "z0eZHQQGKt", - "cjgfoqmk.wpxnvnup@tezos.example.org" ); - ( [ - "flag"; - "quote"; - "will"; - "valley"; - "mouse"; - "chat"; - "hold"; - "prosper"; - "silk"; - "tent"; - "cruel"; - "cause"; - "demise"; - "bottom"; - "practice"; - ], - "41f98b15efc63fa893d61d7d6eee4a2ce9427ac4", - "72954577464032", - "tz1X4maqF9tC1Yn4jULjHRAyzjAtc25Z68TX", - "MHErskWPE6", - "oklmcktr.ztljnpzc@tezos.example.org" ); - ( [ - "library"; - "away"; - "inside"; - "paper"; - "wise"; - "focus"; - "sweet"; - "expose"; - "require"; - "change"; - "stove"; - "planet"; - "zone"; - "reflect"; - "finger"; - ], - "411dfef031eeecc506de71c9df9f8e44297cf5ba", - "217487035428349", - "tz1SWBY7rWMutEuWS54Pt33MkzAS6eWkUuTc", - "0AO6BzQNfN", - "ctgnkvqm.kvtiybky@tezos.example.org" ); - ( [ - "cruel"; - "fluid"; - "damage"; - "demand"; - "mimic"; - "above"; - "village"; - "alpha"; - "vendor"; - "staff"; - "absent"; - "uniform"; - "fire"; - "asthma"; - "milk"; - ], - "08d7d355bc3391d12d140780b39717d9f46fcf87", - "4092742372031", - "tz1amUjiZaevaxQy5wKn4SSRvVoERCip3nZS", - "9kbZ7fR6im", - "bnyxxzqr.tdszcvqb@tezos.example.org" ); - ( [ - "opera"; - "divorce"; - "easy"; - "myself"; - "idea"; - "aim"; - "dash"; - "scout"; - "case"; - "resource"; - "vote"; - "humor"; - "ticket"; - "client"; - "edge"; - ], - "9b7cad042fba557618bdc4b62837c5f125b50e56", - "17590039016550", - "tz1Zaee3QBtD4ErY1SzqUvyYTrENrExu6yQM", - "suxT5H09yY", - "iilkhohu.otnyuvna@tezos.example.org" ); - ( [ - "token"; - "similar"; - "ginger"; - "tongue"; - "gun"; - "sort"; - "piano"; - "month"; - "hotel"; - "vote"; - "undo"; - "success"; - "hobby"; - "shell"; - "cart"; - ], - "124c0ca217f11ffc6c7b76a743d867c8932e5afd", - "26322312350555", - "tz1geDUUhfXK1EMj7VQdRjug1MoFe6gHWnCU", - "4odVdLykaa", - "kwhlglvr.slriitzy@tezos.example.org" ); - ( [ - "shield"; - "warrior"; - "gorilla"; - "birth"; - "steak"; - "neither"; - "feel"; - "only"; - "liberty"; - "float"; - "oven"; - "extend"; - "pulse"; - "suffer"; - "vapor"; - ], - "ac7a2125beea68caf5266a647f24dce9fea018a7", - "244951387881443", - "tz1h3nY7jcZciJgAwRhWcrEwqfVp7VQoffur", - "A6yeMqBFG8", - "lvrmlbyj.yczltcxn@tezos.example.org" ); - ( [ - "waste"; - "open"; - "scan"; - "tip"; - "subway"; - "dance"; - "rent"; - "copper"; - "garlic"; - "laundry"; - "defense"; - "clerk"; - "another"; - "staff"; - "liar"; - ], - "2b3e94be133a960fa0ef87f6c0922c19f9d87ca2", - "80065050465525", - "tz1VzL4Xrb3fL3ckvqCWy6bdGMzU2w9eoRqs", - "oVZqpq60sk", - "rfodmrha.zzdndvyk@tezos.example.org" ); - ( [ - "fiber"; - "next"; - "property"; - "cradle"; - "silk"; - "obey"; - "gossip"; - "push"; - "key"; - "second"; - "across"; - "minimum"; - "nice"; - "boil"; - "age"; - ], - "dac31640199f2babc157aadc0021cd71128ca9ea", - "3569618927693", - "tz1RUHg536oRKhPLFfttcB5gSWAhh4E9TWjX", - "FfytQTTVbu", - "owecikdy.gxnyttya@tezos.example.org" ); - ( [ - "print"; - "labor"; - "budget"; - "speak"; - "poem"; - "diet"; - "chunk"; - "eternal"; - "book"; - "saddle"; - "pioneer"; - "ankle"; - "happy"; - "only"; - "exclude"; - ], - "bb841227f250a066eb8429e56937ad504d7b34dd", - "9034781424478", - "tz1M1LFbgctcPWxstrao9aLr2ECW1fV4pH5u", - "zknAl3lrX2", - "ettilrvh.zsrqrbud@tezos.example.org" ); - ] - -(** Helper: Create a genesis block with predefined commitments, - accounts and balances. *) -let activation_init () = - Context.init1 ~consensus_threshold:0 ~commitments () >|=? fun (b, c) -> - secrets () |> fun ss -> (b, c, ss) - -(** Verify the genesis block created by [activation_init] can be - baked. *) -let test_simple_init_with_commitments () = - activation_init () >>=? fun (blk, _contract, _secrets) -> - Block.bake blk >>=? fun (_ : Block.t) -> return_unit - -(** A single activation *) -let test_single_activation () = - activation_init () >>=? fun (blk, _contract, secrets) -> - let ({account; activation_code; amount = expected_amount; _} as _first_one) = - WithExceptions.Option.get ~loc:__LOC__ @@ List.hd secrets - in - (* Contract does not exist *) - Assert.balance_is ~loc:__LOC__ (B blk) (Contract.Implicit account) Tez.zero - >>=? fun () -> - Op.activation (B blk) account activation_code >>=? fun operation -> - Block.bake ~operation blk >>=? fun blk -> - (* Contract does exist *) - Assert.balance_is - ~loc:__LOC__ - (B blk) - (Contract.Implicit account) - expected_amount - -(** 10 activations, one per bake. *) -let test_multi_activation_1 () = - activation_init () >>=? fun (blk, _contract, secrets) -> - List.fold_left_es - (fun blk {account; activation_code; amount = expected_amount; _} -> - Op.activation (B blk) account activation_code >>=? fun operation -> - Block.bake ~operation blk >>=? fun blk -> - Assert.balance_is - ~loc:__LOC__ - (B blk) - (Contract.Implicit account) - expected_amount - >|=? fun () -> blk) - blk - secrets - >>=? fun (_ : Block.t) -> return_unit - -(** All of the 10 activations occur in one bake. *) -let test_multi_activation_2 () = - activation_init () >>=? fun (blk, _contract, secrets) -> - List.fold_left_es - (fun ops {account; activation_code; _} -> - Op.activation (B blk) account activation_code >|=? fun op -> op :: ops) - [] - secrets - >>=? fun ops -> - Block.bake ~operations:ops blk >>=? fun blk -> - List.iter_es - (fun {account; amount = expected_amount; _} -> - (* Contract does exist *) - Assert.balance_is - ~loc:__LOC__ - (B blk) - (Contract.Implicit account) - expected_amount) - secrets - -(** Transfer with activated account. *) -let test_activation_and_transfer () = - activation_init () >>=? fun (blk, bootstrap_contract, secrets) -> - let ({account; activation_code; _} as _first_one) = - WithExceptions.Option.get ~loc:__LOC__ @@ List.hd secrets - in - let first_contract = Contract.Implicit account in - Op.activation (B blk) account activation_code >>=? fun operation -> - Block.bake ~operation blk >>=? fun blk -> - Context.Contract.balance (B blk) bootstrap_contract >>=? fun amount -> - Test_tez.( /? ) amount 2L >>?= fun half_amount -> - Context.Contract.balance (B blk) first_contract - >>=? fun activated_amount_before -> - Op.transaction (B blk) bootstrap_contract first_contract half_amount - >>=? fun operation -> - Block.bake ~operation blk >>=? fun blk -> - Assert.balance_was_credited - ~loc:__LOC__ - (B blk) - (Contract.Implicit account) - activated_amount_before - half_amount - -(** Transfer to an unactivated account and then activating it. *) -let test_transfer_to_unactivated_then_activate () = - activation_init () >>=? fun (blk, bootstrap_contract, secrets) -> - let ({account; activation_code; amount} as _first_one) = - WithExceptions.Option.get ~loc:__LOC__ @@ List.hd secrets - in - let unactivated_commitment_contract = Contract.Implicit account in - Context.Contract.balance (B blk) bootstrap_contract >>=? fun b_amount -> - b_amount /? 2L >>?= fun b_half_amount -> - Incremental.begin_construction blk >>=? fun inc -> - Op.transaction - (I inc) - bootstrap_contract - unactivated_commitment_contract - b_half_amount - >>=? fun op -> - Incremental.add_operation inc op >>=? fun inc -> - Op.activation (I inc) account activation_code >>=? fun op' -> - Incremental.add_operation inc op' >>=? fun inc -> - Incremental.finalize_block inc >>=? fun blk2 -> - Assert.balance_was_credited - ~loc:__LOC__ - (B blk2) - (Contract.Implicit account) - amount - b_half_amount - -(****************************************************************) -(* The following test scenarios are supposed to raise errors. *) -(****************************************************************) - -(** Invalid pkh activation: expected to fail as the context does not - contain any commitment. *) -let test_invalid_activation_with_no_commitments () = - Context.init1 () >>=? fun (blk, _contract) -> - let secrets = secrets () in - let ({account; activation_code; _} as _first_one) = - WithExceptions.Option.get ~loc:__LOC__ @@ List.hd secrets - in - Op.activation (B blk) account activation_code >>=? fun operation -> - Block.bake ~operation blk >>= fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Validate_errors.Anonymous.Invalid_activation _ -> true - | _ -> false) - -(** Wrong activation: wrong secret given in the operation. *) -let test_invalid_activation_wrong_secret () = - activation_init () >>=? fun (blk, _contract, secrets) -> - let ({account; _} as _first_one) = - WithExceptions.Option.get ~loc:__LOC__ @@ List.nth secrets 0 - in - let ({activation_code; _} as _second_one) = - WithExceptions.Option.get ~loc:__LOC__ @@ List.nth secrets 1 - in - Op.activation (B blk) account activation_code >>=? fun operation -> - Block.bake ~operation blk >>= fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Validate_errors.Anonymous.Invalid_activation _ -> true - | _ -> false) - -(** Invalid pkh activation : expected to fail as the context does not - contain an associated commitment. *) -let test_invalid_activation_inexistent_pkh () = - activation_init () >>=? fun (blk, _contract, secrets) -> - let ({activation_code; _} as _first_one) = - WithExceptions.Option.get ~loc:__LOC__ @@ List.hd secrets - in - let inexistent_pkh = - Signature.Public_key_hash.of_b58check_exn - "tz1PeQHGKPWSpNoozvxgqLN9TFsj6rDqNV3o" - in - Op.activation (B blk) inexistent_pkh activation_code >>=? fun operation -> - Block.bake ~operation blk >>= fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Validate_errors.Anonymous.Invalid_activation _ -> true - | _ -> false) - -(** Invalid pkh activation : expected to fail as the commitment has - already been claimed. *) -let test_invalid_double_activation () = - activation_init () >>=? fun (blk, _contract, secrets) -> - let ({account; activation_code; _} as _first_one) = - WithExceptions.Option.get ~loc:__LOC__ @@ List.hd secrets - in - Incremental.begin_construction blk >>=? fun inc -> - Op.activation (I inc) account activation_code >>=? fun op -> - Incremental.add_operation inc op >>=? fun inc -> - Op.activation (I inc) account activation_code >>=? fun op' -> - Incremental.add_operation inc op' >>= fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Validate_errors.Anonymous.Conflicting_activation _ -> true - | _ -> false) - -(** Transfer from an unactivated commitment account. *) -let test_invalid_transfer_from_unactivated_account () = - activation_init () >>=? fun (blk, bootstrap_contract, secrets) -> - let ({account; _} as _first_one) = - WithExceptions.Option.get ~loc:__LOC__ @@ List.hd secrets - in - let unactivated_commitment_contract = Contract.Implicit account in - (* No activation *) - Op.transaction - (B blk) - unactivated_commitment_contract - bootstrap_contract - Tez.one - >>=? fun operation -> - Block.bake ~operation blk >>= fun res -> - Assert.proto_error_with_info ~loc:__LOC__ res "Empty implicit contract" - -let tests = - [ - Tztest.tztest - "init with commitments" - `Quick - test_simple_init_with_commitments; - Tztest.tztest "single activation" `Quick test_single_activation; - Tztest.tztest "multi-activation one-by-one" `Quick test_multi_activation_1; - Tztest.tztest - "multi-activation all at a time" - `Quick - test_multi_activation_2; - Tztest.tztest "activation and transfer" `Quick test_activation_and_transfer; - Tztest.tztest - "transfer to unactivated account then activate" - `Quick - test_transfer_to_unactivated_then_activate; - Tztest.tztest - "invalid activation with no commitments" - `Quick - test_invalid_activation_with_no_commitments; - Tztest.tztest - "invalid activation with commitments" - `Quick - test_invalid_activation_inexistent_pkh; - Tztest.tztest - "invalid double activation" - `Quick - test_invalid_double_activation; - Tztest.tztest - "wrong activation code" - `Quick - test_invalid_activation_wrong_secret; - Tztest.tztest - "invalid transfer from unactivated account" - `Quick - test_invalid_transfer_from_unactivated_account; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("activation", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_combined_operations.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_combined_operations.ml deleted file mode 100644 index 7a60229cf5fce30ba86fc83088edc69926c2e120..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_combined_operations.ml +++ /dev/null @@ -1,413 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (combined operations) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/operations/main.exe \ - -- --file test_combined_operations.ml - Subject: Multiple operations can be grouped in one ensuring their - deterministic application. - - If an invalid operation is present in this group of - operations, the previously applied operations are - backtracked leaving the context unchanged and the - following operations are skipped. Fees attributed to the - operations are collected by the baker nonetheless. - - Only manager operations are allowed in multiple transactions. - They must all belong to the same manager as there is only one - signature. -*) - -open Protocol -open Alpha_context - -let ten_tez = Test_tez.of_int 10 - -let gas_limit = Op.Custom_gas (Alpha_context.Gas.Arith.integral_of_int_exn 3000) - -(** Groups ten transactions between the same parties. *) -let test_multiple_transfers () = - Context.init3 () >>=? fun (blk, (c1, c2, c3)) -> - List.map_es - (fun _ -> Op.transaction ~gas_limit (B blk) c1 c2 Tez.one) - (1 -- 10) - >>=? fun ops -> - Op.combine_operations ~source:c1 (B blk) ops >>=? fun operation -> - let baker_pkh = Context.Contract.pkh c3 in - Incremental.begin_construction ~policy:(By_account baker_pkh) blk - >>=? fun inc -> - Context.Contract.balance (I inc) c1 >>=? fun c1_old_balance -> - Context.Contract.balance (I inc) c2 >>=? fun c2_old_balance -> - Incremental.add_operation inc operation >>=? fun inc -> - Assert.balance_was_debited - ~loc:__LOC__ - (I inc) - c1 - c1_old_balance - (Test_tez.of_int 10) - >>=? fun () -> - Assert.balance_was_credited - ~loc:__LOC__ - (I inc) - c2 - c2_old_balance - (Test_tez.of_int 10) - >>=? fun () -> return_unit - -(** Groups ten delegated originations. *) -let test_multiple_origination_and_delegation () = - Context.init2 () >>=? fun (blk, (c1, c2)) -> - let n = 10 in - Context.get_constants (B blk) - >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} -> - let delegate_pkh = Context.Contract.pkh c2 in - (* Deploy n smart contracts with dummy scripts from c1 *) - List.map_es - (fun i -> - Op.contract_origination - ~gas_limit - ~delegate:delegate_pkh - ~counter:(Manager_counter.Internal_for_tests.of_int i) - ~fee:Tez.zero - ~script:Op.dummy_script - ~credit:(Test_tez.of_int 10) - (B blk) - c1) - (1 -- n) - >>=? fun originations -> - (* These computed originated contracts are not the ones really created *) - (* We will extract them from the tickets *) - let originations_operations, _ = List.split originations in - Op.combine_operations ~source:c1 (B blk) originations_operations - >>=? fun operation -> - Incremental.begin_construction blk >>=? fun inc -> - Context.Contract.balance (I inc) c1 >>=? fun c1_old_balance -> - Incremental.add_operation inc operation >>=? fun inc -> - (* To retrieve the originated contracts, it is easier to extract them - from the tickets. Else, we could (could we ?) hash each combined - operation individually. *) - let tickets = Incremental.rev_tickets inc in - let open Apply_results in - let tickets = - List.fold_left - (fun acc -> function - | No_operation_metadata -> assert false - | Operation_metadata {contents} -> - to_list (Contents_result_list contents) @ acc) - [] - tickets - |> List.rev - in - let new_contracts = - List.map - (function - | Contents_result - (Manager_operation_result - { - operation_result = - Applied (Origination_result {originated_contracts = [h]; _}); - _; - }) -> - h - | _ -> assert false) - tickets - in - (* Previous balance - (Credit (n * 10tz) + Origination cost (n tz)) *) - Test_tez.(cost_per_byte *? Int64.of_int origination_size) - >>?= fun origination_burn -> - Test_tez.(origination_burn *? Int64.of_int n) - >>?= fun origination_total_cost -> - Test_tez.( *? ) Op.dummy_script_cost 10L - >>? Test_tez.( +? ) (Test_tez.of_int (10 * n)) - >>? Test_tez.( +? ) origination_total_cost - >>?= fun total_cost -> - Assert.balance_was_debited ~loc:__LOC__ (I inc) c1 c1_old_balance total_cost - >>=? fun () -> - List.iter_es - (fun c -> - let c = Contract.Originated c in - Assert.balance_is ~loc:__LOC__ (I inc) c (Test_tez.of_int 10)) - new_contracts - -let expect_apply_failure = function - | Environment.Ecoproto_error err :: _ -> - Assert.test_error_encodings err ; - let error_info = - Error_monad.find_info_of_error (Environment.wrap_tzerror err) - in - if error_info.title = "Balance too low" then return_unit - else failwith "unexpected error" - | _ -> failwith "balance too low should fail" - -(** Groups three operations, the middle one failing. - Checks that the receipt is consistent. - Variant without fees. *) -let test_failing_operation_in_the_middle () = - Context.init2 () >>=? fun (blk, (c1, c2)) -> - Op.transaction ~gas_limit ~fee:Tez.zero (B blk) c1 c2 Tez.one >>=? fun op1 -> - Op.transaction ~gas_limit ~fee:Tez.zero (B blk) c1 c2 Test_tez.max_tez - >>=? fun op2 -> - Op.transaction ~gas_limit ~fee:Tez.zero (B blk) c1 c2 Tez.one >>=? fun op3 -> - let operations = [op1; op2; op3] in - Op.combine_operations ~source:c1 (B blk) operations >>=? fun operation -> - Incremental.begin_construction blk >>=? fun inc -> - Context.Contract.balance (I inc) c1 >>=? fun c1_old_balance -> - Context.Contract.balance (I inc) c2 >>=? fun c2_old_balance -> - Incremental.add_operation ~expect_apply_failure inc operation >>=? fun inc -> - let tickets = Incremental.rev_tickets inc in - let open Apply_results in - let tickets = - List.fold_left - (fun acc -> function - | No_operation_metadata -> assert false - | Operation_metadata {contents} -> - to_list (Contents_result_list contents) @ acc) - [] - tickets - in - (match tickets with - | Contents_result - (Manager_operation_result {operation_result = Backtracked _; _}) - :: Contents_result - (Manager_operation_result {operation_result = Failed (_, trace); _}) - :: Contents_result - (Manager_operation_result {operation_result = Skipped _; _}) - :: _ -> - let trace_string = - Format.asprintf "%a" Environment.Error_monad.pp_trace trace - in - let expect = - Format.asprintf "Balance of contract %a too low" Context.Contract.pp c1 - in - assert (Astring.String.is_infix ~affix:expect trace_string) - | _ -> assert false) ; - Assert.balance_is ~loc:__LOC__ (I inc) c1 c1_old_balance >>=? fun () -> - Assert.balance_is ~loc:__LOC__ (I inc) c2 c2_old_balance >>=? fun () -> - return_unit - -(** Groups three operations, the middle one failing. - Checks that the receipt is consistent. - Variant with fees, that should be spent even in case of failure. *) -let test_failing_operation_in_the_middle_with_fees () = - Context.init2 () >>=? fun (blk, (c1, c2)) -> - Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one >>=? fun op1 -> - Op.transaction ~fee:Tez.one (B blk) c1 c2 Test_tez.max_tez >>=? fun op2 -> - Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one >>=? fun op3 -> - let operations = [op1; op2; op3] in - Op.combine_operations ~source:c1 (B blk) operations >>=? fun operation -> - Incremental.begin_construction blk >>=? fun inc -> - Context.Contract.balance (I inc) c1 >>=? fun c1_old_balance -> - Context.Contract.balance (I inc) c2 >>=? fun c2_old_balance -> - Incremental.add_operation ~expect_apply_failure inc operation >>=? fun inc -> - let tickets = Incremental.rev_tickets inc in - let open Apply_results in - let tickets = - List.fold_left - (fun acc -> function - | No_operation_metadata -> assert false - | Operation_metadata {contents} -> - to_list (Contents_result_list contents) @ acc) - [] - tickets - in - (match tickets with - | Contents_result - (Manager_operation_result {operation_result = Backtracked _; _}) - :: Contents_result - (Manager_operation_result {operation_result = Failed (_, trace); _}) - :: Contents_result - (Manager_operation_result {operation_result = Skipped _; _}) - :: _ -> - let trace_string = - Format.asprintf "%a" Environment.Error_monad.pp_trace trace - in - let expect = - Format.asprintf "Balance of contract %a too low" Context.Contract.pp c1 - in - assert (Astring.String.is_infix ~affix:expect trace_string) - | _ -> assert false) ; - (* In the presence of a failure, all the fees are collected. Even for skipped operations. *) - Assert.balance_was_debited - ~loc:__LOC__ - (I inc) - c1 - c1_old_balance - (Test_tez.of_int 3) - >>=? fun () -> - Assert.balance_is ~loc:__LOC__ (I inc) c2 c2_old_balance >>=? fun () -> - return_unit - -let test_wrong_signature_in_the_middle () = - Context.init2 ~consensus_threshold:0 () >>=? fun (blk, (c1, c2)) -> - Op.transaction ~gas_limit ~fee:Tez.one (B blk) c1 c2 Tez.one >>=? fun op1 -> - Op.transaction ~gas_limit ~fee:Tez.one (B blk) c2 c1 Tez.one >>=? fun op2 -> - (* Make legit transfers, performing reveals *) - Block.bake ~operations:[op1; op2] blk >>=? fun b -> - (* Make c2 reach counter 5 *) - Op.transaction ~gas_limit ~fee:Tez.one (B b) c2 c1 Tez.one - >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - Op.transaction ~gas_limit ~fee:Tez.one (B b) c2 c1 Tez.one - >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - Op.transaction ~gas_limit ~fee:Tez.one (B b) c2 c1 Tez.one - >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - (* Cook transactions for actual test *) - Op.transaction ~gas_limit ~fee:Tez.one (B b) c1 c2 Tez.one >>=? fun op1 -> - Op.transaction ~gas_limit ~fee:Tez.one (B b) c1 c2 Tez.one >>=? fun op2 -> - Op.transaction ~gas_limit ~fee:Tez.one (B b) c1 c2 Tez.one >>=? fun op3 -> - Op.transaction ~gas_limit ~fee:Tez.one (B b) c2 c1 Tez.one - >>=? fun spurious_operation -> - let operations = [op1; op2; op3] in - - Op.combine_operations ~spurious_operation ~source:c1 (B b) operations - >>=? fun operation -> - let expect_failure = function - | Environment.Ecoproto_error - (Validate_errors.Manager.Inconsistent_sources as err) - :: _ -> - Assert.test_error_encodings err ; - return_unit - | _ -> - failwith - "Packed operation has invalid source in the middle : operation \ - expected to fail." - in - Incremental.begin_construction b >>=? fun inc -> - Incremental.add_operation ~expect_failure inc operation - >>=? fun (_inc : Incremental.t) -> return_unit - -let expect_inconsistent_counters list = - if - List.exists - (function - | Environment.Ecoproto_error - Validate_errors.Manager.Inconsistent_counters -> - true - | _ -> false) - list - then return_unit - else - failwith - "Packed operation has inconsistent counters : operation expected to fail \ - but got errors: %a." - Error_monad.pp_print_trace - list - -let test_inconsistent_counters () = - Context.init2 () >>=? fun (blk, (c1, c2)) -> - Op.transaction ~gas_limit ~fee:Tez.one (B blk) c1 c2 Tez.one >>=? fun op1 -> - Op.transaction ~gas_limit ~fee:Tez.one (B blk) c2 c1 Tez.one >>=? fun op2 -> - (* Make legit transfers, performing reveals *) - Block.bake ~operations:[op1; op2] blk >>=? fun b -> - (* Now, counter c1 = counter c2 = 1, Op.transaction builds with counter + 1 *) - Op.transaction - ~gas_limit - ~fee:Tez.one - (B b) - c1 - c2 - ~counter:(Manager_counter.Internal_for_tests.of_int 1) - Tez.one - >>=? fun op1 -> - Op.transaction - ~gas_limit - ~fee:Tez.one - (B b) - c1 - c2 - ~counter:(Manager_counter.Internal_for_tests.of_int 2) - Tez.one - >>=? fun op2 -> - Op.transaction - ~gas_limit - ~fee:Tez.one - (B b) - c1 - c2 - ~counter:(Manager_counter.Internal_for_tests.of_int 2) - (Tez.of_mutez_exn 5_000L) - >>=? fun op2' -> - Op.transaction - ~gas_limit - ~fee:Tez.one - (B b) - c1 - c2 - ~counter:(Manager_counter.Internal_for_tests.of_int 3) - Tez.one - >>=? fun op3 -> - Op.transaction - ~gas_limit - ~fee:Tez.one - (B b) - c1 - c2 - ~counter:(Manager_counter.Internal_for_tests.of_int 4) - Tez.one - >>=? fun op4 -> - (* Canari: Check counters are ok *) - Op.batch_operations ~source:c1 (B b) [op1; op2; op3; op4] >>=? fun op -> - Incremental.begin_construction b >>=? fun inc -> - Incremental.add_operation inc op >>=? fun (_ : Incremental.t) -> - (* Gap in counter in the following op *) - Op.batch_operations ~source:c1 (B b) [op1; op2; op4] >>=? fun op -> - Incremental.add_operation ~expect_failure:expect_inconsistent_counters inc op - >>=? fun (_ : Incremental.t) -> - (* Same counter used twice in the following op *) - Op.batch_operations ~source:c1 (B b) [op1; op2; op2'] >>=? fun op -> - Incremental.add_operation ~expect_failure:expect_inconsistent_counters inc op - >>=? fun (_ : Incremental.t) -> return_unit - -let tests = - [ - Tztest.tztest "multiple transfers" `Quick test_multiple_transfers; - Tztest.tztest - "multiple originations and delegations" - `Quick - test_multiple_origination_and_delegation; - Tztest.tztest - "Failing operation in the middle" - `Quick - test_failing_operation_in_the_middle; - Tztest.tztest - "Failing operation in the middle (with fees)" - `Quick - test_failing_operation_in_the_middle_with_fees; - Tztest.tztest - "Failing operation (wrong manager in the middle of a pack)" - `Quick - test_wrong_signature_in_the_middle; - Tztest.tztest - "Inconsistent counters in batch" - `Quick - test_inconsistent_counters; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("combined", tests)] |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_failing_noop.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_failing_noop.ml deleted file mode 100644 index 9a254c2f55fc24b70f04d6126e0880d29a869fd4..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_failing_noop.ml +++ /dev/null @@ -1,54 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 Metastate AG *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/operations/main.exe \ - -- --file test_failing_noop.ml - Subject: The Failing_noop operation was added bearing in mind the - possibility for the end user to sign arbitrary bytes, - encapsulate in the operation, with the absolute garanty that - the signed bytes can't be used for something against the - user's will. The Failing_noop operation always fails when - applied. - *) - -(** try to apply a failing_noop and assert that the operation fails *) -let failing_noop_must_fail_when_injected () = - Context.init1 () >>=? fun (blk, contract) -> - let source = Context.Contract.pkh contract in - Op.failing_noop (B blk) source "tezos" >>=? fun operation -> - Block.bake ~operation blk >>= fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Protocol.Validate_errors.Failing_noop_error -> true - | _ -> false) - -let tests = - [Tztest.tztest "injection fails" `Quick failing_noop_must_fail_when_injected] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("failling_noop operation", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_origination.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_origination.ml deleted file mode 100644 index f236fafb1fd75e9269d9070cd2930c8884ff93eb..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_origination.ml +++ /dev/null @@ -1,331 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (origination) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/operations/main.exe \ - -- --file test_origination.ml - Subject: On originating contracts. -*) - -open Protocol -open Alpha_context -open Test_tez - -let ten_tez = of_int 10 - -(* The possible fees are: a given credit, an origination burn fee - (constants_repr.default.origination_burn = 257 mtez), a fee that is paid when - creating an originate contract. *) -let total_fees_for_origination ?(fee = Tez.zero) ?(credit = Tez.zero) b = - Context.get_constants (B b) - >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} -> - cost_per_byte *? Int64.of_int origination_size >>?= fun origination_burn -> - credit +? fee >>? ( +? ) origination_burn >>? ( +? ) Op.dummy_script_cost - >>?= fun total_fee -> return total_fee - -(* [test_origination_balances fee credit spendable delegatable] takes four - optional parameter: fee is the fee that pay if require to create an - originated contract; credit is the amount of tez that will send to this - contract; delegatable default is set to true meaning that this contract is - able to delegate. - - This function creates 2 contracts, one for originating (called source) and - one for baking; get the balance of the source contract, call the - origination operation to create a new originated contract from this contract - with all the possible fees; and check the balance before/after originated - operation valid. - - the source contract has payed all the fees - - the originated has been credited correctly. - Note that we need 2 contracts because in Tenderbake the baker receives the - fees instantaneously. So to see that the fees are subtracted, we need that - the bake is done by another delegated. *) -let test_origination_balances ~loc:_ ?(fee = Tez.zero) ?(credit = Tez.zero) () = - Context.init2 () >>=? fun (b, (source, contract_for_bake)) -> - let pkh_for_orig = Context.Contract.pkh source in - let pkh_for_bake = Context.Contract.pkh contract_for_bake in - Op.contract_origination (B b) source ~fee ~credit ~script:Op.dummy_script - >>=? fun (operation, new_contract) -> - total_fees_for_origination ~fee ~credit b >>=? fun total_fee -> - Block.bake ~operation ~policy:(By_account pkh_for_bake) b >>=? fun b -> - (* check that after the block has been baked the contract for originating - was debited all the fees *) - Context.Delegate.current_frozen_deposits (B b) pkh_for_orig - >>=? fun deposits -> - total_fee +? deposits >>?= fun total_fee_plus_deposits -> - Assert.balance_was_debited - ~loc:__LOC__ - (B b) - source - Account.default_initial_balance - total_fee_plus_deposits - >>=? fun () -> - (* check the balance of the originate contract is equal to credit *) - Assert.balance_is ~loc:__LOC__ (B b) new_contract credit - -(** [register_origination fee credit spendable delegatable] takes four - optional parameter: fee for the fee need to be paid if set to - create an originated contract; credit is the amount of tez that - send to this originated contract; spendable default is set to true - meaning that this contract is spendable; delegatable default is - set to true meaning that this contract is able to delegate. *) -let register_origination ?(fee = Tez.zero) ?(credit = Tez.zero) () = - Context.init2 () >>=? fun (b, (source, contract_for_bake)) -> - let source_pkh = Context.Contract.pkh source in - let pkh_for_bake = Context.Contract.pkh contract_for_bake in - Op.contract_origination (B b) source ~fee ~credit ~script:Op.dummy_script - >>=? fun (operation, originated) -> - Block.bake ~operation ~policy:(By_account pkh_for_bake) b >>=? fun b -> - (* fee + credit were debited from source *) - total_fees_for_origination ~fee ~credit b >>=? fun total_fee -> - Context.Delegate.current_frozen_deposits (B b) source_pkh >>=? fun deposits -> - total_fee +? deposits >>?= fun total_fee_plus_deposits -> - Assert.balance_was_debited - ~loc:__LOC__ - (B b) - source - Account.default_initial_balance - total_fee_plus_deposits - >>=? fun () -> - (* originated contract has been credited *) - Assert.balance_was_credited ~loc:__LOC__ (B b) originated Tez.zero credit - >|=? fun () -> - (* TODO spendable or not and delegatable or not if relevant for some - test. Not the case at the moment, cf. uses of - register_origination *) - (b, source, originated) - -(******************************************************) -(* Tests *) -(******************************************************) - -(** Basic test. A contract is created as well as the newly originated - contract (called from origination operation). The balance - before/after are checked. *) -let test_balances_simple () = test_origination_balances ~loc:__LOC__ () - -(** Same as [balances_simple] but credits 10 tez to the originated - contract (no fees). *) -let test_balances_credit () = - test_origination_balances ~loc:__LOC__ ~credit:ten_tez () - -(** Same as [balances_credit] with 10 tez fees. *) -let test_balances_credit_fee () = - test_origination_balances ~loc:__LOC__ ~credit:(of_int 2) ~fee:ten_tez () - -(** Ask source contract to pay a fee when originating a contract. *) -let test_pay_fee () = - register_origination ~credit:(of_int 2) ~fee:ten_tez () - >>=? fun (_b, _contract, _new_contract) -> return_unit - -(******************************************************) -(** Errors *) - -(******************************************************) - -(** Create an originate contract where the contract does not have - enough tez to pay for the fee. *) -let test_not_tez_in_contract_to_pay_fee () = - Context.init2 ~consensus_threshold:0 () - >>=? fun (b, (contract_1, contract_2)) -> - (* transfer everything but one tez from 1 to 2 and check balance of 1 *) - Context.Contract.balance (B b) contract_1 >>=? fun balance -> - balance -? Tez.one >>?= fun amount -> - Op.transaction (B b) contract_1 contract_2 amount >>=? fun operation -> - let pkh1 = Context.Contract.pkh contract_1 in - Block.bake ~policy:(Excluding [pkh1]) ~operation b >>=? fun b -> - Assert.balance_was_debited ~loc:__LOC__ (B b) contract_1 balance amount - >>=? fun () -> - (* use this source contract to create an originate contract where it requires - to pay a fee and add an amount of credit into this new contract *) - Op.contract_origination - (B b) - ~fee:ten_tez - ~credit:Tez.one - contract_1 - ~script:Op.dummy_script - >>=? fun (op, _) -> - Incremental.begin_construction b >>=? fun inc -> - Incremental.add_operation inc op >>= fun inc -> - Assert.proto_error_with_info ~loc:__LOC__ inc "Balance too low" - -(* Set the endorser of the block as manager/delegate of the originated - account. *) -let register_contract_get_endorser () = - Context.init1 () >>=? fun (b, contract) -> - Incremental.begin_construction b >>=? fun inc -> - Context.get_endorser (I inc) >|=? fun (account_endorser, _slots) -> - (inc, contract, account_endorser) - -(* Create multiple originated contracts and ask contract to pay the fee. *) -let n_originations n ?credit ?fee () = - List.fold_left_es - (fun new_contracts _ -> - register_origination ?fee ?credit () - >|=? fun (_b, _source, new_contract) -> new_contract :: new_contracts) - [] - (1 -- n) - -(** Create 100 originations. *) -let test_multiple_originations () = - n_originations 100 ~credit:(of_int 2) ~fee:ten_tez () >>=? fun contracts -> - Assert.equal_int ~loc:__LOC__ (List.length contracts) 100 - -(** Cannot originate two contracts with the same context's counter. *) -let test_counter () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, contract) -> - Op.contract_origination (B b) ~credit:Tez.one contract ~script:Op.dummy_script - >>=? fun (op1, _) -> - Op.contract_origination (B b) ~credit:Tez.one contract ~script:Op.dummy_script - >>=? fun (op2, _) -> - Block.bake ~operation:op1 b >>=? fun b -> - Incremental.begin_construction b >>=? fun inc -> - Incremental.add_operation inc op2 >>= fun res -> - Assert.proto_error_with_info - ~loc:__LOC__ - res - "Invalid counter (already used) in a manager operation" - -let test_unparsable_script () = - let open Lwt_result_syntax in - let* b, contract = Context.init1 ~consensus_threshold:0 () in - let open Alpha_context in - (* Craft an ill-typed origination's contract. *) - let pkh = - match contract with Implicit pkh -> pkh | Originated _ -> assert false - in - let dummy_expr = - Script.lazy_expr - Environment.Micheline.(strip_locations (Int ((), Z.of_int 123))) - in - let script = Script.{code = dummy_expr; storage = dummy_expr} in - let origination = Origination {delegate = None; script; credit = Tez.one} in - let gas_limit = - Gas.Arith.integral_of_int_exn - (49_000 - + Michelson_v1_gas.Internal_for_tests.int_cost_of_manager_operation) - in - let op = - Contents_list - (Single - (Manager_operation - { - source = pkh; - fee = Tez.one; - counter = Manager_counter.Internal_for_tests.of_int 1; - operation = origination; - gas_limit; - storage_limit = Z.zero; - })) - in - let encoded_op = - Data_encoding.Binary.to_bytes_exn Operation.contents_list_encoding op - |> Bytes.to_string - in - let* account = Account.find pkh in - let ill_typed_op = - Data_encoding.Binary.of_string_exn - Operation.contents_list_encoding - encoded_op - |> Op.sign account.sk (Context.branch (B b)) - in - (* Ensure that the application fails with [Ill_typed_contract]. *) - let* i = Incremental.begin_construction b in - let* (_i : Incremental.t) = - Incremental.add_operation - ~expect_apply_failure:(function - | Environment.Ecoproto_error (Script_tc_errors.Ill_typed_contract _) - :: _ -> - return_unit - | trace -> - failwith - "Expected error trace [Ill_typed_contract], but got:@\n%a" - pp_print_trace - trace) - i - ill_typed_op - in - (* Craft an unparsable lazy expr. *) - let encoded_dummy_expr = - let b = - Data_encoding.Binary.to_bytes_exn Script.lazy_expr_encoding dummy_expr - in - assert (Hex.to_bytes_exn (`Hex "0000000300bb01") = b) ; - Bytes.to_string b - in - let unparsable_dummy_expr = - Hex.to_bytes_exn (`Hex "00000003ffffff") |> Bytes.to_string - in - let unparsable_operation = - let encoded_bad_op = - Re.( - replace_string - ~all:true - (compile (str encoded_dummy_expr)) - encoded_op - ~by:unparsable_dummy_expr) - in - Data_encoding.Binary.of_string_exn - Operation.contents_list_encoding - encoded_bad_op - |> Op.sign account.sk (Context.branch (B b)) - in - (* Ensure that the operation is valid but the application fails with - [Lazy_script_decode]. *) - let* (_i : Incremental.t) = - Incremental.add_operation - ~expect_apply_failure:(function - | [Environment.Ecoproto_error Script.Lazy_script_decode] -> return_unit - | trace -> - failwith - "Expected error trace [Lazy_script_decode], but got:@\n%a" - pp_print_trace - trace) - i - unparsable_operation - in - return_unit - -(******************************************************) - -let tests = - [ - Tztest.tztest "balances_simple" `Quick test_balances_simple; - Tztest.tztest "balances_credit" `Quick test_balances_credit; - Tztest.tztest "balances_credit_fee" `Quick test_balances_credit_fee; - Tztest.tztest "pay_fee" `Quick test_pay_fee; - Tztest.tztest - "not enough tez in contract to pay fee" - `Quick - test_not_tez_in_contract_to_pay_fee; - Tztest.tztest "multiple originations" `Quick test_multiple_originations; - Tztest.tztest "counter" `Quick test_counter; - Tztest.tztest "unparsable script" `Quick test_unparsable_script; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("origination", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_paid_storage_increase.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_paid_storage_increase.ml deleted file mode 100644 index 73401e05237faf3c781b111669b7475dcab312bc..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_paid_storage_increase.ml +++ /dev/null @@ -1,250 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (increase_paid_storage) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/operations/main.exe \ - -- --file test_paid_storage_increase.ml - Subject: On increasing a paid amount of contract storage. -*) - -open Protocol -open Alpha_context - -let ten_tez = Test_tez.of_int 10 - -let dummy_script = - "{parameter unit; storage unit; code { CAR ; NIL operation ; PAIR }}" - -let contract_originate block ?(script = dummy_script) - ?(storage = Expr.from_string "Unit") account = - let open Lwt_result_syntax in - let code = Expr.from_string script in - let script = - Alpha_context.Script.{code = lazy_expr code; storage = lazy_expr storage} - in - let source_contract = account in - let baker = Context.Contract.pkh account in - let* op, dst = - Op.contract_origination_hash (B block) source_contract ~fee:Tez.zero ~script - in - let* inc = - Incremental.begin_construction ~policy:Block.(By_account baker) block - in - let* inc = Incremental.add_operation inc op in - let+ b = Incremental.finalize_block inc in - (b, dst) - -(** [test_balances] runs a simple [increase_paid_storage] and verifies that the - source contract balance is correct and that the storage of the - destination contract has been increased by the right amount. *) -let test_balances ~amount = - let open Lwt_result_syntax in - let* b, source = Context.init1 () in - let* b, destination = contract_originate b source in - let* inc = Incremental.begin_construction b in - let* balance_before_op = Context.Contract.balance (I inc) source in - let contract_dst = Contract.Originated destination in - let*! storage_before_op = - Contract.Internal_for_tests.paid_storage_space - (Incremental.alpha_ctxt inc) - contract_dst - in - let* storage_before_op = - Lwt.return (Environment.wrap_tzresult storage_before_op) - in - let* op = - Op.increase_paid_storage ~fee:Tez.zero (I inc) ~source ~destination amount - in - let* inc = Incremental.add_operation inc op in - (* check that after the block has been baked, the source was debited of all - the burned tez *) - let* {parametric = {cost_per_byte; _}; _} = Context.get_constants (I inc) in - let burned_tez = Tez.mul_exn cost_per_byte (Z.to_int amount) in - let* () = - Assert.balance_was_debited - ~loc:__LOC__ - (I inc) - source - balance_before_op - burned_tez - in - (* check that the storage has been increased by the right amount *) - let*! storage = - Contract.Internal_for_tests.paid_storage_space - (Incremental.alpha_ctxt inc) - contract_dst - in - let* storage = Lwt.return (Environment.wrap_tzresult storage) in - let storage_minus_amount = Z.sub storage amount in - Assert.equal_int - ~loc:__LOC__ - (Z.to_int storage_before_op) - (Z.to_int storage_minus_amount) - -(******************************************************) -(* Tests *) -(******************************************************) - -(** Basic test. We test balances in simple cases. *) -let test_balances_simple () = test_balances ~amount:(Z.of_int 100) - -(******************************************************) -(* Errors *) -(******************************************************) - -(** We test the operation when the amount given is null. *) -let test_null_amount () = - let open Lwt_result_syntax in - let*! result = test_balances ~amount:Z.zero in - Assert.proto_error ~loc:__LOC__ result (function - | Fees_storage.Negative_storage_input -> true - | _ -> false) - -(** We test the operation when the amount given is negative. *) -let test_negative_amount () = - let open Lwt_result_syntax in - let amount = Z.of_int (-10) in - let*! result = test_balances ~amount in - Assert.proto_error ~loc:__LOC__ result (function - | Fees_storage.Negative_storage_input -> true - | _ -> false) - -(** We create an implicit account with not enough tez to pay for the - storage increase. *) -let test_no_tez_to_pay () = - let open Lwt_result_syntax in - let* b, (source, baker, receiver) = Context.init3 ~consensus_threshold:0 () in - let* b, destination = contract_originate b source in - let pkh_for_bake = Context.Contract.pkh baker in - let* inc = - Incremental.begin_construction ~policy:Block.(By_account pkh_for_bake) b - in - let* {parametric = {cost_per_byte; _}; _} = Context.get_constants (I inc) in - let increase_amount = - Z.div (Z.of_int 2_000_000) (Z.of_int64 (Tez.to_mutez cost_per_byte)) - in - let* balance = Context.Contract.balance (I inc) source in - let*? tez_to_substract = Test_tez.(balance -? Tez.one) in - let* op = - Op.transaction (I inc) ~fee:Tez.zero source receiver tez_to_substract - in - let* inc = Incremental.add_operation inc op in - let* b = Incremental.finalize_block inc in - let* inc = - Incremental.begin_construction ~policy:Block.(By_account pkh_for_bake) b - in - let* op = - Op.increase_paid_storage (I inc) ~source ~destination increase_amount - in - let*! inc = Incremental.add_operation inc op in - Assert.proto_error ~loc:__LOC__ inc (function - | Fees_storage.Cannot_pay_storage_fee -> true - | _ -> false) - -(** To test when there is no smart contract at the address given. *) -let test_no_contract () = - let open Lwt_result_syntax in - let* b, source = Context.init1 () in - let* inc = Incremental.begin_construction b in - let destination = Contract_helpers.fake_KT1 in - let* op = Op.increase_paid_storage (I inc) ~source ~destination Z.zero in - let*! inc = Incremental.add_operation inc op in - Assert.proto_error ~loc:__LOC__ inc (function - | Raw_context.Storage_error (Missing_key (_, Raw_context.Get)) -> true - | _ -> false) - -(** To test if the increase in storage is effective. *) -let test_effectiveness () = - let open Lwt_result_syntax in - let* b, (source, _contract_source) = - Context.init2 ~consensus_threshold:0 () - in - let script = - "{parameter unit; storage int; code { CDR ; PUSH int 65536 ; MUL ; NIL \ - operation ; PAIR }}" - in - let storage = - Tezos_micheline.Micheline.strip_locations (Expr_common.int Z.one) - in - let* b, destination = contract_originate ~script ~storage b source in - let* inc = Incremental.begin_construction b in - (* We ensure that the transaction can't be made with a 0 burn cap. *) - let contract_dst = Contract.Originated destination in - let* op = - Op.transaction - ~storage_limit:Z.zero - ~fee:Tez.zero - (I inc) - source - contract_dst - Tez.zero - in - let*! inc_test = Incremental.add_operation inc op in - let* () = - Assert.proto_error ~loc:__LOC__ inc_test (function - | Fees.Operation_quota_exceeded -> true - | _ -> false) - in - let* b = Incremental.finalize_block inc in - let* inc = Incremental.begin_construction b in - let* op = - Op.increase_paid_storage - (I inc) - ~fee:Tez.zero - ~source - ~destination - (Z.of_int 10) - in - let* inc = Incremental.add_operation inc op in - let* b = Incremental.finalize_block inc in - let* inc = Incremental.begin_construction b in - (* We test the same transaction to see if increase_paid_storage worked. *) - let* op = - Op.transaction - ~storage_limit:Z.zero - ~fee:Tez.zero - (I inc) - source - contract_dst - Tez.zero - in - let+ (_inc : Incremental.t) = Incremental.add_operation inc op in - () - -let tests = - [ - Tztest.tztest "balances simple" `Quick test_balances_simple; - Tztest.tztest "null amount" `Quick test_null_amount; - Tztest.tztest "negative amount" `Quick test_negative_amount; - Tztest.tztest "not enough tez to pay" `Quick test_no_tez_to_pay; - Tztest.tztest "no contract to bump its paid storage" `Quick test_no_contract; - Tztest.tztest "effectiveness" `Quick test_effectiveness; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("paid storage increase", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_reveal.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_reveal.ml deleted file mode 100644 index 71c61091d4c6fd8771a89f38cadd5f539d5498c8..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_reveal.ml +++ /dev/null @@ -1,752 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020-2022 Nomadic Labs. *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (revelation) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/operations/main.exe \ - -- --file test_reveal.ml - Subject: On the reveal operation. -*) - -(** Protocol integration tests for the [Reveal] operation. *) - -open Protocol -open Alpha_context -open Test_tez - -let ten_tez = of_int 10 - -let test_simple_reveal () = - Context.init1 ~consensus_threshold:0 () >>=? fun (blk, c) -> - let new_c = Account.new_account () in - let new_contract = Alpha_context.Contract.Implicit new_c.pkh in - (* Create the contract *) - Op.transaction (B blk) c new_contract Tez.one >>=? fun operation -> - Block.bake blk ~operation >>=? fun blk -> - (Context.Contract.is_manager_key_revealed (B blk) new_contract >|=? function - | true -> Stdlib.failwith "Unexpected revelation" - | false -> ()) - >>=? fun () -> - (* Reveal the contract *) - Op.revelation (B blk) new_c.pk >>=? fun operation -> - Block.bake blk ~operation >>=? fun blk -> - Context.Contract.is_manager_key_revealed (B blk) new_contract >|=? function - | true -> () - | false -> Stdlib.failwith "New contract revelation failed." - -let test_empty_account_on_reveal () = - Context.init1 ~consensus_threshold:0 () >>=? fun (blk, c) -> - let new_c = Account.new_account () in - let new_contract = Alpha_context.Contract.Implicit new_c.pkh in - let amount = Tez.one_mutez in - (* Create the contract *) - Op.transaction (B blk) c new_contract amount >>=? fun operation -> - Block.bake blk ~operation >>=? fun blk -> - (Context.Contract.is_manager_key_revealed (B blk) new_contract >|=? function - | true -> Stdlib.failwith "Unexpected revelation: expecting fresh pkh" - | false -> ()) - >>=? fun () -> - (* Reveal the contract *) - Op.revelation ~fee:amount (B blk) new_c.pk >>=? fun operation -> - Incremental.begin_construction blk >>=? fun inc -> - let expect_apply_failure = function - | [ - Environment.Ecoproto_error (Contract_storage.Empty_implicit_contract pkh); - ] - when pkh = new_c.pkh -> - return_unit - | _ -> assert false - in - Incremental.add_operation ~expect_apply_failure inc operation >>=? fun inc -> - Context.Contract.balance (I inc) new_contract >>=? fun balance -> - Assert.equal_tez ~loc:__LOC__ balance Tez.zero >>=? fun () -> - Context.Contract.is_manager_key_revealed (I inc) new_contract >|=? function - | false -> () - | true -> Stdlib.failwith "Empty account still exists and is revealed." - -let test_not_enough_funds_for_reveal () = - Context.init1 () >>=? fun (blk, c) -> - let new_c = Account.new_account () in - let new_contract = Alpha_context.Contract.Implicit new_c.pkh in - (* Create the contract *) - Op.transaction (B blk) c new_contract Tez.one_mutez >>=? fun operation -> - Block.bake blk ~operation >>=? fun blk -> - (Context.Contract.is_manager_key_revealed (B blk) new_contract >|=? function - | true -> Stdlib.failwith "Unexpected revelation" - | false -> ()) - >>=? fun () -> - (* Reveal the contract *) - Op.revelation ~fee:Tez.fifty_cents (B blk) new_c.pk >>=? fun operation -> - Block.bake blk ~operation >>= fun res -> - Assert.proto_error_with_info ~loc:__LOC__ res "Balance too low" - -let test_transfer_fees_emptying_after_reveal_batched () = - Context.init1 () >>=? fun (blk, c) -> - let new_c = Account.new_account () in - let new_contract = Alpha_context.Contract.Implicit new_c.pkh in - (* Create the contract *) - Op.transaction (B blk) c new_contract Tez.one >>=? fun operation -> - Block.bake blk ~operation >>=? fun blk -> - Incremental.begin_construction blk >>=? fun inc -> - Op.revelation ~fee:Tez.zero (I inc) new_c.pk >>=? fun reveal -> - Incremental.add_operation inc reveal >>=? fun tmp_inc -> - Op.transaction ~fee:Tez.one (I tmp_inc) new_contract c Tez.one - >>=? fun transaction -> - Op.batch_operations ~source:new_contract (I inc) [reveal; transaction] - >>=? fun op -> - let expect_apply_failure = function - | [ - Environment.Ecoproto_error (Contract_storage.Empty_implicit_contract pkh); - ] - when pkh = new_c.pkh -> - return_unit - | _ -> assert false - in - Incremental.add_operation ~expect_apply_failure inc op - >>=? fun (_inc : Incremental.t) -> return_unit - -(* We assert that the changes introduced in !5182, splitting the - application of Reveal operations into a pre-checking and - an application phase, do not allow to forge dishonest revelations. *) -let test_reveal_with_fake_account () = - Context.init1 ~consensus_threshold:0 () >>=? fun (blk, bootstrap) -> - (* Create two fresh, unrevealed, accounts a and b. *) - let account_a = Account.new_account () in - let a_pkh = account_a.pkh in - let a_contract = Contract.Implicit a_pkh in - let account_b = Account.new_account () in - let b_pkh = account_b.pkh in - let b_contract = Contract.Implicit b_pkh in - (* Assert a and b are fresh.*) - (* TODO tezos/tezos#2996 - - These preambles are too verbose and boilerplate. We should factor - out revealing fresh unrevealed accounts. *) - when_ (Signature.Public_key_hash.equal a_pkh b_pkh) (fun () -> - failwith - "Expected different pkhs: got %a %a" - Signature.Public_key_hash.pp - a_pkh - Signature.Public_key_hash.pp - b_pkh) - >>=? fun () -> - Op.transaction (B blk) bootstrap a_contract Tez.one >>=? fun oa -> - Op.transaction (B blk) bootstrap b_contract Tez.one >>=? fun ob -> - Op.batch_operations - ~recompute_counters:true - ~source:bootstrap - (B blk) - [oa; ob] - >>=? fun batch -> - Block.bake blk ~operation:batch >>=? fun b -> - (Context.Contract.is_manager_key_revealed (B blk) a_contract >|=? function - | true -> Stdlib.failwith "Unexpected revelation: expected fresh pkh" - | false -> ()) - >>=? fun () -> - (Context.Contract.is_manager_key_revealed (B blk) b_contract >|=? function - | true -> Stdlib.failwith "Unexpected revelation: expected fresh pkh" - | false -> ()) - >>=? fun () -> - (* get initial balance of account_a *) - Context.Contract.balance (B b) a_contract >>=? fun a_balance_before -> - (* We will attempt to forge a reveal with a fake account that - impersonates account_a but uses account_b's public and secret - keys, e.g. - - fake_a = Account.{pkh = account_a.pkh; pk = account_b.pk; sk = - account_b.sk} - - and we will attempt to reveal the public key of b with a's - pkh. This operation should fail without updating account_a's - balance *) - Op.revelation ~fee:Tez.one_mutez ~forge_pkh:(Some a_pkh) (B b) account_b.pk - >>=? fun operation -> - Incremental.begin_construction b >>=? fun i -> - Incremental.add_operation - ~expect_failure:(function - | [ - Environment.Ecoproto_error - (Contract_manager_storage.Inconsistent_hash _); - ] -> - return_unit - | errs -> - failwith - "Expected an Contract_manager_storage.Inconsistent_hash error but \ - got %a" - Error_monad.pp_print_trace - errs) - i - operation - >>=? fun i -> - Context.Contract.balance (I i) a_contract >>=? fun a_balance_after -> - unless (Tez.equal a_balance_after a_balance_before) (fun () -> - failwith - "Balance of contract_a should have not changed: expected %atz, got %atz" - Tez.pp - a_balance_before - Tez.pp - a_balance_after) - -(* On the following test, we create an account a, fund it, reveal it, - and get its balance. Then we attempt to forge a reveal for another - account b, using a's pkh. *) -let test_reveal_with_fake_account_already_revealed () = - Context.init1 ~consensus_threshold:0 () >>=? fun (blk, bootstrap) -> - (* Create two fresh, unrevealed, accounts a and b. *) - let account_a = Account.new_account () in - let a_pkh = account_a.pkh in - let a_contract = Contract.Implicit a_pkh in - let account_b = Account.new_account () in - let b_pkh = account_b.pkh in - let b_contract = Contract.Implicit b_pkh in - (* Assert a and b are fresh.*) - (* TODO tezos/tezos#2996 - - These preambles are too verbose and boilerplate. We should factor - out revealing fresh unrevealed accounts. *) - when_ (Signature.Public_key_hash.equal a_pkh b_pkh) (fun () -> - failwith - "Expected different pkhs: got %a %a" - Signature.Public_key_hash.pp - a_pkh - Signature.Public_key_hash.pp - b_pkh) - >>=? fun () -> - Op.transaction (B blk) bootstrap a_contract Tez.one >>=? fun oa -> - Op.transaction (B blk) bootstrap b_contract Tez.one >>=? fun ob -> - Op.batch_operations - ~recompute_counters:true - ~source:bootstrap - (B blk) - [oa; ob] - >>=? fun batch -> - Block.bake blk ~operation:batch >>=? fun b -> - (Context.Contract.is_manager_key_revealed (B blk) a_contract >|=? function - | true -> Stdlib.failwith "Unexpected revelation: expected fresh pkh" - | false -> ()) - >>=? fun () -> - (Context.Contract.is_manager_key_revealed (B blk) b_contract >|=? function - | true -> Stdlib.failwith "Unexpected revelation: expected fresh pkh" - | false -> ()) - >>=? fun () -> - (* We first reveal a in a block *) - Op.revelation ~fee:Tez.one_mutez (B b) account_a.pk >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - Context.Contract.balance (B b) a_contract >>=? fun a_balance_before -> - (* Reveal the public key of b while impersonating account_a. This - operation should fail without updating account_a's balance *) - Op.revelation ~fee:Tez.one_mutez ~forge_pkh:(Some a_pkh) (B b) account_b.pk - >>=? fun operation -> - Incremental.begin_construction b >>=? fun i -> - Incremental.add_operation - ~expect_failure:(function - | [ - Environment.Ecoproto_error - (Contract_manager_storage.Inconsistent_hash _); - ] -> - return_unit - | errs -> - failwith - "Expected a Previously_revealed_key error but got %a" - Error_monad.pp_print_trace - errs) - i - operation - >>=? fun i -> - Context.Contract.balance (I i) a_contract >>=? fun a_balance_after -> - unless (Tez.equal a_balance_after a_balance_before) (fun () -> - failwith - "Balance of contract_a should have not changed: expected %atz, got %atz" - Tez.pp - a_balance_before - Tez.pp - a_balance_after) - -(* cf: #2386 - - On tezos/tezos!5182 we have reverted the behaviour implemented by - tezos/tezos!587, which explicitly avoided marking reveal operations - as backtracked to reflect the fact that a reveal in a failing batch - did still take effect (cf #338). - - We test that backtracked reveals stay backtracked. *) -let test_backtracked_reveal_in_batch () = - Context.init1 ~consensus_threshold:0 () >>=? fun (blk, c) -> - let new_c = Account.new_account () in - let new_contract = Contract.Implicit new_c.pkh in - (* Create the contract *) - Op.transaction (B blk) c new_contract Tez.one >>=? fun operation -> - Block.bake blk ~operation >>=? fun blk -> - (Context.Contract.is_manager_key_revealed (B blk) new_contract >|=? function - | true -> Stdlib.failwith "Unexpected revelation: expected fresh pkh" - | false -> ()) - >>=? fun () -> - Incremental.begin_construction blk >>=? fun inc -> - Op.revelation ~fee:Tez.zero (I inc) new_c.pk >>=? fun op_reveal -> - Op.transaction - ~force_reveal:false - ~fee:Tez.zero - (I inc) - new_contract - new_contract - (Tez.of_mutez_exn 1_000_001L) - >>=? fun op_transfer -> - Op.batch_operations - ~recompute_counters:true - ~source:new_contract - (I inc) - [op_reveal; op_transfer] - >>=? fun batched_operation -> - let expect_apply_failure = function - | [ - Environment.Ecoproto_error (Contract_storage.Balance_too_low _); - Environment.Ecoproto_error (Tez_repr.Subtraction_underflow _); - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - Incremental.add_operation ~expect_apply_failure inc batched_operation - >>=? fun inc -> - (* We assert the manager key is still unrevealed, as the batch has failed *) - Context.Contract.is_manager_key_revealed (I inc) new_contract - >>=? fun revelead -> - when_ revelead (fun () -> - failwith "Unexpected contract revelation: reveal was expected to fail") - -(* Asserts that re-revealing an already revealed manager will make the - whole batch fail. *) -let test_already_revealed_manager_in_batch () = - Context.init1 ~consensus_threshold:0 () >>=? fun (blk, c) -> - let new_c = Account.new_account () in - let new_contract = Contract.Implicit new_c.pkh in - (* Create the contract *) - Op.transaction (B blk) c new_contract Tez.one >>=? fun operation -> - Block.bake blk ~operation >>=? fun blk -> - (Context.Contract.is_manager_key_revealed (B blk) new_contract >|=? function - | true -> Stdlib.failwith "Unexpected revelation: expecting fresh pkh" - | false -> ()) - >>=? fun () -> - (* Reveal the contract *) - Op.revelation (B blk) new_c.pk >>=? fun operation -> - Block.bake blk ~operation >>=? fun blk -> - (* We pack a correct batch of operations attempting to re-reveal the contract *) - Incremental.begin_construction blk >>=? fun inc -> - Op.revelation ~fee:Tez.zero (I inc) new_c.pk >>=? fun op_reveal -> - Op.transaction - ~force_reveal:false - ~fee:Tez.zero - (I inc) - new_contract - new_contract - (Tez.of_mutez_exn 1_000_001L) - >>=? fun op_transfer -> - Op.batch_operations - ~recompute_counters:true - ~source:new_contract - (B blk) - [op_reveal; op_transfer] - >>=? fun batched_operation -> - let expect_apply_failure = function - | [ - Environment.Ecoproto_error - (Contract_manager_storage.Previously_revealed_key _); - ] -> - return_unit - | _ -> assert false - in - Incremental.add_operation ~expect_apply_failure inc batched_operation - >>=? fun inc -> - (* We assert the manager key is still revealed. *) - Context.Contract.is_manager_key_revealed (I inc) new_contract - >>=? fun revelead -> - unless revelead (fun () -> - Stdlib.failwith - "Unexpected unrevelation: failing batch shouldn't unreveal the manager") - -(* cf: #2386 - - We imitate the behaviour of - - https://tzkt.io/ooSocfx3xxzDo7eFyGu6ZDR1svzMrbaJtBikQanXXhwrqMuWfGz - - which provides evidence of a failing reveal with a gas exhaustion - error due to an incorrect gas limit of 0, which still takes effect - as witnessed by the subsequent (reveal-less) transfer - - https://tzkt.io/opBQQJQ5senPP5v8PfPFf4uVQqKRE5RVjbwx8uD4SqeRs2JGcVw - - This showcases a bad separation of concerns between pre-checking - and the application of manager operations per-se within - [Protocol.Apply.apply_operation]. The situation originated because - [precheck_manager_contents_lists] would reveal the manager by - calling [Protocol.Alpha_context.Contract.reveal_manager_key] before - [prepare_apply_manager_operation_content] has consumed the declared - gas. - - With !5182 we have fixed this situation by revealing the manager - contract at application time. The following test isolates the - failing reveal and asserts that the manager is not revealed after - the failing op. - - As of !5506, the reveal operation does not pass precheck - anyway. Unfortunately, this means that this test has lost some of - its original purpose. Fortunately, {!test_empty_account_on_reveal} - offers a similar scenario to what this test was supposed to do: a - reveal fails during application and we check that the contract is - not revealed afterward. *) -let test_no_reveal_when_gas_exhausted () = - Context.init1 ~consensus_threshold:0 () >>=? fun (blk, c) -> - let new_c = Account.new_account () in - let new_contract = Contract.Implicit new_c.pkh in - (* Fund the contract with a sufficient balance *) - Op.transaction (B blk) c new_contract (Tez.of_mutez_exn 1_000L) - >>=? fun operation -> - (* Create the contract *) - Block.bake blk ~operation >>=? fun blk -> - (* Assert that the account has not been revealed yet *) - (Context.Contract.is_manager_key_revealed (B blk) new_contract >|=? function - | true -> Stdlib.failwith "Unexpected revelation: expected fresh pkh" - | false -> ()) - >>=? fun () -> - (* We craft a new (bad) reveal operation with a 0 gas_limit *) - Op.revelation ~fee:Tez.zero ~gas_limit:Zero (B blk) new_c.pk >>=? fun op -> - Incremental.begin_construction blk >>=? fun inc -> - (* The application of this operation is expected to fail with a - {! Protocol.Raw_context.Operation_quota_exceeded} error *) - let expect_failure = function - | [ - Environment.Ecoproto_error - Validate_errors.Manager.Insufficient_gas_for_manager; - Environment.Ecoproto_error Raw_context.Operation_quota_exceeded; - ] -> - return_unit - | _ -> assert false - in - Incremental.add_operation ~expect_failure inc op >>=? fun inc -> - (* We assert the manager key is still unrevealed, as the operation has failed *) - Context.Contract.is_manager_key_revealed (I inc) new_contract - >>=? fun revelead -> - when_ revelead (fun () -> - failwith "Unexpected revelation: reveal operation failed") - -(* Fix #2774 - - We test that reveals can only succeed if they are placed at the - first position in a batch of manager operations, and that moreover - reveal operations occur uniquely in batches. - - - First, [test_reveal_incorrect_position_in_batch] asserts that a - [[transfer; reveal]] batch where a valid reveal follows another - valid op (different from a reveal, so here a transfer) fails with - an [Apply.Incorrect_reveal_position] error. - - - Second, we test a batch consisting of duplicate (potentially) - valid reveal operations. We assert the second reveal to fail again - with an [Apply.Incorrect_reveal_position] error, and for the first - reveal to be backtracked. - - - Then, we test batches with duplicate reveals which follow a - failing one and we assert again the second reveal fails skipped. We - do this for the 3 different reasons a well-placed reveal might fail - (as tested above): gas exhaustion, insolvency, and emptying the - balance while revealing. -*) -let test_reveal_incorrect_position_in_batch () = - Context.init1 ~consensus_threshold:0 () >>=? fun (blk, c) -> - let new_c = Account.new_account () in - let new_contract = Contract.Implicit new_c.pkh in - (* Create the contract *) - Op.transaction (B blk) c new_contract Tez.one >>=? fun operation -> - Block.bake blk ~operation >>=? fun blk -> - (Context.Contract.is_manager_key_revealed (B blk) new_contract >|=? function - | true -> Stdlib.failwith "Unexpected revelation: expected fresh pkh" - | false -> ()) - >>=? fun () -> - Incremental.begin_construction blk >>=? fun inc -> - Op.transaction - ~force_reveal:false - ~fee:Tez.zero - (I inc) - new_contract - new_contract - (Tez.of_mutez_exn 1L) - >>=? fun op_transfer -> - Op.revelation ~fee:Tez.zero (I inc) new_c.pk >>=? fun op_reveal -> - Op.batch_operations - ~recompute_counters:true - ~source:new_contract - (I inc) - [op_transfer; op_reveal] - >>=? fun batched_operation -> - let expect_failure = function - | [ - Environment.Ecoproto_error - Validate_errors.Manager.Incorrect_reveal_position; - ] -> - return_unit - | _ -> assert false - in - Incremental.add_operation ~expect_failure inc batched_operation - >>=? fun inc -> - (* We assert the manager key is still unrevealed, as the operation has failed *) - Context.Contract.is_manager_key_revealed (I inc) new_contract - >>=? fun revelead -> - when_ revelead (fun () -> - failwith "Unexpected revelation: reveal operation was expected to fail") - -(* Test that a batch [reveal pk; reveal pk] where the first reveal - succeeds but the second one results in the second one failing, and - then first reveal being backtracked. *) -let test_duplicate_valid_reveals () = - Context.init1 ~consensus_threshold:0 () >>=? fun (blk, c) -> - let new_c = Account.new_account () in - let new_contract = Contract.Implicit new_c.pkh in - (* Create the contract *) - Op.transaction (B blk) c new_contract Tez.one >>=? fun operation -> - Block.bake blk ~operation >>=? fun blk -> - (Context.Contract.is_manager_key_revealed (B blk) new_contract >|=? function - | true -> Stdlib.failwith "Unexpected revelation: expected fresh pkh" - | false -> ()) - >>=? fun () -> - Incremental.begin_construction blk >>=? fun inc -> - Op.revelation ~fee:Tez.zero (I inc) new_c.pk >>=? fun op_rev1 -> - Op.revelation ~fee:Tez.zero (I inc) new_c.pk >>=? fun op_rev2 -> - Op.batch_operations - ~recompute_counters:true - ~source:new_contract - (I inc) - [op_rev1; op_rev2] - >>=? fun batched_operation -> - let expect_failure = function - | [ - Environment.Ecoproto_error - Validate_errors.Manager.Incorrect_reveal_position; - ] -> - return_unit - | _ -> assert false - in - Incremental.add_operation ~expect_failure inc batched_operation - >>=? fun inc -> - (* We assert the manager key is still unrevealed, as the operation has failed *) - Context.Contract.is_manager_key_revealed (I inc) new_contract - >>=? fun revelead -> - when_ revelead (fun () -> - failwith "Unexpected contract revelation: backtracking expected") - -(* Test that a batch [failed_reveal pk; reveal pk] where the first - reveal fails with a gas exhaustion results in the second one - failing due to not being well-placed at the beginnning of the - batch. *) -let test_valid_reveal_after_gas_exhausted_one () = - Context.init1 ~consensus_threshold:0 () >>=? fun (blk, c) -> - let new_c = Account.new_account () in - let new_contract = Contract.Implicit new_c.pkh in - (* Create the contract *) - Op.transaction (B blk) c new_contract Tez.one >>=? fun operation -> - Block.bake blk ~operation >>=? fun blk -> - (Context.Contract.is_manager_key_revealed (B blk) new_contract >|=? function - | true -> Stdlib.failwith "Unexpected revelation: expected fresh pkh" - | false -> ()) - >>=? fun () -> - Incremental.begin_construction blk >>=? fun inc -> - (* We first craft a (bad) reveal operation with a 0 gas_limit *) - Op.revelation ~fee:Tez.zero ~gas_limit:Zero (B blk) new_c.pk - >>=? fun bad_reveal -> - (* While the second is a valid one *) - Op.revelation ~fee:Tez.zero (I inc) new_c.pk >>=? fun good_reveal -> - Op.batch_operations - ~recompute_counters:true - ~source:new_contract - (I inc) - [bad_reveal; good_reveal] - >>=? fun batched_operation -> - let expect_failure = function - | [ - Environment.Ecoproto_error - Validate_errors.Manager.Incorrect_reveal_position; - ] -> - return_unit - | _ -> assert false - in - Incremental.add_operation ~expect_failure inc batched_operation - >>=? fun inc -> - (* We assert the manager key is still unrevealed, as the batch has failed *) - Context.Contract.is_manager_key_revealed (I inc) new_contract - >>=? fun revelead -> - when_ revelead (fun () -> - failwith "Unexpected contract revelation: no valid reveal in batch") - -(* Test that a batch [failed_reveal pk; reveal pk; transfer] where the - first reveal fails with insufficient funds results in the second - one failing due to not being well-placed at the beginnning of the - batch. We add the trailing transfer to ensure covering all branches - of `check_batch_tail_sanity` in `find_manager_public_key` when - calling {!Apply.check_manager_signature} to verify the manager's pk - while processing the second reveal. *) -let test_valid_reveal_after_insolvent_one () = - Context.init1 ~consensus_threshold:0 () >>=? fun (blk, c) -> - let new_c = Account.new_account () in - let new_contract = Contract.Implicit new_c.pkh in - (* Create the contract *) - Op.transaction (B blk) c new_contract Tez.one >>=? fun operation -> - Block.bake blk ~operation >>=? fun blk -> - (Context.Contract.is_manager_key_revealed (B blk) new_contract >|=? function - | true -> Stdlib.failwith "Unexpected revelation: expected fresh pkh" - | false -> ()) - >>=? fun () -> - Incremental.begin_construction blk >>=? fun inc -> - (* We first craft an insolvent reveal operation *) - Op.revelation ~fee:ten_tez (B blk) new_c.pk >>=? fun bad_reveal -> - (* While the second is a free valid one *) - Op.revelation ~fee:Tez.zero (I inc) new_c.pk >>=? fun good_reveal -> - Op.transaction ~fee:Tez.zero (I inc) new_contract c Tez.one - >>=? fun transfer -> - Op.batch_operations - ~recompute_counters:true - ~source:new_contract - (I inc) - [bad_reveal; good_reveal; transfer] - >>=? fun batched_operation -> - let expect_failure = function - | [ - Environment.Ecoproto_error - Validate_errors.Manager.Incorrect_reveal_position; - ] -> - return_unit - | _ -> assert false - in - Incremental.add_operation ~expect_failure inc batched_operation - >>=? fun inc -> - (* We assert the manager key is still unrevealed, as the batch has failed *) - Context.Contract.is_manager_key_revealed (I inc) new_contract - >>=? fun revelead -> - when_ revelead (fun () -> - failwith "Unexpected contract revelation: no valid reveal in batch") - -(* Test that a batch [failed_reveal pk; reveal pk] where the first - reveal fails with insufficient funds results in the second one - failing due to not being well-placed at the beginnning of the - batch. *) -let test_valid_reveal_after_emptying_balance () = - Context.init1 ~consensus_threshold:0 () >>=? fun (blk, c) -> - let new_c = Account.new_account () in - let new_contract = Contract.Implicit new_c.pkh in - let amount = Tez.one_mutez in - (* Create the contract *) - Op.transaction (B blk) c new_contract amount >>=? fun operation -> - Block.bake blk ~operation >>=? fun blk -> - (Context.Contract.is_manager_key_revealed (B blk) new_contract >|=? function - | true -> Stdlib.failwith "Unexpected revelation" - | false -> ()) - >>=? fun () -> - Incremental.begin_construction blk >>=? fun inc -> - (* Reveal the contract, spending all its balance in fees *) - Op.revelation ~fee:amount (B blk) new_c.pk >>=? fun bad_reveal -> - (* While the second is a free valid one *) - Op.revelation ~fee:Tez.zero (I inc) new_c.pk >>=? fun good_reveal -> - Op.batch_operations - ~recompute_counters:true - ~source:new_contract - (I inc) - [bad_reveal; good_reveal] - >>=? fun batched_operation -> - let expect_failure = function - | [ - Environment.Ecoproto_error - Validate_errors.Manager.Incorrect_reveal_position; - ] -> - return_unit - | _ -> assert false - in - Incremental.add_operation ~expect_failure inc batched_operation - >>=? fun inc -> - (* We assert the manager key is still unrevealed, as the batch has failed *) - Context.Contract.is_manager_key_revealed (I inc) new_contract - >>=? fun revelead -> - when_ revelead (fun () -> - failwith "Unexpected contract revelation: no valid reveal in batch") - -let tests = - [ - Tztest.tztest "simple reveal" `Quick test_simple_reveal; - Tztest.tztest "empty account on reveal" `Quick test_empty_account_on_reveal; - Tztest.tztest - "not enough funds for reveal" - `Quick - test_not_enough_funds_for_reveal; - Tztest.tztest - "transfer fees emptying balance after reveal in batch" - `Quick - test_transfer_fees_emptying_after_reveal_batched; - Tztest.tztest - "cannot forge reveal with fake keys and signature" - `Quick - test_reveal_with_fake_account; - Tztest.tztest - "cannot re-reveal an account with fake keys and signature" - `Quick - test_reveal_with_fake_account_already_revealed; - Tztest.tztest - "a backtracked reveal in a batch doesn't take effect" - `Quick - test_backtracked_reveal_in_batch; - Tztest.tztest - "cannot re-reveal a manager in a batch" - `Quick - test_already_revealed_manager_in_batch; - Tztest.tztest - "do not reveal when gas exhausted" - `Quick - test_no_reveal_when_gas_exhausted; - Tztest.tztest - "incorrect reveal position in batch" - `Quick - test_reveal_incorrect_position_in_batch; - Tztest.tztest - "cannot duplicate valid reveals in batch" - `Quick - test_duplicate_valid_reveals; - Tztest.tztest - "cannot batch a good reveal after a gas-exhausted one" - `Quick - test_valid_reveal_after_gas_exhausted_one; - Tztest.tztest - "cannot batch a good reveal after an insolvent one" - `Quick - test_valid_reveal_after_insolvent_one; - Tztest.tztest - "cannot batch a good reveal after one emptying account" - `Quick - test_valid_reveal_after_emptying_balance; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("revelation", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_sc_rollup.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_sc_rollup.ml deleted file mode 100644 index cd0d4d50cd3d0aaeaf581b0417095eaca0f3ec6f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_sc_rollup.ml +++ /dev/null @@ -1,3558 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* Copyright (c) 2022 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Rollup layer 1 logic - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/operations/main.exe \ - -- --file test_sc_rollup.ml - Subject: Test smart contract rollup -*) - -open Protocol -open Alpha_context - -exception Sc_rollup_test_error of string - -let err x = Exn (Sc_rollup_test_error x) - -let assert_fails ~loc ?error m = - let open Lwt_result_syntax in - let*! res = m in - match res with - | Ok _ -> Stdlib.failwith "Expected failure" - | Error err_res -> ( - match (err_res, error) with - | Environment.Ecoproto_error err' :: _, Some err when err = err' -> - (* Matched exact error. *) - return_unit - | Environment.Ecoproto_error err' :: _, Some err -> - let msg = - Format.asprintf - "Expected error [%a] but got [%a] at location %s" - Environment.Error_monad.pp - err' - Environment.Error_monad.pp - err - loc - in - Stdlib.failwith msg - | _, Some _ -> - (* Expected a different error. *) - let msg = - Printf.sprintf "Expected a different error at location %s" loc - in - Stdlib.failwith msg - | _, None -> - (* Any error is ok. *) - return ()) - -let assert_equal_z ~loc x y = - Assert.equal ~loc Z.equal "Compare Z.t" Z.pp_print x y - -let get_game_status_result incr = - match Incremental.rev_tickets incr with - | [] -> - Stdlib.failwith - "Failed to find an applied operation result in the metadata" - | operations -> ( - List.find_map - (function - | Apply_results.Operation_metadata - { - contents = - Single_result - (Manager_operation_result - {operation_result = Applied op; _}); - } -> ( - match op with - | Sc_rollup_refute_result {game_status; _} -> - Some (game_status, `Refute) - | Sc_rollup_timeout_result {game_status; _} -> - Some (game_status, `Timeout) - | _ -> None) - | _ -> None) - operations - |> function - | None -> - Stdlib.failwith - "No operation [Sc_rollup_refute_result] or \ - [Sc_rollup_timeout_result] found" - | Some x -> x) - -let assert_equal_game_status ?game_status actual_game_status = - match game_status with - | None -> return_unit - | Some game_status -> - if game_status = actual_game_status then return_unit - else - let msg = - Format.asprintf - "Expected game status [%a] but got [%a]" - Sc_rollup.Game.pp_status - game_status - Sc_rollup.Game.pp_status - actual_game_status - in - Stdlib.failwith msg - -let assert_refute_result ?game_status incr = - let actual_game_status, op_type = get_game_status_result incr in - assert (op_type = `Refute) ; - assert_equal_game_status ?game_status actual_game_status - -let assert_timeout_result ?game_status incr = - let actual_game_status, op_type = get_game_status_result incr in - assert (op_type = `Timeout) ; - assert_equal_game_status ?game_status actual_game_status - -let bake_timeout_period ?timeout_period_in_blocks block = - let open Lwt_result_syntax in - let* timeout_period_in_blocks = - match timeout_period_in_blocks with - | Some v -> return v - | None -> - let* constants = Context.get_constants (B block) in - let Constants.Parametric.{timeout_period_in_blocks; _} = - constants.parametric.sc_rollup - in - return timeout_period_in_blocks - in - Block.bake_n timeout_period_in_blocks block - -(** [context_init tup] initializes a context and returns the created - context and contracts. *) -let context_init ?(sc_rollup_challenge_window_in_blocks = 10) - ?(timeout_period_in_blocks = 10) ?hard_gas_limit_per_operation - ?hard_gas_limit_per_block tup = - Context.init_with_constants_gen - tup - { - Context.default_test_constants with - consensus_threshold = 0; - hard_gas_limit_per_operation = - Option.value - hard_gas_limit_per_operation - ~default:Context.default_test_constants.hard_gas_limit_per_operation; - hard_gas_limit_per_block = - Option.value - hard_gas_limit_per_block - ~default:Context.default_test_constants.hard_gas_limit_per_block; - sc_rollup = - { - Context.default_test_constants.sc_rollup with - enable = true; - arith_pvm_enable = true; - challenge_window_in_blocks = sc_rollup_challenge_window_in_blocks; - timeout_period_in_blocks; - }; - } - -(** [test_disable_feature_flag ()] tries to originate a smart contract - rollup when the feature flag is deactivated and checks that it - fails. *) -let test_disable_feature_flag () = - let open Lwt_result_syntax in - let* b, contract = Context.init1 ~sc_rollup_enable:false () in - let* i = Incremental.begin_construction b in - let kind = Sc_rollup.Kind.Example_arith in - let* op, _ = Sc_rollup_helpers.origination_op (B b) contract kind in - let expect_failure = function - | Environment.Ecoproto_error - (Validate_errors.Manager.Sc_rollup_feature_disabled as e) - :: _ -> - Assert.test_error_encodings e ; - return_unit - | _ -> failwith "It should have failed with [Sc_rollup_feature_disabled]" - in - let* (_ : Incremental.t) = Incremental.add_operation ~expect_failure i op in - return_unit - -(** [test_disable_arith_pvm_feature_flag ()] tries to originate a Arith smart - rollup when the Arith PVM feature flag is deactivated and checks that it - fails. *) -let test_disable_arith_pvm_feature_flag () = - let open Lwt_result_syntax in - let* b, contract = Context.init1 ~sc_rollup_arith_pvm_enable:false () in - let* i = Incremental.begin_construction b in - let kind = Sc_rollup.Kind.Example_arith in - let* op, _ = Sc_rollup_helpers.origination_op (B b) contract kind in - let expect_failure = function - | Environment.Ecoproto_error - (Validate_errors.Manager.Sc_rollup_arith_pvm_disabled as e) - :: _ -> - Assert.test_error_encodings e ; - return_unit - | _ -> failwith "It should have failed with [Sc_rollup_feature_disabled]" - in - let* (_ : Incremental.t) = Incremental.add_operation ~expect_failure i op in - return_unit - -(** Initializes the context and originates a SCORU. *) -let sc_originate ?boot_sector ?origination_proof ?parameters_ty block contract = - let open Lwt_result_syntax in - let kind = Sc_rollup.Kind.Example_arith in - let* operation, rollup = - Sc_rollup_helpers.origination_op - ?boot_sector - ?origination_proof - ?parameters_ty - (B block) - contract - kind - in - let* incr = Incremental.begin_construction block in - let* incr = Incremental.add_operation incr operation in - let* block = Incremental.finalize_block incr in - return (block, rollup) - -(** Initializes the context and originates a SCORU. *) -let init_and_originate ?boot_sector ?origination_proof ?parameters_ty - ?sc_rollup_challenge_window_in_blocks tup = - let open Lwt_result_syntax in - let* block, contracts = - context_init ?sc_rollup_challenge_window_in_blocks tup - in - let contract = Context.tup_hd tup contracts in - let* block, rollup = - sc_originate ?boot_sector ?origination_proof ?parameters_ty block contract - in - return (block, contracts, rollup) - -let number_of_ticks_exn n = - match Sc_rollup.Number_of_ticks.of_value n with - | Some x -> x - | None -> Stdlib.failwith "Bad Number_of_ticks" - -let next_inbox_level ?predecessor ctxt rollup = - let open Lwt_result_syntax in - let* genesis_info = Context.Sc_rollup.genesis_info ctxt rollup in - let+ constants = Context.get_constants ctxt in - let commitment_freq = - constants.parametric.sc_rollup.commitment_period_in_blocks - in - let pred_level = - Option.fold - ~none:genesis_info.level - ~some:(fun pred -> pred.Sc_rollup.Commitment.inbox_level) - predecessor - in - Raw_level.Internal_for_tests.add pred_level commitment_freq - -let dummy_commitment ?predecessor ?compressed_state ?(number_of_ticks = 3000L) - ?inbox_level ctxt rollup = - let open Lwt_result_syntax in - let* genesis_info = Context.Sc_rollup.genesis_info ctxt rollup in - let predecessor_hash = - match predecessor with - | Some pred -> Sc_rollup.Commitment.hash_uncarbonated pred - | None -> genesis_info.commitment_hash - in - let* compressed_state = - match compressed_state with - | None -> - let* {compressed_state; _} = - Context.Sc_rollup.commitment ctxt rollup predecessor_hash - in - return compressed_state - | Some compressed_state -> return compressed_state - in - let* inbox_level = - match inbox_level with - | Some inbox_level -> return inbox_level - | None -> next_inbox_level ?predecessor ctxt rollup - in - return - Sc_rollup.Commitment. - { - predecessor = predecessor_hash; - inbox_level; - number_of_ticks = number_of_ticks_exn number_of_ticks; - compressed_state; - } - -(* Bakes blocks to satisfy requirement of next_commitment.inbox_level <= current_level *) -let bake_blocks_until_next_inbox_level ?predecessor block rollup = - let open Lwt_result_syntax in - let* next_level = next_inbox_level ?predecessor (B block) rollup in - Block.bake_until_level next_level block - -let bake_blocks_until_inbox_level block commitment = - Block.bake_until_level commitment.Sc_rollup.Commitment.inbox_level block - -let publish_op_and_dummy_commitment ~src ?compressed_state ?predecessor rollup - block = - let open Lwt_result_syntax in - let compressed_state = - Option.map - (fun s -> - Sc_rollup.State_hash.context_hash_to_state_hash - (Context_hash.hash_string [s])) - compressed_state - in - let* commitment = - dummy_commitment ?compressed_state ?predecessor (B block) rollup - in - let* publish = Op.sc_rollup_publish (B block) src rollup commitment in - return (publish, commitment) - -(* Verify that parameters and unparsed parameters match. *) -let verify_params ctxt ~parameters_ty ~parameters ~unparsed_parameters = - let open Lwt_result_wrap_syntax in - let show exp = Expr.to_string @@ exp in - let unparse ctxt parameters = - Script_ir_translator.unparse_data - ctxt - Script_ir_unparser.Optimized - parameters_ty - parameters - in - let*@ unparsed_parameters, ctxt = - (* Make sure we can parse the unparsed-parameters with the given parameters - type. *) - let* parsed_unparsed_parameters, ctxt = - Script_ir_translator.parse_data - ctxt - ~elab_conf:Script_ir_translator_config.(make ~legacy:true ()) - ~allow_forged:true - parameters_ty - (Environment.Micheline.root unparsed_parameters) - in - (* Un-parse again to get back to Micheline. *) - unparse ctxt parsed_unparsed_parameters - in - (* Un-parse the parsed parameters. *) - let*@ expected_unparsed_parameters, _ctxt = unparse ctxt parameters in - (* Verify that both version match. *) - Assert.equal_string - ~loc:__LOC__ - (show unparsed_parameters) - (show expected_unparsed_parameters) - -(* Verify that the given list of transactions and transaction operations match. - Also checks each transaction operation for type mismatches etc. *) -let verify_execute_outbox_message_operations incr rollup ~loc ~operations - ~expected_transactions = - let open Lwt_result_wrap_syntax in - let ctxt = Incremental.alpha_ctxt incr in - let validate_and_extract_operation_params ctxt op = - match op with - | Script_typed_ir.Internal_operation - { - source = op_source; - operation = - Transaction_to_smart_contract - { - destination; - amount; - entrypoint; - location = _; - parameters_ty; - parameters; - unparsed_parameters; - }; - nonce = _; - } -> - (* Check that the parameters match. *) - let* () = - verify_params ctxt ~parameters_ty ~parameters ~unparsed_parameters - in - let* () = - (* Check that the sources match. *) - Assert.equal_string - ~loc - (Destination.to_b58check (Sc_rollup rollup)) - (Destination.to_b58check op_source) - in - (* Assert that the amount is 0. *) - let* () = Assert.equal_tez ~loc amount Tez.zero in - (* Load the arg-type and entrypoints of the destination script. *) - let* ( Script_ir_translator.Ex_script (Script {arg_type; entrypoints; _}), - ctxt ) = - let*@ ctxt, _cache_key, cached = Script_cache.find ctxt destination in - match cached with - | Some (_script, ex_script) -> return (ex_script, ctxt) - | None -> failwith "Could not load script at %s" loc - in - (* Find the script parameters ty of the script. *) - let*? entrypoint_res, ctxt = - Environment.wrap_tzresult - (Gas_monad.run - ctxt - (Script_ir_translator.find_entrypoint - ~error_details:(Informative ()) - arg_type - entrypoints - entrypoint)) - in - let*? (Ex_ty_cstr {ty = script_parameters_ty; _}) = - Environment.wrap_tzresult entrypoint_res - in - (* Check that the script parameters type matches the one from the - transaction. *) - let*? ctxt = - Environment.wrap_tzresult - (let open Result_syntax in - let* eq, ctxt = - Gas_monad.run - ctxt - (Script_ir_translator.ty_eq - ~error_details:(Informative (-1)) - script_parameters_ty - parameters_ty) - in - let+ Eq = eq in - ctxt) - in - return (ctxt, (destination, entrypoint, unparsed_parameters)) - | _ -> - failwith - "Expected an internal transaction operation to a smart-contract, \ - called from %s" - loc - in - let* _ctxt, operations_data = - List.fold_left_map_es validate_and_extract_operation_params ctxt operations - in - let compare_data (d1, e1, p1) (d2, e2, p2) = - Contract_hash.equal d1 d2 - && Entrypoint_repr.(e1 = e2) - && String.equal (Expr.to_string p1) (Expr.to_string p2) - in - let pp_data fmt (d, e, p) = - Format.fprintf - fmt - "(%a, %a, %s)" - Contract_hash.pp - d - Entrypoint_repr.pp - e - (Expr.to_string p) - in - let transactions_data = - let data_of_transaction (contract, entrypoint, params) = - let params = Expr.from_string params in - (contract, entrypoint, params) - in - List.map data_of_transaction expected_transactions - in - Assert.assert_equal_list - ~loc - compare_data - "Compare operations data" - pp_data - operations_data - transactions_data - -(* Helper function to create output used for executing outbox messages. *) -let make_output ~outbox_level ~message_index transactions = - let transactions = - List.map - (fun (destination, entrypoint, parameters) -> - let unparsed_parameters = Expr.from_string parameters in - {Sc_rollup.Outbox.Message.unparsed_parameters; destination; entrypoint}) - transactions - in - let message = - Sc_rollup.Outbox.Message.Atomic_transaction_batch {transactions} - in - let outbox_level = Raw_level.of_int32_exn (Int32.of_int outbox_level) in - let message_index = Z.of_int message_index in - Sc_rollup.{outbox_level; message_index; message} - -let string_ticket_token ticketer content = - let open Lwt_result_syntax in - let contents = - Result.value_f ~default:(fun _ -> assert false) - @@ Script_string.of_string content - in - let*? ticketer = Environment.wrap_tzresult @@ Contract.of_b58check ticketer in - return - (Ticket_token.Ex_token - {ticketer; contents_type = Script_typed_ir.string_t; contents}) - -let originate_contract incr ~script ~baker ~storage ~source_contract = - let open Lwt_result_syntax in - let* block = Incremental.finalize_block incr in - let* contract, _, block = - Contract_helpers.originate_contract_from_string_hash - ~script - ~storage - ~source_contract - ~baker - block - in - let* incr = Incremental.begin_construction block in - return (contract, incr) - -let hash_commitment incr commitment = - let open Result_syntax in - let ctxt = Incremental.alpha_ctxt incr in - let+ ctxt, hash = Sc_rollup.Commitment.hash ctxt commitment in - (Incremental.set_alpha_ctxt incr ctxt, hash) - -let publish_commitment incr staker rollup commitment = - let open Lwt_result_syntax in - let* incr = - if - (Incremental.header incr).Block_header.shell.level - < Raw_level.to_int32 commitment.Sc_rollup.Commitment.inbox_level - then - let* block = Incremental.finalize_block incr in - let* block = bake_blocks_until_inbox_level block commitment in - Incremental.begin_construction block - else return incr - in - let* operation = Op.sc_rollup_publish (I incr) staker rollup commitment in - let* incr = Incremental.add_operation incr operation in - Incremental.finalize_block incr - -let publish_commitments block staker rollup commitments = - List.fold_left_es - (fun block commitment -> - let open Lwt_result_syntax in - let* incr = Incremental.begin_construction block in - publish_commitment incr staker rollup commitment) - block - commitments - -let cement_commitment ?challenge_window_in_blocks block rollup staker hash = - let open Lwt_result_syntax in - let* challenge_window_in_blocks = - match challenge_window_in_blocks with - | Some x -> return x - | None -> - let* constants = Context.get_constants (B block) in - return constants.parametric.sc_rollup.challenge_window_in_blocks - in - let* block = Block.bake_n challenge_window_in_blocks block in - let* cement = Op.sc_rollup_cement (B block) staker rollup hash in - Block.bake ~operation:cement block - -let cement_commitments ?challenge_window_in_blocks block rollup staker hashes = - List.fold_left_es - (fun block hash -> - cement_commitment ?challenge_window_in_blocks block rollup staker hash) - block - hashes - -let publish_and_cement_commitment incr ~baker ~originator rollup commitment = - let open Lwt_result_wrap_syntax in - let* block = publish_commitment incr originator rollup commitment in - let* constants = Context.get_constants (B block) in - let* block = - Block.bake_n constants.parametric.sc_rollup.challenge_window_in_blocks block - in - let* incr = - Incremental.begin_construction ~policy:Block.(By_account baker) block - in - let*?@ incr, hash = hash_commitment incr commitment in - let* cement_op = Op.sc_rollup_cement (I incr) originator rollup hash in - let* incr = Incremental.add_operation incr cement_op in - let* block = Incremental.finalize_block incr in - let* incr = - Incremental.begin_construction ~policy:Block.(By_account baker) block - in - return (hash, incr) - -let publish_and_cement_commitments incr ~baker ~originator rollup commitments = - let open Lwt_result_syntax in - List.fold_left_es - (fun incr commitment -> - let* _hash, incr = - publish_and_cement_commitment incr ~baker ~originator rollup commitment - in - return incr) - incr - commitments - -let publish_and_cement_dummy_commitment incr ~baker ~originator rollup = - let open Lwt_result_syntax in - let* commitment = dummy_commitment (I incr) rollup in - publish_and_cement_commitment incr ~baker ~originator rollup commitment - -(* Publishes repeated cemented commitments until a commitment with - [inbox_level >= min_inbox_level] is found (such a commitment - is also published and cemented). *) -let publish_commitments_until_min_inbox_level incr rollup ~baker ~originator - ~min_inbox_level ~cemented_commitment_hash ~cemented_commitment = - let rec aux incr hash ({Sc_rollup.Commitment.inbox_level; _} as commitment) = - let open Lwt_result_syntax in - let level = Raw_level.to_int32 inbox_level in - if level >= Int32.of_int min_inbox_level then return (hash, incr) - else - let* commitment = - dummy_commitment ~predecessor:commitment (I incr) rollup - in - let* hash, incr = - publish_and_cement_commitment incr ~baker ~originator rollup commitment - in - aux incr hash commitment - in - aux incr cemented_commitment_hash cemented_commitment - -let adjust_ticket_token_balance_of_rollup ctxt rollup ticket_token ~delta = - let open Lwt_result_syntax in - let* incr = - Context.( - match ctxt with - | I incr -> return incr - | B block -> Incremental.begin_construction block) - in - let alpha_ctxt = Incremental.alpha_ctxt incr in - let* hash, alpha_ctxt = - Ticket_helpers.adjust_ticket_token_balance - alpha_ctxt - (Destination.Sc_rollup rollup) - ticket_token - ~delta - in - let incr = Incremental.set_alpha_ctxt incr alpha_ctxt in - return (hash, incr) - -(** A version of execute outbox message that output ignores proof validation. *) -let execute_outbox_message_without_proof_validation incr rollup - ~cemented_commitment outbox_message = - let open Lwt_result_wrap_syntax in - let*@ res, ctxt = - Sc_rollup_operations.Internal_for_tests.execute_outbox_message - (Incremental.alpha_ctxt incr) - ~validate_and_decode_output_proof: - (fun ctxt ~cemented_commitment:_ _rollup ~output_proof:_ -> - return (outbox_message, ctxt)) - rollup - ~cemented_commitment - ~output_proof:"Not used" - in - return (res, Incremental.set_alpha_ctxt incr ctxt) - -let execute_outbox_message incr ~originator rollup ~output_proof - ~commitment_hash = - let open Lwt_result_syntax in - let* batch_op = - Op.sc_rollup_execute_outbox_message - (I incr) - originator - rollup - commitment_hash - ~output_proof - in - let* incr = Incremental.add_operation incr batch_op in - let* block = Incremental.finalize_block incr in - Incremental.begin_construction block - -let assert_ticket_token_balance ~loc incr token owner expected = - let open Lwt_result_wrap_syntax in - let ctxt = Incremental.alpha_ctxt incr in - let*@ balance, _ = - let* key_hash, ctxt = Ticket_balance_key.of_ex_token ctxt ~owner token in - Ticket_balance.get_balance ctxt key_hash - in - match (balance, expected) with - | Some b, Some e -> Assert.equal_int ~loc (Z.to_int b) e - | Some b, None -> - failwith "%s: Expected no balance but got some %d" loc (Z.to_int b) - | None, Some b -> failwith "%s: Expected balance %d but got none" loc b - | None, None -> return () - -(** Assert that the computation fails with the given message. *) -let assert_fails_with ~__LOC__ k expected_err = - let open Lwt_result_syntax in - let*! res = k in - Assert.proto_error ~loc:__LOC__ res (( = ) expected_err) - -type balances = {liquid : Tez.t; frozen : Tez.t} - -let balances ctxt contract = - let open Lwt_result_syntax in - let* liquid = Context.Contract.balance ctxt contract in - let* frozen = Context.Contract.frozen_bonds ctxt contract in - return {liquid; frozen} - -let check_balances_evolution bal_before {liquid; frozen} ~action = - let open Lwt_result_wrap_syntax in - let* {liquid = expected_liquid; frozen = expected_frozen} = - match action with - | `Freeze amount -> - let*?@ liquid = Tez.( -? ) bal_before.liquid amount in - let*?@ frozen = Tez.( +? ) bal_before.frozen amount in - return {liquid; frozen} - | `Unfreeze amount -> - let*?@ liquid = Tez.( +? ) bal_before.liquid amount in - let*?@ frozen = Tez.( -? ) bal_before.frozen amount in - return {liquid; frozen} - in - let* () = Assert.equal_tez ~loc:__LOC__ expected_liquid liquid in - let* () = Assert.equal_tez ~loc:__LOC__ expected_frozen frozen in - return () - -(* Generates a list of cemented dummy commitments. *) -let gen_commitments incr rollup ~predecessor ~num_commitments = - let open Lwt_result_syntax in - let* constants = Context.get_constants (I incr) in - let delta = constants.parametric.sc_rollup.commitment_period_in_blocks in - let rec aux predecessor n acc = - if n <= 0 then return (List.rev acc) - else - let inbox_level = - Raw_level.Internal_for_tests.add - predecessor.Sc_rollup.Commitment.inbox_level - delta - in - let* commitment = - dummy_commitment - ~predecessor - ~inbox_level - ~compressed_state:predecessor.compressed_state - (I incr) - rollup - in - let hash = Sc_rollup.Commitment.hash_uncarbonated commitment in - aux commitment (n - 1) ((commitment, hash) :: acc) - in - aux predecessor num_commitments [] - -let attempt_to_recover_bond i contract ?staker rollup = - let open Lwt_result_syntax in - (* Recover its own bond by default. *) - let staker = - match staker with - | Some staker -> staker - | None -> ( - match contract with - | Contract.Implicit staker -> staker - | _ -> assert false) - in - let* recover_bond_op = - Op.sc_rollup_recover_bond (I i) contract rollup staker - in - let* i = Incremental.add_operation i recover_bond_op in - let* b = Incremental.finalize_block i in - return b - -let recover_bond_not_lcc i contract rollup = - assert_fails_with - ~__LOC__ - (attempt_to_recover_bond i contract rollup) - Sc_rollup_errors.Sc_rollup_not_staked_on_lcc_or_ancestor - -let recover_bond_not_staked i contract rollup = - assert_fails_with - ~__LOC__ - (attempt_to_recover_bond i contract rollup) - Sc_rollup_errors.Sc_rollup_not_staked - -let recover_bond_with_success i contract rollup = - let open Lwt_result_syntax in - let* bal_before = balances (I i) contract in - let* b = attempt_to_recover_bond i contract rollup in - let* bal_after = balances (B b) contract in - let* constants = Context.get_constants (I i) in - let* () = - check_balances_evolution - bal_before - bal_after - ~action:(`Unfreeze constants.parametric.sc_rollup.stake_amount) - in - return b - -(** [test_publish_cement_and_recover_bond] creates a rollup, publishes a - commitment and then [challenge_window_in_blocks] blocks later cements - that commitment. - The comitter tries to withdraw stake before and after cementing. Only the - second attempt is expected to succeed. *) -let test_publish_cement_and_recover_bond () = - let open Lwt_result_wrap_syntax in - let* block, contracts, rollup = init_and_originate Context.T2 in - let _, contract = contracts in - let* block = bake_blocks_until_next_inbox_level block rollup in - let* i = Incremental.begin_construction block in - (* not staked yet *) - let* () = recover_bond_not_staked i contract rollup in - let* c = dummy_commitment (I i) rollup in - let* operation = Op.sc_rollup_publish (B block) contract rollup c in - let* i = Incremental.add_operation i operation in - let* b = Incremental.finalize_block i in - let* constants = Context.get_constants (B b) in - let* b = - Block.bake_n constants.parametric.sc_rollup.challenge_window_in_blocks b - in - let* i = Incremental.begin_construction b in - let*?@ i, hash = hash_commitment i c in - (* stake not on LCC *) - let* () = recover_bond_not_lcc i contract rollup in - let* cement_op = Op.sc_rollup_cement (I i) contract rollup hash in - let* i = Incremental.add_operation i cement_op in - let* b = Incremental.finalize_block i in - let* i = - let pkh = - (* We forbid the stake owner from baker to correctly check the unfrozen - amount below. *) - match contract with Implicit pkh -> pkh | Originated _ -> assert false - in - Incremental.begin_construction b ~policy:(Excluding [pkh]) - in - (* recover bond should succeed *) - let* b = recover_bond_with_success i contract rollup in - let* i = Incremental.begin_construction b in - (* not staked anymore *) - let* () = recover_bond_not_staked i contract rollup in - return_unit - -(** [test_publish_fails_on_double_stake] creates a rollup and then - publishes two different commitments with the same staker. We check - that the second publish fails. *) -let test_publish_fails_on_double_stake () = - let open Lwt_result_syntax in - let* ctxt, contracts, rollup = init_and_originate Context.T2 in - let* ctxt = bake_blocks_until_next_inbox_level ctxt rollup in - let _, contract = contracts in - let* i = Incremental.begin_construction ctxt in - let* commitment1 = dummy_commitment (I i) rollup in - let commitment2 = - {commitment1 with number_of_ticks = number_of_ticks_exn 3001L} - in - let* operation1 = Op.sc_rollup_publish (B ctxt) contract rollup commitment1 in - let* i = Incremental.add_operation i operation1 in - let* b = Incremental.finalize_block i in - let* operation2 = Op.sc_rollup_publish (B b) contract rollup commitment2 in - let* i = Incremental.begin_construction b in - let expect_apply_failure = function - | Environment.Ecoproto_error - (Sc_rollup_errors.Sc_rollup_staker_double_stake as e) - :: _ -> - Assert.test_error_encodings e ; - return_unit - | _ -> failwith "It should have failed with [Sc_rollup_staker_double_stake]" - in - let* (_ : Incremental.t) = - Incremental.add_operation ~expect_apply_failure i operation2 - in - return_unit - -(** [test_cement_fails_on_conflict] creates a rollup and then publishes - two different commitments. It waits 20 blocks and then attempts to - cement one of the commitments; it checks that this fails because the - commitment is contested. *) -let test_cement_fails_on_conflict () = - let open Lwt_result_wrap_syntax in - let* ctxt, contracts, rollup = init_and_originate Context.T3 in - let* ctxt = bake_blocks_until_next_inbox_level ctxt rollup in - let _, contract1, contract2 = contracts in - let* i = Incremental.begin_construction ctxt in - let* commitment1 = dummy_commitment (I i) rollup in - let commitment2 = - {commitment1 with number_of_ticks = number_of_ticks_exn 3001L} - in - let* operation1 = - Op.sc_rollup_publish (B ctxt) contract1 rollup commitment1 - in - let* i = Incremental.add_operation i operation1 in - let* b = Incremental.finalize_block i in - let* operation2 = Op.sc_rollup_publish (B b) contract2 rollup commitment2 in - let* i = Incremental.begin_construction b in - let* i = Incremental.add_operation i operation2 in - let* b = Incremental.finalize_block i in - let* constants = Context.get_constants (B b) in - let* b = - Block.bake_n constants.parametric.sc_rollup.challenge_window_in_blocks b - in - let* i = Incremental.begin_construction b in - let*?@ i, hash = hash_commitment i commitment1 in - let* cement_op = Op.sc_rollup_cement (I i) contract1 rollup hash in - let expect_apply_failure = function - | Environment.Ecoproto_error (Sc_rollup_errors.Sc_rollup_disputed as e) :: _ - -> - Assert.test_error_encodings e ; - return_unit - | _ -> failwith "It should have failed with [Sc_rollup_disputed]" - in - let* (_ : Incremental.t) = - Incremental.add_operation ~expect_apply_failure i cement_op - in - return_unit - -let commit_and_cement_after_n_bloc ?expect_apply_failure block contract rollup n - = - let open Lwt_result_wrap_syntax in - let* block = bake_blocks_until_next_inbox_level block rollup in - let* i = Incremental.begin_construction block in - let* commitment = dummy_commitment (I i) rollup in - let* operation = Op.sc_rollup_publish (B block) contract rollup commitment in - let* i = Incremental.add_operation i operation in - let* b = Incremental.finalize_block i in - (* This pattern would add an additional block, so we decrement [n] by one. *) - let* b = Block.bake_n (n - 1) b in - let* i = Incremental.begin_construction b in - let*?@ i, hash = hash_commitment i commitment in - let* cement_op = Op.sc_rollup_cement (I i) contract rollup hash in - let* (_ : Incremental.t) = - Incremental.add_operation ?expect_apply_failure i cement_op - in - return_unit - -(** [test_challenge_window_period_boundaries] checks that cementing a commitment - without waiting for the whole challenge window period fails. Whereas, - succeeds when the period is over. *) -let test_challenge_window_period_boundaries () = - let sc_rollup_challenge_window_in_blocks = 10 in - let open Lwt_result_syntax in - let* ctxt, contract, rollup = - init_and_originate ~sc_rollup_challenge_window_in_blocks Context.T1 - in - (* Should fail because the waiting period is not strictly greater than the - challenge window period. *) - let* () = - let expect_apply_failure = function - | Environment.Ecoproto_error - (Sc_rollup_errors.Sc_rollup_commitment_too_recent _ as e) - :: _ -> - Assert.test_error_encodings e ; - return_unit - | _ -> - failwith - "It should have failed with [Sc_rollup_commitment_too_recent]" - in - commit_and_cement_after_n_bloc - ~expect_apply_failure - ctxt - contract - rollup - (sc_rollup_challenge_window_in_blocks - 1) - in - (* Succeeds because the challenge period is over. *) - let* () = - commit_and_cement_after_n_bloc - ctxt - contract - rollup - sc_rollup_challenge_window_in_blocks - in - return_unit - -(** Test originating with bad type. *) -let test_originating_with_invalid_types () = - let open Lwt_result_syntax in - let* block, (contract, _, _) = context_init Context.T3 in - let assert_fails_for_type parameters_ty = - assert_fails - ~loc:__LOC__ - ~error:Sc_rollup_operations.Sc_rollup_invalid_parameters_type - (sc_originate block contract ~parameters_ty) - in - (* Following types fail at validation time. *) - let* () = - [ - "mutez"; - "big_map string nat"; - "contract string"; - "sapling_state 2"; - "sapling_transaction 2"; - "lambda string nat"; - "or (nat %deposit) (string %name)"; - ] - |> List.iter_es assert_fails_for_type - in - (* Operation fails with a different error as it's not "passable". *) - assert_fails - ~loc:__LOC__ - (sc_originate block contract ~parameters_ty:"operation") - -let test_originating_with_invalid_boot_sector_proof () = - let open Lwt_result_syntax in - let*! origination_proof = - Sc_rollup_helpers.compute_origination_proof - ~boot_sector:"a boot sector" - Sc_rollup.Kind.Example_arith - in - let*! res = - init_and_originate - ~boot_sector:"another boot sector" - ~origination_proof - Context.T1 - in - match res with - | Error - (Environment.Ecoproto_error (Sc_rollup.Proof.Sc_rollup_proof_check _ as e) - :: _) -> - Assert.test_error_encodings e ; - return_unit - | _ -> failwith "It should have failed with [Sc_rollup_proof_check]" - -let test_originating_with_invalid_kind_proof () = - let open Lwt_result_syntax in - let*! origination_proof = - Sc_rollup_helpers.compute_origination_proof - ~boot_sector:"a boot sector" - Sc_rollup.Kind.Wasm_2_0_0 - in - let*! res = - init_and_originate - ~boot_sector:"a boot sector" - ~origination_proof - Context.T1 - in - match res with - | Error - (Environment.Ecoproto_error (Sc_rollup.Proof.Sc_rollup_proof_check _ as e) - :: _) -> - Assert.test_error_encodings e ; - return_unit - | _ -> failwith "It should have failed with [Sc_rollup_proof_check]" - -let test_originating_with_random_proof () = - let open Lwt_result_syntax in - let origination_proof = - Data_encoding.Binary.( - of_string_exn Sc_rollup.Proof.serialized_encoding - @@ to_string_exn Data_encoding.string Hex.(show @@ of_string "bad proof")) - in - let*! res = - init_and_originate - ~boot_sector:"some boot sector" - ~origination_proof - Context.T1 - in - match res with - | Error - (Environment.Ecoproto_error (Sc_rollup.Proof.Sc_rollup_proof_check _ as e) - :: _) -> - Assert.test_error_encodings e ; - return_unit - | _ -> failwith "It should have failed with [Sc_rollup_proof_check]" - -let test_originating_with_wrong_tree ~alter_binary_bit () = - let open Lwt_result_syntax in - let*! origination_proof = - Sc_rollup_helpers.wrong_arith_origination_proof - ~alter_binary_bit - ~boot_sector:"this should produce an invalid proof" - in - let*! res = - init_and_originate - ~boot_sector:"some boot sector" - ~origination_proof - Context.T1 - in - match res with - | Error - (Environment.Ecoproto_error (Sc_rollup.Proof.Sc_rollup_proof_check _ as e) - :: _) -> - Assert.test_error_encodings e ; - return_unit - | _ -> failwith "It should have failed with [Sc_rollup_proof_check]" - -let assert_equal_expr ~loc e1 e2 = - let s1 = Format.asprintf "%a" Michelson_v1_printer.print_expr e1 in - let s2 = Format.asprintf "%a" Michelson_v1_printer.print_expr e2 in - Assert.equal_string ~loc s1 s2 - -let test_originating_with_valid_type () = - let open Lwt_result_wrap_syntax in - let* block, contract = context_init Context.T1 in - let assert_parameters_ty parameters_ty = - let* block, rollup = sc_originate block contract ~parameters_ty in - let* incr = Incremental.begin_construction block in - let ctxt = Incremental.alpha_ctxt incr in - let*@ expr, _ctxt = Sc_rollup.parameters_type ctxt rollup in - let expr = WithExceptions.Option.get ~loc:__LOC__ expr in - let*? expr, _ctxt = - Environment.wrap_tzresult - @@ Script.force_decode_in_context - ~consume_deserialization_gas:When_needed - ctxt - expr - in - assert_equal_expr ~loc:__LOC__ (Expr.from_string parameters_ty) expr - in - [ - "unit"; - "int"; - "nat"; - "signature"; - "string"; - "bytes"; - "key_hash"; - "key"; - "timestamp"; - "address"; - "bls12_381_fr"; - "bls12_381_g1"; - "bls12_381_g2"; - "bool"; - "never"; - "chain_id"; - "ticket string"; - "set nat"; - "option (ticket string)"; - "list nat"; - "pair nat unit"; - "or nat string"; - "map string int"; - "map (option (pair nat string)) (list (ticket nat))"; - ] - |> List.iter_es assert_parameters_ty - -(* A contract that receives a pair of nat and a ticket and stores the ticket - with previously stored tickets. *) -let ticket_receiver = - {| - { parameter (pair nat (ticket string)); - storage (list (ticket string)); - code { UNPAIR; # [(nat, ticket) ; list] - CDR; # [ticket ; list] - CONS; # [ticket :: list] - NIL operation ; # [[] ; ticket :: list] - PAIR; # [([], ticket :: list)] - } - } - |} - -(* A contract that receives a string. *) -let string_receiver = - {| - { parameter string; - storage string; - code { CDR ; NIL operation; PAIR } } - |} - -(* A contract that receives a mutez. *) -let mutez_receiver = - {| - { parameter mutez; - storage mutez; - code { CDR ; NIL operation; PAIR } } - |} - -let test_single_transaction_batch () = - let open Lwt_result_syntax in - let* block, (baker, originator) = context_init Context.T2 in - let baker = Context.Contract.pkh baker in - (* Originate a rollup that accepts a list of string tickets as input. *) - let* block, rollup = - sc_originate block originator ~parameters_ty:"list (ticket string)" - in - let* incr = Incremental.begin_construction block in - (* Originate a contract that accepts a pair of nat and ticket string input. *) - let* ticket_receiver, incr = - originate_contract - incr - ~script:ticket_receiver - ~storage:"{}" - ~source_contract:originator - ~baker - in - (* Ticket-token with content "red". *) - let* red_token = - string_ticket_token "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" - in - (* Publish and cement a commitment. *) - let* cemented_commitment, incr = - publish_and_cement_dummy_commitment incr ~baker ~originator rollup - in - (* Create an atomic batch message. *) - let transactions = - [ - ( ticket_receiver, - Entrypoint.default, - {|Pair 42 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1)|} ); - ] - in - let output = make_output ~outbox_level:0 ~message_index:0 transactions in - (* Set up the balance so that the self contract owns one ticket. *) - let* _ticket_hash, incr = - adjust_ticket_token_balance_of_rollup (I incr) rollup red_token ~delta:Z.one - in - let* Sc_rollup_operations.{operations; _}, incr = - execute_outbox_message_without_proof_validation - incr - rollup - ~cemented_commitment - output - in - (* Confirm that each transaction maps to one operation. *) - let* () = - verify_execute_outbox_message_operations - ~loc:__LOC__ - incr - rollup - ~operations - ~expected_transactions:transactions - in - (* Verify that the balance has moved to ticket-receiver. *) - let* () = - assert_ticket_token_balance - ~loc:__LOC__ - incr - red_token - (Destination.Sc_rollup rollup) - None - in - assert_ticket_token_balance - ~loc:__LOC__ - incr - red_token - (Destination.Contract (Originated ticket_receiver)) - (Some 1) - -(** Test that checks that an outbox message can be executed against all stored - cemented commitments but not against an outdated one. *) -let test_older_cemented_commitment () = - let open Lwt_result_syntax in - let* block, (baker, originator) = context_init Context.T2 in - let baker = Context.Contract.pkh baker in - (* Originate a rollup that accepts a list of string tickets as input. *) - let* block, rollup = - sc_originate block originator ~parameters_ty:"list (ticket string)" - in - let* incr = Incremental.begin_construction block in - (* Originate a contract that accepts a pair of nat and ticket string input. *) - let* ticket_receiver, incr = - originate_contract - incr - ~script:ticket_receiver - ~storage:"{}" - ~source_contract:originator - ~baker - in - (* Ticket-token with content "red". *) - let* red_token = - string_ticket_token "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" - in - let verify_outbox_message_execution incr cemented_commitment = - (* Set up the balance so that the self contract owns one ticket. *) - let* _ticket_hash, incr = - adjust_ticket_token_balance_of_rollup - (I incr) - rollup - red_token - ~delta:Z.one - in - (* Create an atomic batch message. *) - let transactions = - [ - ( ticket_receiver, - Entrypoint.default, - {|Pair 42 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1)|} ); - ] - in - let output = make_output ~outbox_level:0 ~message_index:0 transactions in - let* Sc_rollup_operations.{operations; _}, incr = - execute_outbox_message_without_proof_validation - incr - rollup - ~cemented_commitment - output - in - (* Confirm that each transaction maps to one operation. *) - let* () = - verify_execute_outbox_message_operations - ~loc:__LOC__ - incr - rollup - ~operations - ~expected_transactions:transactions - in - (* Verify that the balance has moved to ticket-receiver. *) - let* () = - assert_ticket_token_balance - ~loc:__LOC__ - incr - red_token - (Destination.Sc_rollup rollup) - None - in - assert_ticket_token_balance - ~loc:__LOC__ - incr - red_token - (Destination.Contract (Originated ticket_receiver)) - (Some 1) - in - let* max_num_stored_cemented_commitments = - let ctxt = Incremental.alpha_ctxt incr in - return - @@ Alpha_context.Constants.max_number_of_stored_cemented_commitments ctxt - in - (* Publish and cement a commitment. *) - let* first_commitment_hash, incr = - publish_and_cement_dummy_commitment incr ~baker ~originator rollup - in - let* first_commitment = - Context.Sc_rollup.commitment (I incr) rollup first_commitment_hash - in - (* Generate a list of commitments that exceed the maximum number of stored - ones by one. *) - let* commitments_and_hashes = - gen_commitments - incr - rollup - ~predecessor:first_commitment - ~num_commitments:(max_num_stored_cemented_commitments + 1) - in - let commitments, commitment_hashes = List.split commitments_and_hashes in - let* incr = - publish_and_cement_commitments incr ~baker ~originator rollup commitments - in - (* FIXME: https://gitlab.com/tezos/tezos/-/issues/4469 - The test actually do not test the good "too old" commitment. *) - let commitment_hashes = first_commitment_hash :: commitment_hashes in - match commitment_hashes with - | too_old_commitment :: stored_hashes -> - (* Executing outbox message for the old non-stored commitment should fail. *) - let* () = - assert_fails - ~loc:__LOC__ - ~error:Sc_rollup_operations.Sc_rollup_invalid_last_cemented_commitment - (verify_outbox_message_execution incr too_old_commitment) - in - (* Executing outbox message for the recent ones should succeed. *) - List.iter_es - (fun commitment -> verify_outbox_message_execution incr commitment) - stored_hashes - | _ -> failwith "Expected non-empty list of commitment hashes." - -let test_multi_transaction_batch () = - let open Lwt_result_syntax in - let* block, (baker, originator) = context_init Context.T2 in - let baker = Context.Contract.pkh baker in - (* Originate a rollup that accepts a list of string tickets as input. *) - let* block, rollup = - sc_originate block originator ~parameters_ty:"list (ticket string)" - in - let* incr = Incremental.begin_construction block in - (* Originate a contract that accepts a pair of nat and ticket string input. *) - let* ticket_receiver, incr = - originate_contract - incr - ~script:ticket_receiver - ~storage:"{}" - ~source_contract:originator - ~baker - in - (* Originate a contract that accepts a string as input. *) - let* string_receiver, incr = - originate_contract - incr - ~script:string_receiver - ~storage:{|""|} - ~source_contract:originator - ~baker - in - (* Publish and cement a commitment. *) - let* cemented_commitment, incr = - publish_and_cement_dummy_commitment incr ~baker ~originator rollup - in - (* Ticket-token with content "red". *) - let* red_token = - string_ticket_token "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" - in - let transactions = - [ - (* A transaction to the ticket-receiver contract. *) - ( ticket_receiver, - Entrypoint.default, - {|Pair 1 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 4)|} ); - (* Another transaction to the ticket-receiver contract. *) - ( ticket_receiver, - Entrypoint.default, - {|Pair 2 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 6)|} ); - (* A transaction to the string-receiver contract. *) - (string_receiver, Entrypoint.default, {|"Hello"|}); - (* Another transaction to the string-receiver contract. *) - (string_receiver, Entrypoint.default, {|"Hello again"|}); - ] - in - (* Create an atomic batch message. *) - let output = make_output ~outbox_level:0 ~message_index:0 transactions in - (* Set up the balance so that the rollup owns 10 units of red tokens. *) - let* _ticket_hash, incr = - adjust_ticket_token_balance_of_rollup - (I incr) - rollup - red_token - ~delta:(Z.of_int 10) - in - let* Sc_rollup_operations.{operations; _}, incr = - execute_outbox_message_without_proof_validation - incr - rollup - ~cemented_commitment - output - in - (* Confirm that each transaction maps to one operation. *) - let* () = - verify_execute_outbox_message_operations - ~loc:__LOC__ - incr - rollup - ~operations - ~expected_transactions:transactions - in - (* Verify that the balance has moved to ticket-receiver. *) - let* () = - assert_ticket_token_balance - ~loc:__LOC__ - incr - red_token - (Destination.Sc_rollup rollup) - None - in - assert_ticket_token_balance - ~loc:__LOC__ - incr - red_token - (Destination.Contract (Originated ticket_receiver)) - (Some 10) - -(** Test that executing an L2 to L1 transaction that involves an invalid - parameter (mutez) fails. *) -let test_transaction_with_invalid_type () = - let open Lwt_result_syntax in - let* block, (baker, originator) = context_init Context.T2 in - let baker = Context.Contract.pkh baker in - let* block, rollup = - sc_originate block originator ~parameters_ty:"list (ticket string)" - in - let* incr = Incremental.begin_construction block in - let* mutez_receiver, incr = - originate_contract - incr - ~script:mutez_receiver - ~storage:"0" - ~source_contract:originator - ~baker - in - (* Publish and cement a commitment. *) - let* cemented_commitment, incr = - publish_and_cement_dummy_commitment incr ~baker ~originator rollup - in - let transactions = [(mutez_receiver, Entrypoint.default, "12")] in - (* Create an atomic batch message. *) - let output = make_output ~outbox_level:0 ~message_index:1 transactions in - assert_fails - ~loc:__LOC__ - ~error:Sc_rollup_operations.Sc_rollup_invalid_parameters_type - (execute_outbox_message_without_proof_validation - incr - rollup - ~cemented_commitment - output) - -(** Test that executing the same outbox message for the same twice fails. *) -let test_execute_message_twice () = - let open Lwt_result_syntax in - let* block, (baker, originator) = context_init Context.T2 in - let baker = Context.Contract.pkh baker in - (* Originate a rollup that accepts a list of string tickets as input. *) - let* block, rollup = - sc_originate block originator ~parameters_ty:"list (ticket string)" - in - let* incr = Incremental.begin_construction block in - (* Originate a contract that accepts a pair of nat and ticket string input. *) - let* string_receiver, incr = - originate_contract - incr - ~script:string_receiver - ~storage:{|""|} - ~source_contract:originator - ~baker - in - (* Publish and cement a commitment. *) - let* cemented_commitment, incr = - publish_and_cement_dummy_commitment incr ~baker ~originator rollup - in - (* Create an atomic batch message. *) - let transactions = [(string_receiver, Entrypoint.default, {|"Hello"|})] in - let output = make_output ~outbox_level:0 ~message_index:1 transactions in - (* Execute the message once - should succeed. *) - let* Sc_rollup_operations.{operations; _}, incr = - execute_outbox_message_without_proof_validation - incr - rollup - ~cemented_commitment - output - in - (* Confirm that each transaction maps to one operation. *) - let* () = - verify_execute_outbox_message_operations - ~loc:__LOC__ - incr - rollup - ~operations - ~expected_transactions:transactions - in - (* Execute the same message again should fail. *) - assert_fails - ~loc:__LOC__ - ~error:Sc_rollup_errors.Sc_rollup_outbox_message_already_applied - (execute_outbox_message_without_proof_validation - incr - rollup - ~cemented_commitment - output) - -(** Verifies that it is not possible to execute the same message twice from - different commitments. *) -let test_execute_message_twice_different_cemented_commitments () = - let open Lwt_result_syntax in - let* block, (baker, originator) = context_init Context.T2 in - let baker = Context.Contract.pkh baker in - (* Originate a rollup that accepts a list of string tickets as input. *) - let* block, rollup = - sc_originate block originator ~parameters_ty:"list (ticket string)" - in - let* incr = Incremental.begin_construction block in - (* Originate a contract that accepts a pair of nat and ticket string input. *) - let* string_receiver, incr = - originate_contract - incr - ~script:string_receiver - ~storage:{|""|} - ~source_contract:originator - ~baker - in - (* Publish and cement a commitment. *) - let* first_cemented_commitment, incr = - publish_and_cement_dummy_commitment incr ~baker ~originator rollup - in - let* predecessor = - Context.Sc_rollup.commitment (I incr) rollup first_cemented_commitment - in - let* commitment = dummy_commitment ~predecessor (I incr) rollup in - let* second_cemented_commitment, incr = - publish_and_cement_commitment incr ~baker ~originator rollup commitment - in - (* Create an atomic batch message. *) - let transactions = [(string_receiver, Entrypoint.default, {|"Hello"|})] in - let output = make_output ~outbox_level:0 ~message_index:1 transactions in - (* Execute the message once - should succeed. *) - let* Sc_rollup_operations.{operations; _}, incr = - execute_outbox_message_without_proof_validation - incr - rollup - ~cemented_commitment:first_cemented_commitment - output - in - (* Confirm that each transaction maps to one operation. *) - let* () = - verify_execute_outbox_message_operations - ~loc:__LOC__ - incr - rollup - ~operations - ~expected_transactions:transactions - in - (* Execute the same message again should fail. *) - assert_fails - ~loc:__LOC__ - ~error:Sc_rollup_errors.Sc_rollup_outbox_message_already_applied - (execute_outbox_message_without_proof_validation - incr - rollup - ~cemented_commitment:second_cemented_commitment - output) - -let test_zero_amount_ticket () = - let open Lwt_result_syntax in - let* block, (baker, originator) = context_init Context.T2 in - let baker = Context.Contract.pkh baker in - (* Originate a rollup that accepts a list of string tickets as input. *) - let* block, rollup = - sc_originate block originator ~parameters_ty:"list (ticket string)" - in - let* incr = Incremental.begin_construction block in - (* Originate a contract that accepts a pair of nat and ticket string input. *) - let* ticket_receiver, incr = - originate_contract - incr - ~script:ticket_receiver - ~storage:"{}" - ~source_contract:originator - ~baker - in - (* Publish and cement a commitment. *) - let* cemented_commitment, incr = - publish_and_cement_dummy_commitment incr ~baker ~originator rollup - in - (* Create an atomic batch message. *) - let transactions = - [ - ( ticket_receiver, - Entrypoint.default, - {|Pair 42 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 0)|} ); - ] - in - let output = make_output ~outbox_level:0 ~message_index:0 transactions in - let*! result = - execute_outbox_message_without_proof_validation - incr - rollup - ~cemented_commitment - output - in - match result with - | Error e -> - if - Option.is_some - @@ List.find - (function - | Environment.Ecoproto_error - Script_tc_errors.Forbidden_zero_ticket_quantity -> - true - | _ -> false) - e - then return_unit - else Stdlib.failwith "Expected failure" - | Ok _ -> Stdlib.failwith "Expected failure" - -(* Check that executing an outbox message fails when the inclusion proof in - invalid. *) -let test_invalid_output_proof () = - let open Lwt_result_syntax in - let* block, (baker, originator) = context_init Context.T2 in - let baker = Context.Contract.pkh baker in - (* Originate a rollup that accepts a list of string tickets as input. *) - let* block, rollup = - sc_originate block originator ~parameters_ty:"list (ticket string)" - in - let* incr = Incremental.begin_construction block in - (* Publish and cement a commitment. *) - let* cemented_commitment, incr = - publish_and_cement_dummy_commitment incr ~baker ~originator rollup - in - assert_fails - ~loc:__LOC__ - ~error:Sc_rollup_operations.Sc_rollup_invalid_output_proof - (execute_outbox_message - incr - rollup - ~originator - ~output_proof:"No good" - ~commitment_hash:cemented_commitment) - -let test_execute_message_override_applied_messages_slot () = - let open Lwt_result_syntax in - let* block, (baker, originator) = context_init Context.T2 in - let baker = Context.Contract.pkh baker in - (* Originate a rollup that accepts a list of string tickets as input. *) - let* block, rollup = - sc_originate block originator ~parameters_ty:"list (ticket string)" - in - let* incr = Incremental.begin_construction block in - (* Originate a contract that accepts a pair of nat and ticket string input. *) - let* string_receiver, incr = - originate_contract - incr - ~script:string_receiver - ~storage:{|""|} - ~source_contract:originator - ~baker - in - let max_active_levels = - Int32.to_int - (Constants_storage.sc_rollup_max_active_outbox_levels - (Alpha_context.Internal_for_tests.to_raw @@ Incremental.alpha_ctxt incr)) - in - let execute_message incr ~outbox_level ~message_index - ~cemented_commitment_hash = - let transactions = [(string_receiver, Entrypoint.default, {|"Hello"|})] in - let output = make_output ~outbox_level ~message_index transactions in - let* ( Sc_rollup_operations. - {operations = _; ticket_receipt = _; paid_storage_size_diff}, - incr ) = - execute_outbox_message_without_proof_validation - incr - rollup - ~cemented_commitment:cemented_commitment_hash - output - in - return (paid_storage_size_diff, incr) - in - let* cemented_commitment = dummy_commitment (I incr) rollup in - let* cemented_commitment_hash, incr = - publish_and_cement_commitment - incr - rollup - ~baker - ~originator - cemented_commitment - in - (* Execute a message. *) - let* _, incr = - execute_message - incr - ~outbox_level:0 - ~message_index:0 - ~cemented_commitment_hash - in - (* Publish a bunch of commitments until the inbox level of the lcc is greater - than [max_active_levels]. *) - let* cemented_commitment_hash, incr = - publish_commitments_until_min_inbox_level - incr - rollup - ~baker - ~originator - ~min_inbox_level:(max_active_levels + 10) - ~cemented_commitment_hash - ~cemented_commitment - in - (* Execute the message again but at [max_active_levels] outbox-level. *) - let* paid_storage_size_diff, incr = - execute_message - incr - ~outbox_level:max_active_levels - ~message_index:1 - ~cemented_commitment_hash - in - (* Since bitset has already been created for the slot, there should be no - extra storage space. *) - let* () = assert_equal_z ~loc:__LOC__ paid_storage_size_diff Z.zero in - (* Execute a message at index 99. *) - let* paid_storage_size_diff, incr = - execute_message - incr - ~outbox_level:max_active_levels - ~message_index:99 - ~cemented_commitment_hash - in - (* A message at slot 99 is now recorded which expands the size of the bitset. - We therefore see an increase in size. - *) - let* () = assert_equal_z ~loc:__LOC__ paid_storage_size_diff (Z.of_int 14) in - (* Execute at index 98. *) - let* paid_storage_size_diff, incr = - execute_message - incr - ~outbox_level:max_active_levels - ~message_index:98 - ~cemented_commitment_hash - in - (* The bitset is not expanded so we don't pay anything. *) - let* () = assert_equal_z ~loc:__LOC__ paid_storage_size_diff Z.zero in - (* If we now try to record a message at level 0 it should fail since it - expired. *) - let* () = - assert_fails - ~loc:__LOC__ - ~error:Sc_rollup_operations.Sc_rollup_invalid_outbox_level - (execute_message - incr - ~outbox_level:0 - ~message_index:0 - ~cemented_commitment_hash) - in - let* _paid_storage_size_diff, _incr = - execute_message - incr - ~outbox_level:(max_active_levels + 5) - ~message_index:0 - ~cemented_commitment_hash - in - (* This should fail even if no message exists for the corresponding slot. - The reason is that outbox-level is smaller than the minimum level: - [last-cemented-commitment-level - max-active-levels]. - *) - let* () = - assert_fails - ~loc:__LOC__ - ~error:Sc_rollup_operations.Sc_rollup_invalid_outbox_level - (execute_message - incr - ~outbox_level:1 - ~message_index:0 - ~cemented_commitment_hash) - in - return_unit - -(** Test that a transaction fails if it attempts to transfer more tickets than - allowed. *) -let test_insufficient_ticket_balances () = - let open Lwt_result_syntax in - let* block, (baker, originator) = context_init Context.T2 in - let baker = Context.Contract.pkh baker in - (* Originate a rollup that accepts a list of string tickets as input. *) - let* block, rollup = - sc_originate block originator ~parameters_ty:"list (ticket string)" - in - let* incr = Incremental.begin_construction block in - (* Originate a contract that accepts a pair of nat and ticket string input. *) - let* ticket_receiver, incr = - originate_contract - incr - ~script:ticket_receiver - ~storage:"{}" - ~source_contract:originator - ~baker - in - (* Originate a contract that accepts a string as input. *) - let* string_receiver, incr = - originate_contract - incr - ~script:string_receiver - ~storage:{|""|} - ~source_contract:originator - ~baker - in - (* Publish and cement a commitment. *) - let* cemented_commitment, incr = - publish_and_cement_dummy_commitment incr ~baker ~originator rollup - in - (* Ticket-token with content "red". *) - let* red_token = - string_ticket_token "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" - in - let transactions = - [ - (* A transaction to the ticket-receiver contract. *) - ( ticket_receiver, - Entrypoint.default, - {|Pair 1 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 4)|} ); - (* Another transaction to the ticket-receiver contract. *) - ( ticket_receiver, - Entrypoint.default, - {|Pair 2 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 6)|} ); - (* A transaction to the string-receiver contract. *) - (string_receiver, Entrypoint.default, {|"Hello"|}); - (* Another transaction to the string-receiver contract. *) - (string_receiver, Entrypoint.default, {|"Hello again"|}); - ] - in - (* Create an atomic batch message. *) - let output = make_output ~outbox_level:0 ~message_index:0 transactions in - (* Set up the balance so that the rollup owns 7 units of red tokens. - This is insufficient wrt the set of transactions above. - *) - let* ticket_hash, incr = - adjust_ticket_token_balance_of_rollup - (I incr) - rollup - red_token - ~delta:(Z.of_int 7) - in - (* Executing the batch fails because the rollup only has 7 units of tickets - but attempts to transfer 10 units. *) - assert_fails - ~loc:__LOC__ - ~error: - (Ticket_balance.Negative_ticket_balance - {key = ticket_hash; balance = Z.of_int (-3)}) - (execute_outbox_message_without_proof_validation - incr - rollup - ~cemented_commitment - output) - -let test_inbox_max_number_of_messages_per_level () = - let open Lwt_result_syntax in - let* block, (account1, account2) = - (* set sort of unlimited gas or we are going to hit gas exhaustion. *) - context_init - ~hard_gas_limit_per_operation:(Gas.Arith.integral_of_int_exn 100_000_000) - ~hard_gas_limit_per_block: - (Gas.Arith.integral_of_int_exn Int.(max_int / 1000)) - Context.T2 - in - let* block, _rollup = sc_originate block account1 in - let max_number_of_messages_per_level = - Constants.sc_rollup_max_number_of_messages_per_level - in - let* incr = Incremental.begin_construction block in - (* This just one message below the limit *) - let messages = - List.repeat (Z.to_int max_number_of_messages_per_level) "foo" - in - let* op = - Op.sc_rollup_add_messages ~gas_limit:Max (I incr) account1 messages - in - let* incr = Incremental.add_operation ~check_size:false incr op in - (* This break the limit *) - let* op = Op.sc_rollup_add_messages (I incr) account2 ["foo"] in - let* (_incr : Incremental.t) = - let expect_apply_failure = function - | Environment.Ecoproto_error - (Sc_rollup_inbox_repr.Inbox_level_reached_messages_limit as e) - :: _ -> - Assert.test_error_encodings e ; - return_unit - | _ -> - failwith - "It should have failed with [Inbox_level_reached_messages_limit]" - in - - Incremental.add_operation ~expect_apply_failure incr op - in - return_unit - -let add_op block op = - let open Lwt_result_syntax in - let* incr = Incremental.begin_construction block in - let* incr = Incremental.add_operation incr op in - Incremental.finalize_block incr - -let add_publish ~rollup block account commitment = - let open Lwt_result_syntax in - let* publish = Op.sc_rollup_publish (B block) account rollup commitment in - let* block = bake_blocks_until_inbox_level block commitment in - add_op block publish - -(** [test_number_of_parallel_games_bounded] checks that one cannot - play an arbitrary number of games. *) -let test_number_of_parallel_games_bounded () = - let open Lwt_result_syntax in - let max_number_of_parallel_games = - Context.default_test_constants.sc_rollup.max_number_of_parallel_games - in - let nb_accounts = max_number_of_parallel_games + 2 in - let* block, accounts = - context_init - ~sc_rollup_challenge_window_in_blocks:100 - (Context.TList nb_accounts) - in - let* block, rollup = sc_originate block (Stdlib.List.hd accounts) in - let* dummy_commitment = dummy_commitment (B block) rollup in - - let commitments = - List.mapi - (fun i _ -> - { - dummy_commitment with - number_of_ticks = number_of_ticks_exn (Int64.of_int (i + 1)); - }) - accounts - in - let* block = - List.fold_left2_es - ~when_different_lengths:[] - (fun block account commitment -> - add_publish ~rollup block account commitment) - block - accounts - commitments - in - let staker, opponents = - match accounts with - | staker :: opponents -> (staker, opponents) - | [] -> - (* Because [max_number_of_parallel_games] is strictly positive. *) - assert false - in - let staker_commitment, opponents_commitments = - match commitments with - | staker_commitment :: opponents_commitments -> - (staker_commitment, opponents_commitments) - | [] -> - (* Because [max_number_of_parallel_games] is strictly positive. *) - assert false - in - let expect_apply_failure = function - | Environment.Ecoproto_error - (Sc_rollup_errors.Sc_rollup_max_number_of_parallel_games_reached - xstaker) - :: _ -> - assert ( - Signature.Public_key_hash.( - xstaker = Account.pkh_of_contract_exn staker)) ; - return_unit - | _ -> - failwith - "It should have failed with \ - [Sc_rollup_max_number_of_parallel_games_reached]" - in - let* block = Incremental.begin_construction block in - let* _block, _counter = - List.fold_left2_es - ~when_different_lengths:[] - (fun (block, counter) opponent opponent_commitment -> - let addr = Account.pkh_of_contract_exn staker in - let refutation = - Sc_rollup.Game.Start - { - player_commitment_hash = - Sc_rollup.Commitment.hash_uncarbonated opponent_commitment; - opponent_commitment_hash = - Sc_rollup.Commitment.hash_uncarbonated staker_commitment; - } - in - let* op = - Op.sc_rollup_refute (I block) opponent rollup addr refutation - in - let* block = - if counter = max_number_of_parallel_games then - Incremental.add_operation ~expect_apply_failure block op - else Incremental.add_operation block op - in - return (block, counter + 1)) - (block, 0) - opponents - opponents_commitments - in - return () - -(** [test_timeout] test multiple cases of the timeout logic. -- Test to timeout a player before it's allowed and fails. -- Test that the timeout left by player decreases as expected. -- Test another account can timeout a late player. -*) -let test_timeout () = - let open Lwt_result_syntax in - let* block, (account1, account2, account3) = context_init Context.T3 in - let pkh1 = Account.pkh_of_contract_exn account1 in - let pkh2 = Account.pkh_of_contract_exn account2 in - let* block, rollup = sc_originate block account1 in - let* constants = Context.get_constants (B block) in - let Constants.Parametric.{timeout_period_in_blocks; _} = - constants.parametric.sc_rollup - in - let* genesis_info = Context.Sc_rollup.genesis_info (B block) rollup in - let* dummy_commitment = dummy_commitment (B block) rollup in - let commitment1 = - { - dummy_commitment with - number_of_ticks = number_of_ticks_exn 4L; - compressed_state = - Sc_rollup.State_hash.context_hash_to_state_hash - (Context_hash.hash_string ["first"]); - } - in - let commitment2 = - { - dummy_commitment with - number_of_ticks = number_of_ticks_exn 4L; - compressed_state = - Sc_rollup.State_hash.context_hash_to_state_hash - (Context_hash.hash_string ["second"]); - } - in - - let* block = add_publish ~rollup block account1 commitment1 in - let* block = add_publish ~rollup block account2 commitment2 in - let refutation = - Sc_rollup.Game.Start - { - player_commitment_hash = - Sc_rollup.Commitment.hash_uncarbonated commitment1; - opponent_commitment_hash = - Sc_rollup.Commitment.hash_uncarbonated commitment2; - } - in - let* start_game_op = - Op.sc_rollup_refute (B block) account1 rollup pkh2 refutation - in - let* block = add_op block start_game_op in - let* block = Block.bake_n (timeout_period_in_blocks - 1) block in - let game_index = Sc_rollup.Game.Index.make pkh1 pkh2 in - (* Testing to send a timeout before it's allowed. There is one block left - before timeout is allowed, that is, the current block. *) - let* (_incr : Incremental.t) = - let expected_block_left = 0l in - let expect_apply_failure = function - | Environment.Ecoproto_error - (Sc_rollup_errors.Sc_rollup_timeout_level_not_reached - (blocks_left, staker) as e) - :: _ -> - Assert.test_error_encodings e ; - if blocks_left = expected_block_left && pkh1 = staker then return_unit - else - failwith - "It should have failed with [Sc_rollup_timeout_level_not_reached \ - (%ld, %a)] but got [Sc_rollup_timeout_level_not_reached (%ld, \ - %a)]" - expected_block_left - Signature.Public_key_hash.pp - pkh1 - blocks_left - Signature.Public_key_hash.pp - staker - | _ -> - failwith - "It should have failed with [Sc_rollup_timeout_level_not_reached \ - (%ld, %a)]" - expected_block_left - Signature.Public_key_hash.pp - pkh1 - in - let* timeout = Op.sc_rollup_timeout (B block) account3 rollup game_index in - let* incr = Incremental.begin_construction block in - Incremental.add_operation ~expect_apply_failure incr timeout - in - let* refute = - let tick = - WithExceptions.Option.get ~loc:__LOC__ (Sc_rollup.Tick.of_int 0) - in - let* {compressed_state; _} = - Context.Sc_rollup.commitment (B block) rollup genesis_info.commitment_hash - in - let first_chunk = - Sc_rollup.Dissection_chunk.{state_hash = Some compressed_state; tick} - in - let* rest = - List.init_es ~when_negative_length:[] 4 (fun i -> - let state_hash = None in - let tick = - WithExceptions.Option.get - ~loc:__LOC__ - (Sc_rollup.Tick.of_int (i + 1)) - in - return Sc_rollup.Dissection_chunk.{state_hash; tick}) - in - let step = Sc_rollup.Game.Dissection (first_chunk :: rest) in - let refutation = Sc_rollup.Game.(Move {choice = tick; step}) in - Op.sc_rollup_refute (B block) account1 rollup pkh2 refutation - in - let* block = add_op block refute in - let* pkh1_timeout, pkh2_timeout = - let+ timeout = Context.Sc_rollup.timeout (B block) rollup pkh1 pkh2 in - let timeout = WithExceptions.Option.get ~loc:__LOC__ timeout in - if game_index.alice = pkh1 then (timeout.alice, timeout.bob) - else (timeout.bob, timeout.alice) - in - let* () = Assert.equal_int ~loc:__LOC__ pkh1_timeout 0 in - let* () = - Assert.equal_int ~loc:__LOC__ pkh2_timeout timeout_period_in_blocks - in - let* block = Block.bake_n timeout_period_in_blocks block in - let* timeout = Op.sc_rollup_timeout (B block) account3 rollup game_index in - let* incr = Incremental.begin_construction block in - let* incr = Incremental.add_operation incr timeout in - let expected_game_status : Sc_rollup.Game.status = - Ended (Loser {reason = Timeout; loser = pkh2}) - in - assert_timeout_result ~game_status:expected_game_status incr - -let init_with_conflict () = - let open Lwt_result_syntax in - let* block, (account1, account2) = context_init Context.T2 in - let pkh1 = Account.pkh_of_contract_exn account1 in - let pkh2 = Account.pkh_of_contract_exn account2 in - let* block, rollup = sc_originate block account1 in - let compressed_state = - Sc_rollup.State_hash.context_hash_to_state_hash - (Context_hash.hash_string ["first"]) - in - let* commitment1 = - dummy_commitment ~compressed_state ~number_of_ticks:1L (B block) rollup - in - let compressed_state = - Sc_rollup.State_hash.context_hash_to_state_hash - (Context_hash.hash_string ["second"]) - in - let* commitment2 = - dummy_commitment ~compressed_state ~number_of_ticks:1L (B block) rollup - in - let* block = add_publish ~rollup block account1 commitment1 in - let* block = add_publish ~rollup block account2 commitment2 in - let refutation = - Sc_rollup.Game.Start - { - player_commitment_hash = - Sc_rollup.Commitment.hash_uncarbonated commitment1; - opponent_commitment_hash = - Sc_rollup.Commitment.hash_uncarbonated commitment2; - } - in - let* start_game_op = - Op.sc_rollup_refute (B block) account1 rollup pkh2 refutation - in - let* block = add_op block start_game_op in - return (block, (account1, pkh1), (account2, pkh2), rollup) - -module Arith_pvm = Sc_rollup_helpers.Arith_pvm - -let dumb_proof ~choice = - let open Lwt_result_syntax in - let context_arith_pvm = Sc_rollup_helpers.make_empty_context () in - let empty = - Sc_rollup_helpers.In_memory_context.Tree.empty context_arith_pvm - in - let*! arith_state = Arith_pvm.initial_state ~empty in - let*! arith_state = Arith_pvm.install_boot_sector arith_state "" in - let input = Sc_rollup_helpers.make_external_input "c4c4" in - let* pvm_step = - Arith_pvm.produce_proof context_arith_pvm (Some input) arith_state - >|= Environment.wrap_tzresult - in - let pvm_step = - WithExceptions.Result.get_ok ~loc:__LOC__ - @@ Sc_rollup.Proof.serialize_pvm_step ~pvm:(module Arith_pvm) pvm_step - in - let inbox_proof = - Sc_rollup.Proof.Inbox_proof - { - level = Raw_level.root; - message_counter = Z.zero; - proof = - Sc_rollup.Inbox.Internal_for_tests.serialized_proof_of_string - "dummy proof"; - } - in - let proof = Sc_rollup.Proof.{pvm_step; input_proof = Some inbox_proof} in - return Sc_rollup.Game.(Move {choice; step = Proof proof}) - -(** Test that two invalid proofs from the two players lead to a draw - in the refutation game. *) -let test_draw_with_two_invalid_moves () = - let open Lwt_result_syntax in - let* block, (p1, p1_pkh), (p2, p2_pkh), rollup = init_with_conflict () in - - (* Player1 will play an invalid final move. *) - let* block = - let* p1_refutation = - let choice = Sc_rollup.Tick.initial in - dumb_proof ~choice - in - let* p1_final_move_op = - Op.sc_rollup_refute (B block) p1 rollup p2_pkh p1_refutation - in - add_op block p1_final_move_op - in - - (* Get the frozen bonds for the two players before the draw. *) - let* frozen_bonds_p1 = Context.Contract.frozen_bonds (B block) p1 in - let* frozen_bonds_p2 = Context.Contract.frozen_bonds (B block) p2 in - - (* Player2 will also send an invalid final move. *) - let* incr = - let* p2_refutation = - let choice = Sc_rollup.Tick.initial in - dumb_proof ~choice - in - let* p2_final_move_op = - Op.sc_rollup_refute (B block) p2 rollup p1_pkh p2_refutation - in - let* incr = Incremental.begin_construction block in - Incremental.add_operation incr p2_final_move_op - in - - (* As both players played invalid moves, the game ends in a draw. *) - let expected_game_status : Sc_rollup.Game.status = Ended Draw in - let* () = assert_refute_result ~game_status:expected_game_status incr in - - (* The two players should have been slashed. *) - let* constants = Context.get_constants (I incr) in - let stake_amount = constants.parametric.sc_rollup.stake_amount in - let* () = - Assert.frozen_bonds_was_debited - ~loc:__LOC__ - (I incr) - p1 - frozen_bonds_p1 - stake_amount - in - let* () = - Assert.frozen_bonds_was_debited - ~loc:__LOC__ - (I incr) - p2 - frozen_bonds_p2 - stake_amount - in - return_unit - -(** Test that timeout a player during the final move ends the game if - the other player played. *) -let test_timeout_during_final_move () = - let open Lwt_result_syntax in - let* block, (p1, p1_pkh), (_p2, p2_pkh), rollup = init_with_conflict () in - - (* Player1 will play an invalid final move. *) - let* block = - let* p1_refutation = - let choice = Sc_rollup.Tick.initial in - dumb_proof ~choice - in - - let* p1_final_move_op = - Op.sc_rollup_refute (B block) p1 rollup p2_pkh p1_refutation - in - add_op block p1_final_move_op - in - - (* Player2 will not play and it will be timeout. *) - let* incr = - let* block = bake_timeout_period block in - let game_index = Sc_rollup.Game.Index.make p1_pkh p2_pkh in - let* timeout = Op.sc_rollup_timeout (B block) p1 rollup game_index in - let* incr = Incremental.begin_construction block in - Incremental.add_operation incr timeout - in - - (* As the player1 played an invalid move, the timeout is counted - as an invalid one too. The game ends in a draw. *) - let expected_game_status : Sc_rollup.Game.status = Ended Draw in - assert_timeout_result ~game_status:expected_game_status incr - -(** Test that playing a dissection during a final move is rejected. *) -let test_dissection_during_final_move () = - let open Lwt_result_syntax in - let* block, (p1, p1_pkh), (p2, p2_pkh), rollup = init_with_conflict () in - - (* Player1 will play an invalid final move. *) - let* block = - let* p1_refutation = - let choice = Sc_rollup.Tick.initial in - dumb_proof ~choice - in - - let* p1_final_move_op = - Op.sc_rollup_refute (B block) p1 rollup p2_pkh p1_refutation - in - add_op block p1_final_move_op - in - - (* Player2 will play a dissection. *) - let dumb_dissection = - let choice = Sc_rollup.Tick.initial in - Sc_rollup.Game.(Move {choice; step = Dissection []}) - in - let* p2_op = Op.sc_rollup_refute (B block) p2 rollup p1_pkh dumb_dissection in - (* Dissecting is no longer accepted. *) - let* incr = Incremental.begin_construction block in - let expect_apply_failure = function - | Environment.Ecoproto_error - (Sc_rollup_game_repr.Dissecting_during_final_move as e) - :: _ -> - Assert.test_error_encodings e ; - return_unit - | _ -> failwith "It should have failed with [Dissecting_during_final_move]" - in - let* (_incr : Incremental.t) = - Incremental.add_operation ~expect_apply_failure incr p2_op - in - return_unit - -let init_arith_state ~boot_sector = - let open Lwt_syntax in - let context = Sc_rollup_helpers.make_empty_context () in - let empty = Sc_rollup_helpers.In_memory_context.Tree.empty context in - let* state = Arith_pvm.initial_state ~empty in - let* state = Arith_pvm.install_boot_sector state boot_sector in - return (context, state) - -(** [make_arith_state ?boot_sector metadata] initializes an arith PVM - waiting to read its first input, after evaluating the boot sector - and the [metadata]. - - [boot_sector] defaults to [""]. -*) -let make_arith_state ?(boot_sector = "") metadata = - let open Lwt_syntax in - let* context, state = init_arith_state ~boot_sector in - let* state_hash1 = Arith_pvm.state_hash state in - - (* 1. We evaluate the boot sector. *) - let* input_required = Arith_pvm.is_input_state state in - assert (input_required = Sc_rollup.No_input_required) ; - let* state = Arith_pvm.eval state in - let* state_hash2 = Arith_pvm.state_hash state in - (* 2. The state now needs the metadata. *) - let* input_required = Arith_pvm.is_input_state state in - assert (input_required = Sc_rollup.Needs_reveal Reveal_metadata) ; - (* 3. We feed the state with the metadata. *) - let input = Sc_rollup.(Reveal (Metadata metadata)) in - let* state = Arith_pvm.set_input input state in - let* state_hash3 = Arith_pvm.state_hash state in - let* input_required = Arith_pvm.is_input_state state in - assert (input_required = Sc_rollup.Initial) ; - - return (context, state, state_hash1, state_hash2, state_hash3) - -let make_set_input_refutation context state input input_proof = - let open Lwt_syntax in - let* proof = Arith_pvm.produce_proof context (Some input) state in - let pvm_step = WithExceptions.Result.get_ok ~loc:__LOC__ proof in - let pvm_step = - WithExceptions.Result.get_ok ~loc:__LOC__ - @@ Sc_rollup.Proof.serialize_pvm_step ~pvm:(module Arith_pvm) pvm_step - in - let choice = Sc_rollup.Tick.(next initial) in - let step : Sc_rollup.Game.step = - Proof {pvm_step; input_proof = Some input_proof} - in - return Sc_rollup.Game.(Move {choice; step}) - -(** [test_refute_set_input p1_info p2_info make_state_before] creates - a refutation game where the final tick refuted is a [set_input] - step. It uses [p1_info] (and respectively [p2_info]) to create - the input (and the input proof) executed. [make_state_before] - initializes the context and the state before the divergence - between the two players. - - The first player will be expected to win the game. *) -let test_refute_set_input - (p1_info : - Sc_rollup.t -> - Sc_rollup.Commitment.genesis_info -> - Sc_rollup.input * Sc_rollup.Proof.input_proof) p2_info - (make_state_before : - Sc_rollup.t -> - Sc_rollup.Commitment.genesis_info -> - (Arith_pvm.context * Arith_pvm.state) tzresult Lwt.t) = - let open Lwt_result_syntax in - let* block, (p1, p2) = context_init Context.T2 in - let pkh1 = Account.pkh_of_contract_exn p1 in - let pkh2 = Account.pkh_of_contract_exn p2 in - let* block, rollup = sc_originate block p1 in - let* genesis_info = Context.Sc_rollup.genesis_info (B block) rollup in - let* genesis_commitment = - Context.Sc_rollup.commitment (B block) rollup genesis_info.commitment_hash - in - - let p1_input, p1_input_proof = p1_info rollup genesis_info in - let p2_input, p2_input_proof = p2_info rollup genesis_info in - let* context, prior_state = make_state_before rollup genesis_info in - - let post_commitment_from_set_input block account input = - let* inbox_level = next_inbox_level (B block) rollup in - let*! state_hash1 = Arith_pvm.state_hash prior_state in - let*! state = Arith_pvm.set_input input prior_state in - let*! state_hash2 = Arith_pvm.state_hash state in - let commitment : Sc_rollup.Commitment.t = - { - predecessor = genesis_info.commitment_hash; - inbox_level; - number_of_ticks = number_of_ticks_exn 2L; - compressed_state = state_hash2; - } - in - let* block = add_publish ~rollup block account commitment in - return (commitment, block, state, state_hash1, state_hash2) - in - - let* commitment1, block, _state, state_hash1, p1_state_hash2 = - post_commitment_from_set_input block p1 p1_input - in - let* commitment2, block, _, _, _ = - post_commitment_from_set_input block p2 p2_input - in - - (* [p1] starts a game. - - The dissection is: - 0 -> predecessor state hash - 1 -> state just before the [set_input] - 2 -> tick in conflict with different evaluations of [set_input] - *) - let* start_game_op = - let refutation = - Sc_rollup.Game.Start - { - player_commitment_hash = - Sc_rollup.Commitment.hash_uncarbonated commitment1; - opponent_commitment_hash = - Sc_rollup.Commitment.hash_uncarbonated commitment2; - } - in - Op.sc_rollup_refute (B block) p1 rollup pkh2 refutation - in - let* dissection_op = - let dissection : Sc_rollup.Game.refutation = - let choice = Sc_rollup.Tick.initial in - let step : Sc_rollup.Game.step = - let zero = Sc_rollup.Tick.initial in - let one = Sc_rollup.Tick.next zero in - let two = Sc_rollup.Tick.next one in - Dissection - [ - {tick = zero; state_hash = Some genesis_commitment.compressed_state}; - {tick = one; state_hash = Some state_hash1}; - {tick = two; state_hash = Some p1_state_hash2}; - ] - in - Move {choice; step} - in - Op.sc_rollup_refute (B block) p1 rollup pkh2 dissection - in - let* p1_moves = - Op.batch_operations - ~recompute_counters:true - ~source:p1 - (B block) - [start_game_op; dissection_op] - in - let* block = Block.bake ~operation:p1_moves block in - - (* [p2] plays its [set_input], he is expected to play an invalid one. *) - let* p2_final_move_op = - let*! proof = - make_set_input_refutation context prior_state p2_input p2_input_proof - in - Op.sc_rollup_refute (B block) p2 rollup pkh1 proof - in - (* [p1] plays it [set_input] too. *) - let* p1_final_move_op = - let*! proof = - make_set_input_refutation context prior_state p1_input p1_input_proof - in - Op.sc_rollup_refute (B block) p1 rollup pkh2 proof - in - let* incr = Incremental.begin_construction block in - let* incr = Incremental.add_operation incr p2_final_move_op in - let* incr = Incremental.add_operation incr p1_final_move_op in - let expected_game_status : Sc_rollup.Game.status = - Ended (Loser {reason = Conflict_resolved; loser = pkh2}) - in - assert_refute_result ~game_status:expected_game_status incr - -let test_refute_invalid_metadata () = - let open Lwt_result_syntax in - let p1_info rollup (genesis_info : Sc_rollup.Commitment.genesis_info) = - let metadata = - Sc_rollup.Metadata. - {address = rollup; origination_level = genesis_info.level} - in - Sc_rollup.(Reveal (Metadata metadata), Proof.Reveal_proof Metadata_proof) - in - let p2_info rollup _genesis_info = - let invalid_metadata = - Sc_rollup.Metadata. - {address = rollup; origination_level = Raw_level.of_int32_exn 42l} - in - Sc_rollup. - (Reveal (Metadata invalid_metadata), Proof.Reveal_proof Metadata_proof) - in - let make_state_before _rollup _genesis_info = - let*! context, state = init_arith_state ~boot_sector:"" in - let*! state = Arith_pvm.eval state in - return (context, state) - in - test_refute_set_input p1_info p2_info make_state_before - -(** [arith_state_before_reveal metadata hash] initializes an arith PVM waiting - for the data associated to [hash] to be revealed. - - Starts by creating a state with {!make_arith_state}, then triggers the - [Needs_reveal] state through an external message annoucing the [hash]. -*) -let arith_state_before_reveal metadata hash = - let open Lwt_result_syntax in - let*! context, state, _, _, _ = make_arith_state metadata in - let input = - Sc_rollup_helpers.make_external_input - ~inbox_level:Raw_level.root - ~message_counter:Z.zero - ("hash:" ^ hash) - in - let*! state = Arith_pvm.set_input input state in - let rec eval_until_needs_reveal state = - let*! input_request = Arith_pvm.is_input_state state in - match input_request with - | Needs_reveal _ -> return state - | _ -> - let*! state = Arith_pvm.eval state in - eval_until_needs_reveal state - in - let* state = eval_until_needs_reveal state in - return (context, state) - -let test_refute_invalid_reveal () = - let data = String.make Constants_repr.sc_rollup_message_size_limit 'f' in - let invalid_data = "foo" in - let hash = - Sc_rollup_reveal_hash.(hash_string ~scheme:Blake2B [data] |> to_hex) - in - let p1_info _rollup _genesis_info = - Sc_rollup.(Reveal (Raw_data data), Proof.Reveal_proof (Raw_data_proof data)) - in - let p2_info _rollup _genesis_info = - Sc_rollup. - ( Reveal (Raw_data invalid_data), - Proof.Reveal_proof (Raw_data_proof invalid_data) ) - in - let make_state_before rollup - (genesis_info : Sc_rollup.Commitment.genesis_info) = - let metadata = - Sc_rollup.Metadata. - {address = rollup; origination_level = genesis_info.level} - in - arith_state_before_reveal metadata hash - in - test_refute_set_input p1_info p2_info make_state_before - -let full_history_inbox (genesis_predecessor_timestamp, genesis_predecessor) - all_external_messages = - let open Sc_rollup_helpers in - let payloads_per_levels = - List.map - (fun (pred_info, level, external_messages) -> - wrap_messages ~pred_info level external_messages) - all_external_messages - in - Sc_rollup_helpers.Node_inbox.construct_inbox - ~genesis_predecessor_timestamp - ~genesis_predecessor - payloads_per_levels - -let input_included ~snapshot ~full_history_inbox (l, n) = - let open Lwt_result_syntax in - let open Sc_rollup_helpers in - let Sc_rollup_helpers.Node_inbox.{payloads_histories; history; inbox} = - full_history_inbox - in - let history_proof = Sc_rollup.Inbox.old_levels_messages inbox in - (* Create an inclusion proof of the inbox message at [(l, n)]. *) - let* proof, _ = - Sc_rollup.Inbox.produce_proof - ~get_payloads_history:(get_payloads_history payloads_histories) - ~get_history:(get_history history) - history_proof - (l, n) - >|= Environment.wrap_tzresult - in - let*? inbox_message_verified = - Sc_rollup.Inbox.verify_proof (l, n) snapshot proof - |> Environment.wrap_tzresult - in - return - @@ Option.map - (fun inbox_message -> Sc_rollup.Inbox_message inbox_message) - inbox_message_verified - -(** Test that the protocol adds a [SOL], [Info_per_level] and [EOL] for each - Tezos level, even if no messages are added to the inbox. *) -let test_automatically_added_internal_messages () = - let open Lwt_result_syntax in - let assert_input_included ~__LOC__ ~snapshot ~full_history_inbox (l, n) input - = - let* input_verified = input_included ~snapshot ~full_history_inbox (l, n) in - Assert.equal - ~loc:__LOC__ - (Option.equal Sc_rollup.input_equal) - "Input found with the proof is different from input provided" - (fun ppf v -> - match v with - | None -> Format.pp_print_string ppf "None" - | Some v -> Sc_rollup.pp_input ppf v) - input_verified - input - in - - let assert_sol ~snapshot ~full_history_inbox ~inbox_level = - let sol = Sc_rollup_helpers.make_sol ~inbox_level in - assert_input_included - ~snapshot - ~full_history_inbox - (inbox_level, Z.zero) - (Some sol) - in - - let assert_ipl ~snapshot ~full_history_inbox ~level_info ~inbox_level = - let predecessor_timestamp, predecessor = level_info in - let info_per_level = - Sc_rollup_helpers.make_info_per_level - ~inbox_level - ~predecessor_timestamp - ~predecessor - in - assert_input_included - ~snapshot - ~full_history_inbox - (inbox_level, Z.one) - (Some info_per_level) - in - - let assert_protocol_migration ~snapshot ~full_history_inbox ~inbox_level = - let protocol_migration = - Sc_rollup_helpers.make_protocol_migration ~inbox_level - in - assert_input_included - ~snapshot - ~full_history_inbox - (inbox_level, Z.(succ one)) - (Some protocol_migration) - in - - let assert_eol ~snapshot ~full_history_inbox ~inbox_level ~message_counter = - let eol = Sc_rollup_helpers.make_eol ~inbox_level ~message_counter in - assert_input_included - ~snapshot - ~full_history_inbox - (inbox_level, message_counter) - (Some eol) - in - - let assert_no_message ~snapshot ~full_history_inbox ~inbox_level - ~message_counter = - assert_input_included - ~snapshot - ~full_history_inbox - (inbox_level, message_counter) - None - in - - let info_per_block (block : Block.t) = - (block.header.shell.timestamp, block.hash) - in - - (* Create the first block. *) - let* block, account = context_init Context.T1 in - - let level_zero_info = - ( Time.Protocol.epoch, - Block_hash.of_b58check_exn - "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU" ) - in - - let level_one_info = info_per_block block in - (* Bake a second block. *) - let* block = Block.bake block in - - let level_two_info = info_per_block block in - (* Bake a third block where a message is added. *) - let* operation = Op.sc_rollup_add_messages (B block) account ["foo"] in - let* block = Block.bake ~operation block in - - let* inbox = Context.Sc_rollup.inbox (B block) in - let snapshot = Sc_rollup.Inbox.take_snapshot inbox in - - let level_zero = Raw_level.of_int32_exn 0l in - let level_one = Raw_level.of_int32_exn 1l in - let level_two = Raw_level.of_int32_exn 2l in - let*? ({inbox; _} as full_history_inbox) = - full_history_inbox - level_zero_info - [(level_one_info, level_one, []); (level_two_info, level_two, ["foo"])] - in - - (* Assertions about level 0. *) - let* () = - assert_sol ~__LOC__ ~snapshot ~full_history_inbox ~inbox_level:level_zero - in - let* () = - assert_ipl - ~__LOC__ - ~snapshot - ~full_history_inbox - ~inbox_level:level_zero - ~level_info:level_zero_info - in - let* () = - assert_protocol_migration - ~__LOC__ - ~snapshot - ~full_history_inbox - ~inbox_level:level_zero - in - let* () = - assert_eol - ~__LOC__ - ~snapshot - ~full_history_inbox - ~inbox_level:level_zero - ~message_counter:(Z.of_int 3) - in - - (* Assertions about level 1. *) - let* () = - assert_sol ~__LOC__ ~snapshot ~full_history_inbox ~inbox_level:level_one - in - let* () = - assert_ipl - ~__LOC__ - ~snapshot - ~full_history_inbox - ~inbox_level:level_one - ~level_info:level_one_info - in - let* () = - assert_protocol_migration - ~__LOC__ - ~snapshot - ~full_history_inbox - ~inbox_level:level_zero - in - let* () = - assert_eol - ~__LOC__ - ~snapshot - ~full_history_inbox - ~inbox_level:level_one - ~message_counter:(Z.of_int 3) - in - - (* Assertions about level 2. *) - let* () = - assert_sol ~__LOC__ ~snapshot ~full_history_inbox ~inbox_level:level_two - in - let* () = - assert_ipl - ~__LOC__ - ~snapshot - ~full_history_inbox - ~inbox_level:level_two - ~level_info:level_two_info - in - let* () = - assert_eol - ~__LOC__ - ~snapshot - ~full_history_inbox - ~inbox_level:level_two - ~message_counter:(Z.of_int 3) - in - let* () = - assert_no_message - ~__LOC__ - ~snapshot - ~full_history_inbox - ~inbox_level:level_two - ~message_counter:(Z.of_int 4) - in - - (* Assert the computed inbox and protocol's inbox are equal. *) - let history_proof = Sc_rollup.Inbox.old_levels_messages inbox in - Assert.equal - ~loc:__LOC__ - Sc_rollup.Inbox.equal_history_proof - "Computed and protocol inboxes aren't equal" - Sc_rollup.Inbox.pp_history_proof - snapshot - history_proof - -(** With [Start_of_level] and [End_of_level] inbox messages in each inbox level, - it's impossible to give a valid commitment with 0 ticks. *) -let test_zero_tick_commitment_fails () = - let open Lwt_result_syntax in - let* ctxt, contract, rollup = init_and_originate Context.T1 in - let* incr = Incremental.begin_construction ctxt in - let* commitment = dummy_commitment (I incr) rollup in - let commitment = {commitment with number_of_ticks = number_of_ticks_exn 0L} in - let* publish_commitment = - Op.sc_rollup_publish (B ctxt) contract rollup commitment - in - let expect_apply_failure = function - | Environment.Ecoproto_error - (Sc_rollup_errors.Sc_rollup_zero_tick_commitment as e) - :: _ -> - Assert.test_error_encodings e ; - return_unit - | _ -> - failwith "It should have failed with [Sc_rollup_zero_tick_commitment]" - in - let* _incr = - Incremental.add_operation ~expect_apply_failure incr publish_commitment - in - return_unit - -(** [test_curfew] creates a rollup, publishes two conflicting - commitments. Branches are expected to continue (commitment are able to be - published). Tries to publish another commitment at the same initial - `inbox_level` after [challenge_window_in_blocks - 1] and after - [challenge_window_in_blocks] blocks. Only the first attempt is expected to - succeed. *) -let test_curfew () = - let open Lwt_result_syntax in - let* block, (account1, account2, account3), rollup = - (* sc_rollup_challenge_window_in_blocks should be at least commitment period *) - init_and_originate ~sc_rollup_challenge_window_in_blocks:60 Context.T3 - in - let* constants = Context.get_constants (B block) in - let challenge_window = - constants.parametric.sc_rollup.challenge_window_in_blocks - in - let* publish1, commitment1 = - publish_op_and_dummy_commitment - ~src:account1 - ~compressed_state:"first" - rollup - block - in - let* publish2, commitment2 = - publish_op_and_dummy_commitment - ~src:account2 - ~compressed_state:"second" - rollup - block - in - let* block = bake_blocks_until_inbox_level block commitment1 in - let* block = Block.bake ~operations:[publish1; publish2] block in - let* block = Block.bake_n (challenge_window - 1) block in - - let* publish11, commitment11 = - publish_op_and_dummy_commitment - ~src:account1 - ~predecessor:commitment1 - rollup - block - in - let* publish21, commitment21 = - publish_op_and_dummy_commitment - ~src:account2 - ~predecessor:commitment2 - rollup - block - in - let* publish3, _commitment3 = - publish_op_and_dummy_commitment - ~src:account3 - ~compressed_state:"third" - rollup - block - in - let* block = bake_blocks_until_inbox_level block commitment11 in - let* block = Block.bake ~operations:[publish11; publish21; publish3] block in - let* publish111, commitment111 = - publish_op_and_dummy_commitment - ~src:account1 - ~predecessor:commitment11 - rollup - block - in - let* publish211, _commitment211 = - publish_op_and_dummy_commitment - ~src:account2 - ~predecessor:commitment21 - rollup - block - in - let* publish4, _commitment4 = - publish_op_and_dummy_commitment - ~src:account3 - ~compressed_state:"fourth" - rollup - block - in - let* block = bake_blocks_until_inbox_level block commitment111 in - let* incr = Incremental.begin_construction block in - let* incr = Incremental.add_operation incr publish111 in - let* incr = Incremental.add_operation incr publish211 in - let expect_apply_failure = function - | Environment.Ecoproto_error - (Sc_rollup_errors.Sc_rollup_commitment_past_curfew as e) - :: _ -> - Assert.test_error_encodings e ; - return_unit - | _ -> - failwith "It should have failed with [Sc_rollup_commitment_past_curfew]" - in - let* _incr = Incremental.add_operation ~expect_apply_failure incr publish4 in - return_unit - -(** [test_curfew_period_is_started_only_after_first_publication checks that - publishing the first commitment of a given [inbox_level] after - [inbox_level + challenge_window] is still possible. *) -let test_curfew_period_is_started_only_after_first_publication () = - let open Lwt_result_syntax in - let* block, account1, rollup = init_and_originate Context.T1 in - let* constants = Context.get_constants (B block) in - let challenge_window = - constants.parametric.sc_rollup.challenge_window_in_blocks - in - let commitment_period = - constants.parametric.sc_rollup.commitment_period_in_blocks - in - let* block = Block.bake_n commitment_period block in - let* block = Block.bake_n challenge_window block in - let* commitment = dummy_commitment (B block) rollup in - let* operation = Op.sc_rollup_publish (B block) account1 rollup commitment in - let* _block = Block.bake ~operation block in - return_unit - -let test_offline_staker_does_not_prevent_cementation () = - let open Lwt_result_syntax in - let* ctxt, contracts, rollup = init_and_originate Context.T2 in - let contract1, contract2 = contracts in - let* ctxt = bake_blocks_until_next_inbox_level ctxt rollup in - (* A publishes a commitment on C1. *) - let* commitment1 = dummy_commitment (B ctxt) rollup in - let* operation = Op.sc_rollup_publish (B ctxt) contract1 rollup commitment1 in - let* b = Block.bake ~operation ctxt in - - (* We cement C1. *) - let* constants = Context.get_constants (B b) in - let* b = - Block.bake_n constants.parametric.sc_rollup.challenge_window_in_blocks b - in - let hash = Sc_rollup.Commitment.hash_uncarbonated commitment1 in - let* cement_op = Op.sc_rollup_cement (B b) contract1 rollup hash in - let* b = Block.bake ~operation:cement_op b in - - (* A now goes offline, B takes over. *) - let* commitment2 = dummy_commitment ~predecessor:commitment1 (B b) rollup in - let* operation2 = - Op.sc_rollup_publish (B ctxt) contract2 rollup commitment2 - in - let* b = bake_blocks_until_inbox_level b commitment2 in - let* b = Block.bake ~operation:operation2 b in - - (* We cement C2. *) - let* constants = Context.get_constants (B b) in - let* b = - Block.bake_n constants.parametric.sc_rollup.challenge_window_in_blocks b - in - let hash = Sc_rollup.Commitment.hash_uncarbonated commitment2 in - let* cement_op = Op.sc_rollup_cement (B b) contract2 rollup hash in - let* _b = Block.bake ~operation:cement_op b in - return_unit - -let init_with_4_conflicts () = - let open Lwt_result_syntax in - let dumb_compressed_state s = - Sc_rollup.State_hash.context_hash_to_state_hash - (Context_hash.hash_string [s]) - in - let* block, players = context_init (Context.TList 4) in - let pA, pB, pC, pD = - match players with - | [pA; pB; pC; pD] -> (pA, pB, pC, pD) - | _ -> assert false - in - let pA_pkh = Account.pkh_of_contract_exn pA in - let pB_pkh = Account.pkh_of_contract_exn pB in - let pC_pkh = Account.pkh_of_contract_exn pC in - let pD_pkh = Account.pkh_of_contract_exn pD in - let* block, rollup = sc_originate block pA in - - (* The four players stake on a conflicting commitment. *) - let* pA_commitment = - dummy_commitment - ~number_of_ticks:1L - ~compressed_state:(dumb_compressed_state "A") - (B block) - rollup - in - let* pB_commitment = - dummy_commitment - ~number_of_ticks:1L - ~compressed_state:(dumb_compressed_state "B") - (B block) - rollup - in - let* pC_commitment = - dummy_commitment - ~number_of_ticks:1L - ~compressed_state:(dumb_compressed_state "C") - (B block) - rollup - in - let* pD_commitment = - dummy_commitment - ~number_of_ticks:1L - ~compressed_state:(dumb_compressed_state "D") - (B block) - rollup - in - let* block = - List.fold_left_es - (fun block (player, commitment) -> - add_publish ~rollup block player commitment) - block - [ - (pA, pA_commitment); - (pB, pB_commitment); - (pC, pC_commitment); - (pD, pD_commitment); - ] - in - return (block, rollup, (pA, pA_pkh), (pB, pB_pkh), (pC, pC_pkh), (pD, pD_pkh)) - -let start_refutation_game_op block rollup (p1, p1_pkh) p2_pkh = - let open Lwt_result_syntax in - let* ctxt = - let+ incr = Incremental.begin_construction block in - Incremental.alpha_ctxt incr - in - let* (p1_point, p2_point), _ctxt = - Sc_rollup.Refutation_storage.Internal_for_tests.get_conflict_point - ctxt - rollup - p1_pkh - p2_pkh - >|= Environment.wrap_tzresult - in - let refutation = - Sc_rollup.Game.Start - { - player_commitment_hash = p1_point.hash; - opponent_commitment_hash = p2_point.hash; - } - in - Op.sc_rollup_refute (B block) p1 rollup p2_pkh refutation - -(** Test that when A plays against B, C, D and if A losts the game against - one of them, the others can win against A for free. *) -let test_winner_by_forfeit () = - let open Lwt_result_syntax in - let* block, rollup, (pA, pA_pkh), (pB, pB_pkh), (pC, pC_pkh), (pD, pD_pkh) = - init_with_4_conflicts () - in - - (* Refutation game starts: A against B, C and D. *) - (* A starts against B and D so it can be timeouted. *) - let* pA_against_pB_op = - start_refutation_game_op block rollup (pA, pA_pkh) pB_pkh - in - let* pA_against_pD_op = - start_refutation_game_op block rollup (pA, pA_pkh) pD_pkh - in - let* pA_op = - Op.batch_operations - ~recompute_counters:true - ~source:pA - (B block) - [pA_against_pB_op; pA_against_pD_op] - in - (* C starts against A so it can win through a move. *) - let* pC_against_pA_op = - start_refutation_game_op block rollup (pC, pC_pkh) pA_pkh - in - let* block = Block.bake block ~operations:[pA_op; pC_against_pA_op] in - let* block = bake_timeout_period block in - - (* B timeouts A. *) - let game_index = Sc_rollup.Game.Index.make pA_pkh pB_pkh in - let* pB_timeout = Op.sc_rollup_timeout (B block) pB rollup game_index in - let* block = Block.bake block ~operation:pB_timeout in - - (* C sends a dumb move but A was already slashed. *) - let dumb_dissection = - let choice = Sc_rollup.Tick.initial in - Sc_rollup.Game.(Move {choice; step = Dissection []}) - in - let* pC_move = - Op.sc_rollup_refute (B block) pC rollup pA_pkh dumb_dissection - in - - (* D timeouts A. *) - let game_index = Sc_rollup.Game.Index.make pA_pkh pD_pkh in - let* pD_timeout = Op.sc_rollup_timeout (B block) pD rollup game_index in - - (* Both operation fails with [Unknown staker], because pA was removed when - it lost against B. *) - let* incr = Incremental.begin_construction block in - let* _incr = Incremental.add_operation incr pC_move in - let* _incr = Incremental.add_operation incr pD_timeout in - - return_unit - -(** Test the same property as in {!test_winner_by_forfeit} but where two - players slashed eachother with a draw. *) -let test_winner_by_forfeit_with_draw () = - let open Lwt_result_syntax in - let* block, rollup, (pA, pA_pkh), (pB, pB_pkh), (pC, pC_pkh), (_pD, _pD_pkh) = - init_with_4_conflicts () - in - let* constants = Context.get_constants (B block) in - let Constants.Parametric.{timeout_period_in_blocks; stake_amount; _} = - constants.parametric.sc_rollup - in - - (* A and B starts a refutation game against C. *) - let* pA_against_pC_op = - start_refutation_game_op block rollup (pA, pA_pkh) pC_pkh - in - let* pB_against_pC_op = - start_refutation_game_op block rollup (pB, pB_pkh) pC_pkh - in - - let* block = Block.bake block ~operation:pA_against_pC_op in - let* block = Block.bake block ~operation:pB_against_pC_op in - - (* A starts a refutation against B. *) - let* frozen_bonds_pA = Context.Contract.frozen_bonds (B block) pA in - let* frozen_bonds_pB = Context.Contract.frozen_bonds (B block) pB in - let* pA_against_pB_op = - start_refutation_game_op block rollup (pA, pA_pkh) pB_pkh - in - let* block = Block.bake block ~operation:pA_against_pB_op in - - (* A and B will both make an invalid move and ends up in a draw. *) - let* dumb_move = - let choice = Sc_rollup.Tick.initial in - dumb_proof ~choice - in - let* pA_dumb_move_op = - Op.sc_rollup_refute (B block) pA rollup pB_pkh dumb_move - in - let* block = Block.bake block ~operation:pA_dumb_move_op in - let* pB_dumb_move_op = - Op.sc_rollup_refute (B block) pB rollup pA_pkh dumb_move - in - let* block = Block.bake block ~operation:pB_dumb_move_op in - - (* Assert the draw by checking the frozen bonds. *) - let* () = - Assert.frozen_bonds_was_debited - ~loc:__LOC__ - (B block) - pA - frozen_bonds_pA - stake_amount - in - let* () = - Assert.frozen_bonds_was_debited - ~loc:__LOC__ - (B block) - pB - frozen_bonds_pB - stake_amount - in - - (* Now C will win the game against A and B with a timeout. *) - let* block = bake_timeout_period ~timeout_period_in_blocks block in - - (* C timeouts A. *) - let game_index = Sc_rollup.Game.Index.make pC_pkh pA_pkh in - let* pC_timeout_pA = Op.sc_rollup_timeout (B block) pC rollup game_index in - let* block = Block.bake block ~operation:pC_timeout_pA in - - (* C timeouts B. *) - let game_index = Sc_rollup.Game.Index.make pC_pkh pB_pkh in - let* pC_timeout_pB = Op.sc_rollup_timeout (B block) pC rollup game_index in - let* _block = Block.bake block ~operation:pC_timeout_pB in - - return_unit - -let test_conflict_point_on_a_branch () = - let open Lwt_result_syntax in - let* block, (pA, pB), rollup = - init_and_originate ~sc_rollup_challenge_window_in_blocks:1000 Context.T2 - in - let pA_pkh = Account.pkh_of_contract_exn pA in - let pB_pkh = Account.pkh_of_contract_exn pB in - (* pA stakes on a whole branch. *) - let* genesis_info = Context.Sc_rollup.genesis_info (B block) rollup in - let* predecessor = - Context.Sc_rollup.commitment (B block) rollup genesis_info.commitment_hash - in - let* commitments_and_hashes = - let* incr = Incremental.begin_construction block in - gen_commitments incr rollup ~predecessor ~num_commitments:10 - in - let commitments, _ = List.split commitments_and_hashes in - let* block = publish_commitments block pA rollup commitments in - (* pB stakes on only one commitment. *) - let pA_commitment, pB_commitment = - let commitment = Stdlib.List.nth commitments 8 in - ( commitment, - { - commitment with - compressed_state = - Sc_rollup.State_hash.context_hash_to_state_hash - (Context_hash.hash_string ["foo"]); - } ) - in - let* block = publish_commitments block pB rollup [pB_commitment] in - let* ( ( {commitment = _; hash = conflict_pA_hash}, - {commitment = _; hash = conflict_pB_hash} ), - _ctxt ) = - let* ctxt = - let+ incr = Incremental.begin_construction block in - Incremental.alpha_ctxt incr - in - Sc_rollup.Refutation_storage.Internal_for_tests.get_conflict_point - ctxt - rollup - pA_pkh - pB_pkh - >|= Environment.wrap_tzresult - in - let pA_hash = Sc_rollup.Commitment.hash_uncarbonated pA_commitment in - let pB_hash = Sc_rollup.Commitment.hash_uncarbonated pB_commitment in - let expected_conflict = - Sc_rollup.Commitment.Hash.( - equal conflict_pA_hash pA_hash && equal conflict_pB_hash pB_hash) - in - Assert.equal_bool ~loc:__LOC__ true expected_conflict - -let test_agreeing_stakers_cannot_play () = - let open Lwt_result_syntax in - let* block, (pA, pB), rollup = - init_and_originate ~sc_rollup_challenge_window_in_blocks:1000 Context.T2 - in - let pB_pkh = Account.pkh_of_contract_exn pB in - (* pA stakes on a whole branch. *) - let* genesis_info = Context.Sc_rollup.genesis_info (B block) rollup in - let* predecessor = - Context.Sc_rollup.commitment (B block) rollup genesis_info.commitment_hash - in - let* commitments_and_hashes = - let* incr = Incremental.begin_construction block in - gen_commitments incr rollup ~predecessor ~num_commitments:10 - in - let commitments, _ = List.split commitments_and_hashes in - let* block = publish_commitments block pA rollup commitments in - let* block = publish_commitments block pB rollup commitments in - let _, agreed_commitment_hash = - WithExceptions.Option.get ~loc:__LOC__ - @@ List.last_opt commitments_and_hashes - in - let refutation = - Sc_rollup.Game.Start - { - player_commitment_hash = agreed_commitment_hash; - opponent_commitment_hash = agreed_commitment_hash; - } - in - let* op = Op.sc_rollup_refute (B block) pA rollup pB_pkh refutation in - let* incr = Incremental.begin_construction block in - let expect_apply_failure = function - | Environment.Ecoproto_error (Sc_rollup_errors.Sc_rollup_no_conflict as e) - :: _ -> - Assert.test_error_encodings e ; - return_unit - | _ -> failwith "It should have failed with [Sc_rollup_no_conflict]" - in - let* _incr = Incremental.add_operation ~expect_apply_failure incr op in - return_unit - -let test_start_game_on_cemented_commitment () = - let open Lwt_result_syntax in - let* block, (pA, pB), rollup = - init_and_originate ~sc_rollup_challenge_window_in_blocks:1000 Context.T2 - in - let* constants = Context.get_constants (B block) in - let pA_pkh = Account.pkh_of_contract_exn pA in - let pB_pkh = Account.pkh_of_contract_exn pB in - let* genesis_info = Context.Sc_rollup.genesis_info (B block) rollup in - let* predecessor = - Context.Sc_rollup.commitment (B block) rollup genesis_info.commitment_hash - in - let* commitments_and_hashes = - let* incr = Incremental.begin_construction block in - gen_commitments incr rollup ~predecessor ~num_commitments:10 - in - (* pA and pB publishes and cements 10 commitments. *) - let commitments, hashes = List.split commitments_and_hashes in - let* block = publish_commitments block pA rollup commitments in - let* block = publish_commitments block pB rollup commitments in - let* block = - cement_commitments - ~challenge_window_in_blocks: - constants.parametric.sc_rollup.challenge_window_in_blocks - block - rollup - pA - hashes - in - - (* We now check that pA and pB cannot start a refutation against on - cemented commitments. *) - List.iter_es - (fun hash -> - (* The refutation game checks that [pA] stakes on [hash] and - [pB] on [hash]. As the storage keeps in the storage only - the metadata for active commitments, any game started on a cemented - commitment will fail with " not staked on ". *) - let refutation = - Sc_rollup.Game.Start - {player_commitment_hash = hash; opponent_commitment_hash = hash} - in - let* pA_against_pB = - Op.sc_rollup_refute (B block) pA rollup pB_pkh refutation - in - let* pB_against_pA = - Op.sc_rollup_refute (B block) pB rollup pA_pkh refutation - in - let expect_apply_failure = function - | Environment.Ecoproto_error - (Sc_rollup_errors.Sc_rollup_wrong_staker_for_conflict_commitment _ - as e) - :: _ -> - Assert.test_error_encodings e ; - return_unit - | _ -> - failwith - "It should have failed with \ - [Sc_rollup_wrong_staker_for_conflict_commitment]" - in - let* incr = Incremental.begin_construction block in - (* Even if there is no conflict, the refutation game will reject - it before that. This test behaves as a regression test to prevent - to break this property. *) - let* (_ : Incremental.t) = - Incremental.add_operation ~expect_apply_failure incr pA_against_pB - in - let* (_ : Incremental.t) = - Incremental.add_operation ~expect_apply_failure incr pB_against_pA - in - return_unit) - hashes - -let tests = - [ - Tztest.tztest - "check effect of disabled feature flag" - `Quick - test_disable_feature_flag; - Tztest.tztest - "check effect of disabled arith pvm flag" - `Quick - test_disable_arith_pvm_feature_flag; - Tztest.tztest - "can publish a commit, cement it and withdraw stake" - `Quick - test_publish_cement_and_recover_bond; - Tztest.tztest - "publish will fail if staker is double staking" - `Quick - test_publish_fails_on_double_stake; - Tztest.tztest - "cement will fail if commitment is contested" - `Quick - test_cement_fails_on_conflict; - Tztest.tztest - "check the challenge window period boundaries" - `Quick - test_challenge_window_period_boundaries; - Tztest.tztest - "originating with invalid types" - `Quick - test_originating_with_invalid_types; - Tztest.tztest - "originating with valid type" - `Quick - test_originating_with_valid_type; - Tztest.tztest - "originating with invalid boot sector proof" - `Quick - test_originating_with_invalid_boot_sector_proof; - Tztest.tztest - "originating with invalid kind proof" - `Quick - test_originating_with_invalid_kind_proof; - Tztest.tztest - "originating with random proof" - `Quick - test_originating_with_random_proof; - Tztest.tztest - "originating with proof for Tezos context trees" - `Quick - (test_originating_with_wrong_tree ~alter_binary_bit:false); - Tztest.tztest - "originating with proof for Tezos context trees trying to pass as a \ - binary tree" - `Quick - (test_originating_with_wrong_tree ~alter_binary_bit:true); - Tztest.tztest - "single transaction atomic batch" - `Quick - test_single_transaction_batch; - Tztest.tztest - "execute outbox message against older cemented commitment" - `Quick - test_older_cemented_commitment; - Tztest.tztest - "multi-transaction atomic batch" - `Quick - test_multi_transaction_batch; - Tztest.tztest - "transaction with invalid type" - `Quick - test_transaction_with_invalid_type; - Tztest.tztest "execute same message twice" `Quick test_execute_message_twice; - Tztest.tztest - "execute same message twice against different cemented commitments" - `Quick - test_execute_message_twice_different_cemented_commitments; - Tztest.tztest - "transaction with zero amount ticket" - `Quick - test_zero_amount_ticket; - Tztest.tztest "invalid output proof" `Quick test_invalid_output_proof; - Tztest.tztest - "outbox message that overrides an old slot" - `Quick - test_execute_message_override_applied_messages_slot; - Tztest.tztest - "insufficient ticket balances" - `Quick - test_insufficient_ticket_balances; - Tztest.tztest - "inbox max number of messages per inbox level" - `Quick - test_inbox_max_number_of_messages_per_level; - Tztest.tztest - "a player can't timeout another player before timeout period and related \ - timeout value." - `Quick - test_timeout; - Tztest.tztest - "a player cannot play more than max_number_of_parallel_games games in \ - parallel." - `Quick - test_number_of_parallel_games_bounded; - Tztest.tztest - "Two invalid final moves end the game in a draw situation" - `Quick - test_draw_with_two_invalid_moves; - Tztest.tztest - "Timeout during the final move can end the game in a draw situation" - `Quick - test_timeout_during_final_move; - Tztest.tztest - "Cannot play a dissection when the final move has started" - `Quick - test_dissection_during_final_move; - Tztest.tztest - "Invalid metadata initialization can be refuted" - `Quick - test_refute_invalid_metadata; - Tztest.tztest - "Invalid reveal can be refuted" - `Quick - test_refute_invalid_reveal; - Tztest.tztest - "SOL/Info_per_level/EOL are added in the inbox" - `Quick - test_automatically_added_internal_messages; - Tztest.tztest - "0-tick commitments are forbidden" - `Quick - test_zero_tick_commitment_fails; - Tztest.tztest "the curfew functionality" `Quick test_curfew; - Tztest.tztest - "a commitment can be published after the inbox_level + challenge window \ - is passed." - `Quick - test_curfew_period_is_started_only_after_first_publication; - Tztest.tztest - "An offline staker should not prevent cementation" - `Quick - test_offline_staker_does_not_prevent_cementation; - Tztest.tztest "win refutation game by forfeit" `Quick test_winner_by_forfeit; - Tztest.tztest - "win refutation game by forfeit with draw" - `Quick - test_winner_by_forfeit_with_draw; - Tztest.tztest - "cannot start a game with agreeing stakers" - `Quick - test_agreeing_stakers_cannot_play; - Tztest.tztest - "find conflict point with incomplete branch" - `Quick - test_conflict_point_on_a_branch; - Tztest.tztest - "cannot start a game on a cemented commitment" - `Quick - test_start_game_on_cemented_commitment; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("sc rollup", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_sc_rollup_transfer.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_sc_rollup_transfer.ml deleted file mode 100644 index c9bf05adf368a15d281bd1bed79b11552d415c2f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_sc_rollup_transfer.ml +++ /dev/null @@ -1,433 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Sc rollup L1/L2 communication - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/operations/main.exe \ - -- --file test_sc_rollup_transfer.ml - Subject: Test transfers from Michelson to smart contract rollups -*) - -open Protocol -open Alpha_context - -(* Helpers *) - -exception Unexpected_error - -let check_proto_error ~loc ~exp f trace = - let open Lwt_result_syntax in - let*? proto_trace = - List.map_e - (function - | Environment.Ecoproto_error e -> ok e - | e -> - error_with - "At %s, expected protocol error %s, got non-protocol error %a in \ - trace %a" - loc - exp - Error_monad.pp - e - Error_monad.pp_print_trace - trace) - trace - in - try f proto_trace - with Unexpected_error -> - failwith - "At %s, expected error %s, got %a" - loc - exp - Error_monad.pp_print_trace - trace - -let sc_originate = Test_sc_rollup.sc_originate - -(* A contract with four entrypoints: - - [transfer_non_zero] takes a [contract int] and attempts to transfer with a - non-zero amount to it. Expected to fail. - - - [transfer_int] takes a [contract int] and transfers an int to it. Expected - to succeed. - - - [transfer_zero_ticket] takes a [contract (ticket string)] and transfers a - zero-amount ticket to it. Expected to fail. - - - [transfer_ticket] takes a [contract (ticket string)] and transfers a - ticket to it. Expected to succeed. -*) -let contract_originate block account = - let script = - {| - parameter (or (contract %transfer_non_zero int) - (or (contract %transfer_int int) - (or (contract %transfer_zero_ticket (ticket string)) - (or (contract %transfer_ticket (ticket string)) - never)))); - storage unit; - code { - UNPAIR; - IF_LEFT { - # transfer_non_zero - PUSH mutez 1; - PUSH int 42; - TRANSFER_TOKENS; - } { - IF_LEFT { - # transfer_int - PUSH mutez 0; - PUSH int 42; - TRANSFER_TOKENS; - } { - IF_LEFT { - # transfer_zero_ticket - PUSH mutez 0; - PUSH nat 0; - PUSH string "ticket payload"; - TICKET; - ASSERT_SOME; - TRANSFER_TOKENS; - } { - IF_LEFT { - # transfer ticket - PUSH mutez 0; - PUSH nat 137; - PUSH string "G"; - TICKET; - ASSERT_SOME; - TRANSFER_TOKENS; - } { - NEVER - } - } - } - }; - NIL operation; - SWAP; - CONS; - PAIR } -|} - in - Contract_helpers.originate_contract_from_string_hash - ~baker:(Context.Contract.pkh account) - ~source_contract:account - ~script - ~storage:"Unit" - block - -let context_init parameters_ty = - let open Lwt_result_syntax in - let* b, c = Test_sc_rollup.context_init T1 in - let* contract, _script, b = contract_originate b c in - let* b, rollup = sc_originate b c ~parameters_ty in - return (b, c, contract, rollup) - -let transfer ?expect_apply_failure b ~from ~to_ ~param ~entrypoint = - let open Lwt_result_syntax in - let parameters = Script.lazy_expr (Expr.from_string param) in - let* op = - Op.transaction - (B b) - from - (Contract.Originated to_) - Tez.zero - ~parameters - ~entrypoint:(Entrypoint.of_string_strict_exn entrypoint) - ~gas_limit:High - in - let* inc = Incremental.begin_construction b in - let* inc = Incremental.add_operation ?expect_apply_failure inc op in - Incremental.finalize_block inc - -(* Tests *) - -(* Test parsing a [contract] with a badly formatted sr1 address. *) -let test_transfer_to_bad_sc_rollup_address () = - let open Lwt_result_syntax in - let* b, c, contract, _rollup = context_init "unit" in - let not_an_sc_rollup_address = {|"sr1Fq8fPi2NjhWUXtcXBggbL6zFjZctDamso"|} in - let* (_b : Block.t) = - transfer - b - ~from:c - ~to_:contract - ~param:not_an_sc_rollup_address - ~entrypoint:"transfer_non_zero" - ~expect_apply_failure: - (check_proto_error ~loc:__LOC__ ~exp:"Invalid_destination_b58check" - @@ function - | [ - Script_interpreter.Bad_contract_parameter _; - Script_tc_errors.Invalid_constant (_loc, _expr, ty); - Destination_repr.Invalid_destination_b58check _; - ] -> - Assert.equal_string - ~loc:__LOC__ - "(contract int)" - (Expr.to_string ty) - | _ -> raise Unexpected_error) - in - return_unit - -(* Now, the address is well-formatted but the rollup does not exist. *) -let test_transfer_to_unknown_sc_rollup_address () = - let open Lwt_result_syntax in - let* b, c, contract, _rollup = context_init "unit" in - let unknown_sc_rollup_address = {|"sr1Fq8fPi2NjhWUXtcXBggbL6zFjZctGkmso"|} in - let* (_b : Block.t) = - transfer - b - ~from:c - ~to_:contract - ~param:unknown_sc_rollup_address - ~entrypoint:"transfer_non_zero" - ~expect_apply_failure: - (check_proto_error ~loc:__LOC__ ~exp:"Sc_rollup_does_not_exist" - @@ function - | [ - Script_interpreter.Bad_contract_parameter _; - Script_tc_errors.Invalid_constant _; - Sc_rollup_errors.Sc_rollup_does_not_exist _; - ] -> - return_unit - | _ -> raise Unexpected_error) - in - return_unit - -(* Now, let's originate an sc rollup, use its address but with a wrong type. *) -let test_transfer_to_wrongly_typed_sc_rollup () = - let open Lwt_result_syntax in - let* b, c, contract, rollup = context_init "unit" in - let param = Format.sprintf "%S" (Sc_rollup.Address.to_b58check rollup) in - let* (_b : Block.t) = - transfer - b - ~from:c - ~to_:contract - ~param - ~entrypoint:"transfer_non_zero" - ~expect_apply_failure: - (check_proto_error ~loc:__LOC__ ~exp:"Inconsistent_types" @@ function - | [ - Script_interpreter.Bad_contract_parameter _; - Script_tc_errors.Invalid_constant _; - Script_tc_errors.Inconsistent_types _; - Script_tc_errors.Inconsistent_types _; - ] -> - return_unit - | _ -> raise Unexpected_error) - in - return_unit - -(* Use the correct type but with a non-zero amount. *) -let test_transfer_non_zero_amount () = - let open Lwt_result_syntax in - let* b, c, contract, rollup = context_init "int" in - let param = Format.sprintf "%S" (Sc_rollup.Address.to_b58check rollup) in - let* (_b : Block.t) = - transfer - b - ~from:c - ~to_:contract - ~param - ~entrypoint:"transfer_non_zero" - ~expect_apply_failure: - (check_proto_error ~loc:__LOC__ ~exp:"Rollup_invalid_transaction_amount" - @@ function - | [ - Script_interpreter.Runtime_contract_error _; - Script_interpreter_defs.Rollup_invalid_transaction_amount; - ] -> - return_unit - | _ -> raise Unexpected_error) - in - return_unit - -(* Use the correct type through an entrypoint but with a non-zero amount. *) -let test_transfer_non_zero_amount_via_entrypoint () = - let open Lwt_result_syntax in - let* b, c, contract, rollup = context_init "int" in - let param = Format.sprintf "%S" (Sc_rollup.Address.to_b58check rollup) in - let* (_b : Block.t) = - transfer - b - ~from:c - ~to_:contract - ~param - ~entrypoint:"transfer_non_zero" - ~expect_apply_failure: - (check_proto_error ~loc:__LOC__ ~exp:"Rollup_invalid_transaction_amount" - @@ function - | [ - Script_interpreter.Runtime_contract_error _; - Script_interpreter_defs.Rollup_invalid_transaction_amount; - ] -> - return_unit - | _ -> raise Unexpected_error) - in - return_unit - -(* Now, transfer with a zero-amount and check that the inbox has been updated correctly. *) -let test_transfer_works () = - let open Lwt_result_syntax in - let* b, c, contract, rollup = context_init "int" in - let* inbox_before = Context.Sc_rollup.inbox (B b) in - let* expected_inbox_after = - let* inc = Incremental.begin_construction b in - let ctxt = Incremental.alpha_ctxt inc in - let payload = Expr.from_string "42" in - let* ctxt = - Sc_rollup.Inbox.add_deposit - ctxt - ~destination:rollup - ~payload - ~sender:contract - ~source:(Context.Contract.pkh c) - >|= Environment.wrap_tzresult - in - let incr = Incremental.set_alpha_ctxt inc ctxt in - let* block = Incremental.finalize_block incr in - let* expected_inbox_after = Context.Sc_rollup.inbox (B block) in - return expected_inbox_after - in - let param = Format.sprintf "%S" (Sc_rollup.Address.to_b58check rollup) in - let* b = transfer b ~from:c ~to_:contract ~param ~entrypoint:"transfer_int" in - let* inbox_after = Context.Sc_rollup.inbox (B b) in - let* () = - Assert.not_equal_with_encoding - ~loc:__LOC__ - Sc_rollup.Inbox.encoding - inbox_before - inbox_after - in - Assert.equal_with_encoding - ~loc:__LOC__ - Sc_rollup.Inbox.encoding - inbox_after - expected_inbox_after - -(* Transfer of zero-amount ticket fails. *) -let test_transfer_zero_amount_ticket () = - let open Lwt_result_syntax in - let* b, c, contract, rollup = context_init "ticket string" in - let param = Format.sprintf "%S" (Sc_rollup.Address.to_b58check rollup) in - let* (_b : Block.t) = - transfer - b - ~from:c - ~to_:contract - ~param - ~entrypoint:"transfer_zero_ticket" - ~expect_apply_failure: - (check_proto_error ~loc:__LOC__ ~exp:"Script_rejected" @@ function - | [ - Script_interpreter.Runtime_contract_error _; - Script_interpreter.Reject _; - ] -> - return_unit - | _ -> raise Unexpected_error) - in - return_unit - -(* Transfer of a non-zero-amount ticket works and the balance table is correctly updated. *) -let test_transfer_non_zero_amount_ticket () = - let open Lwt_result_syntax in - let* b, c, contract, rollup = context_init "ticket string" in - let param = Format.sprintf "%S" (Sc_rollup.Address.to_b58check rollup) in - let* b = - transfer b ~from:c ~to_:contract ~param ~entrypoint:"transfer_ticket" - in - let* ticket_key_for_contract, ticket_key_for_rollup, ctxt = - let* ticket_token = - Ticket_helpers.string_ticket_token - (Contract_hash.to_b58check contract) - "G" - in - let* inc = Incremental.begin_construction b in - let ctxt = Incremental.alpha_ctxt inc in - let* ticket_key_for_contract, ctxt = - Ticket_balance_key.of_ex_token - ctxt - ~owner:(Destination.Contract (Originated contract)) - ticket_token - >|= Environment.wrap_tzresult - in - let* ticket_key_for_rollup, _ctxt = - Ticket_balance_key.of_ex_token - ctxt - ~owner:(Destination.Sc_rollup rollup) - ticket_token - >|= Environment.wrap_tzresult - in - return (ticket_key_for_contract, ticket_key_for_rollup, ctxt) - in - (* The rollup is the owner of the tickets *) - let* () = - Ticket_helpers.assert_balance - ctxt - ~loc:__LOC__ - ticket_key_for_rollup - (Some 137) - in - (* The contract didn't retain any ticket in the operation *) - let* () = - Ticket_helpers.assert_balance ctxt ~loc:__LOC__ ticket_key_for_contract None - in - return_unit - -let tests = - [ - Tztest.tztest - "Transfer to a bad sc rollup address" - `Quick - test_transfer_to_bad_sc_rollup_address; - Tztest.tztest - "Transfer to an unknown rollup address" - `Quick - test_transfer_to_unknown_sc_rollup_address; - Tztest.tztest - "Transfer with a wrong type" - `Quick - test_transfer_to_wrongly_typed_sc_rollup; - Tztest.tztest - "Transfer with a non-zero amount" - `Quick - test_transfer_non_zero_amount_via_entrypoint; - Tztest.tztest "Transfer works" `Quick test_transfer_works; - Tztest.tztest - "Transfer of zero-amount ticket" - `Quick - test_transfer_zero_amount_ticket; - Tztest.tztest - "Transfer of non-zero-amount ticket" - `Quick - test_transfer_non_zero_amount_ticket; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("sc rollup transfer", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_transfer.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_transfer.ml deleted file mode 100644 index b734e3b1fa43e7cbdaf23c5435e2ba8a4f746aa3..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_transfer.ml +++ /dev/null @@ -1,910 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (transfer) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/operations/main.exe \ - -- --file test_transfer.ml - Subject: Quantities transfer between contracts. -*) - -open Protocol -open Alpha_context -open Test_tez -open Transfers - -(*********************************************************************) -(* Utility functions *) -(*********************************************************************) - -(** - [transfer_to_itself_and_check_balances b fee contract amount] - this function takes a block, an optional parameter fee, - a contract that is a source and a destination contract, - and an amount of tez that one wants to transfer. - - 1- Transfer the amount of tez (w/wo transfer fee) from/to a contract itself. - - 2- Check the equivalent of the balance of the contract before - and after transfer. - - This function returns a pair: - - a block that added the valid transaction - - an valid transaction *) -let transfer_to_itself_and_check_balances ~loc ?policy b ?(fee = Tez.zero) - contract amount = - Context.Contract.balance (B b) contract >>=? fun bal -> - Op.transaction (B b) ~fee contract contract amount >>=? fun operation -> - Block.bake ?policy ~operation b >>=? fun b -> - Assert.balance_was_debited ~loc (B b) contract bal fee >|=? fun () -> - (b, operation) - -let ten_tez = of_int 10 - -(*********************************************************************) -(* Tests *) -(*********************************************************************) - -(** Compute a fraction of 2/[n] of the balance of [contract] *) -let two_over_n_of_balance ctxt contract n = - Context.Contract.balance ctxt contract >>=? fun balance -> - Lwt.return (balance /? n >>? fun res -> res *? 2L) - -(********************) -(** Single transfer *) - -(********************) - -let single_transfer ?fee ?expect_apply_failure amount = - Context.init2 () >>=? fun (b, (contract_1, contract_2)) -> - Incremental.begin_construction b >>=? fun b -> - transfer_and_check_balances - ~loc:__LOC__ - ?fee - ?expect_apply_failure - b - contract_1 - contract_2 - amount - >>=? fun (b, _) -> - Incremental.finalize_block b >>=? fun (_ : Block.t) -> return_unit - -(** Single transfer without fee. *) -let test_block_with_a_single_transfer () = single_transfer Tez.one - -(** Single transfer with fee. *) -let test_block_with_a_single_transfer_with_fee () = - single_transfer ~fee:Tez.one Tez.one - -(** Single transfer without fee. *) -let test_transfer_zero_tez () = - let expect_apply_failure = function - | Environment.Ecoproto_error (Apply.Empty_transaction _ as err) :: _ -> - Assert.test_error_encodings err ; - return_unit - | _ -> failwith "Empty transaction should fail" - in - single_transfer ~expect_apply_failure Tez.zero - -(** Transfer zero tez from an implicit contract. *) -let test_transfer_zero_implicit () = - Context.init1 () >>=? fun (b, dest) -> - let account = Account.new_account () in - Incremental.begin_construction b >>=? fun i -> - let src = Contract.Implicit account.Account.pkh in - Op.transaction (I i) src dest Tez.zero >>=? fun op -> - Incremental.add_operation i op >>= fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Contract_storage.Empty_implicit_contract _ as err -> - Assert.test_error_encodings err ; - true - | _ -> false) - -(** Transfer to originated contract. *) -let test_transfer_to_originate_with_fee () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, contract) -> - two_over_n_of_balance (B b) contract 10L >>=? fun fee -> - (* originated contract, paying a fee to originated this contract *) - Op.contract_origination (B b) ~fee:ten_tez contract ~script:Op.dummy_script - >>=? fun (operation, new_contract) -> - Block.bake ~operation b >>=? fun b -> - two_over_n_of_balance (B b) contract 3L >>=? fun amount -> - Incremental.begin_construction b >>=? fun i -> - transfer_and_check_balances ~loc:__LOC__ i ~fee contract new_contract amount - >>=? fun (i, _) -> - Incremental.finalize_block i >>=? fun (_ : Block.t) -> return_unit - -(** Transfer from balance. *) -let test_transfer_amount_of_contract_balance () = - Context.init2 () >>=? fun (b, (contract_1, contract_2)) -> - let pkh1 = Context.Contract.pkh contract_1 in - (* given that contract_1 no longer has a sufficient balance to bake, - make sure it cannot be chosen as baker *) - Incremental.begin_construction b ~policy:(Block.Excluding [pkh1]) - >>=? fun b -> - (* get the balance of the source contract *) - Context.Contract.balance (I b) contract_1 >>=? fun balance -> - (* transfer all the tez inside contract 1 *) - transfer_and_check_balances ~loc:__LOC__ b contract_1 contract_2 balance - >>=? fun (b, _) -> - Incremental.finalize_block b >>=? fun (_ : Block.t) -> return_unit - -(** Transfer to oneself. *) -let test_transfers_to_self () = - Context.init2 ~consensus_threshold:0 () >>=? fun (b, (contract, _)) -> - two_over_n_of_balance (B b) contract 3L >>=? fun amount -> - let pkh1 = Context.Contract.pkh contract in - transfer_to_itself_and_check_balances - ~loc:__LOC__ - ~policy:(Block.Excluding [pkh1]) - b - contract - amount - >>=? fun (b, _) -> - two_over_n_of_balance (B b) contract 5L >>=? fun fee -> - transfer_to_itself_and_check_balances - ~loc:__LOC__ - b - ~policy:(Block.Excluding [pkh1]) - ~fee - contract - ten_tez - >>=? fun (_, _) -> return_unit - -(** Forgot to add the valid transaction into the block. *) -let test_missing_transaction () = - Context.init2 ~consensus_threshold:0 () - >>=? fun (b, (contract_1, contract_2)) -> - (* given that contract_1 no longer has a sufficient balance to bake, - make sure it cannot be chosen as baker *) - let pkh1 = Context.Contract.pkh contract_1 in - Incremental.begin_construction b ~policy:(Block.Excluding [pkh1]) - >>=? fun i -> - two_over_n_of_balance (B b) contract_1 6L >>=? fun amount -> - (* Do the transfer 3 times from source contract to destination contract *) - n_transactions 3 i contract_1 contract_2 amount >>=? fun i -> - (* do the fourth transfer from source contract to destination contract *) - Op.transaction (I i) contract_1 contract_2 amount - >>=? fun (_ : packed_operation) -> - Incremental.finalize_block i >>=? fun (_ : Block.t) -> return_unit - -(** Transfer zero tez to an implicit contract, with fee equals balance of src. *) -let test_transfer_zero_implicit_with_bal_src_as_fee () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, dest) -> - let account = Account.new_account () in - let src_pkh = account.Account.pkh in - let src = Contract.Implicit src_pkh in - Op.transaction ~force_reveal:true (B b) dest src (Tez.of_mutez_exn 100L) - >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - Context.Contract.balance (B b) src >>=? fun bal_src -> - Assert.equal_tez ~loc:__LOC__ bal_src (Tez.of_mutez_exn 100L) >>=? fun () -> - Op.transaction ~force_reveal:true (B b) ~fee:bal_src src dest Tez.zero - >>=? fun op -> - (* Transferring zero tez should result in an application failure as - the implicit contract has been depleted. *) - let expect_apply_failure = function - | [ - Environment.Ecoproto_error (Contract_storage.Empty_implicit_contract pkh); - ] - when pkh = src_pkh -> - return_unit - | _ -> assert false - in - Incremental.begin_construction b >>=? fun i -> - Incremental.add_operation ~expect_apply_failure i op >>=? fun inc -> - Context.Contract.balance (I inc) src >>=? fun balance -> - (* We assert that the failing operation was included and that the - fees were taken, effectively depleting the contract. *) - Assert.equal_tez ~loc:__LOC__ balance Tez.zero >>=? fun () -> - (* Empty contracts should be unrevealed *) - Context.Contract.is_manager_key_revealed (I inc) src >>=? fun revelead -> - when_ revelead (fun () -> - Stdlib.failwith "Empty account still exists and is revealed.") - -(** Transfer zero tez to an originated contract, with fee equals balance of src. *) -let test_transfer_zero_to_originated_with_bal_src_as_fee () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, dest) -> - let account = Account.new_account () in - let src = Contract.Implicit account.Account.pkh in - Op.transaction (B b) dest src (Tez.of_mutez_exn 100L) >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - Op.contract_origination (B b) dest ~script:Op.dummy_script - >>=? fun (operation, new_contract) -> - Block.bake ~operation b >>=? fun b -> - Context.Contract.balance (B b) src >>=? fun bal_src -> - Op.revelation (B b) ~fee:Tez.zero account.pk >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - Op.transaction (B b) ~fee:bal_src src new_contract Tez.zero - >>=? fun operation -> - Assert.equal_tez ~loc:__LOC__ bal_src (Tez.of_mutez_exn 100L) >>=? fun () -> - Block.bake ~operation b >>=? fun (_ : Block.t) -> return_unit - -(** Transfer one tez to an implicit contract, with fee equals balance of src. *) -let test_transfer_one_to_implicit_with_bal_src_as_fee () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, dest) -> - let account = Account.new_account () in - let src = Contract.Implicit account.Account.pkh in - Op.transaction (B b) dest src (Tez.of_mutez_exn 100L) >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - Context.Contract.balance (B b) src >>=? fun bal_src -> - Assert.equal_tez ~loc:__LOC__ bal_src (Tez.of_mutez_exn 100L) >>=? fun () -> - Op.revelation (B b) ~fee:Tez.zero account.pk >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - Op.transaction (B b) ~fee:bal_src src dest Tez.one >>=? fun op -> - Incremental.begin_construction b >>=? fun i -> - Incremental.add_operation i op ~expect_apply_failure:(function - | Environment.Ecoproto_error (Contract_storage.Balance_too_low _ as err) - :: _ -> - Assert.test_error_encodings err ; - return_unit - | t -> failwith "Unexpected error: %a" Error_monad.pp_print_trace t) - >>=? fun (_ : Incremental.t) -> return_unit - -(********************) -(* The following tests are for different kind of contracts: - - implicit to implicit - - implicit to originated - - originated to implicit - - originated to originated *) - -(********************) - -(** Implicit to Implicit. *) -let test_transfer_from_implicit_to_implicit_contract () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap_contract) -> - let account_a = Account.new_account () in - let account_b = Account.new_account () in - let src = Contract.Implicit account_a.Account.pkh in - two_over_n_of_balance (B b) bootstrap_contract 3L >>=? fun amount1 -> - two_over_n_of_balance (B b) bootstrap_contract 10L >>=? fun fee1 -> - Incremental.begin_construction b >>=? fun i -> - transfer_and_check_balances - ~with_burn:true - ~loc:__LOC__ - ~fee:fee1 - i - bootstrap_contract - src - amount1 - >>=? fun (i, _) -> - Incremental.finalize_block i >>=? fun b -> - Incremental.begin_construction b >>=? fun i -> - (* Create an implicit contract as a destination contract. *) - let dest = Contract.Implicit account_b.pkh in - two_over_n_of_balance (I i) bootstrap_contract 4L >>=? fun amount2 -> - two_over_n_of_balance (I i) bootstrap_contract 10L >>=? fun fee2 -> - (* Transfer from implicit contract to another implicit contract. *) - transfer_and_check_balances - ~with_burn:true - ~loc:__LOC__ - ~fee:fee2 - i - src - dest - amount2 - >>=? fun (b, _) -> - Incremental.finalize_block b >>=? fun (_ : Block.t) -> return_unit - -(** Implicit to originated. *) -let test_transfer_from_implicit_to_originated_contract () = - Context.init1 ~consensus_threshold:0 () >>=? fun (b, bootstrap_contract) -> - let contract = bootstrap_contract in - let account = Account.new_account () in - let src = Contract.Implicit account.Account.pkh in - two_over_n_of_balance (B b) bootstrap_contract 3L >>=? fun amount1 -> - Incremental.begin_construction b >>=? fun i -> - (* transfer the money to implicit contract *) - transfer_and_check_balances - ~with_burn:true - ~loc:__LOC__ - i - bootstrap_contract - src - amount1 - >>=? fun (i, _) -> - Incremental.finalize_block i >>=? fun b -> - Incremental.begin_construction b >>=? fun i -> - (* originated contract *) - Op.contract_origination - ~force_reveal:true - (I i) - contract - ~script:Op.dummy_script - >>=? fun (operation, new_contract) -> - Incremental.add_operation i operation >>=? fun i -> - two_over_n_of_balance (I i) bootstrap_contract 4L >>=? fun amount2 -> - (* transfer from implicit contract to originated contract *) - transfer_and_check_balances ~loc:__LOC__ i src new_contract amount2 - >>=? fun (i, _) -> - Incremental.finalize_block i >>=? fun (_ : Block.t) -> return_unit - -(********************) -(* Slow tests case *) - -(********************) - -let multiple_transfer n ?fee amount = - Context.init2 ~consensus_threshold:0 () - >>=? fun (b, (contract_1, contract_2)) -> - Incremental.begin_construction b >>=? fun b -> - n_transactions n b ?fee contract_1 contract_2 amount >>=? fun b -> - Incremental.finalize_block b >>=? fun (_ : Block.t) -> return_unit - -(** 1- Create a block with two contracts; - 2- Apply 100 transfers. -*) -let test_block_with_multiple_transfers () = multiple_transfer 99 (of_int 1000) - -(** 1- Create a block with two contracts; - 2- Apply 100 transfers with 10tz fee. *) -let test_block_with_multiple_transfers_pay_fee () = - multiple_transfer 10 ~fee:ten_tez (of_int 1000) - -(* TODO : increase the number of operations and add a `Slow tag to it in `tests` *) - -(** 1- Create a block with 8 contracts; - 2- Apply multiple transfers without fees; - 3- Apply multiple transfers with fees. *) -let test_block_with_multiple_transfers_with_without_fee () = - Context.init_n ~consensus_threshold:0 8 () >>=? fun (b, contracts) -> - let contracts = Array.of_list contracts in - Incremental.begin_construction b >>=? fun b -> - let hundred = of_int 100 in - let ten = of_int 10 in - let twenty = of_int 20 in - n_transactions 10 b contracts.(0) contracts.(1) Tez.one >>=? fun b -> - n_transactions 30 b contracts.(1) contracts.(2) hundred >>=? fun b -> - n_transactions 30 b contracts.(1) contracts.(3) hundred >>=? fun b -> - n_transactions 30 b contracts.(4) contracts.(3) hundred >>=? fun b -> - n_transactions 20 b contracts.(0) contracts.(1) hundred >>=? fun b -> - n_transactions 10 b contracts.(1) contracts.(3) hundred >>=? fun b -> - n_transactions 10 b contracts.(1) contracts.(3) hundred >>=? fun b -> - n_transactions 20 ~fee:ten b contracts.(3) contracts.(4) ten >>=? fun b -> - n_transactions 10 ~fee:twenty b contracts.(4) contracts.(5) ten >>=? fun b -> - n_transactions 70 ~fee:twenty b contracts.(6) contracts.(0) twenty - >>=? fun b -> - n_transactions 550 ~fee:twenty b contracts.(6) contracts.(4) twenty - >>=? fun b -> - n_transactions 50 ~fee:ten b contracts.(7) contracts.(5) twenty >>=? fun b -> - n_transactions 30 ~fee:ten b contracts.(0) contracts.(7) hundred >>=? fun b -> - n_transactions 20 ~fee:ten b contracts.(1) contracts.(0) twenty >>=? fun b -> - Incremental.finalize_block b >>=? fun (_ : Block.t) -> return_unit - -(** Build a chain that has 10 blocks. *) -let test_build_a_chain () = - Context.init2 ~consensus_threshold:0 () - >>=? fun (b, (contract_1, contract_2)) -> - let ten = of_int 10 in - List.fold_left_es - (fun b _ -> - Incremental.begin_construction b >>=? fun b -> - transfer_and_check_balances ~loc:__LOC__ b contract_1 contract_2 ten - >>=? fun (b, _) -> Incremental.finalize_block b) - b - (1 -- 10) - >>=? fun (_ : Block.t) -> return_unit - -(*********************************************************************) -(* Expected error test cases *) -(*********************************************************************) - -(** Transferring zero tez is forbidden in implicit contract. *) -let test_empty_implicit () = - Context.init1 () >>=? fun (b, dest) -> - let account = Account.new_account () in - let src = Contract.Implicit account.Account.pkh in - two_over_n_of_balance (B b) dest 3L >>=? fun amount -> - (* Transfer zero tez from an implicit contract. *) - Op.transaction (B b) src dest amount >>=? fun op -> - Incremental.begin_construction b >>=? fun incr -> - Incremental.add_operation incr op >>= fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Contract_storage.Empty_implicit_contract _ as err -> - Assert.test_error_encodings err ; - true - | _ -> false) - -(** Balance is too low to transfer. *) -let test_balance_too_low fee () = - let open Lwt_result_syntax in - let* b, (contract_1, contract_2) = Context.init2 ~consensus_threshold:0 () in - let* balance1 = Context.Contract.balance (B b) contract_1 in - let* balance2 = Context.Contract.balance (B b) contract_2 in - (* transfer the amount of tez that is bigger than the balance in the source contract *) - let* op = Op.transaction ~fee (B b) contract_1 contract_2 max_tez in - let expect_failure = function - | Environment.Ecoproto_error (Contract_storage.Balance_too_low _ as err) - :: _ -> - Assert.test_error_encodings err ; - return_unit - | t -> failwith "Unexpected error: %a" Error_monad.pp_print_trace t - in - let* i = Incremental.begin_construction b in - if fee > balance1 then - (* The fee is higher than the balance, so the operation validation - fails with the [Balance_too_low] error. *) - let* (_res : Incremental.t) = - Incremental.add_operation ~expect_failure i op - in - return_unit - else - (* The fee is smaller than or equal to the balance, so the - operation is successfully validated and its fees are - taken. However, since the amount to transfer exceeds the - balance, the application has no further effects and the - operation is marked with the [Balance_too_low] error. *) - let* i = - Incremental.add_operation ~expect_apply_failure:expect_failure i op - in - (* contract_1 loses the fees *) - let* () = - Assert.balance_was_debited ~loc:__LOC__ (I i) contract_1 balance1 fee - in - (* contract_2 is not credited *) - Assert.balance_was_credited ~loc:__LOC__ (I i) contract_2 balance2 Tez.zero - -(** 1- Create a block, and three contracts; - 2- Add a transfer that at the end the balance of a contract is - zero into this block; - 3- Add another transfer that send tez from a zero balance contract; - 4- Catch the expected error: Balance_too_low. *) -let test_balance_too_low_two_transfers fee () = - Context.init3 ~consensus_threshold:0 () - >>=? fun (b, (contract_1, contract_2, contract_3)) -> - Incremental.begin_construction b >>=? fun i -> - Context.Contract.balance (I i) contract_1 >>=? fun balance -> - balance /? 3L >>?= fun res -> - res *? 2L >>?= fun two_third_of_balance -> - transfer_and_check_balances - ~loc:__LOC__ - i - contract_1 - contract_2 - two_third_of_balance - >>=? fun (i, _) -> - Incremental.finalize_block i >>=? fun b -> - Context.Contract.balance (B b) contract_1 >>=? fun balance1 -> - Context.Contract.balance (B b) contract_3 >>=? fun balance3 -> - Op.transaction ~fee (B b) contract_1 contract_3 two_third_of_balance - >>=? fun operation -> - let expect_apply_failure = function - | Environment.Ecoproto_error (Contract_storage.Balance_too_low _ as err) - :: _ -> - Assert.test_error_encodings err ; - return_unit - | t -> failwith "Unexpected error: %a" Error_monad.pp_print_trace t - in - Incremental.begin_construction b >>=? fun i -> - Incremental.add_operation ~expect_apply_failure i operation >>=? fun i -> - (* contract_1 loses the fees *) - Assert.balance_was_debited ~loc:__LOC__ (I i) contract_1 balance1 fee - >>=? fun () -> - (* contract_3 is not credited *) - Assert.balance_was_credited ~loc:__LOC__ (I i) contract_3 balance3 Tez.zero - -(** The counter is already used for the previous operation. *) -let invalid_counter () = - Context.init2 ~consensus_threshold:0 () - >>=? fun (b, (contract_1, contract_2)) -> - Op.transaction (B b) contract_1 contract_2 Tez.one >>=? fun op1 -> - Op.transaction (B b) contract_1 contract_2 Tez.one >>=? fun op2 -> - Block.bake ~operation:op1 b >>=? fun b -> - Incremental.begin_construction b >>=? fun i -> - Incremental.add_operation i op2 >>= fun b -> - Assert.proto_error ~loc:__LOC__ b (function - | Contract_storage.Counter_in_the_past _ as err -> - Assert.test_error_encodings err ; - true - | _ -> false) - -(** Same as before but through a different way to perform this - error. *) -let test_add_the_same_operation_twice () = - Context.init2 () >>=? fun (b, (contract_1, contract_2)) -> - Incremental.begin_construction b >>=? fun i -> - transfer_and_check_balances ~loc:__LOC__ i contract_1 contract_2 ten_tez - >>=? fun (i, op_transfer) -> - Incremental.finalize_block i >>=? fun b -> - Incremental.begin_construction b >>=? fun i -> - Op.transaction (I i) contract_1 contract_2 ten_tez - >>=? fun (_ : packed_operation) -> - Incremental.add_operation i op_transfer >>= fun b -> - Assert.proto_error ~loc:__LOC__ b (function - | Contract_storage.Counter_in_the_past _ as err -> - Assert.test_error_encodings err ; - true - | _ -> false) - -(** The counter is in the future *) -let invalid_counter_in_the_future () = - Context.init2 () >>=? fun (b, (contract_1, contract_2)) -> - Incremental.begin_construction b >>=? fun b -> - Context.Contract.counter (I b) contract_1 >>=? fun cpt -> - let counter = Manager_counter.Internal_for_tests.add cpt 10 in - Op.transaction (I b) contract_1 contract_2 Tez.one ~counter >>=? fun op -> - Incremental.add_operation b op >>= fun b -> - Assert.proto_error ~loc:__LOC__ b (function - | Contract_storage.Counter_in_the_future _ as err -> - Assert.test_error_encodings err ; - true - | _ -> false) - -(** Check ownership. *) -let test_ownership_sender () = - Context.init2 () >>=? fun (b, (contract_1, contract_2)) -> - Incremental.begin_construction b >>=? fun b -> - (* get the manager of the contract_1 as a sender *) - Context.Contract.manager (I b) contract_1 >>=? fun manager -> - let imcontract_1 = Alpha_context.Contract.Implicit manager.pkh in - transfer_and_check_balances ~loc:__LOC__ b imcontract_1 contract_2 Tez.one - >>=? fun (b, _) -> - Incremental.finalize_block b >>=? fun (_ : Block.t) -> return_unit - -(*********************************************************************) -(* Random transfer *) - -(* Return a pair of minimum and maximum random number. *) -let random_range (min, max) = - let interv = max - min + 1 in - let init = - Random.self_init () ; - Random.int interv + min - in - init - -(* Return a random contract. *) -let random_contract contract_array = - let i = Random.int (Array.length contract_array) in - contract_array.(i) - -(** Transfer by randomly choose amount 10 contracts, and randomly - choose the amount in the source contract. *) -let test_random_transfer () = - Context.init_n 10 () >>=? fun (b, contracts) -> - let contracts = Array.of_list contracts in - let source = random_contract contracts in - let dest = random_contract contracts in - let source_pkh = Context.Contract.pkh source in - (* given that source may not have a sufficient balance for the transfer + to bake, - make sure it cannot be chosen as baker *) - Context.Contract.balance (B b) source >>=? fun amount -> - if source = dest then - transfer_to_itself_and_check_balances - ~loc:__LOC__ - ~policy:(Block.Excluding [source_pkh]) - b - source - amount - >>=? fun (_, _) -> return_unit - else - Incremental.begin_construction ~policy:(Block.Excluding [source_pkh]) b - >>=? fun i -> - transfer_and_check_balances ~loc:__LOC__ i source dest amount - >>=? fun (_, _) -> return_unit - -(** Transfer random transactions. *) -let test_random_multi_transactions () = - let n = random_range (1, 100) in - multiple_transfer n (of_int 100) - -(*********************************************************************) - -let test_bad_entrypoint () = - Context.init1 () >>=? fun (b, _c) -> - Incremental.begin_construction b >>=? fun v -> - let ctxt = Incremental.alpha_ctxt v in - let storage = "Unit" in - let parameter = "Unit" in - let entrypoint = Entrypoint.of_string_strict_exn "bad entrypoint" in - (* bad entrypoint *) - Contract_helpers.run_script - ctxt - "{parameter unit; storage unit; code { CAR; NIL operation; PAIR }}" - ~entrypoint - ~storage - ~parameter - () - >>= function - | Ok _ -> Alcotest.fail "expected error" - | Error lst - when List.mem - ~equal:( = ) - (Environment.Ecoproto_error - (Script_tc_errors.No_such_entrypoint entrypoint)) - lst -> - return () - | Error errs -> - Alcotest.failf "Unexpected error: %a" Error_monad.pp_print_trace errs - -let test_bad_parameter () = - Context.init1 () >>=? fun (b, _c) -> - Incremental.begin_construction b >>=? fun v -> - let ctxt = Incremental.alpha_ctxt v in - let storage = "Unit" in - let parameter = "1" in - (* bad parameter *) - Contract_helpers.run_script - ctxt - "{parameter unit; storage unit; code { CAR; NIL operation; PAIR }}" - ~storage - ~parameter - () - >>= function - | Ok _ -> Alcotest.fail "expected error" - | Error lst - when List.mem - ~equal:( = ) - (Environment.Ecoproto_error - (Script_interpreter.Bad_contract_parameter - (Contract.Originated Contract_helpers.default_self))) - lst -> - return () - | Error errs -> - Alcotest.failf "Unexpected error: %a" Error_monad.pp_print_trace errs - -let transfer_to_itself_with_no_such_entrypoint () = - let open Lwt_result_syntax in - let entrypoint = Entrypoint.of_string_strict_exn "bad entrypoint" in - let* b, addr = Context.init1 () in - let* i = Incremental.begin_construction b in - let* transaction = Op.transaction (B b) addr addr Tez.one ~entrypoint in - let expect_apply_failure = function - | Environment.Ecoproto_error (Script_tc_errors.No_such_entrypoint _ as e) - :: _ -> - Assert.test_error_encodings e ; - return () - | _ -> failwith "no such entrypoint should fail" - in - let* (_res : Incremental.t) = - Incremental.add_operation ~expect_apply_failure i transaction - in - return_unit - -(** Originates a contract with a [script] and an initial [credit] and - [storage]. *) -let contract_originate ~baker ~block ~script ~credit ~storage ~source = - let open Lwt_result_syntax in - let code = Expr.from_string script in - let script = - Alpha_context.Script.{code = lazy_expr code; storage = lazy_expr storage} - in - let* op, dst = - Op.contract_origination_hash (B block) source ~fee:Tez.zero ~script ~credit - in - let+ state = - Block.bake ~policy:Block.(By_account baker) ~operations:[op] block - in - (state, dst) - -(** Runs a transaction from a [source] to a [destination]. *) -let transfer ?force_reveal ?parameters ~baker ~block ~source ~destination amount - = - let open Lwt_result_syntax in - let* operation = - Op.transaction - ?force_reveal - ?parameters - ~fee:Tez.zero - (B block) - source - destination - amount - in - Block.bake ~policy:Block.(By_account baker) ~operations:[operation] block - -(** The script of a contract that transfers its balance to the caller, and - stores the parameter of the call. *) -let script = - {| { parameter string ; - storage string ; - code { - CAR ; - SOURCE ; - CONTRACT unit ; - ASSERT_SOME ; - BALANCE ; - UNIT ; - TRANSFER_TOKENS ; - NIL operation ; - SWAP ; - CONS ; - PAIR } -} |} - -(** The tested scenarios are the following : - - - originate a contract with the above [script] and no initial balance, - call it from an account short of sufficient funds to cover storage fees, - and check that this indeed fails. - - - originate a contract with the above [script] and sufficient balance to - cover storage fees of a subsequent call, call the originated contract from - an account short of sufficient funds to cover storage fees, as expected, - this succeeds since the caller receives the originated contract's initial - balance. *) -let test_storage_fees_and_internal_operation () = - let open Lwt_result_syntax in - let* initial_block, contract = Context.init1 ~consensus_threshold:0 () in - let null_string = Expr.from_string "\"\"" in - let caller = Account.new_account () in - (* Initialize a caller account. *) - let* initial_block = - transfer - ~block:initial_block - ~baker:(Context.Contract.pkh contract) - ~source:contract - ~destination:(Contract.Implicit caller.pkh) - Tez.one_mutez - in - (* [originate_and_call] first, originates a contract with an empty string as - initial storage, and an initial credit of [initial_amount]. And then, calls - the originated contract from [caller] with a parameter that allocates - additional storage. *) - let originate_and_call ~initial_block ~initial_amount = - let* block, contract_hash = - contract_originate - ~block:initial_block - ~baker:(Context.Contract.pkh contract) - ~script - ~source:contract - ~credit:initial_amount - ~storage:null_string - in - let random_string = Expr.from_string "\"Abracadabra\"" in - transfer - ~force_reveal:true - ~parameters:(Alpha_context.Script.lazy_expr random_string) - ~block - ~baker:(Context.Contract.pkh contract) - ~source:(Contract.Implicit caller.pkh) - ~destination:(Contract.Originated contract_hash) - Tez.zero - in - (* Ensure failure when the initial balance of the originated contract is not - sufficient to pay storage fees. *) - let*! res = originate_and_call ~initial_block ~initial_amount:Tez.one_mutez in - let* () = - Assert.proto_error_with_info ~loc:__LOC__ res "Cannot pay storage fee" - in - (* Ensure success when the initial balance of the originated contract is - sufficient to pay storage fees. *) - let+ (_ : Block.t) = - originate_and_call ~initial_block ~initial_amount:Tez.one_cent - in - () - -let tests = - [ - (* single transfer *) - Tztest.tztest "single transfer" `Quick test_block_with_a_single_transfer; - Tztest.tztest - "single transfer with fee" - `Quick - test_block_with_a_single_transfer_with_fee; - (* transfer zero tez *) - Tztest.tztest "single transfer zero tez" `Quick test_transfer_zero_tez; - Tztest.tztest - "transfer zero tez from implicit contract" - `Quick - test_transfer_zero_implicit; - Tztest.tztest - "transfer zero tez to an implicit contract with balance of src as fee" - `Quick - test_transfer_zero_implicit_with_bal_src_as_fee; - (* transfer to originated contract *) - Tztest.tztest - "transfer to originated contract paying transaction fee" - `Quick - test_transfer_to_originate_with_fee; - Tztest.tztest - "transfer zero tez to an originated contract with balance of src as fee" - `Quick - test_transfer_zero_to_originated_with_bal_src_as_fee; - (* transfer by the balance of contract *) - Tztest.tztest - "transfer the amount from source contract balance" - `Quick - test_transfer_amount_of_contract_balance; - (* transfer to itself *) - Tztest.tztest "transfers to itself" `Quick test_transfers_to_self; - (* missing operation *) - Tztest.tztest "missing transaction" `Quick test_missing_transaction; - (* transfer from/to implicit/originated contracts*) - Tztest.tztest - "transfer from an implicit to implicit contract" - `Quick - test_transfer_from_implicit_to_implicit_contract; - Tztest.tztest - "transfer from an implicit to an originated contract" - `Quick - test_transfer_from_implicit_to_originated_contract; - (* Slow tests *) - Tztest.tztest - "block with multiple transfers" - `Slow - test_block_with_multiple_transfers; - (* TODO increase the number of transaction times *) - Tztest.tztest - "block with multiple transfer paying fee" - `Slow - test_block_with_multiple_transfers_pay_fee; - Tztest.tztest - "block with multiple transfer without paying fee" - `Slow - test_block_with_multiple_transfers_with_without_fee; - (* build the chain *) - Tztest.tztest "build a chain" `Quick test_build_a_chain; - (* Erroneous *) - Tztest.tztest "empty implicit" `Quick test_empty_implicit; - Tztest.tztest - "balance too low - transfer zero" - `Quick - (test_balance_too_low Tez.zero); - Tztest.tztest "balance too low" `Quick (test_balance_too_low Tez.one); - Tztest.tztest - "balance too low (max fee)" - `Quick - (test_balance_too_low max_tez); - Tztest.tztest - "balance too low with two transfers - transfer zero" - `Quick - (test_balance_too_low_two_transfers Tez.zero); - Tztest.tztest - "balance too low with two transfers" - `Quick - (test_balance_too_low_two_transfers Tez.one); - Tztest.tztest - "transfer one tez to an implicit contract with balance of src as fee" - `Quick - test_transfer_one_to_implicit_with_bal_src_as_fee; - Tztest.tztest "invalid_counter" `Quick invalid_counter; - Tztest.tztest - "add the same operation twice" - `Quick - test_add_the_same_operation_twice; - Tztest.tztest - "invalid_counter_in_the_future" - `Quick - invalid_counter_in_the_future; - Tztest.tztest "ownership sender" `Quick test_ownership_sender; - (* Random tests *) - Tztest.tztest "random transfer" `Quick test_random_transfer; - Tztest.tztest "random multi transfer" `Quick test_random_multi_transactions; - Tztest.tztest "bad entrypoint" `Quick test_bad_entrypoint; - Tztest.tztest "bad parameter" `Quick test_bad_parameter; - Tztest.tztest - "no such entrypoint" - `Quick - transfer_to_itself_with_no_such_entrypoint; - Tztest.tztest - "storage fees after contract call and allocation" - `Quick - test_storage_fees_and_internal_operation; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("transfer", tests)] |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_transfer_ticket.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_transfer_ticket.ml deleted file mode 100644 index 954248ef96e2e20b34dd15181c939a5db4b6c8cd..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_transfer_ticket.ml +++ /dev/null @@ -1,331 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Marigold *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Transfer_ticket logic - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/operations/main.exe \ - -- --file test_transfer_ticket.ml - Subject: Test ticket transfers -*) - -open Protocol -open Alpha_context -open Tezos_micheline - -(* In this test, a ticketer contract mints and transfers a ticket to an implicit account, - who further transfers it to another implicit account. - The ticket balance is inspected for correctness. -*) -let test_mint_deposit_withdraw_implicit_transfer () = - let open Lwt_result_wrap_syntax in - let* block, (account, another_account) = - Context.init2 ~consensus_threshold:0 () - in - let baker = Context.Contract.pkh account in - let* ticketer, _, block = - Contract_helpers.originate_contract_from_string - ~script: - {| - parameter (pair nat nat address) ; - storage unit ; - code { CAR ; - UNPAIR 3 ; - DIG 2 ; - CONTRACT (ticket nat) ; - ASSERT_SOME ; - # contract : nat %ct : nat %qty - PUSH mutez 0 ; - # tez : contract : nat %ct : nat %qty - DIG 3 ; - # nat %qty : tez : contract : nat %ct - DIG 3 ; - # nat %ct : nat %qty : tez : contract - TICKET ; - ASSERT_SOME ; - TRANSFER_TOKENS ; - NIL operation ; - SWAP ; - CONS ; - UNIT ; - SWAP ; - PAIR } - |} - ~storage:"Unit" - ~source_contract:account - ~baker - block - in - let contents = 42 in - let* block = - Op.transaction - (B block) - ~entrypoint:Entrypoint.default - ~parameters: - (Expr_common.( - pair_n [int (Z.of_int contents); int (Z.of_int 1); address account]) - |> Micheline.strip_locations |> Script.lazy_expr) - ~fee:Tez.one - account - ticketer - (Tez.of_mutez_exn 0L) - >>=? fun operation -> Block.bake ~operation block - in - let ty = Expr.from_string "nat" in - let* block = - Op.transfer_ticket - (B block) - ~entrypoint:Entrypoint.default - ~source:account - ~ty:(Script.lazy_expr ty) - ~contents:(Script.lazy_expr @@ Expr.from_string @@ string_of_int contents) - ~amount: - (WithExceptions.Option.get ~loc:__LOC__ - @@ Ticket_amount.of_zint @@ Z.of_int 1) - ~destination:another_account - ~ticketer - >>=? fun operation -> Block.bake ~operation block - in - let make_ex_token ctxt ~ticketer ~ty ~content = - let*?@ Script_ir_translator.Ex_comparable_ty cty, ctxt = - Script_ir_translator.parse_comparable_ty ctxt @@ Micheline.root ty - in - let*@ contents, ctxt = - Script_ir_translator.parse_comparable_data ctxt cty - @@ Micheline.root content - in - return - (Ticket_token.Ex_token {contents_type = cty; ticketer; contents}, ctxt) - in - let* ctxt = - Incremental.begin_construction block >|=? Incremental.alpha_ctxt - in - let* token, ctxt = - make_ex_token - ctxt - ~ticketer - ~ty - ~content:(Expr.from_string @@ string_of_int contents) - in - let*@ key, ctxt = - Ticket_balance_key.of_ex_token ctxt ~owner:(Contract another_account) token - in - let*@ amount, _ = Ticket_balance.get_balance ctxt key in - match amount with - | Some amount -> Assert.equal_int ~loc:__LOC__ (Z.to_int amount) 1 - | _ -> return_unit - -(* In this test, a ticketer contract is called to mint and send a ticket - to an implicit account and a contract. Both destinations are given - in a `contract (ticket nat)` value. - Transfer should be possible since the target contract has the right - parameter type under the given entrypoint. -*) -let test_contract_as_ticket_transfer_destination () = - let open Lwt_result_wrap_syntax in - let* block, (account, another_account) = - Context.init2 ~consensus_threshold:0 () - in - let baker = Context.Contract.pkh account in - let* ticketer, _, block = - Contract_helpers.originate_contract_from_string - ~script: - {| - parameter (pair (contract (ticket nat)) nat nat) ; - storage unit ; - code { CAR ; - UNPAIR 3 ; - # contract (ticket nat) : nat %ct : nat %qty - PUSH mutez 0 ; - # tez : contract (ticket nat) : nat %ct : nat %qty - DIG 3 ; - # nat %qty : tez : contract (ticket nat) : nat %ct - DIG 3 ; - # nat %ct : nat %qty : tez : contract (ticket nat) - TICKET ; - ASSERT_SOME ; - TRANSFER_TOKENS ; - NIL operation ; - SWAP ; - CONS ; - UNIT ; - SWAP ; - PAIR } - |} - ~storage:"Unit" - ~source_contract:account - ~baker - block - in - let* bag, _, block = - Contract_helpers.originate_contract_from_string - ~script: - {| - parameter (or (ticket %save nat) (address %send)); - storage (list (ticket nat)); - code { UNPAIR ; - IF_LEFT - { CONS ; NIL operation ; PAIR } - { SWAP ; - IF_CONS - { DIG 2 ; - CONTRACT %ticket (ticket nat) ; - ASSERT_SOME ; - PUSH mutez 0 ; - DIG 2 ; - TRANSFER_TOKENS ; - NIL operation ; - SWAP ; - CONS ; - PAIR } - { PUSH string "no ticket to send" ; FAILWITH }}} - |} - ~storage:"{}" - ~source_contract:account - ~baker - block - in - let contents = 42 in - let* block = - Op.transaction - (B block) - ~entrypoint:Entrypoint.default - ~parameters: - (Expr_common.( - pair_n - [ - string - (Destination.(to_b58check (Contract account)) - ^ Entrypoint.(to_address_suffix default)); - int (Z.of_int contents); - int (Z.of_int 1); - ]) - |> Micheline.strip_locations |> Script.lazy_expr) - ~fee:Tez.one - account - ticketer - (Tez.of_mutez_exn 0L) - >>=? fun operation -> Block.bake ~operation block - in - let ty = Expr.from_string "nat" in - let* block = - Op.transfer_ticket - (B block) - ~entrypoint:Entrypoint.default - ~source:account - ~ty:(Script.lazy_expr ty) - ~contents:(Script.lazy_expr @@ Expr.from_string @@ string_of_int contents) - ~amount: - (WithExceptions.Option.get ~loc:__LOC__ - @@ Ticket_amount.of_zint @@ Z.of_int 1) - ~destination:another_account - ~ticketer - >>=? fun operation -> Block.bake ~operation block - in - let make_ex_token ctxt ~ticketer ~ty ~content = - let*?@ Script_ir_translator.Ex_comparable_ty cty, ctxt = - Script_ir_translator.parse_comparable_ty ctxt @@ Micheline.root ty - in - let*@ contents, ctxt = - Script_ir_translator.parse_comparable_data ctxt cty - @@ Micheline.root content - in - return - (Ticket_token.Ex_token {contents_type = cty; ticketer; contents}, ctxt) - in - let* ctxt = - Incremental.begin_construction block >|=? Incremental.alpha_ctxt - in - let* token, ctxt = - make_ex_token - ctxt - ~ticketer - ~ty - ~content:(Expr.from_string @@ string_of_int contents) - in - let*@ key, ctxt = - Ticket_balance_key.of_ex_token ctxt ~owner:(Contract another_account) token - in - let*@ amount, _ = Ticket_balance.get_balance ctxt key in - let* () = - match amount with - | Some amount -> Assert.equal_int ~loc:__LOC__ (Z.to_int amount) 1 - | _ -> return_unit - in - let* block = - Op.transaction - (B block) - ~entrypoint:Entrypoint.default - ~parameters: - (Expr_common.( - pair_n - [ - string - (Destination.(to_b58check (Contract bag)) - ^ Entrypoint.(to_address_suffix @@ of_string_strict_exn "save") - ); - int (Z.of_int contents); - int (Z.of_int 1); - ]) - |> Micheline.strip_locations |> Script.lazy_expr) - ~fee:Tez.one - account - ticketer - (Tez.of_mutez_exn 0L) - >>=? fun operation -> Block.bake ~operation block - in - let* ctxt = - Incremental.begin_construction block >|=? Incremental.alpha_ctxt - in - let* token, ctxt = - make_ex_token - ctxt - ~ticketer - ~ty - ~content:(Expr.from_string @@ string_of_int contents) - in - let*@ key, ctxt = - Ticket_balance_key.of_ex_token ctxt ~owner:(Contract bag) token - in - let*@ amount, _ = Ticket_balance.get_balance ctxt key in - match amount with - | Some amount -> Assert.equal_int ~loc:__LOC__ (Z.to_int amount) 1 - | _ -> return_unit - -let tests = - [ - Tztest.tztest - "ticket transfer operations" - `Quick - test_mint_deposit_withdraw_implicit_transfer; - Tztest.tztest - "'contract (ticket cty)' as transfer destination" - `Quick - test_contract_as_ticket_transfer_destination; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("transfer ticket", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_voting.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_voting.ml deleted file mode 100644 index 20ee7f102e3661057b4a6f555ff651afebf3d342..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_voting.ml +++ /dev/null @@ -1,2102 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2022 Trili Tech *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (voting) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/operations/main.exe \ - -- --file test_voting.ml - Subject: On the voting process. - -*) - -open Protocol -open Alpha_context - -(** {2 Constants and ratios used in voting} - - percent_mul denotes the percent multiplier - initial_participation is 7000 that is, 7/10 * percent_mul - the participation EMA ratio pr_ema_weight / den = 7 / 10 - the participation ratio pr_num / den = 2 / 10 - note: we use the same denominator for both participation EMA and participation rate. - supermajority rate is s_num / s_den = 8 / 10 *) -let percent_mul = 100_00 - -let den = 10 - -let initial_participation_num = 7 - -let initial_participation = initial_participation_num * percent_mul / den - -let pr_ema_weight = 8 - -let pr_num = den - pr_ema_weight - -let s_num = 8 - -let s_den = 10 - -let qr_min_num = 2 - -let qr_max_num = 7 - -let expected_qr_num participation_ema = - let participation_ema = Int32.to_int participation_ema in - let participation_ema = participation_ema * den / percent_mul in - Float.( - of_int qr_min_num - +. of_int participation_ema - *. (of_int qr_max_num -. of_int qr_min_num) - /. of_int den) - -(* Protocol_hash.zero is "PrihK96nBAFSxVL1GLJTVhu9YnzkMFiBeuJRPA8NwuZVZCE1L6i" *) -let protos = - Array.map - (fun s -> Protocol_hash.of_b58check_exn s) - [| - "ProtoALphaALphaALphaALphaALphaALphaALpha61322gcLUGH"; - "ProtoALphaALphaALphaALphaALphaALphaALphabc2a7ebx6WB"; - "ProtoALphaALphaALphaALphaALphaALphaALpha84efbeiF6cm"; - "ProtoALphaALphaALphaALphaALphaALphaALpha91249Z65tWS"; - "ProtoALphaALphaALphaALphaALphaALphaALpha537f5h25LnN"; - "ProtoALphaALphaALphaALphaALphaALphaALpha5c8fefgDYkr"; - "ProtoALphaALphaALphaALphaALphaALphaALpha3f31feSSarC"; - "ProtoALphaALphaALphaALphaALphaALphaALphabe31ahnkxSC"; - "ProtoALphaALphaALphaALphaALphaALphaALphabab3bgRb7zQ"; - "ProtoALphaALphaALphaALphaALphaALphaALphaf8d39cctbpk"; - "ProtoALphaALphaALphaALphaALphaALphaALpha3b981byuYxD"; - "ProtoALphaALphaALphaALphaALphaALphaALphaa116bccYowi"; - "ProtoALphaALphaALphaALphaALphaALphaALphacce68eHqboj"; - "ProtoALphaALphaALphaALphaALphaALphaALpha225c7YrWwR7"; - "ProtoALphaALphaALphaALphaALphaALphaALpha58743cJL6FG"; - "ProtoALphaALphaALphaALphaALphaALphaALphac91bcdvmJFR"; - "ProtoALphaALphaALphaALphaALphaALphaALpha1faaadhV7oW"; - "ProtoALphaALphaALphaALphaALphaALphaALpha98232gD94QJ"; - "ProtoALphaALphaALphaALphaALphaALphaALpha9d1d8cijvAh"; - "ProtoALphaALphaALphaALphaALphaALphaALphaeec52dKF6Gx"; - "ProtoALphaALphaALphaALphaALphaALphaALpha841f2cQqajX"; - |] - -(** {2 Helper functions} *) - -let assert_period_kinds expected_kinds kind loc = - if - List.exists - (fun expected_kind -> Stdlib.(expected_kind = kind)) - expected_kinds - then return_unit - else - Alcotest.failf - "%s - Unexpected voting period kind - expected %a, got %a" - loc - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt " or ") - Voting_period.pp_kind) - expected_kinds - Voting_period.pp_kind - kind - -let assert_period_kind expected_kind = assert_period_kinds [expected_kind] - -let assert_period_index expected_index index loc = - if expected_index = index then return_unit - else - Alcotest.failf - "%s - Unexpected voting period index - expected %ld, got %ld" - loc - expected_index - index - -let assert_period_position expected_position position loc = - if position = expected_position then return_unit - else - Alcotest.failf - "%s - Unexpected voting period position blocks - expected %ld, got %ld" - loc - expected_position - position - -let assert_period_remaining expected_remaining remaining loc = - if remaining = expected_remaining then return_unit - else - Alcotest.failf - "%s - Unexpected voting period remaining blocks - expected %ld, got %ld" - loc - expected_remaining - remaining - -let assert_period ?expected_kind ?expected_kinds ?expected_index - ?expected_position ?expected_remaining b loc = - let open Lwt_result_syntax in - let* {voting_period; position; remaining} = - Context.Vote.get_current_period (B b) - in - let* () = - match (expected_kind, expected_kinds) with - | None, None -> return_unit - | Some expected_kind, None -> - assert_period_kind expected_kind voting_period.kind loc - | None, Some expected_kinds -> - assert_period_kinds expected_kinds voting_period.kind loc - | Some _, Some _ -> - invalid_arg - "assert_period: arguments expected_kind and expected_kinds should \ - not both be provided." - in - let* () = - match expected_index with - | Some expected_index -> - assert_period_index expected_index voting_period.index loc - | None -> return_unit - in - let* () = - match expected_position with - | Some expected_position -> - assert_period_position expected_position position loc - | None -> return_unit - in - match expected_remaining with - | Some expected_remaining -> - assert_period_remaining expected_remaining remaining loc - | None -> return_unit - -let assert_ballots expected_ballots b loc = - Context.Vote.get_ballots (B b) >>=? fun ballots -> - Assert.equal - ~loc - Vote.equal_ballots - "Unexpected ballots" - Vote.pp_ballots - ballots - expected_ballots - -let assert_empty_ballots b loc = - assert_ballots Vote.ballots_zero b loc >>=? fun () -> - Context.Vote.get_ballot_list (B b) >>=? function - | [] -> return_unit - | _ -> failwith "%s - Unexpected ballot list" loc - -let mk_contracts_from_pkh pkh_list = - List.map (fun c -> Contract.Implicit c) pkh_list - -(* get the list of delegates and the list of their voting power from listings *) -let get_delegates_and_power_from_listings b = - Context.Vote.get_listings (B b) >|=? fun l -> - (mk_contracts_from_pkh (List.map fst l), List.map snd l) - -(* compute the voting power of each delegate *) -let get_power b delegates loc = - List.map_es - (fun delegate -> - let pkh = Context.Contract.pkh delegate in - Context.Delegate.voting_info (B b) pkh >>=? fun info -> - match info.voting_power with - | None -> failwith "%s - Missing delegate" loc - | Some power -> return power) - delegates - -(* Checks that the listings are populated *) -let assert_listings_not_empty b ~loc = - Context.Vote.get_listings (B b) >>=? function - | [] -> failwith "Unexpected empty listings (%s)" loc - | _ -> return_unit - -let equal_delegate_info a b = - Option.equal Int64.equal a.Vote.voting_power b.Vote.voting_power - && Option.equal Vote.equal_ballot a.current_ballot b.current_ballot - && List.equal - Protocol_hash.equal - (List.sort Protocol_hash.compare a.current_proposals) - (List.sort Protocol_hash.compare b.current_proposals) - && Int.equal a.remaining_proposals b.remaining_proposals - -let assert_equal_info ~loc a b = - Assert.equal - ~loc - equal_delegate_info - "delegate_info" - Vote.pp_delegate_info - a - b - -let bake_until_first_block_of_next_period ?policy b = - Context.Vote.get_current_period (B b) >>=? fun {remaining; _} -> - Block.bake_n ?policy Int32.(add remaining one |> to_int) b - -let context_init_tup tup ?(blocks_per_cycle = 4l) = - (* Note that some of these tests assume (more or less) that the - accounts remain active during a voting period, which roughly - translates to the following condition being assumed to hold: - `blocks_per_voting_period <= preserved_cycles * blocks_per_cycle.` - We also set baking and endorsing rewards to zero in order to - ease accounting of exact baker stake. *) - Context.init_gen - tup - ~blocks_per_cycle - ~cycles_per_voting_period:1l - ~consensus_threshold:0 - ~endorsing_reward_per_slot:Tez.zero - ~baking_reward_bonus_per_slot:Tez.zero - ~baking_reward_fixed_portion:Tez.zero - ~nonce_revelation_threshold:2l - -(** [context_init n ()] returns [(block, contracts)] where [block] is - an initial block with [n] bootstrap accounts, and [contracts] is - the list of associated implicit contracts. - - See {!context_init_tup} and {!Context.init_gen} for optional - arguments. *) -let context_init n = context_init_tup (Context.TList n) - -(** [context_init1 ()] returns [(block, contract)] where [block] is an - initial block with one bootstrap account, and [contract] is the - associated implicit contract. *) -let context_init1 = context_init_tup Context.T1 - -(** [context_init2 ()] returns [(block, contracts)] where [block] is - an initial block with two bootstrap accounts, and [contracts] is - the pair of associated implicit contracts. *) -let context_init2 = context_init_tup Context.T2 - -(** Call {!context_init2}, then inject a Proposals operation and bake - blocks in order to move on to an Exploration period. Return a - block, a delegate (distinct from the one who submitted the - Proposals), and the current proposal. *) -let context_init_exploration ?(proposal = protos.(0)) ?blocks_per_cycle () = - let open Lwt_result_syntax in - let* block, (proposer, other_delegate) = context_init2 ?blocks_per_cycle () in - let* operation = Op.proposals (B block) proposer [proposal] in - let* block = Block.bake block ~operation in - let* block = bake_until_first_block_of_next_period block in - let* () = assert_period ~expected_kind:Exploration block __LOC__ in - return (block, other_delegate, proposal) - -let append_loc ~caller_loc loc = - Format.sprintf "%s@.Called from %s" loc caller_loc - -(** {3 Expected protocol errors} *) - -let wrong_error expected_error_name actual_error_trace loc = - failwith - "%s:@,Expected error trace [%s], but got:@,%a" - loc - expected_error_name - Error_monad.pp_print_trace - actual_error_trace - -let missing_signature loc = function - | [Environment.Ecoproto_error Operation.Missing_signature] -> return_unit - | err -> wrong_error "Missing_signature" err loc - -let invalid_signature loc = function - | [Environment.Ecoproto_error Operation.Invalid_signature] -> return_unit - | err -> wrong_error "Invalid_signature" err loc - -open Validate_errors.Voting - -let wrong_voting_period_index ~current_index ~op_index loc = function - | [ - Environment.Ecoproto_error (Wrong_voting_period_index {expected; provided}); - ] -> - let open Lwt_result_syntax in - let make_loc = append_loc ~caller_loc:loc in - let* () = - Assert.equal_int32 ~loc:(make_loc __LOC__) expected current_index - in - Assert.equal_int32 ~loc:(make_loc __LOC__) provided op_index - | err -> wrong_error "Wrong_voting_period_index" err loc - -let wrong_voting_period_kind loc = function - | [Environment.Ecoproto_error (Wrong_voting_period_kind _)] -> return_unit - | err -> wrong_error "Wrong_voting_period_kind" err loc - -let proposals_from_unregistered_delegate loc = function - | [Environment.Ecoproto_error (Proposals_from_unregistered_delegate _)] -> - return_unit - | err -> wrong_error "Proposals_from_unregistered_delegate" err loc - -let ballot_from_unregistered_delegate loc = function - | [Environment.Ecoproto_error (Ballot_from_unregistered_delegate _)] -> - return_unit - | err -> wrong_error "Ballot_from_unregistered_delegate" err loc - -let source_not_in_vote_listings loc = function - | [Environment.Ecoproto_error Source_not_in_vote_listings] -> return_unit - | err -> wrong_error "Source_not_in_vote_listings" err loc - -let empty_proposals loc = function - | [Environment.Ecoproto_error Empty_proposals] -> return_unit - | err -> wrong_error "Empty_proposals" err loc - -let proposals_contain_duplicate duplicate_proposal loc = function - | [Environment.Ecoproto_error (Proposals_contain_duplicate {proposal})] -> - Assert.equal_protocol_hash - ~loc:(append_loc ~caller_loc:loc __LOC__) - proposal - duplicate_proposal - | err -> wrong_error "Proposals_contain_duplicate" err loc - -let too_many_proposals loc = function - | [Environment.Ecoproto_error (Too_many_proposals _)] -> return_unit - | err -> wrong_error "Too_many_proposals" err loc - -let already_proposed already_proposed_proposal loc = function - | [Environment.Ecoproto_error (Already_proposed {proposal; _})] -> - Assert.equal_protocol_hash - ~loc:(append_loc ~caller_loc:loc __LOC__) - proposal - already_proposed_proposal - | err -> wrong_error "Already_proposed" err loc - -let conflicting_proposals loc = function - | [Environment.Ecoproto_error (Conflicting_proposals _)] -> return_unit - | err -> wrong_error "Conflicting_proposals" err loc - -let ballot_for_wrong_proposal ~current_proposal ~op_proposal loc = function - | [ - Environment.Ecoproto_error (Ballot_for_wrong_proposal {current; submitted}); - ] -> - let open Lwt_result_syntax in - let* () = - Assert.equal_protocol_hash - ~loc:(append_loc ~caller_loc:loc __LOC__) - current_proposal - current - in - Assert.equal_protocol_hash - ~loc:(append_loc ~caller_loc:loc __LOC__) - op_proposal - submitted - | err -> wrong_error "Ballot_for_wrong_proposal" err loc - -let already_submitted_a_ballot loc = function - | [Environment.Ecoproto_error Already_submitted_a_ballot] -> return_unit - | err -> wrong_error "Already_submitted_a_ballot" err loc - -let conflicting_ballot loc = function - | [Environment.Ecoproto_error (Conflicting_ballot _)] -> return_unit - | err -> wrong_error "Conflicting_ballot" err loc - -let assert_validate_proposals_fails ~expected_error ~proposer ~proposals ?period - block loc = - let open Lwt_result_syntax in - let* operation = Op.proposals (B block) proposer ?period proposals in - Incremental.assert_validate_operation_fails - (expected_error loc) - operation - block - -let assert_validate_ballot_fails ~expected_error ~voter ~proposal ~ballot - ?period block loc = - let open Lwt_result_syntax in - let* operation = Op.ballot (B block) voter ?period proposal ballot in - Incremental.assert_validate_operation_fails - (expected_error loc) - operation - block - -(** {2 Scenarized tests} *) - -(** A normal and successful vote sequence. *) -let test_successful_vote num_delegates () = - let open Alpha_context in - let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in - context_init ~min_proposal_quorum num_delegates () >>=? fun (b, _) -> - (* no ballots in proposal period *) - assert_empty_ballots b __LOC__ >>=? fun () -> - (* Last baked block is first block of period Proposal *) - assert_period - ~expected_kind:Proposal - ~expected_index:0l - ~expected_position:0l - b - __LOC__ - >>=? fun () -> - assert_listings_not_empty b ~loc:__LOC__ >>=? fun () -> - (* participation EMA starts at initial_participation *) - Context.Vote.get_participation_ema b >>=? fun v -> - Assert.equal_int ~loc:__LOC__ initial_participation (Int32.to_int v) - >>=? fun () -> - (* listings must be populated in proposal period *) - assert_listings_not_empty b ~loc:__LOC__ >>=? fun () -> - (* beginning of proposal, denoted by _p1; - take a snapshot of the active delegates and their voting power from listings *) - get_delegates_and_power_from_listings b >>=? fun (delegates_p1, power_p1) -> - (* no proposals at the beginning of proposal period *) - Context.Vote.get_proposals (B b) >>=? fun ps -> - (if Environment.Protocol_hash.Map.is_empty ps then return_unit - else failwith "%s - Unexpected proposals" __LOC__) - >>=? fun () -> - (* no current proposal during proposal period *) - (Context.Vote.get_current_proposal (B b) >>=? function - | None -> return_unit - | Some _ -> failwith "%s - Unexpected proposal" __LOC__) - >>=? fun () -> - let del1 = - WithExceptions.Option.get ~loc:__LOC__ @@ List.nth delegates_p1 0 - in - let del2 = - WithExceptions.Option.get ~loc:__LOC__ @@ List.nth delegates_p1 1 - in - let pkh1 = Context.Contract.pkh del1 in - let pkh2 = Context.Contract.pkh del2 in - let pow1 = WithExceptions.Option.get ~loc:__LOC__ @@ List.nth power_p1 0 in - let pow2 = WithExceptions.Option.get ~loc:__LOC__ @@ List.nth power_p1 1 in - let props = - List.map (fun i -> protos.(i)) (2 -- Constants.max_proposals_per_delegate) - in - Op.proposals (B b) del1 (Protocol_hash.zero :: props) >>=? fun ops1 -> - Op.proposals (B b) del2 [Protocol_hash.zero] >>=? fun ops2 -> - Block.bake ~operations:[ops1; ops2] b >>=? fun b -> - Context.Delegate.voting_info (B b) pkh1 >>=? fun info1 -> - Context.Delegate.voting_info (B b) pkh2 >>=? fun info2 -> - assert_equal_info - ~loc:__LOC__ - info1 - { - voting_power = Some pow1; - current_ballot = None; - current_proposals = Protocol_hash.zero :: props; - remaining_proposals = 0; - } - >>=? fun () -> - assert_equal_info - ~loc:__LOC__ - info2 - { - voting_power = Some pow2; - current_ballot = None; - current_proposals = [Protocol_hash.zero]; - remaining_proposals = Constants.max_proposals_per_delegate - 1; - } - >>=? fun () -> - (* proposals are now populated *) - Context.Vote.get_proposals (B b) >>=? fun ps -> - (* correctly count the double proposal for zero *) - (let weight = - Int64.add - (WithExceptions.Option.get ~loc:__LOC__ @@ List.nth power_p1 0) - (WithExceptions.Option.get ~loc:__LOC__ @@ List.nth power_p1 1) - in - match Environment.Protocol_hash.(Map.find zero ps) with - | Some v -> - if v = weight then return_unit - else failwith "%s - Wrong count %Ld is not %Ld" __LOC__ v weight - | None -> failwith "%s - Missing proposal" __LOC__) - >>=? fun () -> - (* proposing more than maximum_proposals fails *) - assert_validate_proposals_fails - ~expected_error:too_many_proposals - ~proposer:del1 - ~proposals:(Protocol_hash.zero :: props) - b - __LOC__ - >>=? fun () -> - (* proposing less than one proposal fails *) - assert_validate_proposals_fails - ~expected_error:empty_proposals - ~proposer:del1 - ~proposals:[] - b - __LOC__ - >>=? fun () -> - (* first block of exploration period *) - bake_until_first_block_of_next_period b >>=? fun b -> - (* next block is first block of exploration *) - assert_period ~expected_kind:Exploration ~expected_index:1l b __LOC__ - >>=? fun () -> - assert_listings_not_empty b ~loc:__LOC__ >>=? fun () -> - (* listings must be populated in proposal period before moving to exploration period *) - assert_listings_not_empty b ~loc:__LOC__ >>=? fun () -> - (* beginning of exploration period, denoted by _p2; - take a snapshot of the active delegates and their voting power from listings *) - get_delegates_and_power_from_listings b >>=? fun (delegates_p2, power_p2) -> - (* no proposals during exploration period *) - Context.Vote.get_proposals (B b) >>=? fun ps -> - (if Environment.Protocol_hash.Map.is_empty ps then return_unit - else failwith "%s - Unexpected proposals" __LOC__) - >>=? fun () -> - (* current proposal must be set during exploration period *) - (Context.Vote.get_current_proposal (B b) >>=? function - | Some v -> - if Protocol_hash.(equal zero v) then return_unit - else failwith "%s - Wrong proposal" __LOC__ - | None -> failwith "%s - Missing proposal" __LOC__) - >>=? fun () -> - (* unanimous vote: all delegates --active when p2 started-- vote *) - List.map_es - (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) - delegates_p2 - >>=? fun operations -> - Block.bake ~operations b >>=? fun b -> - Context.Delegate.voting_info (B b) pkh1 >>=? fun info1 -> - assert_equal_info - ~loc:__LOC__ - info1 - { - voting_power = Some pow1; - current_ballot = Some Yay; - current_proposals = []; - remaining_proposals = 0; - } - >>=? fun () -> - (* Submitting a second ballot for [del1] fails (indeed, [del1] - belongs to [delegates_p2], so they have already sent a ballot - during the unanimous vote right above). *) - assert_validate_ballot_fails - ~expected_error:already_submitted_a_ballot - ~voter:del1 - ~proposal:Protocol_hash.zero - ~ballot:Vote.Nay - b - __LOC__ - >>=? fun () -> - (* Allocate votes from weight of active delegates *) - List.fold_left (fun acc v -> Int64.(add v acc)) 0L power_p2 - |> fun power_sum -> - (* # of Yay in ballots matches votes of the delegates *) - assert_ballots Vote.{yay = power_sum; nay = 0L; pass = 0L} b __LOC__ - >>=? fun () -> - (* One Yay ballot per delegate *) - (Context.Vote.get_ballot_list (B b) >>=? function - | [] -> failwith "%s - Unexpected empty ballot list" __LOC__ - | l -> - List.iter_es - (fun delegate -> - let pkh = Context.Contract.pkh delegate in - match List.find_opt (fun (del, _) -> del = pkh) l with - | None -> failwith "%s - Missing delegate" __LOC__ - | Some (_, Vote.Yay) -> return_unit - | Some _ -> failwith "%s - Wrong ballot" __LOC__) - delegates_p2) - >>=? fun () -> - (* skip to cooldown period *) - bake_until_first_block_of_next_period b >>=? fun b -> - assert_period ~expected_index:2l ~expected_kind:Cooldown b __LOC__ - >>=? fun () -> - (* no ballots in cooldown period *) - assert_empty_ballots b __LOC__ >>=? fun () -> - (* listings must be populated in cooldown period before moving to promotion_vote period *) - assert_listings_not_empty b ~loc:__LOC__ >>=? fun () -> - (* skip to promotion period *) - bake_until_first_block_of_next_period b >>=? fun b -> - assert_period ~expected_kind:Promotion ~expected_index:3l b __LOC__ - >>=? fun () -> - assert_listings_not_empty b ~loc:__LOC__ >>=? fun () -> - (* period 3 *) - (* listings must be populated in promotion period *) - assert_listings_not_empty b ~loc:__LOC__ >>=? fun () -> - (* beginning of promotion period, denoted by _p4; - take a snapshot of the active delegates and their voting power from listings *) - get_delegates_and_power_from_listings b >>=? fun (delegates_p4, power_p4) -> - (* no proposals during promotion period *) - Context.Vote.get_proposals (B b) >>=? fun ps -> - (if Environment.Protocol_hash.Map.is_empty ps then return_unit - else failwith "%s - Unexpected proposals" __LOC__) - >>=? fun () -> - (* current proposal must be set during promotion period *) - (Context.Vote.get_current_proposal (B b) >>=? function - | Some v -> - if Protocol_hash.(equal zero v) then return_unit - else failwith "%s - Wrong proposal" __LOC__ - | None -> failwith "%s - Missing proposal" __LOC__) - >>=? fun () -> - (* unanimous vote: all delegates --active when p4 started-- vote *) - List.map_es - (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) - delegates_p4 - >>=? fun operations -> - Block.bake ~operations b >>=? fun b -> - List.fold_left (fun acc v -> Int64.(add v acc)) 0L power_p4 - |> fun power_sum -> - (* # of Yays in ballots matches voting power of the delegate *) - assert_ballots Vote.{yay = power_sum; nay = 0L; pass = 0L} b __LOC__ - >>=? fun () -> - (* One Yay ballot per delegate *) - (Context.Vote.get_ballot_list (B b) >>=? function - | [] -> failwith "%s - Unexpected empty ballot list" __LOC__ - | l -> - List.iter_es - (fun delegate -> - let pkh = Context.Contract.pkh delegate in - match List.find_opt (fun (del, _) -> del = pkh) l with - | None -> failwith "%s - Missing delegate" __LOC__ - | Some (_, Vote.Yay) -> return_unit - | Some _ -> failwith "%s - Wrong ballot" __LOC__) - delegates_p4) - >>=? fun () -> - (* skip to end of promotion period and activation*) - bake_until_first_block_of_next_period b >>=? fun b -> - assert_period ~expected_kind:Adoption ~expected_index:4l b __LOC__ - >>=? fun () -> - (* skip to end of Adoption period and bake 1 more to activate *) - bake_until_first_block_of_next_period b >>=? fun b -> - assert_period ~expected_kind:Proposal ~expected_index:5l b __LOC__ - >>=? fun () -> - assert_listings_not_empty b ~loc:__LOC__ >>=? fun () -> - (* zero is the new protocol (before the vote this value is unset) *) - Context.Vote.get_protocol b >>= fun p -> - Assert.equal - ~loc:__LOC__ - Protocol_hash.equal - "Unexpected proposal" - Protocol_hash.pp - p - Protocol_hash.zero - >>=? fun () -> return_unit - -(* given a list of active delegates, - return the first k active delegates with which one can have quorum, that is: - their voting power divided by the total voting power is bigger than pr_ema_weight/den *) -let get_smallest_prefix_voters_for_quorum active_delegates active_power - participation_ema = - let expected_quorum = expected_qr_num participation_ema in - List.fold_left (fun acc v -> Int64.(add v acc)) 0L active_power - |> fun active_power_sum -> - let rec loop delegates power sum selected = - match (delegates, power) with - | [], [] -> selected - | del :: delegates, del_power :: power -> - if - den * sum - < Float.to_int (expected_quorum *. Int64.to_float active_power_sum) - then - loop delegates power (sum + Int64.to_int del_power) (del :: selected) - else selected - | _, _ -> [] - in - loop active_delegates active_power 0 [] - -let get_expected_participation_ema power voter_power old_participation_ema = - (* formula to compute the updated participation_ema *) - let get_updated_participation_ema old_participation_ema participation = - ((pr_ema_weight * Int32.to_int old_participation_ema) - + (pr_num * participation)) - / den - in - List.fold_left (fun acc v -> Int64.(add v acc)) 0L power |> fun power_sum -> - List.fold_left (fun acc v -> Int64.(add v acc)) 0L voter_power - |> fun voter_power_sum -> - let participation = - Int64.(to_int (div (mul voter_power_sum (of_int percent_mul)) power_sum)) - in - get_updated_participation_ema old_participation_ema participation - -(** If not enough quorum - -- get_updated_participation_ema < pr_ema_weight/den -- - in exploration, go back to proposal period. *) -let test_not_enough_quorum_in_exploration num_delegates () = - let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in - context_init ~min_proposal_quorum num_delegates () >>=? fun (b, delegates) -> - (* proposal period *) - let open Alpha_context in - assert_period ~expected_kind:Proposal b __LOC__ >>=? fun () -> - let proposer = - WithExceptions.Option.get ~loc:__LOC__ @@ List.nth delegates 0 - in - Op.proposals (B b) proposer [Protocol_hash.zero] >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - (* skip to exploration period *) - bake_until_first_block_of_next_period b >>=? fun b -> - (* we moved to an exploration period with one proposal *) - assert_period ~expected_kind:Exploration b __LOC__ >>=? fun () -> - Context.Vote.get_participation_ema b >>=? fun initial_participation_ema -> - (* beginning of exploration period, denoted by _p2; - take a snapshot of the active delegates and their voting power from listings *) - get_delegates_and_power_from_listings b >>=? fun (delegates_p2, power_p2) -> - Context.Vote.get_participation_ema b >>=? fun participation_ema -> - get_smallest_prefix_voters_for_quorum delegates_p2 power_p2 participation_ema - |> fun voters -> - (* take the first two voters out so there cannot be quorum *) - let voters_without_quorum = - WithExceptions.Option.get ~loc:__LOC__ @@ List.tl voters - in - get_power b voters_without_quorum __LOC__ - >>=? fun voters_power_in_exploration -> - (* all voters_without_quorum vote, for yays; - no nays, so supermajority is satisfied *) - List.map_es - (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) - voters_without_quorum - >>=? fun operations -> - Block.bake ~operations b >>=? fun b -> - (* bake to next period *) - bake_until_first_block_of_next_period b >>=? fun b -> - (* we move back to the proposal period because not enough quorum *) - assert_period ~expected_kind:Proposal b __LOC__ >>=? fun () -> - (* check participation_ema update *) - get_expected_participation_ema - power_p2 - voters_power_in_exploration - initial_participation_ema - |> fun expected_participation_ema -> - Context.Vote.get_participation_ema b >>=? fun new_participation_ema -> - (* assert the formula to calculate participation_ema is correct *) - Assert.equal_int - ~loc:__LOC__ - expected_participation_ema - (Int32.to_int new_participation_ema) - >>=? fun () -> return_unit - -(** If not enough quorum - -- get_updated_participation_ema < pr_ema_weight/den -- - In promotion period, go back to proposal period. *) -let test_not_enough_quorum_in_promotion num_delegates () = - let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in - context_init ~min_proposal_quorum num_delegates () >>=? fun (b, delegates) -> - assert_period ~expected_kind:Proposal b __LOC__ >>=? fun () -> - let proposer = - WithExceptions.Option.get ~loc:__LOC__ @@ List.nth delegates 0 - in - Op.proposals (B b) proposer [Protocol_hash.zero] >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - (* skip to exploration period *) - bake_until_first_block_of_next_period b >>=? fun b -> - (* we moved to an exploration period with one proposal *) - assert_period ~expected_kind:Exploration b __LOC__ >>=? fun () -> - (* beginning of exploration period, denoted by _p2; - take a snapshot of the active delegates and their voting power from listings *) - get_delegates_and_power_from_listings b >>=? fun (delegates_p2, power_p2) -> - Context.Vote.get_participation_ema b >>=? fun participation_ema -> - get_smallest_prefix_voters_for_quorum delegates_p2 power_p2 participation_ema - |> fun voters -> - let open Alpha_context in - (* all voters vote, for yays; - no nays, so supermajority is satisfied *) - List.map_es - (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) - voters - >>=? fun operations -> - Block.bake ~operations b >>=? fun b -> - (* skip to first block cooldown period *) - bake_until_first_block_of_next_period b >>=? fun b -> - (* we move to cooldown because we have supermajority and enough quorum *) - assert_period ~expected_kind:Cooldown b __LOC__ >>=? fun () -> - (* skip to first block of promotion period *) - bake_until_first_block_of_next_period b >>=? fun b -> - assert_period ~expected_kind:Promotion b __LOC__ - (* bake_until_first_block_of_next_period ~offset:1l b - * >>=? fun b -> - * assert_period ~expected_kind:Promotion b __LOC__ *) - >>=? - fun () -> - Context.Vote.get_participation_ema b >>=? fun initial_participation_ema -> - (* beginning of promotion period, denoted by _p4; - take a snapshot of the active delegates and their voting power from listings *) - get_delegates_and_power_from_listings b >>=? fun (delegates_p4, power_p4) -> - Context.Vote.get_participation_ema b >>=? fun participation_ema -> - get_smallest_prefix_voters_for_quorum delegates_p4 power_p4 participation_ema - |> fun voters -> - (* take the first voter out so there cannot be quorum *) - let voters_without_quorum = - WithExceptions.Option.get ~loc:__LOC__ @@ List.tl voters - in - get_power b voters_without_quorum __LOC__ >>=? fun voter_power -> - (* all voters_without_quorum vote, for yays; - no nays, so supermajority is satisfied *) - List.map_es - (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) - voters_without_quorum - >>=? fun operations -> - Block.bake ~operations b >>=? fun b -> - (* skip to end of promotion period *) - bake_until_first_block_of_next_period b >>=? fun b -> - get_expected_participation_ema power_p4 voter_power initial_participation_ema - |> fun expected_participation_ema -> - Context.Vote.get_participation_ema b >>=? fun new_participation_ema -> - (* assert the formula to calculate participation_ema is correct *) - Assert.equal_int - ~loc:__LOC__ - expected_participation_ema - (Int32.to_int new_participation_ema) - >>=? fun () -> - (* we move back to the proposal period because not enough quorum *) - assert_period ~expected_kind:Proposal b __LOC__ >>=? fun () -> - assert_listings_not_empty b ~loc:__LOC__ >>=? fun () -> return_unit - -(** Assume the initial balance of accounts allocated by Context.init_n is at - least 4 times the value of the minimal_stake constant. *) -let test_supermajority_in_proposal there_is_a_winner () = - let min_proposal_quorum = 0l in - let initial_balance = 1L in - context_init - ~min_proposal_quorum - ~bootstrap_balances:[initial_balance; initial_balance; initial_balance] - 10 - () - >>=? fun (b, delegates) -> - Context.get_constants (B b) >>=? fun {parametric = {minimal_stake; _}; _} -> - let del1 = WithExceptions.Option.get ~loc:__LOC__ @@ List.nth delegates 0 in - let del2 = WithExceptions.Option.get ~loc:__LOC__ @@ List.nth delegates 1 in - let del3 = WithExceptions.Option.get ~loc:__LOC__ @@ List.nth delegates 2 in - let pkhs = - List.map (fun del -> Context.Contract.pkh del) [del1; del2; del3] - in - let policy = Block.Excluding pkhs in - Op.transaction - (B b) - (WithExceptions.Option.get ~loc:__LOC__ @@ List.nth delegates 3) - del1 - minimal_stake - >>=? fun op1 -> - Op.transaction - (B b) - (WithExceptions.Option.get ~loc:__LOC__ @@ List.nth delegates 4) - del2 - minimal_stake - >>=? fun op2 -> - (if there_is_a_winner then Test_tez.( *? ) minimal_stake 3L - else - Test_tez.( *? ) minimal_stake 2L - >>? Test_tez.( +? ) (Test_tez.of_mutez_exn initial_balance)) - >>?= fun bal3 -> - Op.transaction - (B b) - (WithExceptions.Option.get ~loc:__LOC__ @@ List.nth delegates 5) - del3 - bal3 - >>=? fun op3 -> - Block.bake ~policy ~operations:[op1; op2; op3] b >>=? fun b -> - bake_until_first_block_of_next_period ~policy b >>=? fun b -> - (* make the proposals *) - Op.proposals (B b) del1 [protos.(0)] >>=? fun ops1 -> - Op.proposals (B b) del2 [protos.(0)] >>=? fun ops2 -> - Op.proposals (B b) del3 [protos.(1)] >>=? fun ops3 -> - Block.bake ~policy ~operations:[ops1; ops2; ops3] b >>=? fun b -> - bake_until_first_block_of_next_period ~policy b >>=? fun b -> - (* we remain in the proposal period when there is no winner, - otherwise we move to the exploration period *) - (if there_is_a_winner then assert_period ~expected_kind:Exploration b __LOC__ - else assert_period ~expected_kind:Proposal b __LOC__) - >>=? fun () -> return_unit - -(** After one voting period, if [has_quorum] then the period kind must - have been the cooldown vote. Otherwise, it should have remained in - place in the proposal period. *) -let test_quorum_in_proposal has_quorum () = - let total_tokens = 32_000_000_000_000L in - let half_tokens = Int64.div total_tokens 2L in - context_init ~bootstrap_balances:[1L; half_tokens; half_tokens] 3 () - >>=? fun (b, delegates) -> - Context.get_constants (B b) - >>=? fun {parametric = {min_proposal_quorum; _}; _} -> - let del1 = WithExceptions.Option.get ~loc:__LOC__ @@ List.nth delegates 0 in - let del2 = WithExceptions.Option.get ~loc:__LOC__ @@ List.nth delegates 1 in - let pkhs = List.map (fun del -> Context.Contract.pkh del) [del1; del2] in - let policy = Block.Excluding pkhs in - let quorum = - if has_quorum then Int64.of_int32 min_proposal_quorum - else Int64.(sub (of_int32 min_proposal_quorum) 10L) - in - let bal = - Int64.(div (mul total_tokens quorum) 100_00L) |> Test_tez.of_mutez_exn - in - Op.transaction (B b) del2 del1 bal >>=? fun op2 -> - Block.bake ~policy ~operation:op2 b >>=? fun b -> - bake_until_first_block_of_next_period b >>=? fun b -> - (* make the proposal *) - Op.proposals (B b) del1 [protos.(0)] >>=? fun operation -> - Block.bake ~policy ~operation b >>=? fun b -> - bake_until_first_block_of_next_period b >>=? fun b -> - (* we remain in the proposal period when there is no quorum, - otherwise we move to the cooldown vote period *) - (if has_quorum then assert_period ~expected_kind:Exploration b __LOC__ - else assert_period ~expected_kind:Proposal b __LOC__) - >>=? fun () -> return_unit - -(** If a supermajority is reached, then the voting period must be - reached. Otherwise, it remains in proposal period. *) -let test_supermajority_in_exploration supermajority () = - let min_proposal_quorum = Int32.(of_int @@ (100_00 / 100)) in - context_init ~min_proposal_quorum 100 () >>=? fun (b, delegates) -> - let del1 = WithExceptions.Option.get ~loc:__LOC__ @@ List.nth delegates 0 in - let proposal = protos.(0) in - Op.proposals (B b) del1 [proposal] >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - bake_until_first_block_of_next_period b >>=? fun b -> - (* move to exploration *) - assert_period ~expected_kind:Exploration b __LOC__ >>=? fun () -> - (* assert our proposal won *) - (Context.Vote.get_current_proposal (B b) >>=? function - | Some v -> - if Protocol_hash.(equal proposal v) then return_unit - else failwith "%s - Wrong proposal" __LOC__ - | None -> failwith "%s - Missing proposal" __LOC__) - >>=? fun () -> - (* beginning of exploration period, denoted by _p2; - take a snapshot of the active delegates and their voting power from listings *) - get_delegates_and_power_from_listings b >>=? fun (delegates_p2, _power_p2) -> - (* supermajority means [num_yays / (num_yays + num_nays) >= s_num / s_den], - which is equivalent with [num_yays >= num_nays * s_num / (s_den - s_num)] *) - let num_delegates = List.length delegates_p2 in - let num_nays = num_delegates / 5 in - (* any smaller number will do as well *) - let num_yays = num_nays * s_num / (s_den - s_num) in - (* majority/minority vote depending on the [supermajority] parameter *) - let num_yays = if supermajority then num_yays else num_yays - 1 in - let open Alpha_context in - let nays_delegates, rest = List.split_n num_nays delegates_p2 in - let yays_delegates, _ = List.split_n num_yays rest in - List.map_es (fun del -> Op.ballot (B b) del proposal Vote.Yay) yays_delegates - >>=? fun operations_yays -> - List.map_es (fun del -> Op.ballot (B b) del proposal Vote.Nay) nays_delegates - >>=? fun operations_nays -> - let operations = operations_yays @ operations_nays in - Block.bake ~operations b >>=? fun b -> - bake_until_first_block_of_next_period b >>=? fun b -> - (if supermajority then assert_period ~expected_kind:Cooldown b __LOC__ - else assert_period ~expected_kind:Proposal b __LOC__) - >>=? fun () -> return_unit - -(** Test also how the selection scales: all delegates propose max - proposals. *) -let test_no_winning_proposal num_delegates () = - let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in - context_init ~min_proposal_quorum num_delegates () >>=? fun (b, _) -> - (* beginning of proposal, denoted by _p1; - take a snapshot of the active delegates and their voting power from listings *) - get_delegates_and_power_from_listings b >>=? fun (delegates_p1, _power_p1) -> - let open Alpha_context in - let props = - List.map (fun i -> protos.(i)) (1 -- Constants.max_proposals_per_delegate) - in - (* all delegates active in p1 propose the same proposals *) - List.map_es (fun del -> Op.proposals (B b) del props) delegates_p1 - >>=? fun operations -> - Block.bake ~operations b >>=? fun b -> - (* skip to exploration period *) - bake_until_first_block_of_next_period b >>=? fun b -> - (* we stay in the same proposal period because no winning proposal *) - assert_period ~expected_kind:Proposal b __LOC__ >>=? fun () -> return_unit - -(** Vote to pass with maximum possible participation_ema (100%), it is - sufficient for the vote quorum to be equal or greater than the - maximum quorum cap. *) -let test_quorum_capped_maximum num_delegates () = - let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in - context_init ~min_proposal_quorum num_delegates () >>=? fun (b, delegates) -> - (* set the participation EMA to 100% *) - Context.Vote.set_participation_ema b 100_00l >>= fun b -> - Context.get_constants (B b) >>=? fun {parametric = {quorum_max; _}; _} -> - (* proposal period *) - let open Alpha_context in - assert_period ~expected_kind:Proposal b __LOC__ >>=? fun () -> - (* propose a new protocol *) - let protocol = Protocol_hash.zero in - let proposer = - WithExceptions.Option.get ~loc:__LOC__ @@ List.nth delegates 0 - in - Op.proposals (B b) proposer [protocol] >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - (* skip to exploration period *) - bake_until_first_block_of_next_period b >>=? fun b -> - (* we moved to an exploration period with one proposal *) - assert_period ~expected_kind:Exploration b __LOC__ >>=? fun () -> - (* take percentage of the delegates equal or greater than quorum_max *) - let minimum_to_pass = - Float.of_int (List.length delegates) - *. Int32.(to_float quorum_max) - /. 100_00. - |> Float.ceil |> Float.to_int - in - let voters = List.take_n minimum_to_pass delegates in - (* all voters vote for yays; no nays, so supermajority is satisfied *) - List.map_es (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters - >>=? fun operations -> - Block.bake ~operations b >>=? fun b -> - (* skip to next period *) - bake_until_first_block_of_next_period b >>=? fun b -> - (* expect to move to cooldown because we have supermajority and enough quorum *) - assert_period ~expected_kind:Cooldown b __LOC__ - -(** Vote to pass with minimum possible participation_ema (0%), it is - sufficient for the vote quorum to be equal or greater than the - minimum quorum cap. *) -let test_quorum_capped_minimum num_delegates () = - let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in - context_init ~min_proposal_quorum num_delegates () >>=? fun (b, delegates) -> - (* set the participation EMA to 0% *) - Context.Vote.set_participation_ema b 0l >>= fun b -> - Context.get_constants (B b) >>=? fun {parametric = {quorum_min; _}; _} -> - (* proposal period *) - let open Alpha_context in - assert_period ~expected_kind:Proposal b __LOC__ >>=? fun () -> - (* propose a new protocol *) - let protocol = Protocol_hash.zero in - let proposer = - WithExceptions.Option.get ~loc:__LOC__ @@ List.nth delegates 0 - in - Op.proposals (B b) proposer [protocol] >>=? fun operation -> - Block.bake ~operation b >>=? fun b -> - (* skip to exploration period *) - bake_until_first_block_of_next_period b >>=? fun b -> - (* we moved to an exploration period with one proposal *) - assert_period ~expected_kind:Exploration b __LOC__ >>=? fun () -> - (* take percentage of the delegates equal or greater than quorum_min *) - let minimum_to_pass = - Float.of_int (List.length delegates) - *. Int32.(to_float quorum_min) - /. 100_00. - |> Float.ceil |> Float.to_int - in - let voters = List.take_n minimum_to_pass delegates in - (* all voters vote for yays; no nays, so supermajority is satisfied *) - List.map_es (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters - >>=? fun operations -> - Block.bake ~operations b >>=? fun b -> - (* skip to next period *) - bake_until_first_block_of_next_period b >>=? fun b -> - (* expect to move to cooldown because we have supermajority and enough quorum *) - assert_period ~expected_kind:Cooldown b __LOC__ - -(* gets the voting power *) -let get_voting_power block pkhash = - let ctxt = Context.B block in - Context.get_voting_power ctxt pkhash - -(** Test that the voting power changes if the balance between bakers changes - and the blockchain moves to the next voting period. It also checks that - the total voting power coincides with the addition of the voting powers - of bakers *) -let test_voting_power_updated_each_voting_period () = - let init_bal1 = 80_000_000_000L in - let init_bal2 = 48_000_000_000L in - let init_bal3 = 40_000_000_000L in - (* Create three accounts with different amounts *) - context_init ~bootstrap_balances:[init_bal1; init_bal2; init_bal3] 3 () - >>=? fun (genesis, contracts) -> - let con1 = WithExceptions.Option.get ~loc:__LOC__ @@ List.nth contracts 0 in - let con2 = WithExceptions.Option.get ~loc:__LOC__ @@ List.nth contracts 1 in - let con3 = WithExceptions.Option.get ~loc:__LOC__ @@ List.nth contracts 2 in - (* Get the key hashes of the bakers *) - let baker1 = Context.Contract.pkh con1 in - let baker2 = Context.Contract.pkh con2 in - let baker3 = Context.Contract.pkh con3 in - (* Retrieve balance of con1 *) - let open Test_tez in - Context.Contract.balance (B genesis) con1 >>=? fun balance1 -> - Context.Delegate.current_frozen_deposits (B genesis) baker1 - >>=? fun frozen_deposits1 -> - balance1 +? frozen_deposits1 >>?= fun full_balance1 -> - Assert.equal_tez ~loc:__LOC__ full_balance1 (of_mutez_exn init_bal1) - >>=? fun () -> - (* Retrieve balance of con2 *) - Context.Contract.balance (B genesis) con2 >>=? fun balance2 -> - Context.Delegate.current_frozen_deposits (B genesis) baker2 - >>=? fun frozen_deposits2 -> - balance2 +? frozen_deposits2 >>?= fun full_balance2 -> - Assert.equal_tez ~loc:__LOC__ full_balance2 (of_mutez_exn init_bal2) - >>=? fun () -> - (* Retrieve balance of con3 *) - Context.Contract.balance (B genesis) con3 >>=? fun balance3 -> - Context.Delegate.current_frozen_deposits (B genesis) baker3 - >>=? fun frozen_deposits3 -> - balance3 +? frozen_deposits3 >>?= fun full_balance3 -> - Assert.equal_tez ~loc:__LOC__ full_balance3 (of_mutez_exn init_bal3) - >>=? fun () -> - (* Auxiliary assert_voting_power *) - let assert_voting_power ~loc n block baker = - get_voting_power block baker >>=? fun voting_power -> - Assert.equal_int64 ~loc n voting_power - in - (* Auxiliary assert_total_voting_power *) - let assert_total_voting_power ~loc n block = - Context.get_total_voting_power (B block) >>=? fun total_voting_power -> - Assert.equal_int64 ~loc n total_voting_power - in - let expected_power_of_baker_1 = Tez.to_mutez full_balance1 in - assert_voting_power ~loc:__LOC__ expected_power_of_baker_1 genesis baker1 - >>=? fun () -> - let expected_power_of_baker_2 = Tez.to_mutez full_balance2 in - assert_voting_power ~loc:__LOC__ expected_power_of_baker_2 genesis baker2 - >>=? fun () -> - (* Assert total voting power *) - let expected_power_of_baker_3 = Tez.to_mutez full_balance3 in - assert_total_voting_power - ~loc:__LOC__ - Int64.( - add - (add expected_power_of_baker_1 expected_power_of_baker_2) - expected_power_of_baker_3) - genesis - >>=? fun () -> - (* Create policy that excludes baker1 and baker2 from baking *) - let policy = Block.Excluding [baker1; baker2] in - (* Transfer 30,000 tez from baker1 to baker2 *) - let amount = Tez.of_mutez_exn 30_000_000_000L in - Op.transaction (B genesis) con1 con2 amount >>=? fun operation -> - (* Bake the block containing the transaction *) - Block.bake ~policy ~operation genesis >>=? fun block -> - (* Retrieve balance of con1 *) - Context.Contract.balance (B block) con1 >>=? fun balance1 -> - (* Assert balance has changed by deducing the amount *) - of_mutez_exn init_bal1 -? amount >>?= fun balance1_after_deducing_amount -> - Context.Delegate.current_frozen_deposits (B block) baker1 - >>=? fun frozen_deposit1 -> - balance1_after_deducing_amount -? frozen_deposit1 - >>?= Assert.equal_tez ~loc:__LOC__ balance1 - >>=? fun () -> - (* Retrieve balance of con2 *) - Context.Contract.balance (B block) con2 >>=? fun balance2 -> - (* Assert balance has changed by adding amount *) - of_mutez_exn init_bal2 +? amount >>?= fun balance2_after_adding_amount -> - Context.Delegate.current_frozen_deposits (B block) baker2 - >>=? fun frozen_deposit2 -> - balance2_after_adding_amount -? frozen_deposit2 - >>?= Assert.equal_tez ~loc:__LOC__ balance2 - >>=? fun () -> - Block.bake ~policy block >>=? fun block -> - (* Assert voting power (and total) remains the same before next voting period *) - assert_voting_power ~loc:__LOC__ expected_power_of_baker_1 block baker1 - >>=? fun () -> - assert_voting_power ~loc:__LOC__ expected_power_of_baker_2 block baker2 - >>=? fun () -> - assert_voting_power ~loc:__LOC__ expected_power_of_baker_3 block baker3 - >>=? fun () -> - assert_total_voting_power - ~loc:__LOC__ - Int64.( - add - (add expected_power_of_baker_1 expected_power_of_baker_2) - expected_power_of_baker_3) - block - >>=? fun () -> - bake_until_first_block_of_next_period block >>=? fun block -> - (* Assert voting power of baker1 has decreased by [amount] *) - let expected_power_of_baker_1 = - Int64.sub expected_power_of_baker_1 (Tez.to_mutez amount) - in - assert_voting_power ~loc:__LOC__ expected_power_of_baker_1 block baker1 - >>=? fun () -> - (* Assert voting power of baker2 has increased by [amount] *) - let expected_power_of_baker_2 = - Int64.add expected_power_of_baker_2 (Tez.to_mutez amount) - in - assert_voting_power ~loc:__LOC__ expected_power_of_baker_2 block baker2 - >>=? fun () -> - (* Retrieve voting power of baker3 *) - get_voting_power block baker3 >>=? fun power -> - let power_of_baker_3 = power in - (* Assert total voting power *) - assert_total_voting_power - ~loc:__LOC__ - Int64.( - add - (add expected_power_of_baker_1 expected_power_of_baker_2) - power_of_baker_3) - block - -let test_voting_period_pp () = - let vp = - Voting_period_repr. - { - index = Int32.of_int 123; - kind = Proposal; - start_position = Int32.of_int 321; - } - in - Assert.equal - ~loc:__LOC__ - ( = ) - "Unexpected pretty printing of voting period" - Format.pp_print_string - (Format.asprintf "%a" Voting_period_repr.pp vp) - "index: 123, kind:proposal, start_position: 321" - -(** {2 Validity tests} - - For each vote operation (Proposals and Ballot), we define a serie - of negative tests and a positive test. - - Negative tests target errors that can occur during - application. They check that the appropriate error is triggered. - - If the operation is valid, then its application must succeed when - it is baked into a block. Positive tests observe the effects of the - operation application by comparing the states before and after the - block. *) - -(** {3 Proposal -- Negative tests} *) - -(** Test that a Proposals operation fails when it is unsigned. *) -let test_proposals_missing_signature () = - let open Lwt_result_syntax in - let* block, proposer = context_init1 () in - let* contents = Op.proposals_contents (B block) proposer [protos.(0)] in - let op = Op.pack_operation (B block) None contents in - Incremental.assert_validate_operation_fails - (missing_signature __LOC__) - op - block - -(** Test that a Proposals operation fails when its signature is invalid. *) -let test_proposals_invalid_signature () = - let open Lwt_result_syntax in - let* block, proposer = context_init1 () in - let* contents = Op.proposals_contents (B block) proposer [protos.(0)] in - let op = Op.pack_operation (B block) (Some Signature.zero) contents in - Incremental.assert_validate_operation_fails - (invalid_signature __LOC__) - op - block - -(** Test that a Proposals operation fails when the period index - provided in the operation is not the current voting period index. *) -let test_proposals_wrong_voting_period_index () = - let open Lwt_result_syntax in - let* block, proposer = context_init1 () in - let* current_period = Context.Vote.get_current_period (B block) in - let current_index = current_period.voting_period.index in - let op_index = Int32.succ current_index in - assert_validate_proposals_fails - ~expected_error:(wrong_voting_period_index ~current_index ~op_index) - ~proposer - ~proposals:[Protocol_hash.zero] - ~period:op_index - block - __LOC__ - -(** Test that a Proposals operation fails when it occurs in a - non-Proposal voting period. *) -let test_proposals_wrong_voting_period_kind () = - let open Lwt_result_syntax in - let* block, proposer = context_init1 () in - let proposal = protos.(0) in - let assert_proposals_fails_with_unexpected_proposal = - assert_validate_proposals_fails - ~expected_error:wrong_voting_period_kind - ~proposer - ~proposals:[proposal] - in - (* End the initial Proposals period with a submitted - proposal, to move on to an Exploration period. *) - let* operation = Op.proposals (B block) proposer [proposal] in - let* block = Block.bake block ~operation in - let* block = bake_until_first_block_of_next_period block in - (* Proposals during Exploration. *) - let* () = assert_period ~expected_kind:Exploration block __LOC__ in - let* () = assert_proposals_fails_with_unexpected_proposal block __LOC__ in - (* End the Exploration period with enough votes to move on to a - Cooldown period. *) - let* operation = Op.ballot (B block) proposer proposal Vote.Yay in - let* block = Block.bake ~operation block in - let* block = bake_until_first_block_of_next_period block in - (* Proposals during Cooldown. *) - let* () = assert_period ~expected_kind:Cooldown block __LOC__ in - let* () = assert_proposals_fails_with_unexpected_proposal block __LOC__ in - (* Proposals during Promotion. *) - let* block = bake_until_first_block_of_next_period block in - let* () = assert_period ~expected_kind:Promotion block __LOC__ in - let* () = assert_proposals_fails_with_unexpected_proposal block __LOC__ in - (* End the Promotion period with enough votes to move on to an - Adoption period. *) - let* operation = Op.ballot (B block) proposer proposal Vote.Yay in - let* block = Block.bake ~operation block in - let* block = bake_until_first_block_of_next_period block in - (* Proposals during Adoption. *) - let* () = assert_period ~expected_kind:Adoption block __LOC__ in - assert_proposals_fails_with_unexpected_proposal block __LOC__ - -(** Test that a Proposals operation fails when the proposer is not in - the vote listings (with the same error, no matter how far the - source is from being a delegate with voting rights). *) -let test_proposals_source_not_in_vote_listings () = - let open Lwt_result_syntax in - (* The chosen [blocks_per_cycle] is an arbitrary value that we will - not reach with the blocks baked in this test. *) - let* block, funder = context_init1 ~blocks_per_cycle:10l () in - let fresh_account = Account.new_account () in - let proposer = Contract.Implicit fresh_account.pkh in - let assert_fails_with_unregistered_delegate block = - assert_validate_proposals_fails - ~expected_error:proposals_from_unregistered_delegate - ~proposer - ~proposals:[Protocol_hash.zero] - block - in - let assert_fails_with_source_not_in_vote_listings block = - assert_validate_proposals_fails - ~expected_error:source_not_in_vote_listings - ~proposer - ~proposals:[Protocol_hash.zero] - block - in - (* Fail when the source has no contract in the storage. *) - let* () = assert_fails_with_unregistered_delegate block __LOC__ in - let* operation = Op.transaction (B block) funder proposer Tez.one in - let* block = Block.bake block ~operation in - (* Fail when the contract's public key is unreavealed. *) - let* () = assert_fails_with_unregistered_delegate block __LOC__ in - let* operation = Op.revelation (B block) fresh_account.pk in - let* block = Block.bake block ~operation in - (* Fail when the source is not a delegate. *) - let* () = assert_fails_with_unregistered_delegate block __LOC__ in - let* operation = Op.delegation (B block) proposer (Some fresh_account.pkh) in - let* block = Block.bake block ~operation in - (* Fail when the source is a delegate, but not yet in the vote listings. *) - assert_fails_with_source_not_in_vote_listings block __LOC__ - -(** Test that a Proposals operation fails when its proposal list is - empty. *) -let test_empty_proposals () = - let open Lwt_result_syntax in - let* block, proposer = context_init1 () in - assert_validate_proposals_fails - ~expected_error:empty_proposals - ~proposer - ~proposals:[] - block - __LOC__ - -(** Test that a Proposals operation fails when its proposal list - contains multiple occurrences of the same proposal. *) -let test_proposals_contain_duplicate () = - let open Lwt_result_syntax in - let* block, proposer = context_init1 () in - assert_validate_proposals_fails - ~expected_error:(proposals_contain_duplicate protos.(1)) - ~proposer - ~proposals:[protos.(0); protos.(1); protos.(2); protos.(1); protos.(3)] - block - __LOC__ - -(** Test that a Proposals operation fails when it would make the total - count of proposals submitted by the proposer exceed the - [max_proposals_per_delegate] protocol constant. *) -let test_too_many_proposals () = - let open Lwt_result_syntax in - let* block, proposer = context_init1 () in - assert (Array.length protos >= Constants.max_proposals_per_delegate + 1) ; - let proposals = - List.map (Array.get protos) (1 -- Constants.max_proposals_per_delegate) - in - let* operation = Op.proposals (B block) proposer proposals in - let* block = Block.bake block ~operation in - assert_validate_proposals_fails - ~expected_error:too_many_proposals - ~proposer - ~proposals:[protos.(0)] - block - __LOC__ - -(** Test that a Proposals operation fails when one of its proposals has - already been submitted by the same proposer in an earlier block. *) -let test_already_proposed () = - let open Lwt_result_syntax in - let* block, proposer = context_init1 () in - let* operation = Op.proposals (B block) proposer [protos.(0); protos.(1)] in - let* block = Block.bake block ~operation in - (* The [proposer] cannot submit protocol [0] again. *) - let* () = - assert_validate_proposals_fails - ~expected_error:(already_proposed protos.(0)) - ~proposer - ~proposals:[protos.(0)] - block - __LOC__ - in - (* The [proposer] cannot submit protocol [1] again, even among other - new proposals. *) - let* () = - assert_validate_proposals_fails - ~expected_error:(already_proposed protos.(1)) - ~proposer - ~proposals:[protos.(2); protos.(1); protos.(3)] - block - __LOC__ - in - (* The initial [operation] cannot be replayed. *) - let* () = - Incremental.assert_validate_operation_fails - (already_proposed protos.(0) __LOC__) - operation - block - in - let* block = bake_until_first_block_of_next_period block in - Incremental.assert_validate_operation_fails - (wrong_voting_period_index ~current_index:1l ~op_index:0l __LOC__) - operation - block - -(** Test that a Proposals operation fails when it would make the total - count of proposals submitted by the proposer exceed the - [max_proposals_per_delegate] protocol constant, because of - previously validated operations in the current block/mempool. *) -let test_conflict_too_many_proposals () = - let open Lwt_result_syntax in - let* block, proposer = context_init1 () in - let n_proposals_in_previous_blocks = 5 in - assert (Array.length protos >= Constants.max_proposals_per_delegate + 1) ; - let proposals_in_previous_blocks = - List.map (Array.get protos) (1 -- n_proposals_in_previous_blocks) - in - let* operation = - Op.proposals (B block) proposer proposals_in_previous_blocks - in - let* block = Block.bake block ~operation in - let* current_block_state = Incremental.begin_construction block in - let proposals_in_current_block = - List.map - (Array.get protos) - (n_proposals_in_previous_blocks + 1 - -- Constants.max_proposals_per_delegate) - in - let* op_in_current_block = - Op.proposals (B block) proposer proposals_in_current_block - in - let* current_block_state = - Incremental.validate_operation current_block_state op_in_current_block - in - let* op = Op.proposals (B block) proposer [protos.(0)] in - let* (_i : Incremental.t) = - Incremental.validate_operation - ~expect_failure:(conflicting_proposals __LOC__) - current_block_state - op - in - return_unit - -(** Test that a Proposals operation fails when its source has already - submitted a Proposals operation in the current block/mempool. *) -let test_conflicting_proposal () = - let open Lwt_result_syntax in - let* block, proposer = context_init1 () in - let proposal = protos.(0) in - let* current_block_state = Incremental.begin_construction block in - let* op_in_current_block = Op.proposals (B block) proposer [proposal] in - let* current_block_state = - Incremental.validate_operation current_block_state op_in_current_block - in - let* op = Op.proposals (B block) proposer [proposal] in - let* (_i : Incremental.t) = - Incremental.validate_operation - ~expect_failure:(conflicting_proposals __LOC__) - current_block_state - op - in - let proposal' = protos.(1) in - let* op' = Op.proposals (B block) proposer [proposal'] in - let* (_i : Incremental.t) = - Incremental.validate_operation - ~expect_failure:(conflicting_proposals __LOC__) - current_block_state - op' - in - return_unit - -(** {3 Proposals -- Positive test} - - A Proposals operation is valid when: - - - its source is a registered delegate and belongs to the voting - listings, - - - the current voting period is a Proposal period and has the same - index as the period provided in the operation, - - - its list of proposals is not empty, - - - it won't make the total proposal count of the proposer exceed - the [max_proposals_per_delegate] protocol constant, and - - - its signature is valid. - - We can observe the successful application of the Proposals - operation from a pre-state to a post-state as follows: - - - the proposal count of the proposer has been incremented by the - number of proposals in the operation, - - - the operation proposals have been added to the recorded - proposals of the proposer, and - - - the total weight supporting each of the proposals has been - incremented by the voting power of the proposer. *) - -let observe_proposals pre_state post_state op caller_loc = - let open Lwt_result_syntax in - let make_loc = append_loc ~caller_loc in - let* (Proposals {source; period; proposals}) = - let (Operation_data {contents; _}) = op.protocol_data in - match contents with - | Single (Proposals _ as contents) -> return contents - | _ -> failwith "%s - Expected a Proposals operation" (make_loc __LOC__) - in - - (* Validity conditions *) - let proposals_num = List.length proposals in - let* () = Assert.not_equal_int ~loc:(make_loc __LOC__) 0 proposals_num in - let* () = - assert_period ~expected_kind:Proposal pre_state (make_loc __LOC__) - in - let* pre_period = Context.Vote.get_current_period (B pre_state) in - let* () = - Assert.equal_int32 - ~loc:(make_loc __LOC__) - period - pre_period.voting_period.index - in - let* del = - Context.Contract.delegate (B pre_state) (Contract.Implicit source) - in - let* () = Assert.equal_pkh ~loc:(make_loc __LOC__) source del in - let* dels, _powers = get_delegates_and_power_from_listings pre_state in - assert (List.mem ~equal:Contract.equal (Contract.Implicit source) dels) ; - let* pre_voting_infos = Context.Delegate.voting_info (B pre_state) source in - let* () = - Assert.not_equal_int - ~loc:(make_loc __LOC__) - 0 - pre_voting_infos.remaining_proposals - in - let* () = - Assert.leq_int - ~loc:(make_loc __LOC__) - proposals_num - pre_voting_infos.remaining_proposals - in - - (* Observations *) - (* Check [voting_info] update. *) - let* post_voting_infos = Context.Delegate.voting_info (B post_state) source in - let* () = - Assert.equal_int - ~loc:(make_loc __LOC__) - post_voting_infos.remaining_proposals - (pre_voting_infos.remaining_proposals - proposals_num) - in - assert ( - List.for_all - (fun a -> Stdlib.List.mem a post_voting_infos.current_proposals) - proposals) ; - (* Check [Storage.Vote.Proposals_count] update. *) - let* proposal_count_pre = - Context.Vote.get_delegate_proposal_count (B pre_state) source - in - let* proposal_count_post = - Context.Vote.get_delegate_proposal_count (B post_state) source - in - let* () = - Assert.equal_int - ~loc:(make_loc __LOC__) - (proposal_count_pre + proposals_num) - proposal_count_post - in - (* Check the update of the total weight of supporters for each proposal. *) - let* proposal_weights_pre = Context.Vote.get_proposals (B pre_state) in - let* proposal_weights_post = Context.Vote.get_proposals (B post_state) in - let* source_power = - Assert.get_some ~loc:(make_loc __LOC__) pre_voting_infos.voting_power - in - List.iter_es - (fun proposal -> - let weight_pre = - Environment.Protocol_hash.Map.find proposal proposal_weights_pre - |> Option.value ~default:Int64.zero - in - let* weight_post = - Assert.get_some - ~loc:(make_loc __LOC__) - (Environment.Protocol_hash.Map.find proposal proposal_weights_post) - in - Assert.equal_int64 - ~loc:(make_loc __LOC__) - weight_post - (Int64.add weight_pre source_power)) - proposals - -let test_too_many_proposals_in_one_operation () = - let open Lwt_result_syntax in - let* b0, proposer0 = context_init1 () in - let protos = Array.to_list protos in - Lwt.catch - (fun () -> - let* (_ : packed_operation) = Op.proposals (B b0) proposer0 protos in - failwith - "Encoding of proposals operation with too many proposals should fail") - (function - | Data_encoding.Binary.(Write_error List_invalid_length) -> return_unit - | exn -> Lwt.reraise exn) - -(* Bake blocks with various valid Proposals operations, and observe - that their effects are correctly applied. *) -let test_valid_proposals () = - let open Lwt_result_syntax in - (* We use a higher [blocks_per_cycle] than the - {!default_blocks_per_cycle} (which is [4l]), so that we can bake - each operation in a separate block without reaching the end of - the voting cycle. *) - let* b0, (proposer0, proposer1) = context_init2 ~blocks_per_cycle:10l () in - let* op0 = Op.proposals (B b0) proposer0 [protos.(0)] in - let* b1 = Block.bake b0 ~operation:op0 in - let* () = observe_proposals b0 b1 op0 __LOC__ in - let* op1 = - Op.proposals (B b1) proposer0 [protos.(1); protos.(2); protos.(3)] - in - let* b2 = Block.bake b1 ~operation:op1 in - let* () = observe_proposals b1 b2 op1 __LOC__ in - let* op2 = - Op.proposals - (B b2) - proposer1 - [protos.(0); protos.(2); protos.(4); protos.(5)] - in - let* b3 = Block.bake b2 ~operation:op2 in - let* () = observe_proposals b2 b3 op2 __LOC__ in - let* op3 = Op.proposals (B b3) proposer0 [protos.(5); protos.(6)] in - let* b4 = Block.bake b3 ~operation:op3 in - observe_proposals b3 b4 op3 __LOC__ - -(** {3 Ballot -- Negative tests} *) - -(** Test that a Ballot operation fails when it is unsigned. *) -let test_ballot_missing_signature () = - let open Lwt_result_syntax in - let* block, voter, proposal = context_init_exploration () in - let* contents = Op.ballot_contents (B block) voter proposal Vote.Yay in - let op = Op.pack_operation (B block) None contents in - Incremental.assert_validate_operation_fails - (missing_signature __LOC__) - op - block - -(** Test that a Ballot operation fails when its signature is invalid. *) -let test_ballot_invalid_signature () = - let open Lwt_result_syntax in - let* block, voter, proposal = context_init_exploration () in - let* contents = Op.ballot_contents (B block) voter proposal Vote.Yay in - let op = Op.pack_operation (B block) (Some Signature.zero) contents in - Incremental.assert_validate_operation_fails - (invalid_signature __LOC__) - op - block - -(** Test that a Ballot operation fails when the period index provided - in the operation is not the current voting period index. *) -let test_ballot_wrong_voting_period_index () = - let open Lwt_result_syntax in - let* block, voter = context_init1 () in - let* current_period = Context.Vote.get_current_period (B block) in - let current_index = current_period.voting_period.index in - let op_index = Int32.succ current_index in - assert_validate_ballot_fails - ~expected_error:(wrong_voting_period_index ~current_index ~op_index) - ~voter - ~proposal:protos.(0) - ~ballot:Vote.Yay - ~period:op_index - block - __LOC__ - -(** Test that a Ballot operation fails when it occurs outside of an - Exploration or Promotion voting period. *) -let test_ballot_wrong_voting_period_kind () = - let open Lwt_result_syntax in - let* block, voter = context_init1 () in - let proposal = protos.(0) in - let assert_ballot_fails_with_unexpected_ballot = - assert_validate_ballot_fails - ~expected_error:wrong_voting_period_kind - ~voter - ~proposal - ~ballot:Vote.Nay - in - (* Ballot during Proposals. *) - let* () = assert_period ~expected_kind:Proposal block __LOC__ in - let* () = assert_ballot_fails_with_unexpected_ballot block __LOC__ in - (* End the Proposals period with a submitted proposal, to move on to - an Exploration period. *) - let* operation = Op.proposals (B block) voter [proposal] in - let* block = Block.bake block ~operation in - let* block = bake_until_first_block_of_next_period block in - (* End the Exploration period with enough votes to move on to a - Cooldown period. *) - let* operation = Op.ballot (B block) voter proposal Vote.Yay in - let* block = Block.bake block ~operation in - let* block = bake_until_first_block_of_next_period block in - (* Ballot during Cooldown. *) - let* () = assert_period ~expected_kind:Cooldown block __LOC__ in - let* () = assert_ballot_fails_with_unexpected_ballot block __LOC__ in - (* End the Cooldown period, then end the Promotion period with - enough votes to move on to an Adoption period. *) - let* block = bake_until_first_block_of_next_period block in - let* operation = Op.ballot (B block) voter proposal Vote.Yay in - let* block = Block.bake ~operation block in - let* block = bake_until_first_block_of_next_period block in - (* Ballot during Adoption. *) - let* () = assert_period ~expected_kind:Adoption block __LOC__ in - assert_ballot_fails_with_unexpected_ballot block __LOC__ - -(** Test that a Ballot operation fails when its proposal is not the - current proposal. *) -let test_ballot_for_wrong_proposal () = - let open Lwt_result_syntax in - let* block, voter, current_proposal = - context_init_exploration ~proposal:protos.(0) () - in - let op_proposal = protos.(1) in - assert_validate_ballot_fails - ~expected_error:(ballot_for_wrong_proposal ~current_proposal ~op_proposal) - ~voter - ~proposal:op_proposal - ~ballot:Vote.Yay - block - __LOC__ - -(** Test that a Ballot operation fails when its source has already - submitted a Ballot. *) -let test_already_submitted_a_ballot () = - let open Lwt_result_syntax in - let* block, voter, proposal = context_init_exploration () in - let* operation = Op.ballot (B block) voter proposal Vote.Yay in - let* block = Block.bake ~operation block in - assert_validate_ballot_fails - ~expected_error:already_submitted_a_ballot - ~voter - ~proposal - ~ballot:Vote.Nay - block - __LOC__ - -(** Test that a Ballot operation fails when its source is not in the - vote listings (with the same error, no matter how far the source is - from being a delegate with voting rights). *) -let test_ballot_source_not_in_vote_listings () = - let open Lwt_result_syntax in - let* block, funder, proposal = - (* The chosen [blocks_per_cycle] is an arbitrary value that we - will not reach with the blocks baked in this test. *) - context_init_exploration ~blocks_per_cycle:10l () - in - let fresh_account = Account.new_account () in - let voter = Contract.Implicit fresh_account.pkh in - let assert_fails_with_source_not_in_vote_listings block = - assert_validate_ballot_fails - ~expected_error:source_not_in_vote_listings - ~voter - ~proposal - ~ballot:Vote.Yay - block - in - let assert_fails_with_unregistered_delegate block = - assert_validate_ballot_fails - ~expected_error:ballot_from_unregistered_delegate - ~voter - ~proposal - ~ballot:Vote.Yay - block - in - (* Fail when the source has no contract in the storage. *) - let* () = assert_fails_with_unregistered_delegate block __LOC__ in - let* operation = Op.transaction (B block) funder voter Tez.one in - let* block = Block.bake block ~operation in - (* Fail when the contract's public key is unreavealed. *) - let* () = assert_fails_with_unregistered_delegate block __LOC__ in - let* operation = Op.revelation (B block) fresh_account.pk in - let* block = Block.bake block ~operation in - (* Fail when the source is not a delegate. *) - let* () = assert_fails_with_unregistered_delegate block __LOC__ in - let* operation = Op.delegation (B block) voter (Some fresh_account.pkh) in - let* block = Block.bake block ~operation in - (* Fail when the source is a delegate, but not yet in the vote listings. *) - assert_fails_with_source_not_in_vote_listings block __LOC__ - -(** Test that a Ballot operation fails when its source has already - submitted a Ballot in a previously validated operation of the - current block. *) -let test_conflicting_ballot () = - let open Lwt_result_syntax in - let* block, voter, proposal = context_init_exploration () in - let* current_block_state = Incremental.begin_construction block in - let* op_in_current_block = Op.ballot (B block) voter proposal Vote.Yay in - let* current_block_state = - Incremental.validate_operation current_block_state op_in_current_block - in - let* op = Op.ballot (B block) voter proposal Vote.Nay in - let* (_i : Incremental.t) = - Incremental.validate_operation - ~expect_failure:(conflicting_ballot __LOC__) - current_block_state - op - in - return_unit - -(** {3 Ballot -- Positive test} - - A Ballot operation is valid when: - - - its source is a registered delegate and belongs to the voting - listings, - - - the current voting period is an Exploration or Promotion period, - and has the same index as the period provided in the operation, - - - its proposal is the current proposal in the context, - - - the voter had submitted no ballot in the current voting period - yet, and - - - its signature is valid. - - We can observe the successful application of a Ballot operation by - checking that: - - - the ballot has been recorded for the voter in the post-state, - and - - - the score of the ballot's vote (yay/nay/pass) has been - incremented by the voting power of the source. *) - -let observe_ballot pre_state post_state op caller_loc = - let open Lwt_result_syntax in - let make_loc = append_loc ~caller_loc in - let* (Ballot {source; period; proposal; ballot}) = - let (Operation_data {contents; _}) = op.protocol_data in - match contents with - | Single (Ballot _ as contents) -> return contents - | _ -> failwith "%s - Expected a Ballot operation" (make_loc __LOC__) - in - (* Validity conditions *) - let* () = - assert_period - ~expected_kinds:[Exploration; Promotion] - pre_state - (make_loc __LOC__) - in - let* pre_period = Context.Vote.get_current_period (B pre_state) in - let* () = - Assert.equal_int32 - ~loc:(make_loc __LOC__) - period - pre_period.voting_period.index - in - let* del = - Context.Contract.delegate (B pre_state) (Contract.Implicit source) - in - let* () = Assert.equal_pkh ~loc:(make_loc __LOC__) source del in - let* dels, _powers = get_delegates_and_power_from_listings pre_state in - assert (List.mem ~equal:Contract.equal (Contract.Implicit source) dels) ; - let* pre_voting_infos = Context.Delegate.voting_info (B pre_state) source in - let* () = - Assert.is_none - ~loc:(make_loc __LOC__) - ~pp:(fun fmt _ -> Format.fprintf fmt "Voter already has a ballot.@.") - pre_voting_infos.current_ballot - in - let* current_proposal = Context.Vote.get_current_proposal (B pre_state) in - let* current_proposal = - Assert.get_some ~loc:(make_loc __LOC__) current_proposal - in - assert (Protocol_hash.equal proposal current_proposal) ; - (* Observations *) - let* post_voting_infos = Context.Delegate.voting_info (B post_state) source in - let* recorded_ballot = - Assert.get_some ~loc:(make_loc __LOC__) post_voting_infos.current_ballot - in - let* () = - Assert.equal - ~loc:(make_loc __LOC__) - Vote.equal_ballot - "Wrong ballot recorded" - Vote.pp_ballot - ballot - recorded_ballot - in - let* ballots_pre = Context.Vote.get_ballots (B pre_state) in - let* source_power = - Assert.get_some ~loc:(make_loc __LOC__) pre_voting_infos.voting_power - in - let expected_ballots_post = - match ballot with - | Yay -> {ballots_pre with yay = Int64.add ballots_pre.yay source_power} - | Nay -> {ballots_pre with nay = Int64.add ballots_pre.nay source_power} - | Pass -> {ballots_pre with pass = Int64.add ballots_pre.pass source_power} - in - assert_ballots expected_ballots_post post_state (make_loc __LOC__) - -let test_valid_ballot () = - let open Lwt_result_syntax in - (* The chosen [blocks_per_cycle] is an arbitrary value that we will - not reach with the blocks baked in this test. *) - let* block, delegates = context_init ~blocks_per_cycle:10l 4 () in - let* proposer, voter1, voter2, voter3 = - match delegates with - | [a; b; c; d] -> return (a, b, c, d) - | _ -> failwith "%s@,[context_init n] should return [n] delegates" __LOC__ - in - let proposal = protos.(0) in - let* operation = Op.proposals (B block) proposer [proposal] in - let* block = Block.bake block ~operation in - let* b0 = bake_until_first_block_of_next_period block in - let* operation = Op.ballot (B b0) voter1 proposal Vote.Yay in - let* b1 = Block.bake b0 ~operation in - let* () = observe_ballot b0 b1 operation __LOC__ in - let* operation = Op.ballot (B b1) voter2 proposal Vote.Nay in - let* b2 = Block.bake b1 ~operation in - let* () = observe_ballot b1 b2 operation __LOC__ in - let* operation = Op.ballot (B b2) voter3 proposal Vote.Pass in - let* b3 = Block.bake b2 ~operation in - observe_ballot b2 b3 operation __LOC__ - -let tests = - [ - (* Scenarized tests *) - Tztest.tztest "voting successful_vote" `Quick (test_successful_vote 137); - Tztest.tztest - "voting cooldown, not enough quorum" - `Quick - (test_not_enough_quorum_in_exploration 245); - Tztest.tztest - "voting promotion, not enough quorum" - `Quick - (test_not_enough_quorum_in_promotion 432); - Tztest.tztest - "voting proposal, with supermajority" - `Quick - (test_supermajority_in_proposal true); - Tztest.tztest - "voting proposal, without supermajority" - `Quick - (test_supermajority_in_proposal false); - Tztest.tztest - "voting proposal, with quorum" - `Quick - (test_quorum_in_proposal true); - Tztest.tztest - "voting proposal, without quorum" - `Quick - (test_quorum_in_proposal false); - Tztest.tztest - "voting cooldown, with supermajority" - `Quick - (test_supermajority_in_exploration true); - Tztest.tztest - "voting cooldown, without supermajority" - `Quick - (test_supermajority_in_exploration false); - Tztest.tztest - "voting proposal, no winning proposal" - `Quick - (test_no_winning_proposal 400); - Tztest.tztest - "voting quorum, quorum capped maximum" - `Quick - (test_quorum_capped_maximum 400); - Tztest.tztest - "voting quorum, quorum capped minimum" - `Quick - (test_quorum_capped_minimum 401); - Tztest.tztest - "voting power updated in each voting period" - `Quick - test_voting_power_updated_each_voting_period; - Tztest.tztest "voting period pretty print" `Quick test_voting_period_pp; - (* Validity tests on Proposals *) - Tztest.tztest - "Proposals missing signature" - `Quick - test_proposals_missing_signature; - Tztest.tztest - "Proposals invalid signature" - `Quick - test_proposals_invalid_signature; - Tztest.tztest - "Proposals wrong voting period index" - `Quick - test_proposals_wrong_voting_period_index; - Tztest.tztest - "Proposals wrong voting period kind" - `Quick - test_proposals_wrong_voting_period_kind; - Tztest.tztest - "Proposals source not in vote listings" - `Quick - test_proposals_source_not_in_vote_listings; - Tztest.tztest "Empty proposals" `Quick test_empty_proposals; - Tztest.tztest - "Proposals contain a duplicate proposal" - `Quick - test_proposals_contain_duplicate; - Tztest.tztest - "Too many proposals (over one operation)" - `Quick - test_too_many_proposals_in_one_operation; - Tztest.tztest - "Too many proposals (over two operations)" - `Quick - test_too_many_proposals; - Tztest.tztest - "A proposal had already been proposed" - `Quick - test_already_proposed; - Tztest.tztest - "Conflict: too many proposals in current block/mempool" - `Quick - test_conflict_too_many_proposals; - Tztest.tztest - "Conflicting proposals in current block/mempool" - `Quick - test_conflicting_proposal; - Tztest.tztest "Valid Proposals operations" `Quick test_valid_proposals; - (* Validity tests on Ballot *) - Tztest.tztest - "Ballot missing signature" - `Quick - test_ballot_missing_signature; - Tztest.tztest - "Ballot invalid signature" - `Quick - test_ballot_invalid_signature; - Tztest.tztest - "Ballot wrong voting period index" - `Quick - test_ballot_wrong_voting_period_index; - Tztest.tztest - "Ballot wrong voting period kind" - `Quick - test_ballot_wrong_voting_period_kind; - Tztest.tztest - "Ballot for wrong proposal" - `Quick - test_ballot_for_wrong_proposal; - Tztest.tztest - "Delegate has already submitted a ballot" - `Quick - test_already_submitted_a_ballot; - Tztest.tztest - "Ballot source not in vote listings" - `Quick - test_ballot_source_not_in_vote_listings; - Tztest.tztest - "Conflicting ballot in current block/mempool" - `Quick - test_conflicting_ballot; - Tztest.tztest "Valid Ballot operations" `Quick test_valid_ballot; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("voting", tests)] |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_zk_rollup.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_zk_rollup.ml deleted file mode 100644 index fb9f845aa6a95470f44ca4c7ca38a790bafe9ed4..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/operations/test_zk_rollup.ml +++ /dev/null @@ -1,1285 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Rollup layer 1 logic - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/operations/main.exe \ - -- --file test_zk_rollup.ml - Subject: Test zk rollup -*) - -open Protocol -open Alpha_context -open Error_monad_operators - -exception Zk_rollup_test_error of string - -(* Number of operations in each private batch *) -let batch_size = 10 - -module Operator = Dummy_zk_rollup.Operator (struct - let batch_size = batch_size -end) - -(* Operation with payload = 1 *) -let true_op l1_dst rollup_id = - Zk_rollup.Operation. - { - op_code = 0; - price = Operator.Internal_for_tests.true_op.price; - l1_dst; - rollup_id; - payload = [|Bls12_381.Fr.one|]; - } - -let of_plonk_smap s = Zk_rollup.Account.SMap.of_seq @@ Kzg.SMap.to_seq s - -(* Operation with payload = 0 *) -let false_op l1_dst rollup_id = - {(true_op l1_dst rollup_id) with payload = [|Bls12_381.Fr.zero|]} - -(** [check_proto_error_f f t] checks that the first error of [t] - satisfies the boolean function [f]. *) -let check_proto_error_f f t = - match t with - | Environment.Ecoproto_error e :: _ when f e -> - Assert.test_error_encodings e ; - return_unit - | _ -> failwith "Unexpected error: %a" Error_monad.pp_print_trace t - -(** [check_proto_error e t] checks that the first error of [t] - equals [e]. *) -let check_proto_error e t = check_proto_error_f (( = ) e) t - -(* Check that originating a ZKRU fails when the feature flag is disabled. *) -let test_disable_feature_flag () = - let open Lwt_result_syntax in - let _prover_pp, public_parameters = Lazy.force Operator.lazy_pp in - let* b, contract = - Context.init_with_constants1 - { - Context.default_test_constants with - zk_rollup = - {Context.default_test_constants.zk_rollup with enable = false}; - } - in - let* i = Incremental.begin_construction b in - let* op, _zk_rollup = - Op.zk_rollup_origination - (I i) - contract - ~public_parameters - ~circuits_info:(of_plonk_smap Operator.circuits) - ~init_state:Operator.init_state - ~nb_ops:1 - in - let* (_i : Incremental.t) = - Incremental.add_operation - ~expect_failure: - (check_proto_error Validate_errors.Manager.Zk_rollup_feature_disabled) - i - op - in - return_unit - -(** [context_init n] initializes a context for testing in which the - [zk_rollup_enable] constant is set to true. It returns the created - context and [n] contracts. *) -let context_init = - Context.init_with_constants_n - { - Context.default_test_constants with - zk_rollup = {Context.default_test_constants.zk_rollup with enable = true}; - consensus_threshold = 0; - } - -(* Check that the expected origination fees are paid. *) -let test_origination_fees () = - let open Lwt_result_syntax in - let* ctxt, contracts = context_init 1 in - let* constants = Context.get_constants (B ctxt) in - let contract = Stdlib.List.hd contracts in - let _prover_pp, public_parameters = Lazy.force Operator.lazy_pp in - let expected_size = - (* TODO: create ZK constant *) - let origination_size = constants.parametric.tx_rollup.origination_size in - let init_account = - Zk_rollup.Account. - { - static = - { - public_parameters; - state_length = 1; - circuits_info = of_plonk_smap Operator.circuits; - nb_ops = 1; - }; - dynamic = - { - state = Operator.init_state; - paid_l2_operations_storage_space = Z.of_int origination_size; - used_l2_operations_storage_space = Z.zero; - }; - } - in - let init_pl = Zk_rollup.(Empty {next_index = 0L}) in - origination_size + Zk_rollup.Address.size - + Data_encoding.Binary.length Zk_rollup.Account.encoding init_account - + Data_encoding.Binary.length Zk_rollup.pending_list_encoding init_pl - in - let expected_fees = - Tez.mul_exn constants.parametric.cost_per_byte expected_size - in - let* operation, _rollup = - Op.zk_rollup_origination - (B ctxt) - contract - ~public_parameters - ~circuits_info:(of_plonk_smap Operator.circuits) - ~init_state:Operator.init_state - ~nb_ops:1 - in - let* balance_before = Context.Contract.balance (B ctxt) contract in - let* i = Incremental.begin_construction ctxt in - let* i = Incremental.add_operation i operation in - Assert.balance_was_debited - ~loc:__LOC__ - (I i) - contract - balance_before - expected_fees - -let test_origination_negative_nb_ops () = - let open Lwt_result_syntax in - let* ctxt, contracts = context_init 1 in - let contract = Stdlib.List.hd contracts in - let _prover_pp, public_parameters = Lazy.force Operator.lazy_pp in - let* operation, _rollup = - Op.zk_rollup_origination - (B ctxt) - contract - ~public_parameters - ~circuits_info:(of_plonk_smap Operator.circuits) - ~init_state:Operator.init_state - ~nb_ops:(-1) - in - let* i = Incremental.begin_construction ctxt in - let* (_i : Incremental.t) = - Incremental.add_operation - ~expect_apply_failure: - (check_proto_error Zk_rollup_apply.Zk_rollup_negative_nb_ops) - i - operation - in - return_unit - -(** Initializes the context and originates a ZKRU. *) -let init_and_originate n = - let open Lwt_result_syntax in - let* ctxt, contracts = context_init n in - let contract = Stdlib.List.hd contracts in - let _prover_pp, public_parameters = Lazy.force Operator.lazy_pp in - let* operation, rollup = - Op.zk_rollup_origination - (B ctxt) - contract - ~public_parameters - ~circuits_info:(of_plonk_smap Operator.circuits) - ~init_state:Operator.init_state - ~nb_ops:1 - in - let* b = Block.bake ~operation ctxt in - return (b, contracts, rollup) - -let no_ticket op = (op, None) - -(* Checks that originating two ZK rollups leads to different - rollup addresses. *) -let test_originate_two_rollups () = - let open Lwt_result_syntax in - let* ctxt, contracts, zk_rollup1 = init_and_originate 1 in - let contract = Stdlib.List.hd contracts in - let _prover_pp, public_parameters = Lazy.force Operator.lazy_pp in - let* operation, zk_rollup2 = - Op.zk_rollup_origination - (B ctxt) - contract - ~public_parameters - ~circuits_info:(of_plonk_smap Operator.circuits) - ~init_state:Operator.init_state - ~nb_ops:1 - in - let* (_b : Block.t) = Block.bake ~operation ctxt in - assert (zk_rollup1 <> zk_rollup2) ; - return_unit - -(* Initializes the context and originates a ZKRU with [n_pending] - operations. *) -let init_with_pending ?(n_pending = 1) n = - let open Lwt_result_syntax in - let* ctxt, contracts, zk_rollup = init_and_originate n in - let contract = Stdlib.List.hd contracts in - let pkh = match contract with Implicit pkh -> pkh | _ -> assert false in - let* operation = - Op.zk_rollup_publish - (B ctxt) - contract - ~zk_rollup - ~ops: - (Stdlib.List.init n_pending (fun i -> - no_ticket - @@ - if i mod 2 = 0 then false_op pkh zk_rollup - else true_op pkh zk_rollup)) - in - let* b = Block.bake ~operation ctxt in - return (b, contracts, zk_rollup, pkh) - -(* Test for an invalid append: - The operation being appended has an invalid op code. -*) -let test_append_out_of_range_op_code () = - let open Lwt_result_syntax in - let* ctxt, contracts, zk_rollup = init_and_originate 1 in - let contract = Stdlib.List.hd contracts in - let pkh = match contract with Implicit pkh -> pkh | _ -> assert false in - let l2_op = false_op pkh zk_rollup in - let* i = Incremental.begin_construction ctxt in - let* operation = - Op.zk_rollup_publish - (I i) - contract - ~zk_rollup - ~ops:[no_ticket {l2_op with op_code = 1}] - in - let* (_i : Incremental.t) = - Incremental.add_operation - ~expect_apply_failure: - (check_proto_error (Zk_rollup_storage.Zk_rollup_invalid_op_code 1)) - i - operation - in - return_unit - -(* Test for an invalid append: - The operation being appended through an external op has positive price. -*) -let test_append_external_deposit () = - let open Lwt_result_syntax in - let* ctxt, contracts, zk_rollup = init_and_originate 1 in - let contract = Stdlib.List.hd contracts in - let pkh = match contract with Implicit pkh -> pkh | _ -> assert false in - let l2_op = false_op pkh zk_rollup in - let* i = Incremental.begin_construction ctxt in - let* operation = - Op.zk_rollup_publish - (I i) - contract - ~zk_rollup - ~ops: - [no_ticket {l2_op with price = {l2_op.price with amount = Z.of_int 10}}] - in - let* (_i : Incremental.t) = - Incremental.add_operation - ~expect_apply_failure: - (check_proto_error Zk_rollup.Errors.Deposit_as_external) - i - operation - in - return_unit - -(* ------------------------- TESTS WITH TICKETS ------------------------- *) - -(** [make_ticket_key ty contents ticketer zk_rollup] computes the ticket hash - of the ticket containing [contents] of type [ty], crafted by [ticketer] and - owned by [zk_rollup]. *) -let make_ticket_key ctxt ~ty ~contents ~ticketer zk_rollup = - (match ctxt with - | Context.B block -> Incremental.begin_construction block - | Context.I incr -> return incr) - >>=? fun incr -> - let ctxt = Incremental.alpha_ctxt incr in - Script_ir_translator.parse_comparable_ty ctxt ty - >>??= fun (Ex_comparable_ty contents_type, ctxt) -> - Script_ir_translator.parse_comparable_data ctxt contents_type contents - >>=?? fun (contents, ctxt) -> - Ticket_balance_key.of_ex_token - ctxt - ~owner:(Zk_rollup zk_rollup) - (Ticket_token.Ex_token {ticketer; contents_type; contents}) - >|=?? fst - -module Make_ticket (T : sig - val ty_str : string - - type contents - - type contents_type - - val contents_type : contents_type Script_typed_ir.comparable_ty - - val contents_to_micheline : contents -> contents_type - - val contents_to_string : contents -> string -end) (C : sig - val contents : T.contents -end) = -struct - include T - include C - - let ty = Expr.from_string ty_str - - let ex_token ~ticketer = - Ticket_token.Ex_token - {ticketer; contents_type; contents = contents_to_micheline contents} - - let contents_string = contents_to_string contents - - let contents_expr = Expr.from_string contents_string - - let ticket_hash ctxt ~ticketer ~zk_rollup = - make_ticket_key - ctxt - ~ty:(Tezos_micheline.Micheline.root ty) - ~contents:(Tezos_micheline.Micheline.root contents_expr) - ~ticketer - zk_rollup - - let zkru_ticket ~ticketer : Zk_rollup.Ticket.t = - Zk_rollup.Ticket.{contents = contents_expr; ty; ticketer} - - let init_deposit_contract amount block account = - let script = - Format.asprintf - {| parameter (pair address bytes); - storage unit; - code { - # cast the address to contract type - CAR; - UNPAIR; - CONTRACT %%deposit (pair (ticket %s) bytes); - ASSERT_SOME; - SWAP; - PUSH mutez 0; - SWAP; - # create a ticket - PUSH nat %a; - PUSH %s %s; - TICKET; - ASSERT_SOME; - PAIR ; - TRANSFER_TOKENS; - PUSH unit Unit; - NIL operation; - DIG 2 ; - CONS; - PAIR } |} - ty_str - Z.pp_print - amount - ty_str - contents_string - in - Contract_helpers.originate_contract_from_string - ~baker:(Context.Contract.pkh account) - ~source_contract:account - ~script - ~storage:"Unit" - block - - let deposit_op ~block ~zk_rollup ~(zk_op : Zk_rollup.Operation.t) ~account - ~deposit_contract = - let zk_op_literal = - let bytes = - Data_encoding.Binary.to_bytes_exn Zk_rollup.Operation.encoding zk_op - in - let (`Hex hex) = Hex.of_bytes bytes in - "0x" ^ String.uppercase_ascii hex - in - Op.transaction - (B block) - ~entrypoint:Entrypoint.default - ~parameters: - (Script.lazy_expr @@ Expr.from_string - @@ Printf.sprintf - {| Pair %S %s |} - (Zk_rollup.Address.to_b58check zk_rollup) - zk_op_literal) - ~fee:Tez.one - account - deposit_contract - (Tez.of_mutez_exn 0L) - - (** Return an operation to originate a contract that will deposit [amount] - tickets with l2 operation [op] on [zk_rollup] *) - let init_deposit ~block ~amount ~zk_op ~zk_rollup ~account = - init_deposit_contract amount block account - >>=? fun (deposit_contract, _script, block) -> - deposit_op ~block ~zk_rollup ~zk_op ~account ~deposit_contract - >|=? fun op -> (block, op, deposit_contract) -end - -module Nat_ticket = Make_ticket (struct - let ty_str = "nat" - - type contents = int - - type contents_type = Script_int.n Script_int.num - - let contents_type = Script_typed_ir.nat_t - - let contents_to_string = string_of_int - - let contents_to_micheline c = - WithExceptions.Option.get ~loc:__LOC__ @@ Script_int.(of_int c |> is_nat) -end) - -module String_ticket = Make_ticket (struct - let ty_str = "string" - - type contents = string - - type contents_type = Script_string.t - - let contents_type = Script_typed_ir.string_t - - let contents_to_string s = "\"" ^ s ^ "\"" - - let contents_to_micheline c = - WithExceptions.Result.get_ok ~loc:__LOC__ Script_string.(of_string c) -end) - -let test_append_errors () = - let open Lwt_result_syntax in - let open Zk_rollup.Operation in - (* Create two accounts and 1 zk rollup *) - let* block, contracts, zk_rollup = init_and_originate 2 in - let contract0 = Stdlib.List.nth contracts 0 in - let contract1 = Stdlib.List.nth contracts 1 in - (* Create and originate the deposit contract *) - let module Nat_ticket = Nat_ticket (struct - let contents = 1 - end) in - let* deposit_contract, _script, block = - Nat_ticket.init_deposit_contract (Z.of_int 10) block contract0 - in - (* Preparing operation and ticket for tests *) - let op = - let pkh = match contract0 with Implicit pkh -> pkh | _ -> assert false in - false_op pkh zk_rollup - in - let* ticket_hash = - Nat_ticket.ticket_hash (B block) ~ticketer:deposit_contract ~zk_rollup - in - let ticket = Nat_ticket.zkru_ticket ~ticketer:contract0 in - (* Start generating block *) - let* i = Incremental.begin_construction block in - (* Send ticket but price = 0 *) - let* operation = - let price = {id = ticket_hash; amount = Z.zero} in - Op.zk_rollup_publish - (I i) - contract1 - ~zk_rollup - ~ops:[({op with price}, Some ticket)] - in - let* (_i : Incremental.t) = - Incremental.add_operation - ~expect_apply_failure: - (check_proto_error Zk_rollup.Errors.Invalid_deposit_amount) - i - operation - in - (* None ticket, price < 0 *) - let* operation = - let price = {id = ticket_hash; amount = Z.of_string "-10"} in - Op.zk_rollup_publish - (I i) - contract1 - ~zk_rollup - ~ops:[no_ticket {op with price}] - in - let* (_i : Incremental.t) = - Incremental.add_operation - ~expect_apply_failure: - (check_proto_error Zk_rollup.Errors.Invalid_deposit_amount) - i - operation - in - (* Some ticket, price < 0, op.price ≠ hash(ticket, zkru) *) - let* operation = - let price = - { - id = Ticket_hash.of_bytes_exn (Bytes.create 32); - amount = Z.of_string "-10"; - } - in - Op.zk_rollup_publish - (I i) - contract1 - ~zk_rollup - ~ops:[({op with price}, Some ticket)] - in - let* (_i : Incremental.t) = - Incremental.add_operation - ~expect_apply_failure: - (check_proto_error Zk_rollup.Errors.Invalid_deposit_ticket) - i - operation - in - return_unit - -let assert_ticket_balance ~loc incr token owner expected = - let ctxt = Incremental.alpha_ctxt incr in - Ticket_balance_key.of_ex_token ctxt ~owner token >>=?? fun (key_hash, ctxt) -> - Ticket_balance.get_balance ctxt key_hash >>=?? fun (balance, _) -> - match (balance, expected) with - | Some b, Some e -> Assert.equal_int ~loc (Z.to_int b) e - | Some b, None -> - failwith "%s: Expected no balance but got some %d" loc (Z.to_int b) - | None, Some b -> failwith "%s: Expected balance %d but got none" loc b - | None, None -> return () - -let test_invalid_deposit () = - let open Lwt_result_syntax in - (* Create 2 accounts and one zk rollups *) - let* block, contracts, zk_rollup = init_and_originate 5 in - let contract0 = Stdlib.List.nth contracts 0 in - let contract1 = Stdlib.List.nth contracts 1 in - let contract2 = Stdlib.List.nth contracts 2 in - let contract3 = Stdlib.List.nth contracts 3 in - let contract4 = Stdlib.List.nth contracts 4 in - (* Create and originate the deposit contract *) - let module Nat_ticket = Nat_ticket (struct - let contents = 1 - end) in - let* deposit_contract, _script, block = - Nat_ticket.init_deposit_contract (Z.of_int 10) block contract0 - in - let token = Nat_ticket.ex_token ~ticketer:deposit_contract in - (* Generate ticket created by deposit contract and owned by rollup *) - let* ticket_hash = - Nat_ticket.ticket_hash (B block) ~ticketer:deposit_contract ~zk_rollup - in - let pkh = match contract0 with Implicit pkh -> pkh | _ -> assert false in - (* ----- Start generating block *) - let* i = Incremental.begin_construction block in - (* check rollup exists with none of these particular tokens *) - let* () = - assert_ticket_balance ~loc:__LOC__ i token (Zk_rollup zk_rollup) None - in - (* ----- op.price = 0 *) - let zk_op = - { - (false_op pkh zk_rollup) with - price = {id = ticket_hash; amount = Z.of_int 0}; - } - in - let* operation = - Nat_ticket.deposit_op - ~block - ~zk_rollup - ~zk_op - ~account:contract0 - ~deposit_contract - in - let* i = - Incremental.add_operation - ~expect_apply_failure: - (check_proto_error Zk_rollup.Errors.Invalid_deposit_amount) - i - operation - in - let* () = - assert_ticket_balance ~loc:__LOC__ i token (Zk_rollup zk_rollup) None - in - (* ----- hash(ticket, zkru) <> op.price *) - let zk_op = - { - (false_op pkh zk_rollup) with - price = - {id = Ticket_hash.of_bytes_exn (Bytes.create 32); amount = Z.of_int 10}; - } - in - let* operation = - Nat_ticket.deposit_op - ~block - ~zk_rollup - ~zk_op - ~account:contract1 - ~deposit_contract - in - let* i = - Incremental.add_operation - i - ~expect_apply_failure: - (check_proto_error Zk_rollup.Errors.Invalid_deposit_ticket) - operation - in - let* () = - assert_ticket_balance ~loc:__LOC__ i token (Zk_rollup zk_rollup) None - in - (* ----- op.price <> ticket amount *) - let zk_op = - { - (false_op pkh zk_rollup) with - price = {id = ticket_hash; amount = Z.of_int 12}; - } - in - let* operation = - Nat_ticket.deposit_op - ~block - ~zk_rollup - ~zk_op - ~account:contract2 - ~deposit_contract - in - let* i = - Incremental.add_operation - ~expect_apply_failure: - (check_proto_error Zk_rollup.Errors.Invalid_deposit_amount) - i - operation - in - let* () = - assert_ticket_balance ~loc:__LOC__ i token (Zk_rollup zk_rollup) None - in - (* ----- ticket amount = 0 *) - let* deposit_contract, _script, block = - Nat_ticket.init_deposit_contract (Z.of_int 0) block contract0 - in - (* Create append/deposit operation with ticket *) - let zk_op = - {(false_op pkh zk_rollup) with price = {id = ticket_hash; amount = Z.zero}} - in - let* operation = - Nat_ticket.deposit_op - ~block - ~zk_rollup - ~zk_op - ~account:contract3 - ~deposit_contract - in - let* i = Incremental.begin_construction block in - let* () = - assert_ticket_balance ~loc:__LOC__ i token (Zk_rollup zk_rollup) None - in - let* i = - Incremental.add_operation - ~expect_apply_failure: - (check_proto_error_f (function - | Script_interpreter.Runtime_contract_error _ -> true - | _ -> false)) - i - operation - in - - let* () = - assert_ticket_balance ~loc:__LOC__ i token (Zk_rollup zk_rollup) None - in - (* ----- ticket size > Constants.tx_rollup_max_ticket_payload_size *) - (* Contents size is such that, together with the ticketer address, - they exceed the maximum size of an operation *) - let contents_size = 15_000 in - let module String_ticket = String_ticket (struct - let contents = String.make contents_size 'a' - end) in - let* deposit_contract, _script, block = - String_ticket.init_deposit_contract (Z.of_int 10) block contract0 - in - let* ticket_hash = - String_ticket.ticket_hash (B block) ~ticketer:deposit_contract ~zk_rollup - in - let token = String_ticket.ex_token ~ticketer:deposit_contract in - (* Create append/deposit operation with ticket *) - let zk_op = - { - (false_op pkh zk_rollup) with - price = {id = ticket_hash; amount = Z.of_int 10}; - } - in - let* operation = - String_ticket.deposit_op - ~block - ~zk_rollup - ~zk_op - ~account:contract4 - ~deposit_contract - in - let* i = Incremental.begin_construction block in - let* () = - assert_ticket_balance ~loc:__LOC__ i token (Zk_rollup zk_rollup) None - in - let* limit = - let* constants = Context.get_constants (I i) in - constants.parametric.tx_rollup.max_ticket_payload_size |> return - in - let* (_i : Incremental.t) = - let payload_size = Saturation_repr.safe_int (contents_size + 216) in - Incremental.add_operation - ~expect_apply_failure: - (check_proto_error - (Zk_rollup.Errors.Ticket_payload_size_limit_exceeded - {payload_size; limit})) - i - operation - in - let* () = - assert_ticket_balance ~loc:__LOC__ i token (Zk_rollup zk_rollup) None - in - return_unit - -(* Test for a valid update: - - 1 private batch of 10 "true" operations - - 1 public "false" operation - On a ZKRU with the initial state and a pending list with - 1 operation ("false"). -*) -let test_update () = - let open Lwt_result_syntax in - let* b, contracts, zk_rollup, pkh = init_with_pending 1 in - let contract = Stdlib.List.hd contracts in - let* i = Incremental.begin_construction b in - let n_batches = 2 in - let _, update = - Operator.( - craft_update - init_state - ~zk_rollup - ~private_ops: - (Stdlib.List.init n_batches (fun batch -> - Stdlib.List.init batch_size - @@ Fun.const - @@ (if batch mod 2 = 0 then true_op else false_op) pkh zk_rollup)) - [false_op pkh zk_rollup]) - in - let* operation = Op.zk_rollup_update (I i) contract ~zk_rollup ~update in - let* _i = Incremental.add_operation i operation in - return_unit - -(* Test for an invalid update: - - 1 public "true" operation - On a ZKRU with the initial state and a pending list with - 1 operation ("false"). - The public operation proved is different from the one in the pending list. -*) -let test_update_false_proof () = - let open Lwt_result_syntax in - let* b, contracts, zk_rollup, pkh = init_with_pending 1 in - let contract = Stdlib.List.hd contracts in - let* i = Incremental.begin_construction b in - (* Testing with proof on incorrect statement *) - let _, update = - Operator.(craft_update init_state ~zk_rollup [true_op pkh zk_rollup]) - in - let* operation = Op.zk_rollup_update (I i) contract ~zk_rollup ~update in - let* _i = - Incremental.add_operation - i - ~expect_apply_failure: - (check_proto_error Zk_rollup.Errors.Invalid_verification) - operation - in - (* Testing with proof with incorrect private inputs *) - let update = - let _, Zk_rollup.Update.{pending_pis; private_pis; fee_pi; proof} = - Operator.(craft_update init_state ~zk_rollup [true_op pkh zk_rollup]) - in - let private_pis = List.rev private_pis in - Zk_rollup.Update.{pending_pis; private_pis; fee_pi; proof} - in - let* operation = Op.zk_rollup_update (I i) contract ~zk_rollup ~update in - let* _i = - Incremental.add_operation - i - ~expect_apply_failure: - (check_proto_error Zk_rollup.Errors.Invalid_verification) - operation - in - return_unit - -(* Test for an invalid update: - A set of inputs for a public circuit is included in the list of - inputs for private batches. -*) -let test_update_public_in_private () = - let open Lwt_result_syntax in - let* b, contracts, zk_rollup, pkh = init_with_pending 1 in - let contract = Stdlib.List.hd contracts in - let* i = Incremental.begin_construction b in - let _, update = - Operator.(craft_update init_state ~zk_rollup [true_op pkh zk_rollup]) - in - let update = - (* Circuit ID and inputs for a public circuit, which will be added to the - [private_pis] list *) - let name, op_pi = Stdlib.List.hd update.pending_pis in - { - update with - private_pis = - (name, {new_state = op_pi.new_state; fees = op_pi.fee}) - :: update.private_pis; - } - in - let* operation = Op.zk_rollup_update (I i) contract ~zk_rollup ~update in - let* _i = - Incremental.add_operation - i - ~expect_apply_failure:(check_proto_error Zk_rollup.Errors.Invalid_circuit) - operation - in - return_unit - -(* Test for an invalid update: - Two ZKRUs are originated: [zk_rollup1] and [zk_rollup2]. - An L2 [op] for [zk_rollup2] is appended to [zk_rollup1]'s pending list. - This operation must be discarded, but a malicious validator tries to process - it by making a proof for an update in which [op]'s [rollup_id] is changed - from [zk_rollup2] to [zk_rollup1]. The verification must fail, because - the Protocol uses the actual [op] from the pending list as input. -*) -let test_update_for_another_rollup () = - let open Lwt_result_syntax in - let _prover_pp, public_parameters = Lazy.force Operator.lazy_pp in - let* b, contracts, zk_rollup1, pkh = init_with_pending 3 in - let contract0 = Stdlib.List.hd contracts in - let contract1 = Stdlib.List.nth contracts 1 in - let contract2 = Stdlib.List.nth contracts 2 in - let* i = Incremental.begin_construction b in - (* Originate [zk_rollup2] *) - let* operation, zk_rollup2 = - Op.zk_rollup_origination - (I i) - contract0 - ~public_parameters - ~circuits_info:(of_plonk_smap Operator.circuits) - ~init_state:Operator.init_state - ~nb_ops:1 - in - let* i = Incremental.add_operation i operation in - (* Append to [zk_rollup1] an op for [zk_rollup2] *) - let* operation = - Op.zk_rollup_publish - (I i) - contract1 - ~zk_rollup:zk_rollup1 - ~ops:[no_ticket @@ true_op pkh zk_rollup2] - in - let* i = Incremental.add_operation i operation in - (* Craft the update, changing the "true" op to have zk_rollup1 as - [rollup_id] *) - let _, update = - Operator.( - craft_update - init_state - ~zk_rollup:zk_rollup1 - [false_op pkh zk_rollup1; true_op pkh zk_rollup1]) - in - let* operation = - Op.zk_rollup_update (I i) contract2 ~zk_rollup:zk_rollup1 ~update - in - let* _i = - Incremental.add_operation - ~expect_apply_failure: - (check_proto_error Zk_rollup.Errors.Invalid_verification) - i - operation - in - return_unit - -(* Test for an invalid update: - The update sent by the prover processes more public operations than - those in the pending list. -*) -let test_update_more_public_than_pending () = - let open Lwt_result_syntax in - (* test with number of pending operations < min_pending_to_process. *) - let* b, contracts, zk_rollup, pkh = init_with_pending 1 in - let contract = Stdlib.List.hd contracts in - let* i = Incremental.begin_construction b in - let _, update = - Operator.( - craft_update - init_state - ~zk_rollup - [false_op pkh zk_rollup; true_op pkh zk_rollup]) - in - let* operation = Op.zk_rollup_update (I i) contract ~zk_rollup ~update in - let* _i = - Incremental.add_operation - ~expect_apply_failure: - (check_proto_error Zk_rollup_storage.Zk_rollup_pending_list_too_short) - i - operation - in - (* test with number of pending operations >= min_pending_to_process. *) - let* constants = Context.get_constants (I i) in - let min_pending_to_process = - constants.parametric.zk_rollup.min_pending_to_process - in - let* b, contracts, zk_rollup, pkh = - init_with_pending ~n_pending:min_pending_to_process 1 - in - let contract = Stdlib.List.hd contracts in - let* i = Incremental.begin_construction b in - let _, update = - Operator.( - craft_update - init_state - ~zk_rollup - (Stdlib.List.init (min_pending_to_process + 1) (fun i -> - if i mod 2 = 0 then false_op pkh zk_rollup - else true_op pkh zk_rollup))) - in - let* operation = Op.zk_rollup_update (I i) contract ~zk_rollup ~update in - let* _i = - Incremental.add_operation - ~expect_apply_failure: - (check_proto_error Zk_rollup_storage.Zk_rollup_pending_list_too_short) - i - operation - in - return_unit - -(* Test for an invalid update: - The update sent by the prover contains a set of circuit inputs in which - the [new_state] is larger than the ZKRU's [state_length]. -*) -let test_update_inconsistent_state () = - let open Lwt_result_syntax in - let* b, contracts, zk_rollup, pkh = init_with_pending 1 in - let contract = Stdlib.List.hd contracts in - let* i = Incremental.begin_construction b in - let _, update = - Operator.(craft_update init_state ~zk_rollup [false_op pkh zk_rollup]) - in - let open Zk_rollup.Update in - let update = - { - update with - pending_pis = - List.map - (fun (s, (op_pi : op_pi)) -> - ( s, - { - op_pi with - new_state = Array.append op_pi.new_state op_pi.new_state; - } )) - update.pending_pis; - } - in - let* operation = Op.zk_rollup_update (I i) contract ~zk_rollup ~update in - let* _i = - Incremental.add_operation - ~expect_apply_failure: - (check_proto_error Zk_rollup.Errors.Inconsistent_state_update) - i - operation - in - return_unit - -(* Test for an invalid update: - The update sent by the prover processes fewer pending operations (p.o.) than - allowed (the exact number of p.o. or at least min_pending_to_process). - The pending list has a length of 2, while only 1 is processed. -*) -let test_update_not_enough_pending () = - let open Lwt_result_syntax in - let* b, contracts, zk_rollup, pkh = init_with_pending ~n_pending:2 1 in - let contract = Stdlib.List.hd contracts in - let* i = Incremental.begin_construction b in - let _, update = - Operator.(craft_update init_state ~zk_rollup [false_op pkh zk_rollup]) - in - let* operation = Op.zk_rollup_update (I i) contract ~zk_rollup ~update in - let* _i = - Incremental.add_operation - ~expect_apply_failure:(check_proto_error Zk_rollup.Errors.Pending_bound) - i - operation - in - return_unit - -(* Test for a valid update: - The update sent by the prover processes a prefix of the pending list, - of the minimum length allowed. -*) -let test_update_valid_prefix () = - let open Lwt_result_syntax in - (* Checking when pending list has more than min_pending_to_process *) - let min_pending_to_process = - Context.default_test_constants.zk_rollup.min_pending_to_process - in - let* b, contracts, zk_rollup, pkh = - init_with_pending ~n_pending:(min_pending_to_process + 1) 1 - in - let contract = Stdlib.List.hd contracts in - let* i = Incremental.begin_construction b in - let _, update = - Operator.( - craft_update - init_state - ~zk_rollup - (Stdlib.List.init min_pending_to_process (fun i -> - if i mod 2 = 0 then false_op pkh zk_rollup - else true_op pkh zk_rollup))) - in - (* Checking when pending list has less than min_pending_to_process *) - let* operation = Op.zk_rollup_update (I i) contract ~zk_rollup ~update in - let* _i = Incremental.add_operation i operation in - let* b, contracts, zk_rollup, pkh = init_with_pending ~n_pending:2 1 in - let contract = Stdlib.List.hd contracts in - let* i = Incremental.begin_construction b in - let _, update = - Operator.( - craft_update - init_state - ~zk_rollup - [false_op pkh zk_rollup; true_op pkh zk_rollup]) - in - let* operation = Op.zk_rollup_update (I i) contract ~zk_rollup ~update in - let* _i = Incremental.add_operation i operation in - return_unit - -let test_valid_deposit_and_withdrawal () = - let open Lwt_result_syntax in - (* Create 2 accounts and one zk rollups *) - let* block, contracts, zk_rollup = init_and_originate 2 in - let contract0 = Stdlib.List.nth contracts 0 in - let contract1 = Stdlib.List.nth contracts 1 in - (* Create and originate the deposit contract *) - let module Nat_ticket = Nat_ticket (struct - let contents = 1 - end) in - let* deposit_contract, _script, block = - Nat_ticket.init_deposit_contract (Z.of_int 10) block contract0 - in - let token = Nat_ticket.ex_token ~ticketer:deposit_contract in - (* Generate ticket created by deposit contract and owned by rollup *) - let* ticket_hash = - Nat_ticket.ticket_hash (B block) ~ticketer:deposit_contract ~zk_rollup - in - let pkh = match contract0 with Implicit pkh -> pkh | _ -> assert false in - (* Create append/deposit operation with ticket *) - let zk_op = - { - (false_op pkh zk_rollup) with - price = {id = ticket_hash; amount = Z.of_int 10}; - } - in - let* operation = - Nat_ticket.deposit_op - ~block - ~zk_rollup - ~zk_op - ~account:contract0 - ~deposit_contract - in - (* ----- Start generating block *) - let* i = Incremental.begin_construction block in - (* check rollup exists with none of these particular tokens *) - let* () = - assert_ticket_balance ~loc:__LOC__ i token (Zk_rollup zk_rollup) None - in - (* ----- Add deposit operation to block*) - let* i = Incremental.add_operation i operation in - (* check *rollup* has 10 of these particular tokens (deposit has been processed) *) - let* () = - assert_ticket_balance ~loc:__LOC__ i token (Zk_rollup zk_rollup) (Some 10) - in - (* check *contract* has no tokens (deposit has been processed) *) - let* () = - assert_ticket_balance ~loc:__LOC__ i token (Contract contract0) None - in - (* Create update operation to process the zk operation (which is a - "deposit-withdrawal" for dummy rollup) *) - let _, update = - Operator.(craft_update init_state ~zk_rollup ~private_ops:[] [zk_op]) - in - let* operation = Op.zk_rollup_update (I i) contract1 ~zk_rollup ~update in - (* ----- Add update operation to block) *) - let* i = Incremental.add_operation i operation in - (* check *rollup* has no tokens (deposit was withdrawn) *) - let* () = - assert_ticket_balance ~loc:__LOC__ i token (Zk_rollup zk_rollup) None - in - (* check *contract* has 10 of these particular tokens (deposit was withdrawn) *) - let* () = - assert_ticket_balance ~loc:__LOC__ i token (Contract contract0) (Some 10) - in - return_unit - -let test_valid_deposit_and_external_withdrawal () = - let open Lwt_result_syntax in - (* Create 2 accounts and one zk rollups *) - let* block, contracts, zk_rollup = init_and_originate 4 in - let contract0 = Stdlib.List.nth contracts 0 in - let contract1 = Stdlib.List.nth contracts 1 in - let contract2 = Stdlib.List.nth contracts 2 in - let contract3 = Stdlib.List.nth contracts 3 in - (* Create and originate the deposit contract *) - let module Nat_ticket = Nat_ticket (struct - let contents = 1 - end) in - let* deposit_contract, _script, block = - Nat_ticket.init_deposit_contract (Z.of_int 10) block contract0 - in - let token = Nat_ticket.ex_token ~ticketer:deposit_contract in - (* Generate ticket created by deposit contract and owned by rollup *) - let* ticket_hash = - Nat_ticket.ticket_hash (B block) ~ticketer:deposit_contract ~zk_rollup - in - let pkh = match contract0 with Implicit pkh -> pkh | _ -> assert false in - (* Create append/deposit operation with ticket *) - let zk_op = - { - (false_op pkh zk_rollup) with - price = {id = ticket_hash; amount = Z.of_int 10}; - } - in - let* operation = - Nat_ticket.deposit_op - ~block - ~zk_rollup - ~zk_op - ~account:contract0 - ~deposit_contract - in - (* ----- Start generating block *) - let* i = Incremental.begin_construction block in - (* check rollup exists with none of these particular tokens *) - let* () = - assert_ticket_balance ~loc:__LOC__ i token (Zk_rollup zk_rollup) None - in - (* ----- Add deposit operation to block*) - let* i = Incremental.add_operation i operation in - (* check *rollup* has 10 of these particular tokens (deposit has been processed) *) - let* () = - assert_ticket_balance ~loc:__LOC__ i token (Zk_rollup zk_rollup) (Some 10) - in - (* check *contract* has no tokens (deposit has been processed) *) - let* () = - assert_ticket_balance ~loc:__LOC__ i token (Contract contract0) None - in - (* Create update operation to process the zk operation (which is a - "deposit" for dummy rollup) *) - let s, update = - Operator.( - craft_update - init_state - ~zk_rollup - ~private_ops:[] - ~exit_validities:[false] - [zk_op]) - in - let* operation = Op.zk_rollup_update (I i) contract1 ~zk_rollup ~update in - (* ----- Add update operation to block) *) - let* i = Incremental.add_operation i operation in - (* check *rollup* has 10 of these particular tokens (deposit has been processed) *) - let* () = - assert_ticket_balance ~loc:__LOC__ i token (Zk_rollup zk_rollup) (Some 10) - in - (* Create withdrawal operation with ticket *) - let zk_op = - { - (false_op pkh zk_rollup) with - price = {id = ticket_hash; amount = Z.of_int (-10)}; - } - in - let ticket = Nat_ticket.zkru_ticket ~ticketer:deposit_contract in - let* operation = - Op.zk_rollup_publish (I i) contract2 ~zk_rollup ~ops:[(zk_op, Some ticket)] - in - let* i = Incremental.add_operation i operation in - (* Create update to process the withdrawal *) - let _, update = - Operator.( - craft_update s ~zk_rollup ~private_ops:[] ~exit_validities:[true] [zk_op]) - in - let* operation = Op.zk_rollup_update (I i) contract3 ~zk_rollup ~update in - let* i = Incremental.add_operation i operation in - (* check *rollup* has no tokens *) - let* () = - assert_ticket_balance ~loc:__LOC__ i token (Zk_rollup zk_rollup) None - in - (* check *contract* has 10 of these particular tokens *) - let* () = - assert_ticket_balance ~loc:__LOC__ i token (Contract contract0) (Some 10) - in - return_unit - -let tests = - [ - Tztest.tztest - "check feature flag is disabled" - `Quick - test_disable_feature_flag; - Tztest.tztest "origination fees" `Quick test_origination_fees; - Tztest.tztest "originate two rollups" `Quick test_originate_two_rollups; - Tztest.tztest - "origination negative nb_ops" - `Quick - test_origination_negative_nb_ops; - Tztest.tztest - "append with invalid op code" - `Quick - test_append_out_of_range_op_code; - Tztest.tztest "append external deposit" `Quick test_append_external_deposit; - Tztest.tztest "append check errors" `Quick test_append_errors; - Tztest.tztest "invalid deposit" `Quick test_invalid_deposit; - Tztest.tztest "update" `Quick test_update; - Tztest.tztest "update with false proof" `Quick test_update_false_proof; - Tztest.tztest - "update with invalid circuit" - `Quick - test_update_public_in_private; - Tztest.tztest - "update with op for another rollup" - `Quick - test_update_for_another_rollup; - Tztest.tztest - "update with more public operations than pending" - `Quick - test_update_more_public_than_pending; - Tztest.tztest - "update with inconsistent state" - `Quick - test_update_inconsistent_state; - Tztest.tztest - "update with not enough pending" - `Quick - test_update_not_enough_pending; - Tztest.tztest "update with valid prefix" `Quick test_update_valid_prefix; - Tztest.tztest "valid deposit" `Quick test_valid_deposit_and_withdrawal; - Tztest.tztest - "valid deposit and external withdrawal" - `Quick - test_valid_deposit_and_external_withdrawal; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("zk rollup", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/test_constants.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/test_constants.ml deleted file mode 100644 index 0a2a2e4e0b9ba627109f785276d8d66a701c7b0b..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/test_constants.ml +++ /dev/null @@ -1,220 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* Copyright (c) 2022 Trilitech *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (baking) - Invocation: dune exec \ - src/proto_017_PtNairob/lib_protocol/test/integration/main.exe \ - -- --file test_constants.ml - Subject: the consistency of parametric constants - *) - -open Test_tez - -let test_constants_consistency () = - let open Default_parameters in - List.iter_es - Block.check_constants_consistency - [constants_mainnet; constants_sandbox; constants_test] - -let test_max_operations_ttl () = - let open Protocol in - (* We check the rationale that the value for [max_operations_time_to_live] is the following: - - [minimal_time_between_blocks * max_operations_time_to_live = 3600] *) - let constants = Default_parameters.constants_mainnet in - Environment.wrap_tzresult - (Alpha_context.Period.mult - (Int32.of_int constants.max_operations_time_to_live) - constants.minimal_block_delay) - >>?= fun result -> - Assert.equal - ~loc:__LOC__ - (fun x y -> Alpha_context.Period.compare x y = 0) - "max_operations_ttl" - Alpha_context.Period.pp - Alpha_context.Period.one_hour - result - -(* Check that - [sc_rollup_challenge_window_in_blocks < sc_rollup_max_lookahead_in_blocks] - - Otherwise committers would be forced to commit at an artificially slow rate, affecting - the throughput of the rollup. *) -let test_sc_rollup_challenge_window_lt_max_lookahead () = - let constants = Default_parameters.constants_mainnet in - let max_lookahead = constants.sc_rollup.max_lookahead_in_blocks in - let challenge_window = - Int32.of_int constants.sc_rollup.challenge_window_in_blocks - in - Assert.lt_int32 ~loc:__LOC__ challenge_window max_lookahead - -(* TODO: https://gitlab.com/tezos/tezos/-/issues/4481 - Improve this to catch more regressions in term of storage consumption *) - -(* Check that - [commitment_storage_cost * max_lookahead / commitment_period < stake_amount] - - Otherwise storage could be overallocated - since backtracking is not allowed, a staker - can allocated at most [d] nodes (where [d] is the tree depth) - the maximum storage cost - of these commitments must be at most the size of the staker's deposit. *) -let test_sc_rollup_max_commitment_storage_cost_lt_deposit () = - let constants = Default_parameters.constants_mainnet in - let open Protocol in - let cost_per_byte_mutez = - Alpha_context.Tez.to_mutez constants.cost_per_byte - in - let commitment_storage_size = - Int64.of_int - Sc_rollup_stake_storage.Internal_for_tests - .max_commitment_storage_size_in_bytes - in - let commitment_storage_cost = - Int64.mul cost_per_byte_mutez commitment_storage_size - in - let max_lookahead = - Int64.of_int32 constants.sc_rollup.max_lookahead_in_blocks - in - let commitment_period = - Int64.of_int constants.sc_rollup.commitment_period_in_blocks - in - let stake_amount = - Alpha_context.Tez.to_mutez constants.sc_rollup.stake_amount - in - Assert.leq_int64 - ~loc:__LOC__ - (Int64.mul - commitment_storage_cost - (Int64.div max_lookahead commitment_period)) - stake_amount - -(* Check that - [{!Sc_rollup_stake_storage.commitment_storage_size_in_bytes} = - commitments_entry_size + commitment_stake_count_entry_size + - commitment_added_entry_size] - - Required to ensure [sc_rollup_stake_amount] and [sc_rollup_max_lookahead] are - correctly scaled with respect to each other - see - {!test_sc_rollup_max_commitment_storage_cost_lt_deposit} -*) -let test_sc_rollup_max_commitment_storage_size () = - let open Protocol in - Assert.get_some - ~loc:__LOC__ - (Sc_rollup_repr.Number_of_ticks.of_value 1232909L) - >>=? fun number_of_ticks -> - let commitment = - Sc_rollup_commitment_repr. - { - predecessor = Sc_rollup_commitment_repr.Hash.zero; - inbox_level = Raw_level_repr.of_int32_exn 21l; - number_of_ticks; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let versioned_commitment = - Sc_rollup_commitment_repr.to_versioned commitment - in - let commitment_length = - Data_encoding.Binary.length - Sc_rollup_commitment_repr.versioned_encoding - versioned_commitment - in - let commitment_hash = - Sc_rollup_commitment_repr.hash_uncarbonated commitment - in - let level = Alpha_context.Raw_level.of_int32_exn 5l in - (* One for the first publication level, and one for the published level. *) - let levels_length = - Data_encoding.Binary.length Alpha_context.Raw_level.encoding level * 2 - in - let staker_index = - Sc_rollup_staker_index_repr.Internal_for_tests.of_z (Z.of_int 94323442) - in - let stakers_index_length = - Data_encoding.( - Binary.length (list Sc_rollup_staker_index_repr.encoding) [staker_index]) - in - let commitment_hashes_length = - Data_encoding.( - Binary.length - (list Sc_rollup_commitment_repr.Hash.encoding) - [commitment_hash]) - in - let max_expected = - Sc_rollup_stake_storage.Internal_for_tests - .max_commitment_storage_size_in_bytes - in - let total_computed = - commitment_length + levels_length + stakers_index_length - + commitment_hashes_length - in - Assert.leq_int ~loc:__LOC__ total_computed max_expected - -(** Test that the amount of the liquidity baking subsidy is epsilon smaller than - 1/16th of the maximum reward. *) -let liquidity_baking_subsidy_param () = - let constants = Default_parameters.constants_mainnet in - constants.baking_reward_bonus_per_slot - *? Int64.of_int (constants.consensus_committee_size / 3) - >>?= fun baking_reward_bonus -> - constants.baking_reward_fixed_portion +? baking_reward_bonus - >>?= fun baking_rewards -> - constants.endorsing_reward_per_slot - *? Int64.of_int constants.consensus_committee_size - >>?= fun validators_rewards -> - baking_rewards +? validators_rewards >>?= fun total_rewards -> - total_rewards /? 16L >>?= fun expected_subsidy -> - constants.liquidity_baking_subsidy -? expected_subsidy >>?= fun diff -> - let max_diff = 1000 (* mutez *) in - Assert.leq_int ~loc:__LOC__ (Int64.to_int (to_mutez diff)) max_diff - -let tests = - [ - Tztest.tztest "constants consistency" `Quick test_constants_consistency; - Tztest.tztest "max_operations_ttl" `Quick test_max_operations_ttl; - Tztest.tztest - "sc rollup challenge window less than max lookahead" - `Quick - test_sc_rollup_challenge_window_lt_max_lookahead; - Tztest.tztest - "sc rollup max commitment storage cost less than deposit" - `Quick - test_sc_rollup_max_commitment_storage_cost_lt_deposit; - Tztest.tztest - "sc rollup commitment storage size correct" - `Quick - test_sc_rollup_max_commitment_storage_size; - Tztest.tztest - "liquidity_baking_subsidy parameter is 1/16th of total baking rewards" - `Quick - liquidity_baking_subsidy_param; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("constants", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/test_frozen_bonds.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/test_frozen_bonds.ml deleted file mode 100644 index bd07edfd342e43dabd95d57b4ec3fe707da7acbb..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/test_frozen_bonds.ml +++ /dev/null @@ -1,703 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (token) - Invocation: dune exec \ - src/proto_017_PtNairob/lib_protocol/test/integration/main.exe \ - -- --file test_frozen_bonds.ml - Subject: Frozen bonds applicable to contracts and part of their stake. -*) - -open Protocol -open Alpha_context -open Test_tez - -let ( >>>=? ) x f = x >|= Environment.wrap_tzresult >>=? f - -let big_random_amount () = - match Tez.of_mutez (Int64.add 100_000L (Random.int64 1_000_000L)) with - | None -> assert false - | Some x -> x - -let small_random_amount () = - match Tez.of_mutez (Int64.add 1_000L (Random.int64 10_000L)) with - | None -> assert false - | Some x -> x - -let very_small_random_amount () = - match Tez.of_mutez (Int64.add 1L (Random.int64 100L)) with - | None -> assert false - | Some x -> x - -let nonce_zero = - Origination_nonce.Internal_for_tests.initial Operation_hash.zero - -let mk_sc_rollup ?(nonce = nonce_zero) () = - ( Sc_rollup.Internal_for_tests.originated_sc_rollup nonce, - Origination_nonce.Internal_for_tests.incr nonce ) - -(** Creates a context with a single account. Returns the context and the public - key hash of the account. *) -let create_context () = - let (Parameters.{public_key_hash; _} as bootstrap_account) = - Account.(new_account () |> make_bootstrap_account) - in - Block.alpha_context [bootstrap_account] >|=? fun ctxt -> - (ctxt, public_key_hash) - -(** Creates a context, a user contract, and a delegate. - Returns the context, the user contract, the user account, and the - delegate's pkh. *) -let init_test ~user_is_delegate = - create_context () >>=? fun (ctxt, _) -> - let delegate, delegate_pk, _ = Signature.generate_key () in - let delegate_contract = Contract.Implicit delegate in - let delegate_account = `Contract (Contract.Implicit delegate) in - let user_contract = - if user_is_delegate then delegate_contract - else - let user, _, _ = Signature.generate_key () in - Contract.Implicit user - in - let user_account = `Contract user_contract in - (* Allocate contracts for user and delegate. *) - let user_balance = big_random_amount () in - Token.transfer ctxt `Minted user_account user_balance >>>=? fun (ctxt, _) -> - let delegate_balance = big_random_amount () in - Token.transfer ctxt `Minted delegate_account delegate_balance - >>>=? fun (ctxt, _) -> - (* Configure delegate, as a delegate by self-delegation, for which - revealing its manager key is a prerequisite. *) - Contract.reveal_manager_key ctxt delegate delegate_pk >>>=? fun ctxt -> - Contract.Delegate.set ctxt delegate_contract (Some delegate) >>>=? fun ctxt -> - return (ctxt, user_contract, user_account, delegate) - -(** Tested scenario : - 1. user contract delegates to 'delegate', - 2. freeze a deposit, - 3. check that staking balance of delegate has not changed, - 4. remove delegation, - 5. check staking balance decreased accordingly, - 6. unfreeze the deposit, - 7. check that staking balance is unchanged, - 8. check that user's balance is unchanged. *) -let test_delegate_then_freeze_deposit () = - init_test ~user_is_delegate:false - >>=? fun (ctxt, user_contract, user_account, delegate) -> - (* Fetch user's initial balance before freeze. *) - Token.balance ctxt user_account >>>=? fun (ctxt, user_balance) -> - (* Let user delegate to "delegate". *) - Contract.Delegate.set ctxt user_contract (Some delegate) >>>=? fun ctxt -> - (* Fetch staking balance after delegation and before freeze. *) - Delegate.staking_balance ctxt delegate >>>=? fun staking_balance -> - (* Freeze a sc-rollup deposit. *) - let sc_rollup, _ = mk_sc_rollup () in - let bond_id = Bond_id.Sc_rollup_bond_id sc_rollup in - let deposit_amount = small_random_amount () in - let deposit_account = `Frozen_bonds (user_contract, bond_id) in - Token.transfer ctxt user_account deposit_account deposit_amount - >>>=? fun (ctxt, _) -> - (* Fetch staking balance after freeze. *) - Delegate.staking_balance ctxt delegate >>>=? fun staking_balance' -> - (* Ensure staking balance did not change. *) - Assert.equal_tez ~loc:__LOC__ staking_balance' staking_balance >>=? fun () -> - (* Remove delegation. *) - Contract.Delegate.set ctxt user_contract None >>>=? fun ctxt -> - (* Fetch staking balance after delegation removal. *) - Delegate.staking_balance ctxt delegate >>>=? fun staking_balance'' -> - (* Ensure staking balance decreased by user's initial balance. *) - Assert.equal_tez - ~loc:__LOC__ - staking_balance'' - (staking_balance' -! user_balance) - >>=? fun () -> - (* Unfreeze the deposit. *) - Token.transfer ctxt deposit_account user_account deposit_amount - >>>=? fun (ctxt, _) -> - (* Fetch staking balance of delegate. *) - Delegate.staking_balance ctxt delegate >>>=? fun staking_balance''' -> - (* Ensure that staking balance is unchanged. *) - Assert.equal_tez ~loc:__LOC__ staking_balance''' staking_balance'' - >>=? fun () -> - (* Fetch user's balance again. *) - Token.balance ctxt user_account >>>=? fun (_, user_balance') -> - (* Ensure user's balance is unchanged. *) - Assert.equal_tez ~loc:__LOC__ user_balance' user_balance - -(** Tested scenario: - 1. freeze a deposit, - 2. user contract delegate to 'delegate', - 3. check that staking balance of delegate has increased as expected, - 4. unfreeze the deposit, - 5. check that staking balance has not changed, - 6. remove delegation, - 7. check that staking balance has decreased as expected, - 8. check that the user's balance is unchanged. *) -let test_freeze_deposit_then_delegate () = - init_test ~user_is_delegate:false - >>=? fun (ctxt, user_contract, user_account, delegate) -> - (* Fetch user's initial balance before freeze. *) - Token.balance ctxt user_account >>>=? fun (ctxt, user_balance) -> - (* Freeze a sc-rollup deposit. *) - let sc_rollup, _ = mk_sc_rollup () in - let bond_id = Bond_id.Sc_rollup_bond_id sc_rollup in - let deposit_amount = small_random_amount () in - let deposit_account = `Frozen_bonds (user_contract, bond_id) in - Token.transfer ctxt user_account deposit_account deposit_amount - >>>=? fun (ctxt, _) -> - (* Here, user balance has decreased. - Now, fetch staking balance before delegation and after freeze. *) - Delegate.staking_balance ctxt delegate >>>=? fun staking_balance -> - (* Let user delegate to "delegate". *) - Contract.Delegate.set ctxt user_contract (Some delegate) >>>=? fun ctxt -> - (* Fetch staking balance after delegation. *) - Delegate.staking_balance ctxt delegate >>>=? fun staking_balance' -> - (* ensure staking balance increased by the user's balance. *) - Assert.equal_tez - ~loc:__LOC__ - staking_balance' - (user_balance +! staking_balance) - >>=? fun () -> - (* Unfreeze the deposit. *) - Token.transfer ctxt deposit_account user_account deposit_amount - >>>=? fun (ctxt, _) -> - (* Fetch staking balance after unfreeze. *) - Delegate.staking_balance ctxt delegate >>>=? fun staking_balance'' -> - (* Ensure that staking balance is unchanged. *) - Assert.equal_tez ~loc:__LOC__ staking_balance'' staking_balance' - >>=? fun () -> - (* Remove delegation. *) - Contract.Delegate.set ctxt user_contract None >>>=? fun ctxt -> - (* Fetch staking balance. *) - Delegate.staking_balance ctxt delegate >>>=? fun staking_balance''' -> - (* Check that staking balance has decreased by the user's initial balance. *) - Assert.equal_tez - ~loc:__LOC__ - staking_balance''' - (staking_balance'' -! user_balance) - >>=? fun () -> - (* Fetch user's balance. *) - Token.balance ctxt user_account >>>=? fun (_, user_balance') -> - (* Ensure user's balance is unchanged. *) - Assert.equal_tez ~loc:__LOC__ user_balance' user_balance - -(** Tested scenario: - 1. freeze a deposit (with deposit amount = balance), - 2. check that the user contract is still allocated, - 3. punish the user contract, - 4. check that the user contract is unallocated, except if it's a delegate. *) -let test_allocated_when_frozen_deposits_exists ~user_is_delegate () = - init_test ~user_is_delegate - >>=? fun (ctxt, user_contract, user_account, _delegate) -> - (* Fetch user's initial balance before freeze. *) - Token.balance ctxt user_account >>>=? fun (ctxt, user_balance) -> - Assert.equal_bool ~loc:__LOC__ Tez.(user_balance > zero) true >>=? fun () -> - (* Freeze a sc-rollup deposit. *) - let sc_rollup, _ = mk_sc_rollup () in - let bond_id = Bond_id.Sc_rollup_bond_id sc_rollup in - let deposit_amount = user_balance in - let deposit_account = `Frozen_bonds (user_contract, bond_id) in - Token.transfer ctxt user_account deposit_account deposit_amount - >>>=? fun (ctxt, _) -> - (* Check that user contract is still allocated, despite a null balance. *) - Token.balance ctxt user_account >>>=? fun (ctxt, balance) -> - Assert.equal_tez ~loc:__LOC__ balance Tez.zero >>=? fun () -> - Token.allocated ctxt user_account >>>=? fun (ctxt, user_allocated) -> - Token.allocated ctxt deposit_account >>>=? fun (ctxt, dep_allocated) -> - Assert.equal_bool ~loc:__LOC__ (user_allocated && dep_allocated) true - >>=? fun () -> - (* Punish the user contract. *) - Token.transfer ctxt deposit_account `Burned deposit_amount - >>>=? fun (ctxt, _) -> - (* Check that user and deposit accounts have been unallocated. *) - Token.allocated ctxt user_account >>>=? fun (ctxt, user_allocated) -> - Token.allocated ctxt deposit_account >>>=? fun (_, dep_allocated) -> - if user_is_delegate then - Assert.equal_bool ~loc:__LOC__ (user_allocated && not dep_allocated) true - else Assert.equal_bool ~loc:__LOC__ (user_allocated || dep_allocated) false - -(** Tested scenario: - 1. freeze two deposits for the user contract, - 2. check that the stake of the user contract is balance + two deposits, - 3. punish for one of the deposits, - 4. check that the stake of the user contract balance + deposit, - 5. punish for the other deposit, - 6. check that the stake of the user contract is equal to balance. *) -let test_total_stake ~user_is_delegate () = - init_test ~user_is_delegate - >>=? fun (ctxt, user_contract, user_account, _delegate) -> - (* Fetch user's initial balance before freeze. *) - Token.balance ctxt user_account >>>=? fun (ctxt, user_balance) -> - Assert.equal_bool ~loc:__LOC__ Tez.(user_balance > zero) true >>=? fun () -> - (* Freeze 2 sc-rollup deposits. *) - let sc_rollup, nonce = mk_sc_rollup () in - let bond_id1 = Bond_id.Sc_rollup_bond_id sc_rollup in - let sc_rollup, _ = mk_sc_rollup ~nonce () in - let bond_id2 = Bond_id.Sc_rollup_bond_id sc_rollup in - let deposit_amount = small_random_amount () in - let deposit_account1 = `Frozen_bonds (user_contract, bond_id1) in - Token.transfer ctxt user_account deposit_account1 deposit_amount - >>>=? fun (ctxt, _) -> - let deposit_account2 = `Frozen_bonds (user_contract, bond_id2) in - Token.transfer ctxt user_account deposit_account2 deposit_amount - >>>=? fun (ctxt, _) -> - (* Test folding on bond ids. *) - Bond_id.Internal_for_tests.fold_on_bond_ids - ctxt - user_contract - ~init:[] - ~order:`Sorted - ~f:(fun id l -> Lwt.return (id :: l)) - >>= fun bond_ids -> - Assert.assert_equal_list - ~loc:__LOC__ - (fun id1 id2 -> Bond_id.compare id1 id2 = 0) - "Unexpected bond identifiers." - Bond_id.pp - (List.sort Bond_id.compare bond_ids) - (List.sort Bond_id.compare [bond_id1; bond_id2]) - >>=? fun () -> - (* Check that the stake of user contract is balance + two deposits. *) - Contract.get_balance_and_frozen_bonds ctxt user_contract >>>=? fun stake -> - Contract.get_frozen_bonds ctxt user_contract >>>=? fun frozen_bonds -> - Token.balance ctxt user_account >>>=? fun (ctxt, balance) -> - Assert.equal_tez ~loc:__LOC__ (stake -! balance) frozen_bonds >>=? fun () -> - Assert.equal_tez ~loc:__LOC__ (stake -! balance) (deposit_amount *! 2L) - >>=? fun () -> - (* Punish for one deposit. *) - Token.transfer ctxt deposit_account2 `Burned deposit_amount - >>>=? fun (ctxt, _) -> - (* Check that stake of contract is balance + deposit. *) - Contract.get_balance_and_frozen_bonds ctxt user_contract >>>=? fun stake -> - Contract.get_frozen_bonds ctxt user_contract >>>=? fun frozen_bonds -> - Assert.equal_tez ~loc:__LOC__ (stake -! balance) frozen_bonds >>=? fun () -> - Assert.equal_tez ~loc:__LOC__ (stake -! balance) deposit_amount >>=? fun () -> - (* Punish for the other deposit. *) - Token.transfer ctxt deposit_account1 `Burned deposit_amount - >>>=? fun (ctxt, _) -> - (* Check that stake of contract is equal to balance. *) - Contract.get_balance_and_frozen_bonds ctxt user_contract >>>=? fun stake -> - Assert.equal_tez ~loc:__LOC__ stake balance - -let check_delegated_balance_is ctxt ~loc delegate expected_balance = - (* Fetch the delegated balance of d. *) - Delegate.delegated_balance ctxt delegate >>>=? fun delegated_balance -> - (* Check that the delegated balance of [delegate] is as explected. *) - Assert.equal_tez ~loc delegated_balance expected_balance - -(** Tested scenario: - 1. freeze some bonds for the delegate, - 2. check that the delegated balance is null, - 3. let user contract delegate to 'delegate', - 4. check that the staking balance of 'delegate' has increased as expected, - 5. check that the delegated balance of 'delegate' is equal to the balance of the delegator, - 6. unfreeze the bonds, - 7. check that the staking balance has not changed, - 8. check that the delegated balance of 'delegate' is equal to the balance of the delegator, - 9. remove the delegation, - 10. check that staking balance has decreased as expected, - 11. check that the delegated balance is null, - 12. check that the user's balance is unchanged. *) -let test_delegated_balance () = - init_test ~user_is_delegate:false - >>=? fun (ctxt, user_contract, user_account, delegate) -> - let delegate_contract = Contract.Implicit delegate in - let delegate_account = `Contract delegate_contract in - (* Fetch user's initial balance before freeze. *) - Token.balance ctxt user_account >>>=? fun (ctxt, user_balance) -> - (* Fetch staking balance before freeze. *) - Delegate.staking_balance ctxt delegate >>>=? fun staking_balance -> - (* Freeze a sc-rollup deposit for the delegate. *) - let sc_rollup, _ = mk_sc_rollup () in - let bond_id = Bond_id.Sc_rollup_bond_id sc_rollup in - let deposit_amount = small_random_amount () in - let deposit_account = `Frozen_bonds (delegate_contract, bond_id) in - Token.transfer ctxt delegate_account deposit_account deposit_amount - >>>=? fun (ctxt, _) -> - (* Check that the delegated balance of [delegate] is null. *) - check_delegated_balance_is ctxt ~loc:__LOC__ delegate Tez.zero >>=? fun () -> - (* Let user delegate to "delegate". *) - Contract.Delegate.set ctxt user_contract (Some delegate) >>>=? fun ctxt -> - (* Fetch staking balance after delegation. *) - Delegate.staking_balance ctxt delegate >>>=? fun staking_balance' -> - (* ensure staking balance increased by the user's balance. *) - Assert.equal_tez - ~loc:__LOC__ - staking_balance' - (user_balance +! staking_balance) - >>=? fun () -> - (* Check that the delegated balance of [delegate] is equal to [user_balance]. *) - check_delegated_balance_is ctxt ~loc:__LOC__ delegate user_balance - >>=? fun () -> - (* Unfreeze the deposit. *) - Token.transfer ctxt deposit_account delegate_account deposit_amount - >>>=? fun (ctxt, _) -> - (* Fetch staking balance after unfreeze. *) - Delegate.staking_balance ctxt delegate >>>=? fun staking_balance'' -> - (* Ensure that staking balance is unchanged. *) - Assert.equal_tez ~loc:__LOC__ staking_balance'' staking_balance' - >>=? fun () -> - (* Check that the delegated balance of [delegate] is equal to [user_balance]. *) - check_delegated_balance_is ctxt ~loc:__LOC__ delegate user_balance - >>=? fun () -> - (* Remove delegation. *) - Contract.Delegate.set ctxt user_contract None >>>=? fun ctxt -> - (* Fetch staking balance. *) - Delegate.staking_balance ctxt delegate >>>=? fun staking_balance''' -> - (* Check that staking balance has decreased by the user's initial balance. *) - Assert.equal_tez - ~loc:__LOC__ - staking_balance''' - (staking_balance'' -! user_balance) - >>=? fun () -> - (* Check that the delegated balance of [delegate] is null. *) - check_delegated_balance_is ctxt ~loc:__LOC__ delegate Tez.zero >>=? fun () -> - (* Fetch user's balance. *) - Token.balance ctxt user_account >>>=? fun (_, user_balance') -> - (* Ensure user's balance is unchanged. *) - Assert.equal_tez ~loc:__LOC__ user_balance' user_balance - -(** Tests that the rpcs [contract/pkh/frozen_bonds] and - [contract/pkh/balance_and_frozen_bonds] can be called successfully. - These rpcs call the functions [Contract.get_frozen_bonds] and - [Contract.get_balance_and_frozen_bonds] already tested in previous tests. *) -let test_rpcs () = - Context.init1 () >>=? fun (blk, contract) -> - Context.Contract.frozen_bonds (B blk) contract >>=? fun frozen_bonds -> - Assert.equal_tez ~loc:__LOC__ frozen_bonds Tez.zero >>=? fun () -> - Context.Contract.balance_and_frozen_bonds (B blk) contract - >>=? fun balance_and_frozen_bonds -> - Context.Contract.balance (B blk) contract >>=? fun balance -> - Assert.equal_tez ~loc:__LOC__ balance_and_frozen_bonds balance - -(** A helper to test a particular delegation/freezing scenario *) -let test_scenario scenario = - init_test ~user_is_delegate:false - >>=? fun (ctxt, user_contract, user_account, delegate1) -> - let delegate2, delegate_pk2, _ = Signature.generate_key () in - let delegate_contract2 = Contract.Implicit delegate2 in - let delegate_account2 = `Contract delegate_contract2 in - let delegate_balance2 = big_random_amount () in - Token.transfer ctxt `Minted delegate_account2 delegate_balance2 - >>>=? fun (ctxt, _) -> - (* Configure delegate, as a delegate by self-delegation, for which - revealing its manager key is a prerequisite. *) - Contract.reveal_manager_key ctxt delegate2 delegate_pk2 >>>=? fun ctxt -> - Contract.Delegate.set ctxt delegate_contract2 (Some delegate2) - >>>=? fun ctxt -> - let sc_rollup1, nonce = mk_sc_rollup () in - let sc_rollup2, _ = mk_sc_rollup ~nonce () in - let bond_id1 = Bond_id.Sc_rollup_bond_id sc_rollup1 in - let bond_id2 = Bond_id.Sc_rollup_bond_id sc_rollup2 in - let deposit_amount = Tez.of_mutez_exn 1000L in - let deposit_account1 = `Frozen_bonds (user_contract, bond_id1) in - let deposit_account2 = `Frozen_bonds (user_contract, bond_id2) in - let do_delegate ?(delegate = delegate1) ctxt = - (* Fetch staking balance before delegation *) - Delegate.staking_balance ctxt delegate >>>=? fun staking_balance -> - (* Fetch user's initial balance before delegate. *) - Contract.get_balance_and_frozen_bonds ctxt user_contract - >>>=? fun user_balance -> - (* Let user delegate to "delegate". *) - Contract.Delegate.set ctxt user_contract (Some delegate) >>>=? fun ctxt -> - (* Fetch staking balance after delegation *) - Delegate.staking_balance ctxt delegate >>>=? fun staking_balance' -> - Assert.equal_tez - ~loc:__LOC__ - staking_balance' - (staking_balance +! user_balance) - >|=? fun () -> (ctxt, user_balance) - in - let do_freeze ?(deposit_account = deposit_account1) ctxt = - (* Fetch staking balance before freeze *) - Delegate.staking_balance ctxt delegate1 >>>=? fun staking_balance1 -> - Delegate.staking_balance ctxt delegate2 >>>=? fun staking_balance2 -> - (* Freeze a sc-rollup deposit. *) - Token.transfer ctxt user_account deposit_account deposit_amount - >>>=? fun (ctxt, _) -> - (* Fetch staking balance after freeze. *) - Delegate.staking_balance ctxt delegate1 >>>=? fun staking_balance1' -> - Delegate.staking_balance ctxt delegate2 >>>=? fun staking_balance2' -> - (* Ensure staking balance did not change. *) - Assert.equal_tez ~loc:__LOC__ staking_balance1' staking_balance1 - >>=? fun () -> - Assert.equal_tez ~loc:__LOC__ staking_balance2' staking_balance2 - >|=? fun () -> ctxt - in - let do_unfreeze ?(deposit_account = deposit_account1) ctxt = - (* Fetch staking balance before unfreeze *) - Delegate.staking_balance ctxt delegate1 >>>=? fun staking_balance1 -> - Delegate.staking_balance ctxt delegate2 >>>=? fun staking_balance2 -> - (* Unfreeze the deposit *) - Token.transfer ctxt deposit_account user_account deposit_amount - >>>=? fun (ctxt, _) -> - (* Fetch staking balance after unfreeze. *) - Delegate.staking_balance ctxt delegate1 >>>=? fun staking_balance1' -> - Delegate.staking_balance ctxt delegate2 >>>=? fun staking_balance2' -> - (* Ensure staking balance did not change. *) - Assert.equal_tez ~loc:__LOC__ staking_balance1' staking_balance1 - >>=? fun () -> - Assert.equal_tez ~loc:__LOC__ staking_balance2' staking_balance2 - >|=? fun () -> ctxt - in - let do_slash ?(deposit_account = deposit_account1) - ?(current_delegate = Some delegate1) ctxt = - (* Fetch staking balance before slash *) - (match current_delegate with - | None -> return Tez.zero - | Some current_delegate -> Delegate.staking_balance ctxt current_delegate) - >>>=? fun staking_balance -> - (* Slash the deposit *) - Token.transfer - ctxt - deposit_account - `Sc_rollup_refutation_punishments - deposit_amount - >>>=? fun (ctxt, _) -> - (* Fetch staking balance after slash. *) - (match current_delegate with - | None -> return_unit - | Some current_delegate -> - Delegate.staking_balance ctxt current_delegate - >>>=? fun staking_balance' -> - (* Ensure balance slashed *) - Assert.equal_tez - ~loc:__LOC__ - staking_balance' - (staking_balance -! deposit_amount)) - >|=? fun () -> ctxt - in - let do_undelegate ?(delegate = delegate1) ctxt amount = - (* Fetch staking balance before undelegate *) - Delegate.staking_balance ctxt delegate >>>=? fun staking_balance -> - (* Fetch user's initial balance before undelegate. *) - Token.balance ctxt user_account >>>=? fun (_, user_balance) -> - (* Remove delegation. *) - Contract.Delegate.set ctxt user_contract None >>>=? fun ctxt -> - (* Fetch staking balance after delegation removal. *) - Delegate.staking_balance ctxt delegate >>>=? fun staking_balance' -> - (* Ensure staking balance decreased by delegation amount *) - Assert.equal_tez ~loc:__LOC__ staking_balance' (staking_balance -! amount) - >>=? fun () -> - (* Fetch user's balance again. *) - Token.balance ctxt user_account >>>=? fun (_, user_balance') -> - (* Ensure user's balance unchanged. *) - Assert.equal_tez ~loc:__LOC__ user_balance' user_balance >|=? fun () -> ctxt - in - let initial_ctxt = ctxt in - (* delegate-then-freeze *) - do_delegate ctxt >>=? fun (ctxt, amount_delegated) -> - do_freeze ctxt >>=? fun ctxt -> - scenario - ctxt - ~accounts:(deposit_account1, deposit_account2) - ~delegates:(delegate1, delegate2) - amount_delegated - ~do_delegate - ~do_undelegate - ~do_freeze - ~do_unfreeze - ~do_slash - >>=? fun () -> - (* freeze-then-delegate *) - let ctxt = initial_ctxt in - do_freeze ctxt >>=? fun ctxt -> - do_delegate ctxt >>=? fun (ctxt, amount_delegated) -> - scenario - ctxt - ~accounts:(deposit_account1, deposit_account2) - ~delegates:(delegate1, delegate2) - amount_delegated - ~do_delegate - ~do_undelegate - ~do_freeze - ~do_unfreeze - ~do_slash - -let test_delegate_freeze_unfreeze_undelegate () = - test_scenario - (fun - ctxt - ~accounts:_ - ~delegates:_ - amount_delegated - ~do_delegate:_ - ~do_undelegate - ~do_freeze:_ - ~do_unfreeze - ~do_slash:_ - -> - do_unfreeze ctxt >>=? fun ctxt -> - do_undelegate ctxt amount_delegated >>=? fun (_ : context) -> return_unit) - -let test_delegate_freeze_undelegate_unfreeze () = - test_scenario - (fun - ctxt - ~accounts:_ - ~delegates:_ - amount_delegated - ~do_delegate:_ - ~do_undelegate - ~do_freeze:_ - ~do_unfreeze - ~do_slash:_ - -> - do_undelegate ctxt amount_delegated >>=? fun ctxt -> - do_unfreeze ctxt >>=? fun (_ : context) -> return_unit) - -let test_delegate_double_freeze_undelegate_unfreeze () = - test_scenario - (fun - ctxt - ~accounts:(deposit_account1, deposit_account2) - ~delegates:_ - amount_delegated - ~do_delegate:_ - ~do_undelegate - ~do_freeze - ~do_unfreeze - ~do_slash:_ - -> - do_freeze ~deposit_account:deposit_account2 ctxt >>=? fun ctxt -> - do_undelegate ctxt amount_delegated >>=? fun ctxt -> - do_unfreeze ~deposit_account:deposit_account1 ctxt - >>=? fun (_ : context) -> return_unit) - -let test_delegate_freeze_redelegate_unfreeze () = - test_scenario - (fun - ctxt - ~accounts:_ - ~delegates:(_delegate1, delegate2) - _amount_delegated - ~do_delegate - ~do_undelegate - ~do_freeze:_ - ~do_unfreeze - ~do_slash:_ - -> - do_delegate ~delegate:delegate2 ctxt >>=? fun (ctxt, amount2) -> - do_unfreeze ctxt >>=? fun ctxt -> - do_undelegate ~delegate:delegate2 ctxt amount2 >>=? fun (_ : context) -> - return_unit) - -let test_delegate_freeze_unfreeze_freeze_redelegate () = - test_scenario - (fun - ctxt - ~accounts:_ - ~delegates:(_delegate1, delegate2) - _amount_delegated - ~do_delegate - ~do_undelegate - ~do_freeze - ~do_unfreeze - ~do_slash:_ - -> - do_unfreeze ctxt >>=? fun ctxt -> - do_freeze ctxt >>=? fun ctxt -> - do_delegate ~delegate:delegate2 ctxt >>=? fun (ctxt, amount2) -> - do_undelegate ~delegate:delegate2 ctxt amount2 >>=? fun (_ : context) -> - return_unit) - -let test_delegate_freeze_slash_undelegate () = - let slash_amount = Tez.of_mutez_exn 1000L in - test_scenario - (fun - ctxt - ~accounts:_ - ~delegates:_ - amount_delegated - ~do_delegate:_ - ~do_undelegate - ~do_freeze:_ - ~do_unfreeze:_ - ~do_slash - -> - do_slash ctxt >>=? fun ctxt -> - do_undelegate ctxt (amount_delegated -! slash_amount) - >>=? fun (_ : context) -> return_unit) - -let tests = - Tztest. - [ - tztest - "frozen bonds - delegate then freeze" - `Quick - test_delegate_then_freeze_deposit; - tztest - "frozen bonds - freeze then delegate" - `Quick - test_freeze_deposit_then_delegate; - tztest - "frozen bonds - contract remains allocated, user is not a delegate" - `Quick - (test_allocated_when_frozen_deposits_exists ~user_is_delegate:false); - tztest - "frozen bonds - contract remains allocated, user is a delegate" - `Quick - (test_allocated_when_frozen_deposits_exists ~user_is_delegate:true); - tztest - "frozen bonds - total stake, user is not a delegate" - `Quick - (test_total_stake ~user_is_delegate:false); - tztest - "frozen bonds - total stake, user is a delegate" - `Quick - (test_total_stake ~user_is_delegate:true); - tztest "frozen bonds - delegated balance" `Quick test_delegated_balance; - tztest "frozen bonds - test rpcs" `Quick test_rpcs; - tztest - "delegate, freeze, unfreeze, undelegate" - `Quick - test_delegate_freeze_unfreeze_undelegate; - tztest - "delegate, freeze, undelegate, unfreeze" - `Quick - test_delegate_freeze_undelegate_unfreeze; - tztest - "delegate, double freeze, undelegate, unfreeze" - `Quick - test_delegate_double_freeze_undelegate_unfreeze; - tztest - "delegate, freeze, redelegate, unfreeze" - `Quick - test_delegate_freeze_redelegate_unfreeze; - tztest - "delegate, freeze, unfreeze, freeze, redelegate" - `Quick - test_delegate_freeze_unfreeze_freeze_redelegate; - tztest - "delegate, freeze, slash, undelegate" - `Quick - test_delegate_freeze_slash_undelegate; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("frozen bonds", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/test_liquidity_baking.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/test_liquidity_baking.ml deleted file mode 100644 index 8775217e279b2e1275d114c85441d79986e6404f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/test_liquidity_baking.ml +++ /dev/null @@ -1,549 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Tocqueville Group, 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: liquidity baking - Invocation: dune exec \ - src/proto_017_PtNairob/lib_protocol/test/integration/main.exe \ - -- --file test_liquidity_baking.ml - Subject: Test liquidity baking subsidies, CPMM storage updates, - and toggle vote. -*) - -open Liquidity_baking_machine -open Protocol -open Test_tez - -let generate_init_state () = - let cpmm_min_xtz_balance = 10_000_000L in - let cpmm_min_tzbtc_balance = 100_000 in - let accounts_balances = - [ - {xtz = 1_000_000L; tzbtc = 1; liquidity = 100}; - {xtz = 1_000L; tzbtc = 1000; liquidity = 100}; - {xtz = 40_000_000L; tzbtc = 350000; liquidity = 300}; - ] - in - ValidationMachine.build - {cpmm_min_xtz_balance; cpmm_min_tzbtc_balance; accounts_balances} - >>=? fun (_, _) -> return_unit - -(* The script hash of - - https://gitlab.com/dexter2tz/dexter2tz/-/blob/d98643881fe14996803997f1283e84ebd2067e35/dexter.liquidity_baking.mligo.tz -*) -let expected_cpmm_hash = - Script_expr_hash.of_b58check_exn - "exprvEBYbxZruLZ9aUDEC9cUxn5KUj361xsaZXGfCxogFoKQ1er9Np" - -(* The script hash of - - https://gitlab.com/dexter2tz/dexter2tz/-/blob/d98643881fe14996803997f1283e84ebd2067e35/lqt_fa12.mligo.tz -*) -let expected_lqt_hash = - Script_expr_hash.of_b58check_exn - "exprufAK15C2FCbxGLCEVXFe26p3eQdYuwZRk1morJUwy9NBUmEZVB" - -(* Test that the scripts of the Liquidity Baking contracts (CPMM and LQT) have the expected hashes. *) -let liquidity_baking_origination () = - Context.init1 () >>=? fun (blk, _contract) -> - Context.get_liquidity_baking_cpmm_address (B blk) >>=? fun cpmm_address -> - Context.Contract.script_hash (B blk) cpmm_address >>=? fun cpmm_hash -> - let lqt_address = - Contract_hash.of_b58check_exn "KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - in - Context.Contract.script_hash (B blk) lqt_address >>=? fun lqt_hash -> - Assert.equal - ~loc:__LOC__ - Script_expr_hash.equal - "Unexpected CPMM script." - Script_expr_hash.pp - cpmm_hash - expected_cpmm_hash - >>=? fun () -> - Assert.equal - ~loc:__LOC__ - Script_expr_hash.equal - "Unexpected LQT script." - Script_expr_hash.pp - lqt_hash - expected_lqt_hash - >>=? fun () -> return_unit - -(* Test that the CPMM address in storage is correct *) -let liquidity_baking_cpmm_address () = - Context.init1 () >>=? fun (blk, _contract) -> - Context.get_liquidity_baking_cpmm_address (B blk) >>=? fun liquidity_baking -> - Assert.equal - ~loc:__LOC__ - String.equal - "CPMM address in storage is incorrect" - Format.pp_print_string - (Contract_hash.to_b58check liquidity_baking) - "KT1TxqZ8QtKvLu3V3JH7Gx58n7Co8pgtpQU5" - >>=? fun () -> return_unit - -(* Test that after [n] blocks, the liquidity baking CPMM contract is credited [n] times the subsidy amount. *) -let liquidity_baking_subsidies n () = - Context.init1 ~consensus_threshold:0 () >>=? fun (blk, _contract) -> - Context.get_liquidity_baking_cpmm_address (B blk) >>=? fun liquidity_baking -> - let liquidity_baking = Alpha_context.Contract.Originated liquidity_baking in - Context.Contract.balance (B blk) liquidity_baking >>=? fun old_balance -> - Block.bake_n n blk >>=? fun blk -> - Context.get_liquidity_baking_subsidy (B blk) - >>=? fun liquidity_baking_subsidy -> - (liquidity_baking_subsidy *? Int64.(of_int n)) >>?= fun expected_credit -> - Assert.balance_was_credited - ~loc:__LOC__ - (B blk) - liquidity_baking - old_balance - expected_credit - >>=? fun () -> return_unit - -(* Test that subsidy shuts off at correct level alternating baking - blocks with liquidity_baking_toggle_vote set to [LB_on], [LB_off], and [LB_pass] followed by [bake_after_toggle] blocks with it set to [LB_pass]. *) -(* Expected level is roughly 2*(log(1-1/(2*p)) / log(0.999)) where [p] is the proportion [LB_off / (LB_on + LB_off)]. *) -let liquidity_baking_toggle ~n_vote_on ~n_vote_off ~n_vote_pass expected_level - bake_after () = - Context.init1 ~consensus_threshold:0 () >>=? fun (blk, _contract) -> - Context.get_liquidity_baking_cpmm_address (B blk) >>=? fun liquidity_baking -> - let liquidity_baking = Alpha_context.Contract.Originated liquidity_baking in - Context.Contract.balance (B blk) liquidity_baking >>=? fun old_balance -> - Context.get_liquidity_baking_subsidy (B blk) - >>=? fun liquidity_baking_subsidy -> - let rec bake_stopping blk i = - if i < expected_level then - Block.bake_n ~liquidity_baking_toggle_vote:LB_on n_vote_on blk - >>=? fun blk -> - Block.bake_n ~liquidity_baking_toggle_vote:LB_off n_vote_off blk - >>=? fun blk -> - Block.bake_n ~liquidity_baking_toggle_vote:LB_pass n_vote_pass blk - >>=? fun blk -> - bake_stopping blk (i + n_vote_on + n_vote_off + n_vote_pass) - else return blk - in - bake_stopping blk 0 >>=? fun blk -> - Context.Contract.balance (B blk) liquidity_baking >>=? fun balance -> - Block.bake_n ~liquidity_baking_toggle_vote:LB_pass bake_after blk - >>=? fun blk -> - Assert.balance_is ~loc:__LOC__ (B blk) liquidity_baking balance >>=? fun () -> - liquidity_baking_subsidy *? Int64.of_int (expected_level - 1) - >>?= fun expected_final_balance -> - Assert.balance_was_credited - ~loc:__LOC__ - (B blk) - liquidity_baking - old_balance - expected_final_balance - >>=? fun () -> return_unit - -(* 100% of blocks have liquidity_baking_toggle_vote = LB_off *) -let liquidity_baking_toggle_100 n () = - liquidity_baking_toggle ~n_vote_on:0 ~n_vote_off:1 ~n_vote_pass:0 1386 n () - -(* 80% of blocks have liquidity_baking_toggle_vote = LB_off *) -let liquidity_baking_toggle_80 n () = - liquidity_baking_toggle ~n_vote_on:1 ~n_vote_off:4 ~n_vote_pass:0 1963 n () - -(* 60% of blocks have liquidity_baking_toggle_vote = LB_off *) -let liquidity_baking_toggle_60 n () = - liquidity_baking_toggle ~n_vote_on:2 ~n_vote_off:3 ~n_vote_pass:0 3583 n () - -(* 50% of blocks have liquidity_baking_toggle_vote = LB_off. - Subsidy should not be stopped. - Bakes until 100 blocks after the test sunset level of 4096 used in previous protocols. *) -let liquidity_baking_toggle_50 () = - Context.init1 ~consensus_threshold:0 () >>=? fun (blk, _contract) -> - Context.get_liquidity_baking_cpmm_address (B blk) >>=? fun liquidity_baking -> - let liquidity_baking = Alpha_context.Contract.Originated liquidity_baking in - Context.Contract.balance (B blk) liquidity_baking >>=? fun old_balance -> - Context.get_liquidity_baking_subsidy (B blk) - >>=? fun liquidity_baking_subsidy -> - let rec bake_stopping blk i = - if i < 4196 then - Block.bake ~liquidity_baking_toggle_vote:LB_on blk >>=? fun blk -> - Block.bake ~liquidity_baking_toggle_vote:LB_off blk >>=? fun blk -> - bake_stopping blk (i + 2) - else return blk - in - bake_stopping blk 0 >>=? fun blk -> - Context.Contract.balance (B blk) liquidity_baking >>=? fun balance -> - Assert.balance_is ~loc:__LOC__ (B blk) liquidity_baking balance >>=? fun () -> - liquidity_baking_subsidy *? Int64.of_int 4196 - >>?= fun expected_final_balance -> - Assert.balance_was_credited - ~loc:__LOC__ - (B blk) - liquidity_baking - old_balance - expected_final_balance - >>=? fun () -> return_unit - -(* Test that the subsidy can restart if LB_on votes regain majority. - Bake n_votes with LB_off, check that the subsidy is paused, bake - n_votes with LB_on, check that the subsidy flows. -*) -let liquidity_baking_restart n_votes n () = - Context.init1 ~consensus_threshold:0 () >>=? fun (blk, _contract) -> - Context.get_liquidity_baking_cpmm_address (B blk) >>=? fun liquidity_baking -> - let liquidity_baking = Alpha_context.Contract.Originated liquidity_baking in - Block.bake_n ~liquidity_baking_toggle_vote:LB_off n_votes blk >>=? fun blk -> - Context.Contract.balance (B blk) liquidity_baking - >>=? fun balance_when_paused -> - Block.bake_n ~liquidity_baking_toggle_vote:LB_pass n blk >>=? fun blk -> - Assert.balance_is ~loc:__LOC__ (B blk) liquidity_baking balance_when_paused - >>=? fun () -> - Block.bake_n ~liquidity_baking_toggle_vote:LB_on n_votes blk >>=? fun blk -> - Context.Contract.balance (B blk) liquidity_baking - >>=? fun balance_when_restarted -> - Block.bake_n ~liquidity_baking_toggle_vote:LB_pass n blk >>=? fun blk -> - Context.get_liquidity_baking_subsidy (B blk) - >>=? fun liquidity_baking_subsidy -> - liquidity_baking_subsidy *? Int64.of_int n >>?= fun expected_balance -> - Assert.balance_was_credited - ~loc:__LOC__ - (B blk) - liquidity_baking - balance_when_restarted - expected_balance - >>=? fun () -> return_unit - -(* Test that the toggle EMA in block metadata is correct. *) -let liquidity_baking_toggle_ema n_vote_on n_vote_off level bake_after - expected_toggle_ema () = - Context.init1 ~consensus_threshold:0 () >>=? fun (blk, _contract) -> - let rec bake_escaping blk i = - if i < level then - Block.bake_n ~liquidity_baking_toggle_vote:LB_on n_vote_on blk - >>=? fun blk -> - Block.bake_n ~liquidity_baking_toggle_vote:LB_off n_vote_off blk - >>=? fun blk -> bake_escaping blk (i + n_vote_on + n_vote_off) - else return blk - in - bake_escaping blk 0 >>=? fun blk -> - (* We only need to return the toggle EMA at the end. *) - Block.bake_n_with_liquidity_baking_toggle_ema bake_after blk - >>=? fun (_blk, toggle_ema) -> - Assert.leq_int - ~loc:__LOC__ - (toggle_ema |> Alpha_context.Liquidity_baking.Toggle_EMA.to_int32 - |> Int32.to_int) - expected_toggle_ema - >>=? fun () -> return_unit - -(* With no bakers setting the toggle vote, EMA should be zero. *) -let liquidity_baking_toggle_ema_zero () = - liquidity_baking_toggle_ema 0 0 0 100 0 () - -(* The EMA should be not much over the threshold after the subsidy has been stopped by a toggle vote. We add 1_000_000 to the constant to give room for the last update. *) -let liquidity_baking_toggle_ema_threshold () = - liquidity_baking_toggle_ema 0 1 1386 1 1_001_000_000 () - -let liquidity_baking_storage n () = - Context.init1 ~consensus_threshold:0 () >>=? fun (blk, _contract) -> - Context.get_liquidity_baking_cpmm_address (B blk) >>=? fun liquidity_baking -> - Context.get_liquidity_baking_subsidy (B blk) >>=? fun subsidy -> - let expected_storage = - Expr.from_string - (Printf.sprintf - "Pair 1\n\ - \ %d\n\ - \ 100\n\ - \ \"KT1VqarPDicMFn1ejmQqqshUkUXTCTXwmkCN\"\n\ - \ \"KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo\"" - (100 + (n * Int64.to_int (to_mutez subsidy)))) - in - Block.bake_n n blk >>=? fun blk -> - Context.Contract.storage (B blk) liquidity_baking >>=? fun storage -> - let to_string expr = - Format.asprintf "%a" Michelson_v1_printer.print_expr expr - in - Assert.equal - ~loc:__LOC__ - String.equal - "Storage isn't equal" - Format.pp_print_string - (to_string storage) - (to_string expected_storage) - >>=? fun () -> return_unit - -let liquidity_baking_balance_update () = - Context.init1 ~consensus_threshold:0 () >>=? fun (blk, _contract) -> - Context.get_liquidity_baking_cpmm_address (B blk) >>=? fun liquidity_baking -> - Context.get_constants (B blk) >>=? fun csts -> - let subsidy = csts.parametric.liquidity_baking_subsidy in - Block.bake_n_with_all_balance_updates 128 blk - >>=? fun (_blk, balance_updates) -> - let liquidity_baking_updates = - List.filter - (fun el -> - match el with - | ( Alpha_context.Receipt.Contract (Originated contract), - Alpha_context.Receipt.Credited _, - Alpha_context.Receipt.Subsidy ) -> - Contract_hash.(contract = liquidity_baking) - | _ -> false) - balance_updates - in - List.fold_left_e - (fun accum (_, update, _) -> - match update with - | Alpha_context.Receipt.Credited x -> accum +? x - | Alpha_context.Receipt.Debited _ -> assert false) - (of_int 0) - liquidity_baking_updates - >>?= fun credits -> - Assert.equal_int - ~loc:__LOC__ - (Int64.to_int (to_mutez credits)) - (128 * Int64.to_int (to_mutez subsidy)) - >>=? fun () -> return_unit - -let get_cpmm_result results = - match results with - | cpmm_result :: _results -> cpmm_result - | _ -> assert false - -let get_lqt_result results = - match results with - | _cpmm_result :: lqt_result :: _results -> lqt_result - | _ -> assert false - -let get_address_in_result result = - match result with - | Apply_results.Origination_result {originated_contracts; _} -> ( - match originated_contracts with [c] -> c | _ -> assert false) - -let get_balance_updates_in_result result = - match result with - | Apply_results.Origination_result {balance_updates; _} -> balance_updates - -let get_balance_update_in_result result = - match get_balance_updates_in_result result with - | [(Contract _, Credited balance, Protocol_migration)] -> balance - | [_; _; _; _; _; (Contract _, Credited balance, Protocol_migration)] -> - balance - | _ -> assert false - -let liquidity_baking_origination_result_cpmm_address () = - Context.init1 () >>=? fun (blk, _contract) -> - Context.get_liquidity_baking_cpmm_address (B blk) - >>=? fun cpmm_address_in_storage -> - Block.bake_n_with_origination_results 1 blk - >>=? fun (_blk, origination_results) -> - let result = get_cpmm_result origination_results in - let address = get_address_in_result result in - Assert.equal - ~loc:__LOC__ - Contract_hash.equal - "CPMM address in storage is not the same as in origination result" - Contract_hash.pp - address - cpmm_address_in_storage - >>=? fun () -> return_unit - -let liquidity_baking_origination_result_cpmm_balance () = - Context.init1 () >>=? fun (blk, _contract) -> - Block.bake_n_with_origination_results 1 blk - >>=? fun (_blk, origination_results) -> - let result = get_cpmm_result origination_results in - let balance_update = get_balance_update_in_result result in - Assert.equal_tez ~loc:__LOC__ balance_update (of_mutez_exn 100L) - >>=? fun () -> return_unit - -let liquidity_baking_origination_result_lqt_address () = - Context.init1 () >>=? fun (blk, _contract) -> - Block.bake_n_with_origination_results 1 blk - >>=? fun (_blk, origination_results) -> - let result = get_lqt_result origination_results in - let address = get_address_in_result result in - Assert.equal - ~loc:__LOC__ - String.equal - "LQT address in origination result is incorrect" - Format.pp_print_string - (Contract_hash.to_b58check address) - "KT1AafHA1C1vk959wvHWBispY9Y2f3fxBUUo" - >>=? fun () -> return_unit - -let liquidity_baking_origination_result_lqt_balance () = - Context.init1 () >>=? fun (blk, _contract) -> - Block.bake_n_with_origination_results 1 blk - >>=? fun (_blk, origination_results) -> - let result = get_lqt_result origination_results in - let balance_updates = get_balance_updates_in_result result in - match balance_updates with - | [ - (Liquidity_baking_subsidies, Debited am1, Protocol_migration); - (Storage_fees, Credited am2, Protocol_migration); - (Liquidity_baking_subsidies, Debited am3, Protocol_migration); - (Storage_fees, Credited am4, Protocol_migration); - ] -> - Assert.equal_tez ~loc:__LOC__ am1 am2 >>=? fun () -> - Assert.equal_tez ~loc:__LOC__ am3 am4 >>=? fun () -> - Assert.equal_tez ~loc:__LOC__ am1 (of_mutez_exn 64_250L) >>=? fun () -> - Assert.equal_tez ~loc:__LOC__ am3 (of_mutez_exn 494_500L) - | _ -> failwith "Unexpected balance updates (%s)" __LOC__ - -(* Test that with no contract at the tzBTC address and the level low enough to indicate we're not on mainnet, three contracts are originated in stitching. *) -let liquidity_baking_origination_test_migration () = - Context.init1 () >>=? fun (blk, _contract) -> - Block.bake_n_with_origination_results 1 blk - >>=? fun (_blk, origination_results) -> - let num_results = List.length origination_results in - Assert.equal_int ~loc:__LOC__ num_results 3 - -(* Test that with no contract at the tzBTC address and the level high enough to indicate we could be on mainnet, no contracts are originated in stitching. *) -let liquidity_baking_origination_no_tzBTC_mainnet_migration () = - Context.init1 ~consensus_threshold:0 ~level:1_437_862l () - >>=? fun (blk, _contract) -> - (* By baking a bit we also check that the subsidy application with no CPMM present does nothing rather than stopping the chain.*) - Block.bake_n_with_origination_results 64 blk - >>=? fun (_blk, origination_results) -> - let num_results = List.length origination_results in - Assert.equal_int ~loc:__LOC__ num_results 0 - -let tests = - [ - Tztest.tztest - "liquidity baking script hashes" - `Quick - liquidity_baking_origination; - Tztest.tztest - "liquidity baking cpmm is originated at the expected address" - `Quick - liquidity_baking_cpmm_address; - Tztest.tztest "Init Context" `Quick generate_init_state; - Tztest.tztest - "liquidity baking subsidy is correct" - `Quick - (liquidity_baking_subsidies 64); - Tztest.tztest - "liquidity baking toggle vote with 100% of bakers voting LB_off baking \ - one block longer" - `Quick - (liquidity_baking_toggle_100 1); - Tztest.tztest - "liquidity baking toggle vote with 100% of bakers voting LB_off baking \ - two blocks longer" - `Quick - (liquidity_baking_toggle_100 2); - Tztest.tztest - "liquidity baking toggle vote with 100% of bakers voting LB_off baking \ - 100 blocks longer" - `Quick - (liquidity_baking_toggle_100 100); - Tztest.tztest - "liquidity baking toggle vote with 80% of bakers voting LB_off baking \ - one block longer" - `Quick - (liquidity_baking_toggle_80 1); - Tztest.tztest - "liquidity baking toggle vote with 80% of bakers voting LB_off baking \ - two blocks longer" - `Quick - (liquidity_baking_toggle_80 2); - Tztest.tztest - "liquidity baking toggle vote with 80% of bakers voting LB_off baking \ - 100 blocks longer" - `Quick - (liquidity_baking_toggle_80 100); - Tztest.tztest - "liquidity baking toggle vote with 60% of bakers voting LB_off baking \ - one block longer" - `Quick - (liquidity_baking_toggle_60 1); - Tztest.tztest - "liquidity baking toggle vote with 60% of bakers voting LB_off baking \ - two blocks longer" - `Quick - (liquidity_baking_toggle_60 2); - Tztest.tztest - "liquidity baking toggle vote with 60% of bakers voting LB_off baking \ - 100 blocks longer" - `Quick - (liquidity_baking_toggle_60 100); - Tztest.tztest - "liquidity baking does not shut off with toggle vote at 50% and baking \ - 100 blocks longer than sunset level in previous protocols" - `Quick - liquidity_baking_toggle_50; - Tztest.tztest - "liquidity baking restart with 100% of bakers voting off, then pass, \ - then on" - `Quick - (liquidity_baking_restart 2000 1); - Tztest.tztest - "liquidity baking toggle ema in block metadata is zero with no bakers \ - voting LB_off." - `Quick - liquidity_baking_toggle_ema_zero; - Tztest.tztest - "liquidity baking toggle ema is equal to the threshold after the subsidy \ - has been stopped by a toggle vote" - `Quick - liquidity_baking_toggle_ema_threshold; - Tztest.tztest - "liquidity baking storage is updated" - `Quick - (liquidity_baking_storage 64); - Tztest.tztest - "liquidity baking balance updates" - `Quick - liquidity_baking_balance_update; - Tztest.tztest - "liquidity baking CPMM address in storage matches address in the \ - origination result" - `Quick - liquidity_baking_origination_result_cpmm_address; - Tztest.tztest - "liquidity baking CPMM balance in origination result is 100 mutez" - `Quick - liquidity_baking_origination_result_cpmm_balance; - Tztest.tztest - "liquidity baking LQT contract is originated at expected address" - `Quick - liquidity_baking_origination_result_lqt_address; - Tztest.tztest - "liquidity baking LQT balance in origination result is 0 mutez" - `Quick - liquidity_baking_origination_result_lqt_balance; - Tztest.tztest - "liquidity baking originates three contracts when tzBTC does not exist \ - and level indicates we are not on mainnet" - `Quick - liquidity_baking_origination_test_migration; - Tztest.tztest - "liquidity baking originates three contracts when tzBTC does not exist \ - and level indicates we might be on mainnet" - `Quick - liquidity_baking_origination_no_tzBTC_mainnet_migration; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("liquidity baking", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/test_storage.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/test_storage.ml deleted file mode 100644 index ff25e3fb86785f403be8dae7cd5c9c3de67b386b..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/test_storage.ml +++ /dev/null @@ -1,243 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 Metastate AG *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Context Storage - Invocation: dune exec \ - src/proto_017_PtNairob/lib_protocol/test/integration/main.exe \ - -- --file test_storage.ml - Subject: Test the correctnesss of debug message from storage_functor - *) - -open Protocol -open Storage_functors -open Storage_sigs - -module Int32 = struct - type t = int32 - - let encoding = Data_encoding.int32 - - module 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 = Environment.RPC_arg.int; - encoding = Data_encoding.int31; - compare = Compare.Int.compare; - } - end -end - -module Int64 = struct - type t = int64 - - let encoding = Data_encoding.int64 - - module Index = struct - type t = int64 - - let path_length = 1 - - let to_path c l = Int64.to_string c :: l - - let of_path = function - | [] | _ :: _ :: _ -> None - | [c] -> Int64.of_string_opt c - - type 'a ipath = 'a * t - - let args = - Storage_description.One - { - rpc_arg = Environment.RPC_arg.int64; - encoding = Data_encoding.int64; - compare = Compare.Int64.compare; - } - end -end - -let create_context name : (module Raw_context.T with type t = Raw_context.t) = - (module Make_subcontext (Registered) (Raw_context) - (struct - let name = [name] - end)) - -let create_subcontext name - (module Context : Raw_context.T with type t = Raw_context.t) : - (module Raw_context.T with type t = Raw_context.t) = - (module Make_subcontext (Registered) (Context) - (struct - let name = [name] - end)) - -let create_single_data_storage name - (module Context : Raw_context.T with type t = Raw_context.t) : - (module Single_data_storage with type t = Context.t and type value = Int32.t) - = - (module Make_single_data_storage (Registered) (Context) - (struct - let name = [name] - end) - (Int32)) - -let create_indexed_subcontext_int32 - (module Context : Raw_context.T with type t = Raw_context.t) : - (module Data_set_storage with type t = Raw_context.t) = - (module Make_data_set_storage (Context) (Int32.Index)) - -let create_indexed_subcontext_int64 - (module Context : Raw_context.T with type t = Raw_context.t) : - (module Data_set_storage with type t = Raw_context.t) = - (module Make_data_set_storage (Context) (Int64.Index)) - -let must_failwith f_prog error = - try - let () = f_prog () in - Alcotest.fail "Unexpected successful result" - with exc -> - if exc = error then Lwt.return_unit - else Alcotest.fail "Unexpected error result" - -(** Test: - - This test check that creating value where value already exists - fails*) -let test_register_single_data () = - let f_prog () = - let context = create_context "context1" in - (create_single_data_storage "single_data" context - :> (module Single_data_storage)) - |> ignore ; - (create_single_data_storage "single_data" context - :> (module Single_data_storage)) - |> ignore - in - let error = - Invalid_argument - "Could not register a value at [context1 / single_data] because of an \ - existing Value." - in - must_failwith f_prog error - -(** Test: - - This test check that creating a subcontext where a value already exists - fails*) -let test_register_named_subcontext () = - let f_prog () = - let context = create_context "context2" in - let subcontext = create_subcontext "sub_context" context in - (create_single_data_storage "error_register" subcontext - :> (module Single_data_storage)) - |> ignore ; - let subcontext = create_subcontext "error_register" subcontext in - (create_single_data_storage "single_data2" subcontext - :> (module Single_data_storage)) - |> ignore - in - let error = - Invalid_argument - "Could not register a named subcontext at [context2 / sub_context / \ - error_register] because of an existing Value." - in - must_failwith f_prog error - -(** Test: - - This test check that creating a indexed subcontext where a value already - exists fails*) -let test_register_indexed_subcontext () = - let f_prog () = - let context = create_context "context3" in - (create_single_data_storage "single_value" context - :> (module Single_data_storage)) - |> ignore ; - (create_indexed_subcontext_int32 context :> (module Data_set_storage)) - |> ignore - in - let error = - Invalid_argument - "Could not register an indexed subcontext at [context3] because of an \ - existing \n\ - single_value Value." - in - must_failwith f_prog error - -(** Test: - - This test check that creating a indexed subcontext where an indexed - subcontext already exists fails*) -let test_register_indexed_subcontext_2 () = - let f_prog () = - let context = create_context "context4" in - (create_indexed_subcontext_int32 context :> (module Data_set_storage)) - |> ignore ; - (create_indexed_subcontext_int64 context :> (module Data_set_storage)) - |> ignore - in - let error = - Invalid_argument - "An indexed subcontext at [context4] already exists but has a different \ - argument: `int64` <> `int`." - in - must_failwith f_prog error - -let tests = - [ - Alcotest_lwt.test_case - "register single data in existing path" - `Quick - (fun _ -> test_register_single_data); - Alcotest_lwt.test_case - "register named subcontext in existing path" - `Quick - (fun _ -> test_register_named_subcontext); - Alcotest_lwt.test_case - "register indexed subcontext in existing path" - `Quick - (fun _ -> test_register_indexed_subcontext); - Alcotest_lwt.test_case - "register indexed subcontext with existing indexed subcontext" - `Quick - (fun _ -> test_register_indexed_subcontext_2); - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("storage description", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/test_storage_functions.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/test_storage_functions.ml deleted file mode 100644 index a6cebdc4f7258767eb53dc96f707e9aed96a5068..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/test_storage_functions.ml +++ /dev/null @@ -1,181 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Oxhead Alpha *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Context Storage - Invocation: dune exec \ - src/proto_017_PtNairob/lib_protocol/test/integration/main.exe \ - -- --file test_storage_functions.ml - Subject: Test storage functions. - *) - -open Protocol -open Storage_functors - -let assert_length ~loc ctxt key expected = - let open Lwt_result_syntax in - let*! length = Raw_context.length ctxt key in - let* () = Assert.equal_int ~loc length expected in - let*! list = Raw_context.list ctxt key in - let list_length = List.length list in - Assert.equal_int ~loc length list_length - -module Int32 = struct - type t = int32 - - let encoding = Data_encoding.int32 - - module 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 = Environment.RPC_arg.int; - encoding = Data_encoding.int31; - compare = Compare.Int.compare; - } - end -end - -module String = struct - type t = string - - let encoding = Data_encoding.string -end - -module Root_raw_context = - Make_subcontext (Registered) (Raw_context) - (struct - let name = ["test_storage_functors"] - end) - -module Indexed_context = - Make_indexed_subcontext - (Make_subcontext (Registered) (Root_raw_context) - (struct - let name = ["index"] - end)) - (Int32.Index) - -module Table = - Make_carbonated_data_set_storage - (Make_subcontext (Registered) (Raw_context) - (struct - let name = ["table"] - end)) - (Int32.Index) - -(** Test: - This test checks that it is possible to add values to a - Carbonated_data_set_storage and iterate over them. *) -let test_fold_keys_unaccounted () = - let open Lwt_result_wrap_syntax in - let* ctxt = Context.default_raw_context () in - let*@ ctxt, _ = Table.init ctxt 1 in - let*@ ctxt, _ = Table.init ctxt 2 in - let*! items = - Table.fold_keys_unaccounted - ctxt - ~order:`Undefined - ~f:(fun x acc -> Lwt.return @@ (x :: acc)) - ~init:[] - in - let items = List.sort Compare.Int.compare items in - Assert.assert_equal_list - ~loc:__LOC__ - Int.equal - "Compare items" - Format.pp_print_int - [1; 2] - items - -(** Test that [length] returns the number of elements for a given path. *) -let test_length () = - let open Lwt_result_wrap_syntax in - let* ctxt = Context.default_raw_context () in - (* Add a tree to the context: - root: - left: - l1 : V1 - l2 : V2 - l3 : V3 - right: - r1 : V4 - r2 : V5 - file : V6 - *) - let*! tree = - let*! tree_left = - let tree = Raw_context.Tree.empty ctxt in - let*! tree = Raw_context.Tree.add tree ["l1"] (Bytes.of_string "V1") in - let*! tree = Raw_context.Tree.add tree ["l2"] (Bytes.of_string "V2") in - Raw_context.Tree.add tree ["c"] (Bytes.of_string "V3") - in - let*! tree_right = - let tree = Raw_context.Tree.empty ctxt in - let*! tree = Raw_context.Tree.add tree ["r1"] (Bytes.of_string "V4") in - Raw_context.Tree.add tree ["r2"] (Bytes.of_string "V5") - in - let tree = Raw_context.Tree.empty ctxt in - let*! tree = Raw_context.Tree.add_tree tree ["left"] tree_left in - let*! tree = Raw_context.Tree.add_tree tree ["right"] tree_right in - Raw_context.Tree.add tree ["file"] (Bytes.of_string "V6") - in - let*@ ctxt = Raw_context.init_tree ctxt ["root"] tree in - (* The root node contains 3 elements. *) - let* () = assert_length ctxt ~loc:__LOC__ ["root"] 3 in - (* The left branch contains 3 elements. *) - let* () = assert_length ctxt ~loc:__LOC__ ["root"; "left"] 3 in - (* The right branch contains 2 elements. *) - let* () = assert_length ctxt ~loc:__LOC__ ["root"; "right"] 2 in - (* Path [root/left/l1] is a leaf and thus returns length 0. *) - let* () = assert_length ctxt ~loc:__LOC__ ["root"; "left"; "l1"] 0 in - (* The length of a non-existing path also returns 0. *) - assert_length ctxt ~loc:__LOC__ ["root"; "right"; "non_existing"] 0 - -let tests = - [ - Tztest.tztest - "fold_keys_unaccounted smoke test" - `Quick - test_fold_keys_unaccounted; - Tztest.tztest "length test" `Quick test_length; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("storage tests", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/test_token.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/test_token.ml deleted file mode 100644 index cb84b16f0ca4376ead2238f4f500e47c25a548a5..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/test_token.ml +++ /dev/null @@ -1,783 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020-2021 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (token) - Invocation: dune exec \ - src/proto_017_PtNairob/lib_protocol/test/integration/main.exe \ - -- --file test_token.ml - Subject: Token movements in the protocol. -*) - -open Protocol -open Alpha_context -open Test_tez - -(** Creates a context with a single account. Returns the context and the public - key hash of the account. *) -let create_context () = - let (Account.{pkh; _} as account) = Account.new_account () in - let bootstrap_account = Account.make_bootstrap_account account in - Block.alpha_context [bootstrap_account] >>=? fun ctxt -> return (ctxt, pkh) - -let random_amount () = - match Tez.of_mutez (Int64.add 1L (Random.int64 100L)) with - | None -> assert false - | Some x -> x - -let nonce = Origination_nonce.Internal_for_tests.initial Operation_hash.zero - -let sc_rollup () = Sc_rollup.Internal_for_tests.originated_sc_rollup nonce - -(** Check balances for a simple transfer from [bootstrap] to new [Implicit]. *) -let test_simple_balances () = - let open Lwt_result_wrap_syntax in - Random.init 0 ; - create_context () >>=? fun (ctxt, pkh) -> - let giver = `Contract (Contract.Implicit pkh) in - let pkh, _pk, _sk = Signature.generate_key () in - let receiver = `Contract (Contract.Implicit pkh) in - let amount = Tez.one in - wrap (Token.transfer ctxt giver receiver amount) >>=? fun (ctxt', _) -> - wrap (Token.balance ctxt giver) >>=? fun (ctxt, bal_giver) -> - wrap (Token.balance ctxt' giver) >>=? fun (ctxt', bal_giver') -> - wrap (Token.balance ctxt receiver) >>=? fun (_, bal_receiver) -> - wrap (Token.balance ctxt' receiver) >>=? fun (_, bal_receiver') -> - bal_giver' +? amount >>?= fun add_bal_giver'_amount -> - bal_receiver +? amount >>?= fun add_bal_receiver_amount -> - Assert.equal_tez ~loc:__LOC__ bal_giver add_bal_giver'_amount >>=? fun () -> - Assert.equal_tez ~loc:__LOC__ bal_receiver' add_bal_receiver_amount - -(** Check balance updates for a simple transfer from [bootstrap] to new - [Implicit]. *) -let test_simple_balance_updates () = - let open Lwt_result_wrap_syntax in - Random.init 0 ; - create_context () >>=? fun (ctxt, pkh) -> - let giver = Contract.Implicit pkh in - let pkh, _pk, _sk = Signature.generate_key () in - let receiver = Contract.Implicit pkh in - let amount = Tez.one in - wrap (Token.transfer ctxt (`Contract giver) (`Contract receiver) amount) - >>=? fun (_, bal_updates) -> - Alcotest.( - check - bool - "Missing balance update for giver contract." - (List.mem - ~equal:( = ) - Receipt.(Contract giver, Debited amount, Block_application) - bal_updates) - true) ; - Alcotest.( - check - bool - "Missing balance update for receiver contract." - (List.mem - ~equal:( = ) - Receipt.(Contract receiver, Credited amount, Block_application) - bal_updates) - true) ; - return_unit - -let test_allocated_and_deallocated ctxt receiver initial_status - status_when_empty = - let open Lwt_result_wrap_syntax in - wrap (Token.allocated ctxt receiver) >>=? fun (ctxt, allocated) -> - Assert.equal_bool ~loc:__LOC__ allocated initial_status >>=? fun () -> - let amount = Tez.one in - wrap (Token.transfer ctxt `Minted receiver amount) >>=? fun (ctxt', _) -> - wrap (Token.allocated ctxt' receiver) >>=? fun (ctxt', allocated) -> - Assert.equal_bool ~loc:__LOC__ allocated true >>=? fun () -> - wrap (Token.balance ctxt' receiver) >>=? fun (ctxt', bal_receiver') -> - wrap (Token.transfer ctxt' receiver `Burned bal_receiver') - >>=? fun (ctxt', _) -> - wrap (Token.allocated ctxt' receiver) >>=? fun (_, allocated) -> - Assert.equal_bool ~loc:__LOC__ allocated status_when_empty >>=? fun () -> - return_unit - -let test_allocated_and_deallocated_when_empty ctxt receiver = - test_allocated_and_deallocated ctxt receiver false false - -let test_allocated_and_still_allocated_when_empty ctxt receiver initial_status = - test_allocated_and_deallocated ctxt receiver initial_status true - -let test_allocated () = - Random.init 0 ; - create_context () >>=? fun (ctxt, pkh) -> - let receiver = `Delegate_balance pkh in - test_allocated_and_still_allocated_when_empty ctxt receiver true - >>=? fun () -> - let pkh, _pk, _sk = Signature.generate_key () in - let receiver = `Contract (Contract.Implicit pkh) in - test_allocated_and_deallocated_when_empty ctxt receiver >>=? fun () -> - let receiver = `Collected_commitments Blinded_public_key_hash.zero in - test_allocated_and_deallocated_when_empty ctxt receiver >>=? fun () -> - let receiver = `Frozen_deposits pkh in - test_allocated_and_still_allocated_when_empty ctxt receiver false - >>=? fun () -> - let receiver = `Block_fees in - test_allocated_and_still_allocated_when_empty ctxt receiver true - >>=? fun () -> - let receiver = - let bond_id = Bond_id.Sc_rollup_bond_id (sc_rollup ()) in - `Frozen_bonds (Contract.Implicit pkh, bond_id) - in - test_allocated_and_deallocated_when_empty ctxt receiver - -let check_receiver_balances ctxt ctxt' receiver amount = - let open Lwt_result_wrap_syntax in - wrap (Token.balance ctxt receiver) >>=? fun (_, bal_receiver) -> - wrap (Token.balance ctxt' receiver) >>=? fun (_, bal_receiver') -> - bal_receiver +? amount >>?= fun add_bal_receiver_amount -> - Assert.equal_tez ~loc:__LOC__ bal_receiver' add_bal_receiver_amount - -(* Accounts of the form (`DelegateBalance pkh) are not allocated when they - receive funds for the first time. To force allocation, we transfer to - (`Contract pkh) instead. *) -let force_allocation_if_need_be ctxt account = - let open Lwt_result_wrap_syntax in - match account with - | `Delegate_balance pkh -> - let account = `Contract (Contract.Implicit pkh) in - wrap (Token.transfer ctxt `Minted account Tez.one_mutez) >|=? fst - | _ -> return ctxt - -let test_transferring_to_receiver ctxt receiver amount expected_bupds = - let open Lwt_result_wrap_syntax in - (* Transferring zero must be a noop, and must not return balance updates. *) - wrap (Token.transfer ctxt `Minted receiver Tez.zero) - >>=? fun (ctxt', bupds) -> - Assert.equal_bool ~loc:__LOC__ (ctxt == ctxt' && bupds = []) true - >>=? fun () -> - (* Force the allocation of [receiver] if need be. *) - force_allocation_if_need_be ctxt receiver >>=? fun ctxt -> - (* Test transferring a non null amount. *) - wrap (Token.transfer ctxt `Minted receiver amount) >>=? fun (ctxt', bupds) -> - check_receiver_balances ctxt ctxt' receiver amount >>=? fun () -> - let expected_bupds = - Receipt.(Minted, Debited amount, Block_application) :: expected_bupds - in - Alcotest.( - check bool "Balance updates do not match." (bupds = expected_bupds) true) ; - (* Test transferring to go beyond capacity. *) - wrap (Token.balance ctxt' receiver) >>=? fun (ctxt', bal) -> - let amount = Tez.of_mutez_exn Int64.max_int -! bal +! Tez.one_mutez in - wrap (Token.transfer ctxt' `Minted receiver amount) >>= fun res -> - Assert.proto_error_with_info ~loc:__LOC__ res "Overflowing tez addition" - -let test_transferring_to_contract ctxt = - let pkh, _pk, _sk = Signature.generate_key () in - let receiver = Contract.Implicit pkh in - let amount = random_amount () in - test_transferring_to_receiver - ctxt - (`Contract receiver) - amount - [(Contract receiver, Credited amount, Block_application)] - -let test_transferring_to_collected_commitments ctxt = - let amount = random_amount () in - let bpkh = Blinded_public_key_hash.zero in - test_transferring_to_receiver - ctxt - (`Collected_commitments bpkh) - amount - [(Commitments bpkh, Credited amount, Block_application)] - -let test_transferring_to_delegate_balance ctxt = - let pkh, _pk, _sk = Signature.generate_key () in - let receiver = Contract.Implicit pkh in - let amount = random_amount () in - test_transferring_to_receiver - ctxt - (`Delegate_balance pkh) - amount - [(Contract receiver, Credited amount, Block_application)] - -let test_transferring_to_frozen_deposits ctxt = - let pkh, _pk, _sk = Signature.generate_key () in - let amount = random_amount () in - test_transferring_to_receiver - ctxt - (`Frozen_deposits pkh) - amount - [(Deposits pkh, Credited amount, Block_application)] - -let test_transferring_to_collected_fees ctxt = - let amount = random_amount () in - test_transferring_to_receiver - ctxt - `Block_fees - amount - [(Block_fees, Credited amount, Block_application)] - -let test_transferring_to_burned ctxt = - let open Lwt_result_wrap_syntax in - let amount = random_amount () in - let minted_bupd = Receipt.(Minted, Debited amount, Block_application) in - wrap (Token.transfer ctxt `Minted `Burned amount) >>=? fun (_, bupds) -> - Assert.equal_bool - ~loc:__LOC__ - (bupds = [minted_bupd; (Burned, Credited amount, Block_application)]) - true - >>=? fun () -> - wrap (Token.transfer ctxt `Minted `Storage_fees amount) >>=? fun (_, bupds) -> - Assert.equal_bool - ~loc:__LOC__ - (bupds = [minted_bupd; (Storage_fees, Credited amount, Block_application)]) - true - >>=? fun () -> - wrap (Token.transfer ctxt `Minted `Double_signing_punishments amount) - >>=? fun (_, bupds) -> - Assert.equal_bool - ~loc:__LOC__ - (bupds - = [ - minted_bupd; - (Double_signing_punishments, Credited amount, Block_application); - ]) - true - >>=? fun () -> - let pkh = Signature.Public_key_hash.zero in - let p, r = (Random.bool (), Random.bool ()) in - wrap - (Token.transfer ctxt `Minted (`Lost_endorsing_rewards (pkh, p, r)) amount) - >>=? fun (_, bupds) -> - Assert.equal_bool - ~loc:__LOC__ - (bupds - = [ - minted_bupd; - (Lost_endorsing_rewards (pkh, p, r), Credited amount, Block_application); - ]) - true - >>=? fun () -> - wrap (Token.transfer ctxt `Minted `Sc_rollup_refutation_punishments amount) - >>=? fun (_, bupds) -> - Assert.equal_bool - ~loc:__LOC__ - (bupds - = [ - minted_bupd; - (Sc_rollup_refutation_punishments, Credited amount, Block_application); - ]) - true - -let test_transferring_to_frozen_bonds ctxt = - let pkh, _pk, _sk = Signature.generate_key () in - let contract = Contract.Implicit pkh in - let sc_rollup = sc_rollup () in - let bond_id = Bond_id.Sc_rollup_bond_id sc_rollup in - let amount = random_amount () in - test_transferring_to_receiver - ctxt - (`Frozen_bonds (contract, bond_id)) - amount - [(Frozen_bonds (contract, bond_id), Credited amount, Block_application)] - -let test_transferring_to_receiver () = - Random.init 0 ; - create_context () >>=? fun (ctxt, _) -> - test_transferring_to_contract ctxt >>=? fun () -> - test_transferring_to_collected_commitments ctxt >>=? fun () -> - test_transferring_to_delegate_balance ctxt >>=? fun () -> - test_transferring_to_frozen_deposits ctxt >>=? fun () -> - test_transferring_to_collected_fees ctxt >>=? fun () -> - test_transferring_to_burned ctxt >>=? fun () -> - test_transferring_to_frozen_bonds ctxt - -let check_giver_balances ctxt ctxt' giver amount = - let open Lwt_result_wrap_syntax in - wrap (Token.balance ctxt giver) >>=? fun (_, bal_giver) -> - wrap (Token.balance ctxt' giver) >>=? fun (_, bal_giver') -> - bal_giver' +? amount >>?= fun add_bal_giver'_amount -> - Assert.equal_tez ~loc:__LOC__ bal_giver add_bal_giver'_amount - -let test_transferring_from_infinite_source ctxt giver expected_bupds = - let open Lwt_result_wrap_syntax in - (* Transferring zero must not return balance updates. *) - wrap (Token.transfer ctxt giver `Burned Tez.zero) >>=? fun (_, bupds) -> - Assert.equal_bool ~loc:__LOC__ (bupds = []) true >>=? fun () -> - (* Test transferring a non null amount. *) - let amount = random_amount () in - wrap (Token.transfer ctxt giver `Burned amount) >>=? fun (_, bupds) -> - let expected_bupds = - expected_bupds amount - @ Receipt.[(Burned, Credited amount, Block_application)] - in - Assert.equal_bool ~loc:__LOC__ (bupds = expected_bupds) true >>=? fun () -> - return_unit - -(* Returns the balance of [account] if [account] is allocated, and returns - [Tez.zero] otherwise. *) -let balance_no_fail ctxt account = - let open Lwt_result_wrap_syntax in - wrap (Token.allocated ctxt account) >>=? fun (ctxt, allocated) -> - if allocated then wrap (Token.balance ctxt account) - else return (ctxt, Tez.zero) - -let test_transferring_from_container ctxt giver amount expected_bupds = - let open Lwt_result_wrap_syntax in - balance_no_fail ctxt giver >>=? fun (ctxt, balance) -> - Assert.equal_tez ~loc:__LOC__ balance Tez.zero >>=? fun () -> - (* Test transferring from an empty account. *) - wrap (Token.transfer ctxt giver `Burned Tez.one) >>= fun res -> - let error_title = - match giver with - | `Contract _ -> "Balance too low" - | `Delegate_balance _ | `Frozen_deposits _ | `Frozen_bonds _ -> - "Storage error (fatal internal error)" - | _ -> "Underflowing tez subtraction" - in - Assert.proto_error_with_info ~loc:__LOC__ res error_title >>=? fun () -> - (* Transferring zero must be a noop, and must not return balance updates. *) - wrap (Token.transfer ctxt giver `Burned Tez.zero) >>=? fun (ctxt', bupds) -> - Assert.equal_bool ~loc:__LOC__ (ctxt == ctxt' && bupds = []) true - >>=? fun () -> - (* Force the allocation of [giver] if need be. *) - force_allocation_if_need_be ctxt giver >>=? fun ctxt -> - (* Test transferring everything. *) - wrap (Token.transfer ctxt `Minted giver amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt giver `Burned amount) >>=? fun (ctxt', bupds) -> - check_giver_balances ctxt ctxt' giver amount >>=? fun () -> - let expected_bupds = - expected_bupds @ Receipt.[(Burned, Credited amount, Block_application)] - in - Assert.equal_bool ~loc:__LOC__ (bupds = expected_bupds) true >>=? fun () -> - (* Test transferring a smaller amount. *) - wrap (Token.transfer ctxt `Minted giver amount) >>=? fun (ctxt, _) -> - (match giver with - | `Frozen_bonds _ -> - wrap (Token.transfer ctxt giver `Burned amount) >>= fun res -> - let error_title = "Partial spending of frozen bonds" in - Assert.proto_error_with_info ~loc:__LOC__ res error_title - | _ -> - wrap (Token.transfer ctxt giver `Burned amount) >>=? fun (ctxt', bupds) -> - check_giver_balances ctxt ctxt' giver amount >>=? fun () -> - Assert.equal_bool ~loc:__LOC__ (bupds = expected_bupds) true) - >>=? fun () -> - (* Test transferring more than available. *) - wrap (Token.balance ctxt giver) >>=? fun (ctxt, balance) -> - wrap (Token.transfer ctxt giver `Burned (balance +! Tez.one)) >>= fun res -> - let error_title = - match giver with - | `Contract _ -> "Balance too low" - | `Frozen_bonds _ -> "Partial spending of frozen bonds" - | _ -> "Underflowing tez subtraction" - in - Assert.proto_error_with_info ~loc:__LOC__ res error_title - -let test_transferring_from_contract ctxt = - let pkh, _pk, _sk = Signature.generate_key () in - let giver = Contract.Implicit pkh in - let amount = random_amount () in - test_transferring_from_container - ctxt - (`Contract giver) - amount - [(Contract giver, Debited amount, Block_application)] - -let test_transferring_from_collected_commitments ctxt = - let amount = random_amount () in - let bpkh = Blinded_public_key_hash.zero in - test_transferring_from_container - ctxt - (`Collected_commitments bpkh) - amount - [(Commitments bpkh, Debited amount, Block_application)] - -let test_transferring_from_delegate_balance ctxt = - let pkh, _pk, _sk = Signature.generate_key () in - let amount = random_amount () in - let giver = Contract.Implicit pkh in - test_transferring_from_container - ctxt - (`Delegate_balance pkh) - amount - [(Contract giver, Debited amount, Block_application)] - -let test_transferring_from_frozen_deposits ctxt = - let pkh, _pk, _sk = Signature.generate_key () in - let amount = random_amount () in - test_transferring_from_container - ctxt - (`Frozen_deposits pkh) - amount - [(Deposits pkh, Debited amount, Block_application)] - -let test_transferring_from_collected_fees ctxt = - let amount = random_amount () in - test_transferring_from_container - ctxt - `Block_fees - amount - [(Block_fees, Debited amount, Block_application)] - -let test_transferring_from_frozen_bonds ctxt = - let pkh, _pk, _sk = Signature.generate_key () in - let contract = Contract.Implicit pkh in - let sc_rollup = sc_rollup () in - let bond_id = Bond_id.Sc_rollup_bond_id sc_rollup in - let amount = random_amount () in - test_transferring_from_container - ctxt - (`Frozen_bonds (contract, bond_id)) - amount - [(Frozen_bonds (contract, bond_id), Debited amount, Block_application)] - -let test_transferring_from_giver () = - Random.init 0 ; - create_context () >>=? fun (ctxt, _) -> - test_transferring_from_infinite_source ctxt `Invoice (fun am -> - [(Invoice, Debited am, Block_application)]) - >>=? fun () -> - test_transferring_from_infinite_source ctxt `Bootstrap (fun am -> - [(Bootstrap, Debited am, Block_application)]) - >>=? fun () -> - test_transferring_from_infinite_source ctxt `Initial_commitments (fun am -> - [(Initial_commitments, Debited am, Block_application)]) - >>=? fun () -> - test_transferring_from_infinite_source ctxt `Revelation_rewards (fun am -> - [(Nonce_revelation_rewards, Debited am, Block_application)]) - >>=? fun () -> - test_transferring_from_infinite_source - ctxt - `Double_signing_evidence_rewards - (fun am -> - [(Double_signing_evidence_rewards, Debited am, Block_application)]) - >>=? fun () -> - test_transferring_from_infinite_source ctxt `Endorsing_rewards (fun am -> - [(Endorsing_rewards, Debited am, Block_application)]) - >>=? fun () -> - test_transferring_from_infinite_source ctxt `Baking_rewards (fun am -> - [(Baking_rewards, Debited am, Block_application)]) - >>=? fun () -> - test_transferring_from_infinite_source ctxt `Baking_bonuses (fun am -> - [(Baking_bonuses, Debited am, Block_application)]) - >>=? fun () -> - test_transferring_from_infinite_source ctxt `Minted (fun am -> - [(Minted, Debited am, Block_application)]) - >>=? fun () -> - test_transferring_from_infinite_source - ctxt - `Liquidity_baking_subsidies - (fun am -> [(Liquidity_baking_subsidies, Debited am, Block_application)]) - >>=? fun () -> - test_transferring_from_contract ctxt >>=? fun () -> - test_transferring_from_collected_commitments ctxt >>=? fun () -> - test_transferring_from_delegate_balance ctxt >>=? fun () -> - test_transferring_from_frozen_deposits ctxt >>=? fun () -> - test_transferring_from_collected_fees ctxt >>=? fun () -> - test_transferring_from_frozen_bonds ctxt - -let cast_to_container_type x = - match x with - | `Burned | `Invoice | `Bootstrap | `Initial_commitments | `Minted - | `Liquidity_baking_subsidies -> - None - | `Contract _ as x -> Some x - | `Collected_commitments _ as x -> Some x - | `Delegate_balance _ as x -> Some x - | `Block_fees as x -> Some x - | `Frozen_bonds _ as x -> Some x - -(** Generates all combinations of constructors. *) -let build_test_cases () = - let open Lwt_result_wrap_syntax in - create_context () >>=? fun (ctxt, pkh) -> - let origin = `Contract (Contract.Implicit pkh) in - let user1, _, _ = Signature.generate_key () in - let user1c = `Contract (Contract.Implicit user1) in - let user2, _, _ = Signature.generate_key () in - let user2c = `Contract (Contract.Implicit user2) in - let baker1, baker1_pk, _ = Signature.generate_key () in - let baker1c = `Contract (Contract.Implicit baker1) in - let baker2, baker2_pk, _ = Signature.generate_key () in - let baker2c = `Contract (Contract.Implicit baker2) in - (* Allocate contracts for user1, user2, baker1, and baker2. *) - wrap (Token.transfer ctxt origin user1c (random_amount ())) - >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin user2c (random_amount ())) - >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin baker1c (random_amount ())) - >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin baker2c (random_amount ())) - >>=? fun (ctxt, _) -> - (* Configure baker1, and baker2 as delegates by self-delegation, for which - revealing their manager key is a prerequisite. *) - wrap (Contract.reveal_manager_key ctxt baker1 baker1_pk) >>=? fun ctxt -> - wrap (Contract.Delegate.set ctxt (Contract.Implicit baker1) (Some baker1)) - >>=? fun ctxt -> - wrap (Contract.reveal_manager_key ctxt baker2 baker2_pk) >>=? fun ctxt -> - wrap (Contract.Delegate.set ctxt (Contract.Implicit baker2) (Some baker2)) - (* Let user1 delegate to baker2. *) - >>=? fun ctxt -> - wrap (Contract.Delegate.set ctxt (Contract.Implicit user1) (Some baker2)) - >>=? fun ctxt -> - let sc_rollup1 = sc_rollup () in - let bond_id1 = Bond_id.Sc_rollup_bond_id sc_rollup1 in - let sc_rollup2 = sc_rollup () in - let bond_id2 = Bond_id.Sc_rollup_bond_id sc_rollup2 in - let user1ic = Contract.Implicit user1 in - let baker2ic = Contract.Implicit baker2 in - let giver_list = - [ - (`Invoice, random_amount ()); - (`Bootstrap, random_amount ()); - (`Initial_commitments, random_amount ()); - (`Minted, random_amount ()); - (`Liquidity_baking_subsidies, random_amount ()); - (`Collected_commitments Blinded_public_key_hash.zero, random_amount ()); - (`Delegate_balance baker1, random_amount ()); - (`Delegate_balance baker2, random_amount ()); - (`Block_fees, random_amount ()); - (user1c, random_amount ()); - (user2c, random_amount ()); - (baker1c, random_amount ()); - (baker2c, random_amount ()); - (`Frozen_bonds (user1ic, bond_id1), random_amount ()); - (`Frozen_bonds (baker2ic, bond_id2), random_amount ()); - ] - in - let receiver_list = - [ - `Collected_commitments Blinded_public_key_hash.zero; - `Delegate_balance baker1; - `Delegate_balance baker2; - `Block_fees; - user1c; - user2c; - baker1c; - baker2c; - `Frozen_bonds (user1ic, bond_id1); - `Frozen_bonds (baker2ic, bond_id2); - `Burned; - ] - in - return (ctxt, List.product giver_list receiver_list) - -let check_giver_balances ctxt ctxt' giver amount = - match cast_to_container_type giver with - | None -> return_unit - | Some giver -> check_giver_balances ctxt ctxt' giver amount - -let check_receiver_balances ctxt ctxt' receiver amount = - match cast_to_container_type receiver with - | None -> return_unit - | Some receiver -> check_receiver_balances ctxt ctxt' receiver amount - -let rec check_balances ctxt ctxt' giver receiver amount = - let open Lwt_result_wrap_syntax in - match (cast_to_container_type giver, cast_to_container_type receiver) with - | None, None -> return_unit - | ( Some (`Delegate_balance d), - Some (`Contract (Contract.Implicit c) as contract) ) - | ( Some (`Contract (Contract.Implicit c) as contract), - Some (`Delegate_balance d) ) - when d = c -> - (* giver and receiver are in fact referring to the same contract *) - check_balances ctxt ctxt' contract contract amount - | Some giver, Some receiver when giver = receiver -> - (* giver and receiver are the same contract *) - wrap (Token.balance ctxt receiver) >>=? fun (_, bal_receiver) -> - wrap (Token.balance ctxt' receiver) >>=? fun (_, bal_receiver') -> - Assert.equal_tez ~loc:__LOC__ bal_receiver bal_receiver' - | Some giver, None -> check_giver_balances ctxt ctxt' giver amount - | None, Some receiver -> check_receiver_balances ctxt ctxt' receiver amount - | Some giver, Some receiver -> - check_giver_balances ctxt ctxt' giver amount >>=? fun () -> - check_receiver_balances ctxt ctxt' receiver amount - -let test_all_combinations_of_givers_and_receivers () = - let open Lwt_result_wrap_syntax in - Random.init 0 ; - build_test_cases () >>=? fun (ctxt, cases) -> - List.iter_es - (fun ((giver, amount), receiver) -> - (match cast_to_container_type giver with - | None -> return ctxt - | Some giver -> - wrap (Token.transfer ctxt `Minted giver amount) >>=? fun (ctxt, _) -> - return ctxt) - >>=? fun ctxt -> - wrap (Token.transfer ctxt giver receiver amount) >>=? fun (ctxt', _) -> - check_balances ctxt ctxt' giver receiver amount) - cases - -(** [coalesce (account, Credited am1, origin) (account, Credited am2, origin) - = Some (account, Credited (am1+am2), origin)] - - [coalesce (account, Debited am1, origin) (account, Debited am2, origin) - = Some (account, Debited (am1+am2), origin)] - - Fails if bu1 and bu2 have different accounts or different origins, or - if one is a credit while the other is a debit. *) -let coalesce_balance_updates bu1 bu2 = - match (bu1, bu2) with - | (bu1_bal, bu1_balupd, bu1_origin), (bu2_bal, bu2_balupd, bu2_origin) -> ( - assert (bu1_bal = bu2_bal) ; - assert (bu1_origin = bu2_origin) ; - let open Receipt in - match (bu1_balupd, bu2_balupd) with - | Credited bu1_am, Credited bu2_am -> - let bu_am = - match bu1_am +? bu2_am with Ok am -> am | _ -> assert false - in - (bu1_bal, Credited bu_am, bu1_origin) - | Debited bu1_am, Debited bu2_am -> - let bu_am = - match bu1_am +? bu2_am with Ok am -> am | _ -> assert false - in - (bu1_bal, Debited bu_am, bu1_origin) - | Credited _, Debited _ | Debited _, Credited _ -> assert false) - -(** Check that elt has the same balance in ctxt1 and ctxt2. *) -let check_balances_are_consistent ctxt1 ctxt2 elt = - match elt with - | #Token.container as elt -> - Token.balance ctxt1 elt >>=? fun (_, elt_bal1) -> - Token.balance ctxt2 elt >>=? fun (_, elt_bal2) -> - assert (elt_bal1 = elt_bal2) ; - return_unit - | `Invoice | `Bootstrap | `Initial_commitments | `Minted - | `Liquidity_baking_subsidies | `Burned -> - return_unit - -(** Test that [transfer_n] is equivalent to n debits followed by n credits. *) -let test_transfer_n ctxt giver receiver = - (* Run transfer_n. *) - Token.transfer_n ctxt giver receiver >>=? fun (ctxt1, bal_updates1) -> - (* Debit all givers. *) - List.fold_left_es - (fun (ctxt, bal_updates) (giver, am) -> - Token.transfer ctxt giver `Burned am >>=? fun (ctxt, debit_logs) -> - return (ctxt, bal_updates @ debit_logs)) - (ctxt, []) - giver - >>=? fun (ctxt, debit_logs) -> - (* remove burning balance updates *) - let debit_logs = - List.filter - (fun b -> match b with Receipt.Burned, _, _ -> false | _ -> true) - debit_logs - in - (* Credit the receiver for each giver. *) - List.fold_left_es - (fun (ctxt, bal_updates) (_, am) -> - Token.transfer ctxt `Minted receiver am >>=? fun (ctxt, credit_logs) -> - return (ctxt, bal_updates @ credit_logs)) - (ctxt, []) - giver - >>=? fun (ctxt2, credit_logs) -> - (* remove minting balance updates *) - let credit_logs = - List.filter - (fun b -> match b with Receipt.Minted, _, _ -> false | _ -> true) - credit_logs - in - (* Check equivalence of balance updates. *) - let credit_logs = - match credit_logs with - | [] -> [] - | head :: tail -> [List.fold_left coalesce_balance_updates head tail] - in - assert (bal_updates1 = debit_logs @ credit_logs) ; - (* Check balances are the same in ctxt1 and ctxt2. *) - List.(iter_es (check_balances_are_consistent ctxt1 ctxt2) (map fst giver)) - >>=? fun () -> check_balances_are_consistent ctxt1 ctxt2 receiver - -let test_transfer_n_with_no_giver () = - let open Lwt_result_wrap_syntax in - Random.init 0 ; - create_context () >>=? fun (ctxt, pkh) -> - wrap (test_transfer_n ctxt [] `Block_fees) >>=? fun () -> - let receiver = `Delegate_balance pkh in - wrap (test_transfer_n ctxt [] receiver) - -let test_transfer_n_with_several_givers () = - let open Lwt_result_wrap_syntax in - Random.init 0 ; - create_context () >>=? fun (ctxt, pkh) -> - let origin = `Contract (Contract.Implicit pkh) in - let user1, _, _ = Signature.generate_key () in - let user1c = `Contract (Contract.Implicit user1) in - let user2, _, _ = Signature.generate_key () in - let user2c = `Contract (Contract.Implicit user2) in - let user3, _, _ = Signature.generate_key () in - let user3c = `Contract (Contract.Implicit user3) in - let user4, _, _ = Signature.generate_key () in - let user4c = `Contract (Contract.Implicit user4) in - (* Allocate contracts for user1, user2, user3, and user4. *) - let amount = - match Tez.of_mutez 1000L with None -> assert false | Some x -> x - in - wrap (Token.transfer ctxt origin user1c amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin user2c amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin user3c amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin user4c (random_amount ())) - >>=? fun (ctxt, _) -> - let givers = - [ - (user2c, random_amount ()); - (user3c, random_amount ()); - (user4c, random_amount ()); - ] - in - wrap (test_transfer_n ctxt givers user1c) >>=? fun () -> - wrap (test_transfer_n ctxt ((user1c, random_amount ()) :: givers) user1c) - -let tests = - Tztest. - [ - tztest "transfer - balances" `Quick test_simple_balances; - tztest "transfer - balance updates" `Quick test_simple_balance_updates; - tztest "transfer - test allocated" `Quick test_allocated; - tztest - "transfer - test transfer to receiver" - `Quick - test_transferring_to_receiver; - tztest - "transfer - test transfer from giver" - `Quick - test_transferring_from_giver; - tztest - "transfer - test all (givers x receivers)" - `Quick - test_all_combinations_of_givers_and_receivers; - tztest - "transfer - test from no giver to a receiver" - `Quick - test_transfer_n_with_no_giver; - tztest - "transfer - test from n givers to a receiver" - `Quick - test_transfer_n_with_several_givers; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("token movements", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/dune b/src/proto_017_PtNairob/lib_protocol/test/integration/validate/dune deleted file mode 100644 index 7cf7d5ff2cab8b499c221067eedd4b465cbfd667..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/dune +++ /dev/null @@ -1,64 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name src_proto_017_PtNairob_lib_protocol_test_integration_validate_tezt_lib) - (instrumentation (backend bisect_ppx)) - (libraries - tezt.core - octez-alcotezt - octez-libs.base - tezos-protocol-017-PtNairob.protocol - qcheck-alcotest - octez-protocol-017-PtNairob-libs.client - octez-libs.test-helpers - octez-protocol-017-PtNairob-libs.test-helpers - octez-libs.base-test-helpers - octez-protocol-017-PtNairob-libs.plugin) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezt_core - -open Tezt_core.Base - -open Octez_alcotezt - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_protocol_017_PtNairob - -open Tezos_client_017_PtNairob - -open Tezos_test_helpers - -open Tezos_017_PtNairob_test_helpers - -open Tezos_base_test_helpers - -open Tezos_protocol_plugin_017_PtNairob) - (modules - generator_descriptors - generators - manager_operation_helpers - test_1m_restriction - test_covalidity - test_manager_operation_validation - test_mempool - test_sanity - test_validation_batch - valid_operations_generators - validate_helpers)) - -(executable - (name main) - (instrumentation (backend bisect_ppx --bisect-sigterm)) - (libraries - src_proto_017_PtNairob_lib_protocol_test_integration_validate_tezt_lib - tezt) - (link_flags - (:standard) - (:include %{workspace_root}/macos-link-flags.sexp)) - (modules main)) - -(rule - (alias runtest) - (package tezos-protocol-017-PtNairob-tests) - (enabled_if (<> false %{env:RUNTEZTALIAS=true})) - (action (run %{dep:./main.exe}))) - -(rule - (targets main.ml) - (action (with-stdout-to %{targets} (echo "let () = Tezt.Test.run ()")))) diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/generator_descriptors.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/validate/generator_descriptors.ml deleted file mode 100644 index 6300c610dc8ede0c26bf605bf3d26ed2ab548c6b..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/generator_descriptors.ml +++ /dev/null @@ -1,911 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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 -open Alpha_context -open Validate_helpers - -type dbl_endorsement_state = { - temporary : (Block.t * Block.t) option; - slashable_preend : - (Kind.preendorsement operation * Kind.preendorsement operation) list; - slashable_end : (Kind.endorsement operation * Kind.endorsement operation) list; -} - -type state = { - block : Block.t; - pred : Block.t option; - bootstraps : public_key_hash list; - delegates : (public_key_hash * public_key_hash option) list; - voters : Contract.t list; - seed_nonce_to_reveal : (Raw_level.t * Nonce_hash.t) list; - commitments : secret_account list; - protocol_hashes : Protocol_hash.t list; - slashable_bakes : (block_header * block_header) list; - vdf : bool; - dbl_endorsement : dbl_endorsement_state; - manager : Manager.infos; -} - -let init_manager_state bootstraps block = - let open Manager in - let ctxt = - { - block; - bootstraps; - originated_contract = None; - sc_rollup = None; - zk_rollup = None; - } - in - let accounts = - {sources = []; dest = None; del = None; sc = None; zk = None} - in - {ctxt; accounts; flags = all_enabled} - -let init_dbl_endorsement_state = - {temporary = None; slashable_preend = []; slashable_end = []} - -(** Initialize the state according to [state] initialisation - for each operation kind. - - When adding a new operation kind, if such an initialization is - required, it should occur here. *) -let init_state block ~voters ~(bootstraps : Contract.t list) = - let bootstraps = - List.map - (function Contract.Implicit pkh -> pkh | _ -> assert false) - bootstraps - in - { - block; - pred = None; - bootstraps; - delegates = List.map (fun pkh -> (pkh, None)) bootstraps; - voters; - seed_nonce_to_reveal = []; - commitments = []; - protocol_hashes = []; - slashable_bakes = []; - vdf = false; - dbl_endorsement = init_dbl_endorsement_state; - manager = init_manager_state bootstraps block; - } - -type cycle_index = On of int | From of int - -type descriptor = { - parameters : Parameters.t -> Parameters.t; - required_cycle : Parameters.t -> int; - required_block : Parameters.t -> int; - prelude : - cycle_index * (state -> (packed_operation list * state) tzresult Lwt.t); - opt_prelude : - (cycle_index * (state -> (packed_operation list * state) tzresult Lwt.t)) - option; - candidates_generator : state -> packed_operation list tzresult Lwt.t; -} - -(** Each voting period lasts a whole cycle in the generation of valid operations. *) -let voting_context_params params = - let cycles_per_voting_period = 1l in - let constants = Parameters.{params.constants with cycles_per_voting_period} in - {params with constants} - -let ballot_exploration_prelude state = - let open Lwt_result_syntax in - let* ctxt = - let+ i = Incremental.begin_construction state.block in - Incremental.alpha_ctxt i - in - let blocks_per_cycle = Alpha_context.Constants.blocks_per_cycle ctxt in - let rem = - Int32.rem state.block.Block.header.Block_header.shell.level blocks_per_cycle - in - if rem = 0l then - match state.voters with - | voter :: voters -> - let* prop = Op.proposals (B state.block) voter [get_n protos 0] in - let* props = - List.map_es - (fun voter -> - Op.proposals (B state.block) voter [Protocol_hash.zero]) - voters - in - return (prop :: props, state) - | _ -> assert false - else return ([], state) - -let activate_descriptor = - { - parameters = - (fun params -> - let commitments = - List.map - (fun {blinded_public_key_hash; amount; _} -> - Commitment.{blinded_public_key_hash; amount}) - secrets - in - {params with commitments}); - required_cycle = (fun _params -> 1); - required_block = (fun _params -> 0); - prelude = - (On 1, fun state -> return ([], {state with commitments = secrets})); - opt_prelude = None; - candidates_generator = - (fun state -> - let gen s = - Op.activation (B state.block) (Ed25519 s.account) s.activation_code - in - List.map_es gen state.commitments); - } - -(** During the first voting period in the setup of valid operations generations, - a proposal must win the proposal period -- hence [ballot_exploration_prelude] - takes place during the first cycle. *) -let ballot_exploration_descriptor = - { - parameters = voting_context_params; - required_cycle = - (fun params -> Int32.to_int params.constants.cycles_per_voting_period); - required_block = (fun _params -> 0); - prelude = (On 1, ballot_exploration_prelude); - opt_prelude = None; - candidates_generator = - (fun state -> - let open Lwt_result_syntax in - let gen contract = - let* voting_period_info = - Context.Vote.get_current_period (B state.block) - in - assert (voting_period_info.voting_period.kind = Exploration) ; - let ballot = pick_one ballots in - Op.ballot (B state.block) contract Protocol_hash.zero ballot - in - List.map_es gen state.voters); - } - -let proposal_descriptor = - { - parameters = voting_context_params; - required_cycle = (fun _ -> 0); - required_block = (fun _ -> 0); - prelude = - (On 0, fun state -> return ([], {state with protocol_hashes = protos})); - opt_prelude = None; - candidates_generator = - (fun state -> - let open Lwt_result_syntax in - let gen contract = - let* voting_period_info = - Context.Vote.get_current_period (B state.block) - in - assert (voting_period_info.voting_period.kind = Proposal) ; - Op.proposals (B state.block) contract [Protocol_hash.zero] - in - List.map_es gen state.voters); - } - -(** [Promotion] is the 4th voting period, it requires 3 voting period - to last and be successful. [voting_context_params] set a - voting_period to 1 cycle. To generate a [Ballot] for this - promotion period: - - - the first period should conclude in a proposal wining -- 3 cycles - before generating the [Ballot], the proposal period must succeed:[ - ballot_exploration_prelude], - - - the exploration must conclude in a supermajority for this - proposal -- 2 cycles before generating the [Ballot], the - exploration period must succeed., and - - - the cooldown must last -- 1 cycle before generating the - [Ballot]. *) -let ballot_promotion_descriptor = - { - parameters = voting_context_params; - required_cycle = - (fun params -> 3 * Int32.to_int params.constants.cycles_per_voting_period); - required_block = (fun _ -> 0); - prelude = (On 3, ballot_exploration_prelude); - opt_prelude = - Some - ( On 2, - fun state -> - let open Lwt_result_syntax in - let* ctxt = - let+ incr = Incremental.begin_construction state.block in - Incremental.alpha_ctxt incr - in - let blocks_per_cycle = - Alpha_context.Constants.blocks_per_cycle ctxt - in - let rem = - Int32.rem - state.block.Block.header.Block_header.shell.level - blocks_per_cycle - in - if rem = 0l then - let* ops = - List.map_es - (fun voter -> - Op.ballot (B state.block) voter Protocol_hash.zero Vote.Yay) - state.voters - in - return (ops, state) - else return ([], state) ); - candidates_generator = - (fun state -> - let open Lwt_result_syntax in - let gen contract = - let* voting_period_info = - Context.Vote.get_current_period (B state.block) - in - assert (voting_period_info.voting_period.kind = Promotion) ; - let ballot = Stdlib.List.hd ballots in - Op.ballot (B state.block) contract Protocol_hash.zero ballot - in - List.map_es gen state.voters); - } - -let seed_nonce_descriptor = - { - parameters = - (fun params -> - assert (params.constants.blocks_per_cycle > 3l) ; - let blocks_per_commitment = - Int32.(div params.constants.blocks_per_cycle 3l) - in - let constants = {params.constants with blocks_per_commitment} in - {params with constants}); - required_cycle = (fun _ -> 1); - required_block = (fun _ -> 0); - prelude = - ( On 1, - fun state -> - let open Lwt_result_syntax in - let b = state.block in - let* seed_nonce_to_reveal = - match - b.Block.header.Block_header.protocol_data.contents.seed_nonce_hash - with - | None -> return state.seed_nonce_to_reveal - | Some nonce_hash -> - let level = - Raw_level.of_int32_exn b.Block.header.Block_header.shell.level - in - return ((level, nonce_hash) :: state.seed_nonce_to_reveal) - in - return ([], {state with seed_nonce_to_reveal}) ); - opt_prelude = None; - candidates_generator = - (fun state -> - let open Lwt_result_syntax in - let gen (level, nonce_hash) = - assert (List.length state.seed_nonce_to_reveal >= 3) ; - let nonce = - WithExceptions.Option.to_exn ~none:Not_found - @@ Registered_nonces.get nonce_hash - in - return (Op.seed_nonce_revelation (B state.block) level nonce) - in - List.map_es gen state.seed_nonce_to_reveal); - } - -(** The heads on which two slashable endorsements or preendorsement - should be made are from the previous level. Hence, the temporary - field of a double_evidence_state is used to transmit them to the - next level in order to make the slashable operations. *) -let register_temporary ba bb state : (Block.t * Block.t) option * state = - let pred_forks = state.dbl_endorsement.temporary in - let temporary = Some (ba, bb) in - let dbl_endorsement = {state.dbl_endorsement with temporary} in - (pred_forks, {state with dbl_endorsement}) - -(** During the slashable period, at each level, two different heads - for the same round are baked by the same baker. At the next level, - a delegate that either preendorses or endorses both heads makes a - pair of slashable pre- or endorsements. - - The pair of heads is placed in the temporary of the - double_evidence_state. If a pair of heads was already in this - field, hence they were baked at the previous level. - - Consequently, two pairs of slashable operations: two endorsements - and two preendorsement, can be made by two distinct endorsers. Each - pair is ordered in operation_hash order. Consequently, each pair - can appear in a denunciation operation and will be valid. *) -let dbl_endorsement_prelude state = - let open Lwt_result_syntax in - let* head_A = Block.bake ~policy:(By_round 0) state.block in - let* addr = pick_addr_endorser (B state.block) in - let ctr = Contract.Implicit addr in - let* operation = Op.transaction (B state.block) ctr ctr Tez.one_mutez in - let* head_B = Block.bake ~policy:(By_round 0) state.block ~operation in - let heads, state = register_temporary head_A head_B state in - match heads with - | None -> return ([], state) - | Some (b1, b2) -> - let* delegate1, delegate2 = pick_two_endorsers (B b1) in - let* op1 = Op.raw_preendorsement ~delegate:delegate1 b1 in - let* op2 = Op.raw_preendorsement ~delegate:delegate1 b2 in - let op1, op2 = - let comp = - Operation_hash.compare (Operation.hash op1) (Operation.hash op2) - in - assert (comp <> 0) ; - if comp < 0 then (op1, op2) else (op2, op1) - in - let slashable_preend = - (op1, op2) :: state.dbl_endorsement.slashable_preend - in - let* op3 = Op.raw_endorsement ~delegate:delegate2 b1 in - let* op4 = Op.raw_endorsement ~delegate:delegate2 b2 in - let op3, op4 = - let comp = - Operation_hash.compare (Operation.hash op3) (Operation.hash op4) - in - assert (comp <> 0) ; - if comp < 0 then (op3, op4) else (op4, op3) - in - let slashable_end = (op3, op4) :: state.dbl_endorsement.slashable_end in - let dbl_endorsement = - {state.dbl_endorsement with slashable_preend; slashable_end} - in - return ([], {state with dbl_endorsement}) - -let double_consensus_descriptor = - { - parameters = Fun.id; - required_cycle = (fun _params -> 2); - required_block = (fun _ -> 0); - prelude = (From 2, dbl_endorsement_prelude); - opt_prelude = None; - candidates_generator = - (fun state -> - let open Lwt_result_syntax in - let gen_dbl_pre (op1, op2) = - Op.double_preendorsement (Context.B state.block) op1 op2 - in - let gen_dbl_end (op1, op2) = - Op.double_endorsement (Context.B state.block) op1 op2 - in - let candidates_pre = - List.map gen_dbl_pre state.dbl_endorsement.slashable_preend - in - let candidates_end = - List.map gen_dbl_end state.dbl_endorsement.slashable_end - in - return (candidates_pre @ candidates_end)); - } - -let double_baking_descriptor = - { - parameters = Fun.id; - required_cycle = (fun params -> params.constants.max_slashing_period); - required_block = (fun _ -> 0); - prelude = - ( From 2, - fun state -> - let open Lwt_result_syntax in - let order_block_header bh1 bh2 = - let hash1 = Block_header.hash bh1 in - let hash2 = Block_header.hash bh2 in - let c = Block_hash.compare hash1 hash2 in - if c < 0 then (bh1, bh2) else (bh2, bh1) - in - let* ctxt = - let+ incr = Incremental.begin_construction state.block in - Incremental.alpha_ctxt incr - in - let blocks_per_cycle = - Alpha_context.Constants.blocks_per_cycle ctxt - in - let rem = - Int32.rem - state.block.Block.header.Block_header.shell.level - blocks_per_cycle - in - if rem = 0l then return ([], state) - else - let* baker1, _baker2 = - Context.get_first_different_bakers (B state.block) - in - let* addr = pick_addr_endorser (B state.block) in - let ctr = Contract.Implicit addr in - let* operation = - Op.transaction (B state.block) ctr ctr Tez.one_mutez - in - let* ba = - Block.bake ~policy:(By_account baker1) ~operation state.block - in - let* bb = Block.bake ~policy:(By_account baker1) state.block in - let ba, bb = order_block_header ba.Block.header bb.Block.header in - let slashable_bakes = (ba, bb) :: state.slashable_bakes in - return ([], {state with slashable_bakes}) ); - opt_prelude = None; - candidates_generator = - (fun state -> - let open Lwt_result_syntax in - let gen (bh1, bh2) = - return (Op.double_baking (B state.block) bh1 bh2) - in - List.map_es gen state.slashable_bakes); - } - -(** A drain delegate operation is valid when, preserved_cycle before, the - delegate has updated its key. This key must then has enough fund in order to - be revealed. - - At the first level of preserved cycle in the past, the key is funded by a - bootstrap account. At the second level, it reveals and at the third the - delegate updates its key to this key. *) -let drain_delegate_prelude state = - let open Lwt_result_syntax in - let* ctxt = - let+ incr = Incremental.begin_construction state.block in - Incremental.alpha_ctxt incr - in - let blocks_per_cycle = Alpha_context.Constants.blocks_per_cycle ctxt in - let rem = - Int32.rem state.block.Block.header.Block_header.shell.level blocks_per_cycle - in - if rem = 0l then - (* Create (n / 2) consensus keys *) - let delegates = - List.mapi - (fun i -> function - | (delegate, None) as del -> - if i mod 2 = 0 then - let acc = Account.new_account () in - (delegate, Some acc.pkh) - else del - | del -> del (* should not happen but apparently does...*)) - state.delegates - in - let dels = - List.filter_map - (function _del, None -> None | del, Some ck -> Some (del, ck)) - delegates - in - let* ops = - List.fold_left_es - (fun ops (del, ck) -> - let* {Account.pk; _} = Account.find ck in - let* op = - Op.update_consensus_key (B state.block) (Contract.Implicit del) pk - in - return (op :: ops)) - [] - dels - in - let state = {state with delegates} in - return (ops, state) - else return ([], state) - -let drain_delegate_descriptor = - { - parameters = Fun.id; - required_cycle = (fun params -> params.constants.preserved_cycles + 1); - required_block = (fun _ -> 0); - prelude = - (On (init_params.constants.preserved_cycles + 1), drain_delegate_prelude); - opt_prelude = None; - candidates_generator = - (fun state -> - let gen (delegate, consensus_key_opt) = - let open Lwt_result_syntax in - match consensus_key_opt with - | None -> return_none - | Some consensus_key -> - let* op = - Op.drain_delegate - (B state.block) - ~consensus_key - ~delegate - ~destination:consensus_key - in - return_some op - in - List.filter_map_es gen state.delegates); - } - -let vdf_revelation_descriptor = - { - parameters = - (fun params -> - {params with constants = {params.constants with vdf_difficulty = 750L}}); - required_cycle = (fun _ -> 1); - required_block = - (fun params -> Int32.to_int params.constants.nonce_revelation_threshold); - prelude = (On 2, fun state -> return ([], {state with vdf = true})); - opt_prelude = None; - candidates_generator = - (fun state -> - let open Lwt_result_syntax in - let* seed_status = Context.get_seed_computation (B state.block) in - let* csts = Context.get_constants (B state.block) in - match seed_status with - | Nonce_revelation_stage | Computation_finished -> assert false - | Vdf_revelation_stage info -> - (* generate the VDF discriminant and challenge *) - let discriminant, challenge = - Alpha_context.Seed.generate_vdf_setup - ~seed_discriminant:info.seed_discriminant - ~seed_challenge:info.seed_challenge - in - (* compute the VDF solution (the result and the proof ) *) - let solution = - (* generate the result and proof *) - Environment.Vdf.prove - discriminant - challenge - csts.parametric.vdf_difficulty - in - return [Op.vdf_revelation (B state.block) solution]); - } - -let preendorsement_descriptor = - { - parameters = Fun.id; - required_cycle = (fun _ -> 1); - required_block = (fun _ -> 1); - prelude = (On 1, fun state -> return ([], state)); - opt_prelude = None; - candidates_generator = - (fun state -> - let open Lwt_result_syntax in - let gen (delegate, ck_opt) = - let* slots_opt = Context.get_endorser_slot (B state.block) delegate in - let delegate = Option.value ~default:delegate ck_opt in - match slots_opt with - | None -> return_none - | Some slots -> ( - match slots with - | [] -> return_none - | _ :: _ -> - let* op = Op.preendorsement ~delegate state.block in - return_some op) - in - List.filter_map_es gen state.delegates); - } - -let endorsement_descriptor = - { - parameters = Fun.id; - required_cycle = (fun _ -> 1); - required_block = (fun _ -> 1); - prelude = (On 1, fun state -> return ([], state)); - opt_prelude = None; - candidates_generator = - (fun state -> - let open Lwt_result_syntax in - let gen (delegate, ck_opt) = - let* slots_opt = Context.get_endorser_slot (B state.block) delegate in - let delegate = Option.value ~default:delegate ck_opt in - match slots_opt with - | None -> return_none - | Some slots -> ( - match slots with - | [] -> return_none - | _ :: _ -> - let* op = Op.endorsement ~delegate state.block in - return_some op) - in - List.filter_map_es gen state.delegates); - } - -(* TODO: #4917 remove direct dependency of the alpha_context. *) -let dal_attestation ctxt current_level delegate = - let open Lwt_result_syntax in - let level = Alpha_context.Level.from_raw ctxt current_level in - let* committee = Dal_apply.compute_committee ctxt level in - match - Environment.Signature.Public_key_hash.Map.find - delegate - committee.pkh_to_shards - with - | None -> return_none - | Some _interval -> - (* The content of the attestation does not matter for covalidity. *) - let attestation = Dal.Attestation.empty in - let next_level = Raw_level.succ current_level in - return_some - (Dal_attestation {attestor = delegate; attestation; level = next_level}) - -let dal_attestation_descriptor = - let open Lwt_result_syntax in - { - parameters = - (fun params -> - let dal = {params.constants.dal with feature_enable = true} in - let constants = {params.constants with dal} in - {params with constants}); - required_cycle = (fun _ -> 0); - required_block = (fun _ -> 0); - prelude = (On 1, fun state -> return ([], state)); - opt_prelude = None; - candidates_generator = - (fun state -> - let gen (delegate, _) = - let* ctxt = - let+ incr = Incremental.begin_construction state.block in - Incremental.alpha_ctxt incr - in - let*? current_level = Context.get_level (B state.block) in - let* op = - dal_attestation ctxt current_level delegate - >|= Environment.wrap_tzresult - in - return - (op - |> Option.map (fun op -> - Op.pack_operation (B state.block) None (Single op))) - in - List.filter_map_es gen state.delegates); - } - -module Manager = Manager_operation_helpers - -let required_nb_account = 7 - -(** Convertion from [manager_state] to a {! Manager_operation_helper.infos}. *) -let infos_of_state source block infos : Manager.infos = - let open Manager in - let ({ctxt; accounts; flags} : infos) = infos in - let ctxt : ctxt = {ctxt with block} in - let accounts = {accounts with sources = [source]} in - {ctxt; accounts; flags} - -(** Updating a [manager_state] according to a {! Manager_operation_helper.infos}. *) -let update_state_with_infos {Manager.ctxt; accounts; flags} - {Manager.ctxt = ctxt2; accounts = accounts2; _} = - let ctxt = - { - ctxt with - originated_contract = ctxt2.originated_contract; - sc_rollup = ctxt2.sc_rollup; - zk_rollup = ctxt2.zk_rollup; - } - in - let accounts = - { - accounts with - dest = accounts2.dest; - del = accounts2.del; - sc = accounts2.sc; - zk = accounts2.zk; - } - in - {Manager.ctxt; accounts; flags} - -(** According to a [Manager.infos] and a block [b], create and fund - the required contracts and accounts on [b]. In additions to the - initiation performed by {! Manager_operation_helper.init_infos}, it - registers a list of funded sources. *) -let manager_prelude (infos : Manager.infos) b = - let open Lwt_result_syntax in - let nb_sources = List.length infos.ctxt.bootstraps in - let* ops_by_bootstrap = - List.map_es - (fun bootstrap -> - let bootstrap = Contract.Implicit bootstrap in - let* counter = Context.Contract.counter (B b) bootstrap in - return (bootstrap, counter, [])) - (List.take_n nb_sources infos.ctxt.bootstraps) - in - let add bootstrap counter ops ops_by_bootstrap = - List.map - (fun (bootstrap', counter', ops') -> - if bootstrap' = bootstrap then - (bootstrap, Manager_counter.succ counter, ops) - else (bootstrap', counter', ops')) - ops_by_bootstrap - in - let batches block ops_by_bootstrap = - List.fold_left_es - (fun acc (source, _counter, operations) -> - match operations with - | [] -> return (List.rev acc) - | _ -> - let* batch = Op.batch_operations ~source (B block) operations in - return (batch :: acc)) - [] - ops_by_bootstrap - in - let create_and_fund sources ops_by_bootstrap = - let account = Account.new_account () in - let n = nb_sources - Stdlib.List.length sources in - let bootstrap, counter, ops = Stdlib.List.nth ops_by_bootstrap (n - 1) in - let amount = Tez.of_mutez (Int64.of_int 150000) in - let+ op, counter = - Manager.fund_account_op b bootstrap account.pkh amount counter - in - (account :: sources, add bootstrap counter (op :: ops) ops_by_bootstrap) - in - let* sources, src_operations = - List.fold_left_es - (fun (acc_accounts, acc_ops) _ -> create_and_fund acc_accounts acc_ops) - ([], ops_by_bootstrap) - (1 -- nb_sources) - in - let* operations = batches b src_operations in - let infos = {infos with accounts = {infos.accounts with sources}} in - let* infos2 = - Manager.init_infos - Manager.ctxt_req_default - b - (List.take_n required_nb_account infos.ctxt.bootstraps) - in - let state = update_state_with_infos infos infos2 in - return (operations, state) - -(** Build a manager operation according to the information in [infos] - on [block] for each source in the [manager_state] guaranteeing - that they are not conflicting. *) -let manager_candidates block infos batch_max_size = - let open Lwt_result_syntax in - let params = - List.map - (fun src -> - let m = gen_bounded_int 1 batch_max_size in - let kd = pick_n m Manager.revealed_subjects in - (src, kd)) - infos.Manager.accounts.sources - in - let gen (source, ks) = - let infos = infos_of_state source block infos in - let* reveal = - Manager.mk_reveal (Manager.operation_req_default Manager.K_Reveal) infos - in - let* operations = - List.map_es - (fun kd -> Manager.select_op (Manager.operation_req_default kd) infos) - ks - in - let* operations = return (reveal :: operations) in - Op.batch_operations - ~recompute_counters:true - ~source:(Contract.Implicit source.pkh) - (B block) - operations - in - List.map_es gen params - -let manager_descriptor max_batch_size nb_accounts = - { - parameters = - (fun params -> - let ctxt_req_default = Manager.ctxt_req_default in - let hard_gas_limit_per_block = - Some (Gas.Arith.integral_of_int_exn ((nb_accounts + 1) * 5_200_000)) - in - let ctxt_req = {ctxt_req_default with hard_gas_limit_per_block} in - Manager.manager_parameters params ctxt_req); - required_cycle = (fun _ -> 1); - required_block = (fun _ -> 1); - prelude = - ( On 1, - fun state -> - let open Lwt_result_syntax in - let* ops, manager = manager_prelude state.manager state.block in - let state = {state with manager} in - return (ops, state) ); - opt_prelude = None; - candidates_generator = - (fun state -> manager_candidates state.block state.manager max_batch_size); - } - -type op_kind = - | KEndorsement - | KPreendorsement - | KDalattestation - | KBallotExp - | KBallotProm - | KProposals - | KNonce - | KVdf - | KActivate - | KDbl_consensus - | KDbl_baking - | KDrain - | KManager - -let op_kind_of_packed_operation op = - let (Operation_data {contents; _}) = op.protocol_data in - match contents with - | Single (Preendorsement _) -> KPreendorsement - | Single (Endorsement _) -> KEndorsement - | Single (Dal_attestation _) -> KDalattestation - | Single (Seed_nonce_revelation _) -> KNonce - | Single (Vdf_revelation _) -> KVdf - | Single (Double_endorsement_evidence _) -> KDbl_consensus - | Single (Double_preendorsement_evidence _) -> KDbl_consensus - | Single (Double_baking_evidence _) -> KDbl_baking - | Single (Activate_account _) -> KActivate - | Single (Proposals _) -> KProposals - | Single (Ballot _) -> KBallotExp - | Single (Drain_delegate _) -> KDrain - | Single (Manager_operation _) -> KManager - | Cons (Manager_operation _, _) -> KManager - | Single (Failing_noop _) -> assert false - -let pp_op_kind fmt kind = - Format.fprintf - fmt - (match kind with - | KManager -> "manager" - | KEndorsement -> "endorsement" - | KPreendorsement -> "preendorsement" - | KDalattestation -> "dal_attestation" - | KBallotExp -> "ballot" - | KBallotProm -> "ballot" - | KProposals -> "proposals" - | KNonce -> "nonce" - | KVdf -> "vdf_revelation" - | KActivate -> "activate_account" - | KDbl_consensus -> "double_consensus" - | KDbl_baking -> "double_baking" - | KDrain -> "drain_delegate") - -let descriptor_of ~nb_bootstrap ~max_batch_size = function - | KManager -> manager_descriptor max_batch_size nb_bootstrap - | KEndorsement -> endorsement_descriptor - | KPreendorsement -> preendorsement_descriptor - | KDalattestation -> dal_attestation_descriptor - | KBallotExp -> ballot_exploration_descriptor - | KBallotProm -> ballot_promotion_descriptor - | KProposals -> proposal_descriptor - | KNonce -> seed_nonce_descriptor - | KVdf -> vdf_revelation_descriptor - | KActivate -> activate_descriptor - | KDbl_consensus -> double_consensus_descriptor - | KDbl_baking -> double_baking_descriptor - | KDrain -> drain_delegate_descriptor - -let descriptors_of ~nb_bootstrap ~max_batch_size = - List.map (descriptor_of ~nb_bootstrap ~max_batch_size) - -(** A context is in a unique voting period. *) -let voting_kinds = [KProposals; KBallotExp; KBallotProm] - -(** A context either wait for nonce revelation or vdf revelation - but not both at the same time. *) -let nonce_generation_kinds = [KNonce; KVdf] - -(** All kind list, used in the sanity check.*) -let non_exclusive_kinds = - [ - KManager; - KEndorsement; - KPreendorsement; - KDalattestation; - KActivate; - KDbl_consensus; - KDbl_baking; - KDrain; - ] - -let all_kinds = voting_kinds @ nonce_generation_kinds @ non_exclusive_kinds diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/generator_descriptors.mli b/src/proto_017_PtNairob/lib_protocol/test/integration/validate/generator_descriptors.mli deleted file mode 100644 index 515df860cfa42d1811b170453edd4eefe8875de9..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/generator_descriptors.mli +++ /dev/null @@ -1,161 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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 -open Alpha_context -open Validate_helpers - -(** {2 Generation state} *) - -(** The state to generate valid double pre- and endorsement evidence - contains a temporary state for making the slashable evidence, and - the lists of slashables operations, one for each kind: - preendorsement and endorsement. *) -type dbl_endorsement_state = { - temporary : (Block.t * Block.t) option; - slashable_preend : - (Kind.preendorsement operation * Kind.preendorsement operation) list; - slashable_end : (Kind.endorsement operation * Kind.endorsement operation) list; -} - -(** Generic generation state collecting - information to generate any kind of operation. - - For example, {!Manager.infos} for manager - or voters (Contract.t list) for voting operations... - - When adding a new operation kind, [state] might be extended if a - new kind of information is required for this new kind valid - operations generation. *) -type state = { - block : Block.t; - pred : Block.t option; - bootstraps : public_key_hash list; - delegates : (public_key_hash * public_key_hash option) list; - voters : Contract.t list; - seed_nonce_to_reveal : (Raw_level.t * Nonce_hash.t) list; - commitments : secret_account list; - protocol_hashes : Protocol_hash.t list; - slashable_bakes : (block_header * block_header) list; - vdf : bool; - dbl_endorsement : dbl_endorsement_state; - manager : Manager.infos; -} - -(** The initialization of a [state] requires the [voters] contracts -- - the contracts allowed to vote -- and the [bootstraps] contracts. *) -val init_state : - Block.t -> voters:Contract.t list -> bootstraps:Contract.t list -> state - -(** {2 Descriptor for valid operations generation} *) - -(** Each prelude action either takes place on a specific cycle or - from a specific cycle to the end a the context setting. *) -type cycle_index = On of int | From of int - -(** Descriptors are specific to operation kinds, [op_kind]. A - descriptor provides the information and functions used in the - context setup to generate valid operations of its kind and a - generator for such operations. - - - [parameters] enables setting constants in the initial context. - - - [required_cycle] is the number of cycles in the context setup - before generating valid operations of this kind. - - - [required_block] the number of blocks in the last cycle. - - - [prelude] is a set of actions that either gather information in - the setup [state] or perform operations in the setup blocks or both - that have to be performed according to a [cycle_index]. - - - [opt_prelude] is an optional prelude. - - - [candidates_generator] generates operations of the descriptor - [op_kind] according to the information in [state] that are valid - upon [state.block]. *) -type descriptor = { - parameters : Parameters.t -> Parameters.t; - required_cycle : Parameters.t -> int; - required_block : Parameters.t -> int; - prelude : - cycle_index * (state -> (packed_operation list * state) tzresult Lwt.t); - opt_prelude : - (cycle_index * (state -> (packed_operation list * state) tzresult Lwt.t)) - option; - candidates_generator : state -> packed_operation list tzresult Lwt.t; -} - -(** {2 Operation kinds} *) - -(** When adding a new operation: - - a new op_kind [k] should extend the [op_kind] type, - - a [descriptor] defined, - - [descriptor_of] must associate this new descriptor to [k], - - [k] must be added to [all_kinds], - - If the validity of [k] operations is not exclusive with the - validity of other [op_kind], [k] must be added to - [non_exclusive_kinds]. Otherwise, see, for example, how voting - operation op_kinds are handled in {! test_covalidity.tests}. *) -type op_kind = - | KEndorsement - | KPreendorsement - | KDalattestation - | KBallotExp - | KBallotProm - | KProposals - | KNonce - | KVdf - | KActivate - | KDbl_consensus - | KDbl_baking - | KDrain - | KManager - -val pp_op_kind : Format.formatter -> op_kind -> unit - -(** This sanity function returns the [op_kind] associated to - an [packed_operation].*) -val op_kind_of_packed_operation : packed_operation -> op_kind - -(** Associate to each [op_kind] a [descriptor]. Some descriptors are - parametrized by the number of bootstraps and the maximum size of a - batch.*) -val descriptor_of : - nb_bootstrap:int -> max_batch_size:int -> op_kind -> descriptor - -(** Given a list of [op_kind] returns the list of corresponding - descriptors as provided by [descriptor_of] for each [op_kind]. - Some descriptors are parametrized by the number of bootstraps and - the maximum size of a batch.*) -val descriptors_of : - nb_bootstrap:int -> max_batch_size:int -> op_kind list -> descriptor list - -(** List of all [op_kind] that are non exclusive (i.e. no voting -operation kind or nonce revelation kind) *) -val non_exclusive_kinds : op_kind trace - -(** List of all [op_kind] used for sanity check. *) -val all_kinds : op_kind list diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/generators.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/validate/generators.ml deleted file mode 100644 index 59f2b10c3a9c68522b95188c199641831e5d356c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/generators.ml +++ /dev/null @@ -1,276 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic-Labs. *) -(* *) -(* 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 -open Alpha_context -open Manager_operation_helpers - -let lwt_run f = - match Lwt_main.run f with - | Error err -> - QCheck.Test.fail_reportf "@.Lwt_main.run error: %a@." pp_print_trace err - | Ok v -> v - -(** {2 Datatypes} *) - -(** Constraints on generated values. - - {ul - {li [Free] states that nothing has to be generated} - - {li [Pure n] generate n} - - {li [Less {n;origin}] (resp Greater) states the expected - constraints for the generated values that must be lesser (resp - greater) than [n] and shrink toward [origin] in case of error} - - {li [Range {min;max;origin}] states the expected constraints for - the generated values that must be between [min] and [max] and - shrink toward [origin] in case of error.}} *) -type cstrs = - | Free - | Pure of int - | Less of {n : int; origin : int} - | Greater of {n : int; origin : int} - | Range of {min : int; max : int; origin : int} - -(** Gas frequency. *) -type gas_freq = { - low : int; - max : int; - high : int; - zero : int; - custom : int * cstrs; -} - -(** Operation constraints. *) -type operation_cstrs = { - counter : cstrs; - fee : cstrs; - gas_limit : gas_freq; - storage_limit : cstrs; - force_reveal : bool option; - amount : cstrs; -} - -(** Context constraints. *) -type ctxt_cstrs = { - hard_gas_limit_per_block : cstrs; - src_cstrs : cstrs; - dest_cstrs : cstrs; - del_cstrs : cstrs; - sc_cstrs : cstrs; - zk_cstrs : cstrs; -} -(** {2 Default values} *) - -(** Default constraint. *) -let default_cstrs = Free - -(** Default gas frequency. *) -let default_gas_freq = - {low = 0; max = 0; high = 1; zero = 0; custom = (0, Free)} - -(** Default constraints for operation. *) -let default_operation_cstrs = - { - counter = default_cstrs; - fee = default_cstrs; - gas_limit = default_gas_freq; - storage_limit = default_cstrs; - force_reveal = None; - amount = default_cstrs; - } - -(** Default constraints for context. *) -let default_ctxt_cstrs = - { - hard_gas_limit_per_block = default_cstrs; - src_cstrs = default_cstrs; - dest_cstrs = default_cstrs; - del_cstrs = default_cstrs; - sc_cstrs = default_cstrs; - zk_cstrs = default_cstrs; - } - -(** {2 Generators} *) - -(** Generator of positive integers. *) -let gen_pos : cstrs -> int option QCheck2.Gen.t = - fun c -> - let open QCheck2.Gen in - match c with - | Free -> pure None - | Pure n -> pure (Some n) - | Less {n; origin} -> - let+ v = int_range ~origin 0 n in - Some v - | Greater {n; origin} -> - let+ v = int_range ~origin n max_int in - Some v - | Range {min; max; origin} -> - let+ v = int_range ~origin min max in - Some v - -(** Generator for Z.t that is used for gas limit. *) -let gen_z : cstrs -> Z.t option QCheck2.Gen.t = - fun cstrs -> - let open QCheck2.Gen in - let+ v = gen_pos cstrs in - Option.map Z.of_int v - -(** Generator for Manager_counter.t. *) -let gen_counter : cstrs -> Manager_counter.t option QCheck2.Gen.t = - fun cstrs -> - let open QCheck2.Gen in - let+ v = gen_pos cstrs in - Option.map Manager_counter.Internal_for_tests.of_int v - -(** Generator for Tez.t. *) -let gen_tez : cstrs -> Tez.t option QCheck2.Gen.t = - fun cstrs -> - let open QCheck2.Gen in - let+ amount = gen_pos cstrs in - match amount with - | Some amount -> - let amount = Int64.of_int amount in - Tez.of_mutez amount - | None -> None - -(** Generator for gas integral. *) -let gen_gas_integral : cstrs -> Gas.Arith.integral option QCheck2.Gen.t = - fun cstrs -> - let open QCheck2.Gen in - let+ v = gen_pos cstrs in - Option.map Gas.Arith.integral_of_int_exn v - -(** Generator for Op.gas_limit. *) -let gen_gas_limit : gas_freq -> Op.gas_limit option QCheck2.Gen.t = - fun gas_freq -> - let open QCheck2.Gen in - frequency - [ - (gas_freq.low, return (Some Op.Low)); - (gas_freq.max, return (Some Op.Max)); - (gas_freq.high, return (Some Op.High)); - (gas_freq.zero, return (Some Op.Zero)); - (let freq, cstrs = gas_freq.custom in - ( freq, - let+ gas = gen_gas_integral cstrs in - match gas with None -> None | Some g -> Some (Op.Custom_gas g) )); - ] - -(** Generator for manager_operation_kind. *) -let gen_kind : - manager_operation_kind list -> manager_operation_kind QCheck2.Gen.t = - fun subjects -> QCheck2.Gen.oneofl subjects - -(** Generator for mode. *) -let gen_mode : mode QCheck2.Gen.t = - QCheck2.Gen.oneofl [Construction; Mempool; Application] - -(** Generator for operation requirements. *) -let gen_operation_req : - operation_cstrs -> - manager_operation_kind list -> - operation_req QCheck2.Gen.t = - fun {counter; fee; gas_limit; storage_limit; force_reveal; amount} subjects -> - let open QCheck2.Gen in - let* kind = gen_kind subjects in - let* counter = gen_counter counter in - let* fee = gen_tez fee in - let* gas_limit = gen_gas_limit gas_limit in - let* storage_limit = gen_z storage_limit in - let+ amount = gen_tez amount in - {kind; counter; fee; gas_limit; storage_limit; force_reveal; amount} - -(** Generator for a pair of operations with the same source and - sequential counters.*) -let gen_2_operation_req : - operation_cstrs -> - manager_operation_kind list -> - (operation_req * operation_req) QCheck2.Gen.t = - fun op_cstrs subjects -> - let open QCheck2.Gen in - let* op1 = - gen_operation_req {op_cstrs with force_reveal = Some true} subjects - in - let counter = - match op1.counter with - | Some x -> Manager_counter.Internal_for_tests.to_int x - | None -> 1 - in - let op_cstr = - { - {op_cstrs with counter = Pure (counter + 2)} with - force_reveal = Some false; - } - in - let+ op2 = gen_operation_req op_cstr subjects in - (op1, op2) - -(** Generator for context requirement. *) -let gen_ctxt_req : ctxt_cstrs -> ctxt_req QCheck2.Gen.t = - fun { - hard_gas_limit_per_block; - src_cstrs; - dest_cstrs; - del_cstrs; - sc_cstrs; - zk_cstrs; - } -> - let open QCheck2.Gen in - let* hard_gas_limit_per_block = gen_gas_integral hard_gas_limit_per_block in - let* fund_src = gen_tez src_cstrs in - let* fund_dest = gen_tez dest_cstrs in - let* fund_del = gen_tez del_cstrs in - let* fund_sc = gen_tez sc_cstrs in - let+ fund_zk = gen_tez zk_cstrs in - { - hard_gas_limit_per_block; - fund_src; - fund_dest; - fund_del; - reveal_accounts = true; - fund_sc; - fund_zk; - flags = all_enabled; - } - -(** {2 Wrappers} *) - -let wrap ~name ?print ?(count = 1) ?check ~(gen : 'a QCheck2.Gen.t) - (f : 'a -> bool tzresult Lwt.t) = - Qcheck2_helpers.qcheck_make_result_lwt - ~name - ?print - ~count - ?check - ~extract:Lwt_main.run - ~pp_error:pp_print_trace - ~gen - f - -let wrap_mode infos op mode = validate_diagnostic ~mode infos op diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/manager_operation_helpers.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/validate/manager_operation_helpers.ml deleted file mode 100644 index 1bbbba012777ef44beecaeb8cf438f9583a2e8b4..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/manager_operation_helpers.ml +++ /dev/null @@ -1,1433 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic-Labs. *) -(* *) -(* 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 -open Alpha_context -open Test_tez - -(** {2 Constants} *) - -(** Hard gas limit *) - -let gb_limit = Gas.Arith.(integral_of_int_exn 100_000) - -let half_gb_limit = Gas.Arith.(integral_of_int_exn 50_000) - -let default_fund = Tez.of_mutez_exn 400_000_000_000L - -(** {2 Datatypes} *) - -(** Context abstraction in a test. *) -type ctxt = { - block : Block.t; - bootstraps : public_key_hash list; - originated_contract : Contract_hash.t option; - sc_rollup : Sc_rollup.t option; - zk_rollup : Zk_rollup.t option; -} - -(** Accounts manipulated in the tests. By convention, each field name - specifies the role of the account in a test. It is the case in most - of the tests. In operations smart contructors, it happens that in - impossible case, [source] is used as a dummy value. In some test that - requires a second source, [del] will be used as the second source. *) -type accounts = { - sources : Account.t list; - dest : Account.t option; - del : Account.t option; - sc : Account.t option; - zk : Account.t option; -} - -(** Feature flags requirements for a context setting for a test. *) -type feature_flags = {dal : bool; scoru : bool; toru : bool; zkru : bool} - -(** Infos describes the information of the setting for a test: the - context and used accounts. *) -type infos = {ctxt : ctxt; accounts : accounts; flags : feature_flags} - -(** This type should be extended for each new manager_operation kind - added in the protocol. See - [test_manager_operation_validation.ensure_kind] for more - information on how we ensure that this type is extended for each - new manager_operation kind. *) -type manager_operation_kind = - | K_Transaction - | K_Origination - | K_Register_global_constant - | K_Delegation - | K_Undelegation - | K_Self_delegation - | K_Set_deposits_limit - | K_Update_consensus_key - | K_Increase_paid_storage - | K_Reveal - | K_Transfer_ticket - | K_Sc_rollup_origination - | K_Sc_rollup_publish - | K_Sc_rollup_cement - | K_Sc_rollup_add_messages - | K_Sc_rollup_refute - | K_Sc_rollup_timeout - | K_Sc_rollup_execute_outbox_message - | K_Sc_rollup_recover_bond - | K_Dal_publish_slot_header - | K_Zk_rollup_origination - | K_Zk_rollup_publish - | K_Zk_rollup_update - -(** The requirements for a tested manager operation. *) -type operation_req = { - kind : manager_operation_kind; - counter : Manager_counter.t option; - fee : Tez.t option; - gas_limit : Op.gas_limit option; - storage_limit : Z.t option; - force_reveal : bool option; - amount : Tez.t option; -} - -(** The requirements for a context setting for a test. *) -type ctxt_req = { - hard_gas_limit_per_block : Gas.Arith.integral option; - fund_src : Tez.t option; - fund_dest : Tez.t option; - fund_del : Tez.t option; - reveal_accounts : bool; - fund_sc : Tez.t option; - fund_zk : Tez.t option; - flags : feature_flags; -} - -(** Validation mode. - - FIXME: https://gitlab.com/tezos/tezos/-/issues/3365 - This type should be replaced by the one defined - in validation, type mode in `validate_operation`, when it would - include the distinction between Contruction and Application. *) -type mode = Construction | Mempool | Application - -(** {2 Default values} *) -let all_enabled = {dal = true; scoru = true; toru = true; zkru = true} - -let disabled_dal = {all_enabled with dal = false} - -let disabled_scoru = {all_enabled with scoru = false} - -let disabled_toru = {all_enabled with toru = false} - -let disabled_zkru = {all_enabled with zkru = false} - -let ctxt_req_default_to_flag flags = - { - hard_gas_limit_per_block = None; - fund_src = Some default_fund; - fund_dest = Some Tez.one; - fund_del = Some default_fund; - reveal_accounts = true; - fund_sc = Some Tez.one; - fund_zk = Some Tez.one; - flags; - } - -let ctxt_req_default = ctxt_req_default_to_flag all_enabled - -let operation_req_default kind = - { - kind; - counter = None; - fee = None; - gas_limit = None; - storage_limit = None; - force_reveal = None; - amount = None; - } - -(** {2 String_of data} *) -let kind_to_string = function - | K_Transaction -> "Transaction" - | K_Delegation -> "Delegation" - | K_Undelegation -> "Undelegation" - | K_Self_delegation -> "Self-delegation" - | K_Set_deposits_limit -> "Set deposits limit" - | K_Update_consensus_key -> "Update consensus key" - | K_Origination -> "Origination" - | K_Register_global_constant -> "Register global constant" - | K_Increase_paid_storage -> "Increase paid storage" - | K_Reveal -> "Revelation" - | K_Transfer_ticket -> "Transfer_ticket" - | K_Sc_rollup_origination -> "Sc_rollup_origination" - | K_Sc_rollup_publish -> "Sc_rollup_publish" - | K_Sc_rollup_cement -> "Sc_rollup_cement" - | K_Sc_rollup_timeout -> "Sc_rollup_timeout" - | K_Sc_rollup_refute -> "Sc_rollup_refute" - | K_Sc_rollup_add_messages -> "Sc_rollup_add_messages" - | K_Sc_rollup_execute_outbox_message -> "Sc_rollup_execute_outbox_message" - | K_Sc_rollup_recover_bond -> "Sc_rollup_recover_bond" - | K_Dal_publish_slot_header -> "Dal_publish_slot_header" - | K_Zk_rollup_origination -> "Zk_rollup_origination" - | K_Zk_rollup_publish -> "Zk_rollup_publish" - | K_Zk_rollup_update -> "Zk_rollup_update" - -(** {2 Pretty-printers} *) -let pp_opt pp v = - let open Format in - pp_print_option ~none:(fun fmt () -> fprintf fmt "None") pp v - -let pp_operation_req pp - {kind; counter; fee; gas_limit; storage_limit; force_reveal; amount} = - Format.fprintf - pp - "@[Operation_req:@,\ - kind: %s@,\ - counter: %a@,\ - fee: %a@,\ - gas_limit: %a@,\ - storage_limit: %a@,\ - force_reveal: %a@,\ - amount: %a@,\ - @]" - (kind_to_string kind) - (pp_opt Manager_counter.pp) - counter - (pp_opt Tez.pp) - fee - (pp_opt Op.pp_gas_limit) - gas_limit - (pp_opt Z.pp_print) - storage_limit - (pp_opt (fun fmt -> Format.fprintf fmt "%b")) - force_reveal - (pp_opt Tez.pp) - amount - -let pp_2_operation_req pp (op_req1, op_req2) = - Format.fprintf - pp - "[ %a,@ and %a,@ @]" - pp_operation_req - op_req1 - pp_operation_req - op_req2 - -let pp_ctxt_req pp - { - hard_gas_limit_per_block; - fund_src; - fund_dest; - fund_del; - reveal_accounts; - fund_sc; - fund_zk; - flags; - } = - Format.fprintf - pp - "@[Ctxt_req:@,\ - hard_gas_limit_per_block:%a@,\ - fund_src: %a tz@,\ - fund_dest: %a tz@,\ - fund_del: %a tz@,\ - reveal_accounts: %b tz@,\ - fund_sc: %a tz@,\ - fund_zk: %a tz@,\ - dal_flag: %a@,\ - scoru_flag: %a@,\ - toru_flag: %a@,\ - zkru_flag: %a@,\ - @]" - (pp_opt Gas.Arith.pp_integral) - hard_gas_limit_per_block - (pp_opt Tez.pp) - fund_src - (pp_opt Tez.pp) - fund_dest - (pp_opt Tez.pp) - fund_del - reveal_accounts - (pp_opt Tez.pp) - fund_sc - (pp_opt Tez.pp) - fund_zk - Format.pp_print_bool - flags.dal - Format.pp_print_bool - flags.scoru - Format.pp_print_bool - flags.toru - Format.pp_print_bool - flags.zkru - -let pp_mode pp = function - | Construction -> Format.fprintf pp "Construction" - | Mempool -> Format.fprintf pp "Mempool" - | Application -> Format.fprintf pp "Block" - -(** {2 Short-cuts} *) -let contract_of (account : Account.t) = Contract.Implicit account.pkh - -(** Make a [mempool_mode], aka a boolean, as used in incremental from - a [mode]. *) -let mempool_mode_of = function Mempool -> true | _ -> false - -let get_pk infos source = - let open Lwt_result_syntax in - let+ account = Context.Contract.manager infos source in - account.pk - -(** Operation for specific context. *) -let self_delegate block pkh = - let open Lwt_result_syntax in - let contract = Contract.Implicit pkh in - let* operation = - Op.delegation ~force_reveal:true (B block) contract (Some pkh) - in - let* block = Block.bake block ~operation in - let* del_opt_new = Context.Contract.delegate_opt (B block) contract in - let* del = Assert.get_some ~loc:__LOC__ del_opt_new in - let+ () = Assert.equal_pkh ~loc:__LOC__ del pkh in - block - -let delegation block source delegate = - let open Lwt_result_syntax in - let delegate_pkh = delegate.Account.pkh in - let contract_source = contract_of source in - let* operation = - Op.delegation - ~force_reveal:true - (B block) - contract_source - (Some delegate_pkh) - in - let* block = Block.bake block ~operation in - let* del_opt_new = Context.Contract.delegate_opt (B block) contract_source in - let* del = Assert.get_some ~loc:__LOC__ del_opt_new in - let* () = Assert.equal_pkh ~loc:__LOC__ del delegate_pkh in - return block - -let originate_sc_rollup block rollup_account = - let open Lwt_result_syntax in - let rollup_contract = contract_of rollup_account in - let kind = Sc_rollup.Kind.Example_arith in - let* rollup_origination, sc_rollup = - Sc_rollup_helpers.origination_op - ~force_reveal:true - (B block) - rollup_contract - kind - in - let+ block = - Block.bake ~allow_manager_failures:true ~operation:rollup_origination block - in - (block, sc_rollup) - -module ZKOperator = Dummy_zk_rollup.Operator (struct - let batch_size = 10 -end) - -let originate_zk_rollup block rollup_account = - let open Lwt_result_syntax in - let rollup_contract = contract_of rollup_account in - let _prover_pp, public_parameters = Lazy.force ZKOperator.lazy_pp in - let* rollup_origination, zk_rollup = - Op.zk_rollup_origination - ~force_reveal:true - (B block) - rollup_contract - ~public_parameters - ~circuits_info: - (Zk_rollup.Account.SMap.of_seq @@ Kzg.SMap.to_seq ZKOperator.circuits) - ~init_state:ZKOperator.init_state - ~nb_ops:1 - in - let+ block = - Block.bake ~allow_manager_failures:true ~operation:rollup_origination block - in - (block, zk_rollup) - -(** {2 Setting's context construction} *) - -let fund_account_op block bootstrap account fund counter = - let open Lwt_result_syntax in - let* fund = - match fund with - | None -> return Tez.one - | Some fund -> - let* source_balance = Context.Contract.balance (B block) bootstrap in - if Tez.(fund > source_balance) then - Lwt.return (Environment.wrap_tzresult Tez.(source_balance -? one)) - else return fund - in - let+ op = - Op.transaction - ~counter - ~gas_limit:Op.High - (B block) - bootstrap - (Contract.Implicit account) - fund - in - (op, Manager_counter.succ counter) - -let fund_account block bootstrap account fund = - let open Lwt_result_syntax in - let* counter = Context.Contract.counter (B block) bootstrap in - let* operation, (_counter : Manager_counter.t) = - fund_account_op block bootstrap account fund counter - in - let*! b = Block.bake ~operation block in - match b with Error _ -> failwith "Funding account error" | Ok b -> return b - -(** Set the constants according to a [ctxt_req] in an existing parameters. *) -let manager_parameters : Parameters.t -> ctxt_req -> Parameters.t = - fun params {hard_gas_limit_per_block; flags; _} -> - let hard_gas_limit_per_block = - match hard_gas_limit_per_block with - | Some gb -> gb - | None -> Gas.Arith.(integral_of_int_exn 5_200_000) - in - let dal = {params.constants.dal with feature_enable = flags.dal} in - let tx_rollup = - { - params.constants.tx_rollup with - sunset_level = Int32.max_int; - enable = flags.toru; - } - in - let sc_rollup = - { - params.constants.sc_rollup with - enable = flags.scoru; - arith_pvm_enable = flags.scoru; - } - in - let zk_rollup = {params.constants.zk_rollup with enable = flags.zkru} in - let constants = - { - params.constants with - hard_gas_limit_per_block; - dal; - tx_rollup; - zk_rollup; - sc_rollup; - } - in - {params with constants} - -(** Initialize a context with the constants extracted from a context requirements - and 7 bootstrap accounts. *) -let init_ctxt_only ctxtreq = - let open Lwt_result_syntax in - let initial_params = - Tezos_protocol_017_PtNairob_parameters.Default_parameters - .parameters_of_constants - {Context.default_test_constants with consensus_threshold = 0} - in - let*? _cryptobox = - Dal_helpers.mk_cryptobox initial_params.constants.dal.cryptobox_parameters - in - let* block, contracts = - Context.init_with_parameters_n (manager_parameters initial_params ctxtreq) 7 - in - return - ( block, - List.map - (function Contract.Implicit pkh -> pkh | Originated _ -> assert false) - contracts ) - -(** Build a generic setting for a test according to a context requirement - on an existing context with 7 bootstraps accounts. *) -let init_infos : - ctxt_req -> Block.t -> public_key_hash list -> infos tzresult Lwt.t = - fun ctxtreq block bootstraps -> - let { - fund_src; - fund_dest; - fund_del; - fund_sc; - fund_zk; - flags; - reveal_accounts; - _; - } = - ctxtreq - in - let open Lwt_result_syntax in - let create_and_fund ?originate_rollup block bootstrap fund = - match fund with - | None -> return (block, None, None) - | Some _ -> - let account = Account.new_account () in - let* block = fund_account block bootstrap account.pkh fund in - let* block, rollup = - match originate_rollup with - | None -> return (block, None) - | Some f -> - let+ block, rollup = f block account in - (block, Some rollup) - in - return (block, Some account, rollup) - in - let reveal_accounts_operations b l = - List.filter_map_es - (function - | None -> return_none - | Some account -> - let* op = Op.revelation ~gas_limit:Low (B b) account.Account.pk in - return_some op) - l - in - let get_bootstrap bootstraps n = - Contract.Implicit (Stdlib.List.nth bootstraps n) - in - let source = Account.new_account () in - let* block = - fund_account block (get_bootstrap bootstraps 0) source.pkh fund_src - in - let* block, dest, _ = - create_and_fund block (get_bootstrap bootstraps 1) fund_dest - in - let* block, del, _ = - create_and_fund block (get_bootstrap bootstraps 2) fund_del - in - let* block, sc, sc_rollup = - if flags.scoru then - create_and_fund - ~originate_rollup:originate_sc_rollup - block - (get_bootstrap bootstraps 4) - fund_sc - else return (block, None, None) - in - let* block, zk, zk_rollup = - if flags.zkru then - create_and_fund - ~originate_rollup:originate_zk_rollup - block - (get_bootstrap bootstraps 5) - fund_zk - else return (block, None, None) - in - let* create_contract_hash, originated_contract = - Op.contract_origination_hash - (B block) - (get_bootstrap bootstraps 6) - ~fee:Tez.zero - ~script:Op.dummy_script - in - let* reveal_operations = - if reveal_accounts then - reveal_accounts_operations block [Some source; dest; del] - else return [] - in - let operations = create_contract_hash :: reveal_operations in - let+ block = Block.bake ~operations block in - let ctxt = - { - block; - bootstraps; - originated_contract = Some originated_contract; - sc_rollup; - zk_rollup; - } - in - {ctxt; accounts = {sources = [source]; dest; del; sc; zk}; flags} - -(** The generic setting for a test is built up according to a context - requirement. It provides a context and accounts where the accounts - have been created and funded according to the context - requirements.*) -let init_ctxt : ctxt_req -> infos tzresult Lwt.t = - fun ctxtreq -> - let open Lwt_result_syntax in - let* block, bootstraps = init_ctxt_only ctxtreq in - init_infos ctxtreq block bootstraps - -(** return the first source from the list of sources in [infos] accounts. *) -let get_source infos = - match infos.accounts.sources with source :: _ -> source | [] -> assert false - -(** In addition of building up a context according to a context - requirement, source is self-delegated. - - see [init_ctxt] description. *) -let ctxt_with_self_delegation : ctxt_req -> infos tzresult Lwt.t = - fun ctxt_req -> - let open Lwt_result_syntax in - let* infos = init_ctxt ctxt_req in - let+ block = self_delegate infos.ctxt.block (get_source infos).pkh in - let ctxt = {infos.ctxt with block} in - {infos with ctxt} - -(** In addition of building up a context accordning to a context - requirement, source delegates to del. - - See [init_ctxt] description. *) -let ctxt_with_delegation : ctxt_req -> infos tzresult Lwt.t = - fun ctxt_req -> - let open Lwt_result_syntax in - let* infos = init_ctxt ctxt_req in - let* delegate = - match infos.accounts.del with - | None -> failwith "Delegate account should be funded" - | Some a -> return a - in - let* block = delegation infos.ctxt.block delegate delegate in - let+ block = delegation block (get_source infos) delegate in - let ctxt = {infos.ctxt with block} in - {infos with ctxt} - -let default_init_ctxt () = init_ctxt ctxt_req_default - -let default_init_with_flags flags = init_ctxt (ctxt_req_default_to_flag flags) - -let default_ctxt_with_self_delegation () = - ctxt_with_self_delegation ctxt_req_default - -let default_ctxt_with_delegation () = ctxt_with_delegation ctxt_req_default - -(** {2 Smart constructors} *) - -(** Smart constructors to forge manager operations according to - operation requirements in a test setting. *) - -let mk_transaction (oinfos : operation_req) (infos : infos) = - Op.transaction - ?force_reveal:oinfos.force_reveal - ?counter:oinfos.counter - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?storage_limit:oinfos.storage_limit - (B infos.ctxt.block) - (contract_of (get_source infos)) - (contract_of - (match infos.accounts.dest with - | None -> get_source infos - | Some dest -> dest)) - (match oinfos.amount with None -> Tez.zero | Some amount -> amount) - -let mk_delegation (oinfos : operation_req) (infos : infos) = - Op.delegation - ?force_reveal:oinfos.force_reveal - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?counter:oinfos.counter - ?storage_limit:oinfos.storage_limit - (B infos.ctxt.block) - (contract_of (get_source infos)) - (Some - (match infos.accounts.del with - | None -> (get_source infos).pkh - | Some delegate -> delegate.pkh)) - -let mk_undelegation (oinfos : operation_req) (infos : infos) = - Op.delegation - ?force_reveal:oinfos.force_reveal - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?counter:oinfos.counter - ?storage_limit:oinfos.storage_limit - (B infos.ctxt.block) - (contract_of (get_source infos)) - None - -let mk_self_delegation (oinfos : operation_req) (infos : infos) = - Op.delegation - ?force_reveal:oinfos.force_reveal - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?counter:oinfos.counter - ?storage_limit:oinfos.storage_limit - (B infos.ctxt.block) - (contract_of (get_source infos)) - (Some (get_source infos).pkh) - -let mk_origination (oinfos : operation_req) (infos : infos) = - let open Lwt_result_syntax in - let+ op, _ = - Op.contract_origination - ?force_reveal:oinfos.force_reveal - ?counter:oinfos.counter - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?storage_limit:oinfos.storage_limit - ~script:Op.dummy_script - (B infos.ctxt.block) - (contract_of (get_source infos)) - in - op - -let mk_register_global_constant (oinfos : operation_req) (infos : infos) = - Op.register_global_constant - ?force_reveal:oinfos.force_reveal - ?counter:oinfos.counter - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?storage_limit:oinfos.storage_limit - (B infos.ctxt.block) - ~source:(contract_of (get_source infos)) - ~value:(Script_repr.lazy_expr (Expr.from_string "Pair 1 2")) - -let mk_set_deposits_limit (oinfos : operation_req) (infos : infos) = - Op.set_deposits_limit - ?force_reveal:oinfos.force_reveal - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?storage_limit:oinfos.storage_limit - ?counter:oinfos.counter - (B infos.ctxt.block) - (contract_of (get_source infos)) - None - -let mk_update_consensus_key (oinfos : operation_req) (infos : infos) = - Op.update_consensus_key - ?force_reveal:oinfos.force_reveal - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?storage_limit:oinfos.storage_limit - ?counter:oinfos.counter - (B infos.ctxt.block) - (contract_of (get_source infos)) - (match infos.accounts.dest with - | None -> (get_source infos).pk - | Some dest -> dest.pk) - -let mk_increase_paid_storage (oinfos : operation_req) (infos : infos) = - let open Lwt_result_syntax in - let* destination = - match infos.ctxt.originated_contract with - | None -> - failwith - "infos should be initialized with an origniated contract to be able \ - to add an increase_paid_storage operation." - | Some c -> return c - in - Op.increase_paid_storage - ?force_reveal:oinfos.force_reveal - ?counter:oinfos.counter - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?storage_limit:oinfos.storage_limit - (B infos.ctxt.block) - ~source:(contract_of (get_source infos)) - ~destination - Z.one - -let mk_reveal (oinfos : operation_req) (infos : infos) = - let open Lwt_result_syntax in - let* pk = get_pk (B infos.ctxt.block) (contract_of (get_source infos)) in - Op.revelation - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?counter:oinfos.counter - ?storage_limit:oinfos.storage_limit - (B infos.ctxt.block) - pk - -let sc_rollup_of = function - | Some sc_rollup -> return sc_rollup - | None -> failwith "Sc_rollup not created in this context" - -let zk_rollup_of = function - | Some zk_rollup -> return zk_rollup - | None -> failwith "Zk_rollup not created in this context" - -let mk_transfer_ticket (oinfos : operation_req) (infos : infos) = - Op.transfer_ticket - ?fee:oinfos.fee - ?force_reveal:oinfos.force_reveal - ?counter:oinfos.counter - ?gas_limit:oinfos.gas_limit - ?storage_limit:oinfos.storage_limit - (B infos.ctxt.block) - ~source:(contract_of (get_source infos)) - ~contents:(Script.lazy_expr (Expr.from_string "1")) - ~ty:(Script.lazy_expr (Expr.from_string "nat")) - ~ticketer: - (contract_of - (match infos.accounts.sc with - | None -> get_source infos - | Some tx -> tx)) - ~amount:Ticket_amount.one - ~destination: - (contract_of - (match infos.accounts.dest with - | None -> get_source infos - | Some dest -> dest)) - ~entrypoint:Entrypoint.default - -let mk_sc_rollup_origination (oinfos : operation_req) (infos : infos) = - let open Lwt_result_syntax in - let+ op, _ = - let kind = Sc_rollup.Kind.Example_arith in - Sc_rollup_helpers.origination_op - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?counter:oinfos.counter - ?storage_limit:oinfos.storage_limit - ?force_reveal:oinfos.force_reveal - (B infos.ctxt.block) - (contract_of (get_source infos)) - kind - in - op - -let sc_dummy_commitment = - let number_of_ticks = - match Sc_rollup.Number_of_ticks.of_value 3000L with - | None -> assert false - | Some x -> x - in - Sc_rollup.Commitment. - { - predecessor = Sc_rollup.Commitment.Hash.zero; - inbox_level = Raw_level.of_int32_exn Int32.zero; - number_of_ticks; - compressed_state = Sc_rollup.State_hash.zero; - } - -let mk_sc_rollup_publish (oinfos : operation_req) (infos : infos) = - let open Lwt_result_syntax in - let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in - Op.sc_rollup_publish - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?counter:oinfos.counter - ?storage_limit:oinfos.storage_limit - ?force_reveal:oinfos.force_reveal - (B infos.ctxt.block) - (contract_of (get_source infos)) - sc_rollup - sc_dummy_commitment - -let mk_sc_rollup_cement (oinfos : operation_req) (infos : infos) = - let open Lwt_result_syntax in - let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in - Op.sc_rollup_cement - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?counter:oinfos.counter - ?storage_limit:oinfos.storage_limit - ?force_reveal:oinfos.force_reveal - (B infos.ctxt.block) - (contract_of (get_source infos)) - sc_rollup - (Sc_rollup.Commitment.hash_uncarbonated sc_dummy_commitment) - -let mk_sc_rollup_refute (oinfos : operation_req) (infos : infos) = - let open Lwt_result_syntax in - let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in - let refutation : Sc_rollup.Game.refutation = - Move {choice = Sc_rollup.Tick.initial; step = Dissection []} - in - Op.sc_rollup_refute - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?counter:oinfos.counter - ?storage_limit:oinfos.storage_limit - ?force_reveal:oinfos.force_reveal - (B infos.ctxt.block) - (contract_of (get_source infos)) - sc_rollup - (match infos.accounts.dest with - | None -> (get_source infos).pkh - | Some dest -> dest.pkh) - refutation - -let mk_sc_rollup_add_messages (oinfos : operation_req) (infos : infos) = - Op.sc_rollup_add_messages - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?counter:oinfos.counter - ?storage_limit:oinfos.storage_limit - ?force_reveal:oinfos.force_reveal - (B infos.ctxt.block) - (contract_of (get_source infos)) - [""] - -let mk_sc_rollup_timeout (oinfos : operation_req) (infos : infos) = - let open Lwt_result_syntax in - let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in - Op.sc_rollup_timeout - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?counter:oinfos.counter - ?storage_limit:oinfos.storage_limit - ?force_reveal:oinfos.force_reveal - (B infos.ctxt.block) - (contract_of (get_source infos)) - sc_rollup - (Sc_rollup.Game.Index.make - (get_source infos).pkh - (match infos.accounts.dest with - | None -> (get_source infos).pkh - | Some dest -> dest.pkh)) - -let mk_sc_rollup_execute_outbox_message (oinfos : operation_req) (infos : infos) - = - let open Lwt_result_syntax in - let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in - Op.sc_rollup_execute_outbox_message - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?counter:oinfos.counter - ?storage_limit:oinfos.storage_limit - ?force_reveal:oinfos.force_reveal - (B infos.ctxt.block) - (contract_of (get_source infos)) - sc_rollup - (Sc_rollup.Commitment.hash_uncarbonated sc_dummy_commitment) - ~output_proof:"" - -let mk_sc_rollup_return_bond (oinfos : operation_req) (infos : infos) = - let open Lwt_result_syntax in - let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in - let source, staker = - match contract_of (get_source infos) with - | Implicit staker as source -> (source, staker) - | _ -> assert false - in - Op.sc_rollup_recover_bond - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?counter:oinfos.counter - ?storage_limit:oinfos.storage_limit - ?force_reveal:oinfos.force_reveal - (B infos.ctxt.block) - source - sc_rollup - staker - -let mk_dal_publish_slot_header (oinfos : operation_req) (infos : infos) = - let published_level = - Alpha_context.Raw_level.succ - @@ Alpha_context.Raw_level.of_int32_exn infos.ctxt.block.header.shell.level - in - let slot_index = Alpha_context.Dal.Slot_index.zero in - let commitment = Alpha_context.Dal.Slot.Commitment.zero in - let commitment_proof = Alpha_context.Dal.Slot.Commitment_proof.zero in - let slot = - Dal.Operations.Publish_slot_header. - {published_level; slot_index; commitment; commitment_proof} - in - Op.dal_publish_slot_header - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?counter:oinfos.counter - ?storage_limit:oinfos.storage_limit - ?force_reveal:oinfos.force_reveal - (B infos.ctxt.block) - (contract_of (get_source infos)) - slot - -let mk_zk_rollup_origination (oinfos : operation_req) (infos : infos) = - let open Lwt_result_syntax in - let _prover_pp, public_parameters = Lazy.force ZKOperator.lazy_pp in - let* op, _ = - Op.zk_rollup_origination - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?counter:oinfos.counter - ?storage_limit:oinfos.storage_limit - ?force_reveal:oinfos.force_reveal - (B infos.ctxt.block) - (contract_of (get_source infos)) - ~public_parameters - ~circuits_info: - (Zk_rollup.Account.SMap.of_seq @@ Kzg.SMap.to_seq ZKOperator.circuits) - ~init_state:ZKOperator.init_state - ~nb_ops:1 - in - return op - -let mk_zk_rollup_publish (oinfos : operation_req) (infos : infos) = - let open Lwt_result_syntax in - let open Zk_rollup.Operation in - let* zk_rollup = zk_rollup_of infos.ctxt.zk_rollup in - let l2_op = - {ZKOperator.Internal_for_tests.false_op with rollup_id = zk_rollup} - in - let* op = - Op.zk_rollup_publish - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?counter:oinfos.counter - ?storage_limit:oinfos.storage_limit - ?force_reveal:oinfos.force_reveal - (B infos.ctxt.block) - (contract_of (get_source infos)) - ~zk_rollup - ~ops:[(l2_op, None)] - in - return op - -let mk_zk_rollup_update (oinfos : operation_req) (infos : infos) = - let open Lwt_result_syntax in - let* zk_rollup = zk_rollup_of infos.ctxt.zk_rollup in - let update = Lazy.force ZKOperator.Internal_for_tests.lazy_update_data in - let* op = - Op.zk_rollup_update - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?counter:oinfos.counter - ?storage_limit:oinfos.storage_limit - ?force_reveal:oinfos.force_reveal - (B infos.ctxt.block) - (contract_of (get_source infos)) - ~zk_rollup - ~update - in - return op - -(** {2 Helpers for generation of generic check tests by manager operation} *) - -(** Generic forge for any kind of manager operation according to - operation requirements in a specific test setting. *) -let select_op (op_req : operation_req) (infos : infos) = - let mk_op = - match op_req.kind with - | K_Transaction -> mk_transaction - | K_Origination -> mk_origination - | K_Register_global_constant -> mk_register_global_constant - | K_Delegation -> mk_delegation - | K_Undelegation -> mk_undelegation - | K_Self_delegation -> mk_self_delegation - | K_Set_deposits_limit -> mk_set_deposits_limit - | K_Update_consensus_key -> mk_update_consensus_key - | K_Increase_paid_storage -> mk_increase_paid_storage - | K_Reveal -> mk_reveal - | K_Transfer_ticket -> mk_transfer_ticket - | K_Sc_rollup_origination -> mk_sc_rollup_origination - | K_Sc_rollup_publish -> mk_sc_rollup_publish - | K_Sc_rollup_cement -> mk_sc_rollup_cement - | K_Sc_rollup_refute -> mk_sc_rollup_refute - | K_Sc_rollup_add_messages -> mk_sc_rollup_add_messages - | K_Sc_rollup_timeout -> mk_sc_rollup_timeout - | K_Sc_rollup_execute_outbox_message -> mk_sc_rollup_execute_outbox_message - | K_Sc_rollup_recover_bond -> mk_sc_rollup_return_bond - | K_Dal_publish_slot_header -> mk_dal_publish_slot_header - | K_Zk_rollup_origination -> mk_zk_rollup_origination - | K_Zk_rollup_publish -> mk_zk_rollup_publish - | K_Zk_rollup_update -> mk_zk_rollup_update - in - mk_op op_req infos - -let make_tztest ?(fmt = Format.std_formatter) name test subjects info_builder = - let open Lwt_result_syntax in - Tztest.tztest name `Quick (fun () -> - let* infos = info_builder () in - List.iter_es - (fun kind -> - Format.fprintf fmt "%s: %s@." name (kind_to_string kind) ; - test infos kind) - subjects) - -let make_tztest_batched ?(fmt = Format.std_formatter) name test subjects - info_builder = - let open Lwt_result_syntax in - Tztest.tztest name `Quick (fun () -> - let* infos = info_builder () in - List.iter_es - (fun kind1 -> - let k1s = kind_to_string kind1 in - List.iter_es - (fun kind2 -> - Format.fprintf - fmt - "%s: [%s ; %s]@." - name - k1s - (kind_to_string kind2) ; - test infos kind1 kind2) - subjects) - subjects) - -(** {2 Diagnostic helpers.} *) - -(** The purpose of diagnostic helpers is to state the correct - observation according to the validate result of a test. *) - -(** For a manager operation a [probes] contains the values required - for observing its validate success. Its source, fees (sum for a - batch), gas_limit (sum of gas_limit of the batch), and the - increment of the counters aka 1 for a single operation, n for a - batch of n manager operations. *) -type probes = { - source : Signature.Public_key_hash.t; - fee : Tez.tez; - gas_limit : Gas.Arith.integral; - nb_counter : int; -} - -let rec contents_infos : - type kind. kind Kind.manager contents_list -> probes tzresult Lwt.t = - fun op -> - let open Lwt_result_syntax in - match op with - | Single (Manager_operation {source; fee; gas_limit; _}) -> - return {source; fee; gas_limit; nb_counter = 1} - | Cons (Manager_operation manop, manops) -> - let* probes = contents_infos manops in - let*? fee = manop.fee +? probes.fee in - let gas_limit = Gas.Arith.add probes.gas_limit manop.gas_limit in - let nb_counter = succ probes.nb_counter in - let* () = Assert.equal_pkh ~loc:__LOC__ manop.source probes.source in - return {fee; source = probes.source; gas_limit; nb_counter} - -(** Computes a [probes] from a list of manager contents. *) -let manager_content_infos op = - let (Operation_data {contents; _}) = op.protocol_data in - match contents with - | Single (Manager_operation _) as op -> contents_infos op - | Cons (Manager_operation _, _) as op -> contents_infos op - | _ -> failwith "Should only handle manager operation" - -(** We need a way to get the available gas in a context of type - block. *) -let available_gas = function - | Context.I inc -> Some (Gas.block_level (Incremental.alpha_ctxt inc)) - | B _ -> None - -(** Computes the witness value in a state. The witness values are the - the initial balance of source, its initial counter and the - available gas in the state. The available gas is computed only - when the context is an incremental one. *) -let witness ctxt source = - let open Lwt_result_syntax in - let* b_in = Context.Contract.balance ctxt source in - let* c_in = Context.Contract.counter ctxt source in - let g_in = available_gas ctxt in - return (b_in, c_in, g_in) - -(** According to the witness in pre-state and the probes, computes the - expected outputs. In any mode, when the source is not deallocated, - the expected witness: - - the balance of source should be the one in the pre-state minus - the fee of probes, - - the counter of source should be the one in the pre-state plus - the number of counter in probes. - - Concerning the expected available gas in the block: - - In [Application] mode, it cannot be computed, so we do not expect - any, - - In [Mempool] mode, it is the remaining gas after removing the gas - of probes gas from an empty block, - - In the [Construction] mode, it is the remaining gas after removing - the gas of probes from the available gas in the pre-state.*) -let expected_witness witness probes ~mode ctxt = - let open Lwt_result_syntax in - let b_in, c_in, g_in = witness in - let*? b_expected = b_in -? probes.fee in - let c_expected = - Manager_counter.Internal_for_tests.add c_in probes.nb_counter - in - let* g_expected = - match (g_in, mode) with - | Some g_in, Construction -> - return_some (Gas.Arith.sub g_in (Gas.Arith.fp probes.gas_limit)) - | _, Mempool -> - Context.get_constants ctxt >>=? fun c -> - return_some - (Gas.Arith.sub - (Gas.Arith.fp c.parametric.hard_gas_limit_per_block) - (Gas.Arith.fp probes.gas_limit)) - | None, Application -> return_none - | Some _, Application -> - failwith "In application mode witness should not care about gas level" - | None, Construction -> - failwith "In Construction mode the witness should return a gas level" - in - return (b_expected, c_expected, g_expected) - -(** The validity of a test in positve case, observes that validation - of a manager operation implies the fee payment. This observation - differs according to the validation calling [mode] (see type mode - for more details) and that the [source] has been [deallocated]. - Given the values of witness in the pre-state, the probes of the - operation probes and the values of witness in the post-state, if - the validation succeeds while deallocating the [source], [source] - must be unallocated in the post-state. - - In case of successful validation Without deallocation, then we - observe in the post-state: - - The balance of source decreases at least by fee of probes when the - application has succeeded, - - Its counter in the pre-state increases by the number of counter of - probes. - - The remaining gas in the pre-state decreases at least by the gas - of probes, in [Construction] and [Mempool] mode. - - In [Mempool] mode, the remaining gas in the pre-state is always - the available gas in an empty block. - - In the [Application] mode, we do not perform any check on the - available gas. *) -let observe ~mode ~deallocated ctxt_pre ctxt_post op = - let open Lwt_result_syntax in - let check_deallocated ctxt contract = - let* actxt = - let+ i = - match ctxt with - | Context.B b -> Incremental.begin_construction b - | I i -> return i - in - Incremental.alpha_ctxt i - in - let*! res = Contract.must_be_allocated actxt contract in - match Environment.wrap_tzresult res with - | Ok () -> - failwith - "%a should have been deallocated@." - Signature.Public_key_hash.pp - (Context.Contract.pkh contract) - | Error - [ - Environment.Ecoproto_error (Contract_storage.Empty_implicit_contract _); - ] -> - return_unit - | Error errs -> - failwith "unexpected error, got %a@." Error_monad.pp_print_trace errs - in - let check_still_allocated ctxt_pre ctxt_post probes contract = - let* witness_in = witness ctxt_pre contract in - let* b_out, c_out, g_out = witness ctxt_post contract in - let* b_expected, c_expected, g_expected = - expected_witness witness_in probes ~mode ctxt_post - in - let b_cmp = - Assert.equal - ~loc:__LOC__ - Tez.( <= ) - "Balance decreases at least by fees" - Tez.pp - in - let* () = b_cmp b_out b_expected in - let* () = - Assert.equal - Manager_counter.equal - ~loc:__LOC__ - "Counter incrementation" - Manager_counter.pp - c_out - c_expected - in - let g_msg = - match mode with - | Application -> "Gas consumption (application)" - | Mempool -> "Gas consumption (mempool)" - | Construction -> "Gas consumption (construction)" - in - match g_expected with - | None -> Assert.is_none ~loc:__LOC__ ~pp:Gas.Arith.pp g_out - | Some g_expected -> - let* g_out = Assert.get_some ~loc:__LOC__ g_out in - Assert.equal - ~loc:__LOC__ - Gas.Arith.( <= ) - g_msg - Gas.Arith.pp - g_out - g_expected - in - let* probes = manager_content_infos op in - let contract = Contract.Implicit probes.source in - if deallocated then check_deallocated ctxt_post contract - else check_still_allocated ctxt_pre ctxt_post probes contract - -let observe_list ~mode ~deallocated ctxt_pre ctxt_post ops = - List.iter_es (fun op -> observe ~mode ~deallocated ctxt_pre ctxt_post op) ops - -let validate_operations_effects inc_in ops = - let open Lwt_result_syntax in - List.fold_left_es - (fun inc op -> - let* inc_out = - Incremental.add_operation ~allow_manager_failure:true inc op - in - return inc_out) - inc_in - ops - -(** In [Construction] and [Mempool] mode, the pre-state provide an - incremental, whereas in the [Application] mode, it is the block in - the setting context of the test. *) -let pre_state_of_mode ~mode infos = - let open Lwt_result_syntax in - match mode with - | Construction | Mempool -> - let* inc = Incremental.begin_construction infos.ctxt.block in - return (Context.I inc) - | Application -> return (Context.B infos.ctxt.block) - -(** In [Construction] and [Mempool] mode, the post-state is - incrementally built upon a pre-state, whereas in the [Application] - mode it is obtained by baking. *) -let post_state_of_mode ?(_only_validate = false) ~mode ctxt ops infos = - let open Lwt_result_syntax in - match (mode, ctxt) with - | (Construction | Mempool), Context.I inc_pre -> - let* inc_post = validate_operations_effects inc_pre ops in - let* block = Incremental.finalize_block inc_post in - return (Context.I inc_post, {infos with ctxt = {infos.ctxt with block}}) - | Application, Context.B b -> - let+ block = - Block.bake - ~allow_manager_failures:true - ~baking_mode:Application - ~operations:ops - b - in - (Context.B block, {infos with ctxt = {infos.ctxt with block}}) - | Application, Context.I _ -> - failwith "In Application mode, context should not be an Incremental" - | (Construction | Mempool), Context.B _ -> - failwith "In (Partial) Contruction mode, context should not be a Block" - -(** A positive test builds a pre-state from a mode, and a setting - context, then it computes a post-state from the mode, the setting - context and the operations. Finally, it observes the result - according to the [emptying] status for each operation. - - See [observe] for more details on the observational validation. - If the operation validation succeeds but should be deallocated, - then [deallocated ] must be set. - - Default mode is [Construction]. *) -let validate_diagnostic ?(deallocated = false) ?(mode = Construction) - (infos : infos) ops = - let open Lwt_result_syntax in - let* ctxt_pre = pre_state_of_mode ~mode infos in - let* ctxt_post, infos = post_state_of_mode ~mode ctxt_pre ops infos in - let* () = observe_list ~mode ~deallocated ctxt_pre ctxt_post ops in - return infos - -let add_operations ~expect_failure inc_in ops = - let open Lwt_result_syntax in - let* last, ops = - match List.rev ops with - | op :: rev_ops -> return (op, List.rev rev_ops) - | [] -> failwith "Empty list of operations given to add_operations" - in - let* inc = - List.fold_left_es - (fun inc op -> - let* inc = Incremental.validate_operation inc op in - return inc) - inc_in - ops - in - Incremental.validate_operation inc last ~expect_failure - -(** [validate_ko_diagnostic] wraps the [expect_failure] when [op] - validate failed. It is used in test that expects validate of the - last operation of a list of operations to fail. *) -let validate_ko_diagnostic ?(mode = Construction) (infos : infos) ops - expect_failure = - let open Lwt_result_syntax in - match mode with - | Construction | Mempool -> - let* i = - Incremental.begin_construction - infos.ctxt.block - ~mempool_mode:(mempool_mode_of mode) - in - let* (_ : Incremental.t) = add_operations ~expect_failure i ops in - return_unit - | Application -> ( - let*! res = - Block.bake - ~allow_manager_failures:true - ~baking_mode:Application - ~operations:ops - infos.ctxt.block - in - match res with - | Error tr -> expect_failure tr - | _ -> failwith "Block application was expected to fail") - -(** List of operation kinds that must run on generic tests. This list - should be extended for each new manager_operation kind. *) -let subjects = - [ - K_Transaction; - K_Origination; - K_Register_global_constant; - K_Delegation; - K_Undelegation; - K_Self_delegation; - K_Set_deposits_limit; - K_Update_consensus_key; - K_Increase_paid_storage; - K_Reveal; - K_Transfer_ticket; - K_Sc_rollup_origination; - K_Sc_rollup_publish; - K_Sc_rollup_cement; - K_Sc_rollup_add_messages; - K_Sc_rollup_refute; - K_Sc_rollup_timeout; - K_Sc_rollup_execute_outbox_message; - K_Sc_rollup_recover_bond; - K_Dal_publish_slot_header; - K_Zk_rollup_origination; - K_Zk_rollup_publish; - K_Zk_rollup_update; - ] - -let is_consumer = function - | K_Set_deposits_limit | K_Update_consensus_key | K_Increase_paid_storage - | K_Reveal | K_Self_delegation | K_Delegation | K_Undelegation - | K_Sc_rollup_add_messages | K_Sc_rollup_origination | K_Sc_rollup_refute - | K_Sc_rollup_timeout | K_Sc_rollup_cement | K_Sc_rollup_publish - | K_Sc_rollup_execute_outbox_message | K_Sc_rollup_recover_bond - | K_Dal_publish_slot_header | K_Zk_rollup_origination | K_Zk_rollup_publish - | K_Zk_rollup_update -> - false - | K_Transaction | K_Origination | K_Register_global_constant - | K_Transfer_ticket -> - true - -let gas_consumer_in_validate_subjects, not_gas_consumer_in_validate_subjects = - List.partition is_consumer subjects - -let revealed_subjects = - List.filter (function K_Reveal -> false | _ -> true) subjects - -let is_disabled flags = function - | K_Transaction | K_Origination | K_Register_global_constant | K_Delegation - | K_Undelegation | K_Self_delegation | K_Set_deposits_limit - | K_Update_consensus_key | K_Increase_paid_storage | K_Reveal - | K_Transfer_ticket -> - false - | K_Sc_rollup_origination | K_Sc_rollup_publish | K_Sc_rollup_cement - | K_Sc_rollup_add_messages | K_Sc_rollup_refute | K_Sc_rollup_timeout - | K_Sc_rollup_execute_outbox_message | K_Sc_rollup_recover_bond -> - flags.scoru = false - | K_Dal_publish_slot_header -> flags.dal = false - | K_Zk_rollup_origination | K_Zk_rollup_publish | K_Zk_rollup_update -> - flags.zkru = false diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/test_1m_restriction.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/validate/test_1m_restriction.ml deleted file mode 100644 index 96d3bbbd977d43f227edc412f0f9a61ddba4da45..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/test_1m_restriction.ml +++ /dev/null @@ -1,231 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic-Labs. *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (validate manager) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/validate/main.exe \ - -- --file test_1m_restriction.ml - Subject: 1M restriction in validation of manager operation. -*) - -open Protocol -open Manager_operation_helpers -open Generators - -let count = 100 - -(** Local default values for the tests. *) -let ctxt_cstrs_default = - { - default_ctxt_cstrs with - src_cstrs = Pure 1500000; - dest_cstrs = Pure 15000; - del_cstrs = Pure 150000; - sc_cstrs = Pure 15000; - zk_cstrs = Pure 15000; - } - -let op_cstrs_default b = - { - default_operation_cstrs with - fee = Range {min = 0; max = 1_000; origin = 1_000}; - force_reveal = Some b; - amount = Range {min = 0; max = 10_000; origin = 10_000}; - } - -let print_one_op (ctxt_req, op_req, mode) = - Format.asprintf - "@[Generator printer:@,%a@,%a@,%a@]" - pp_ctxt_req - ctxt_req - pp_operation_req - op_req - pp_mode - mode - -let print_two_ops (ctxt_req, op_req, op_req', mode) = - Format.asprintf - "@[Generator printer:@,%a@,%a@,%a@,%a@]" - pp_ctxt_req - ctxt_req - pp_operation_req - op_req - pp_operation_req - op_req' - pp_mode - mode - -let print_ops_pair (ctxt_req, op_req, mode) = - Format.asprintf - "@[Generator printer:@,%a@,%a@,%a@]" - pp_ctxt_req - ctxt_req - pp_2_operation_req - op_req - pp_mode - mode - -(** The application of a valid operation succeeds, at least, to perform - the fee payment. *) -let positive_tests = - let gen = - QCheck2.Gen.triple - (Generators.gen_ctxt_req ctxt_cstrs_default) - (Generators.gen_operation_req (op_cstrs_default true) subjects) - Generators.gen_mode - in - wrap - ~count - ~print:print_one_op - ~name:"positive validated op" - ~gen - (fun (ctxt_req, operation_req, mode) -> - let open Lwt_result_syntax in - let* infos = init_ctxt ctxt_req in - let* op = select_op operation_req infos in - let* (_ : infos) = wrap_mode infos [op] mode in - return_true) - -(** Under 1M restriction, neither a block nor a prevalidator's valid - pool should contain two operations with the same manager. It - raises a Manager_restriction error. *) -let two_op_from_same_manager_tests = - let gen = - QCheck2.Gen.quad - (Generators.gen_ctxt_req ctxt_cstrs_default) - (Generators.gen_operation_req (op_cstrs_default true) subjects) - (Generators.gen_operation_req (op_cstrs_default false) revealed_subjects) - Generators.gen_mode - in - let expect_failure = function - | [ - Environment.Ecoproto_error - (Validate_errors.Manager.Manager_restriction _); - ] -> - return_unit - | err -> - failwith - "Error trace:@,\ - \ %a does not match the \ - [Validate_errors.Manager.Manager_restriction] error" - Error_monad.pp_print_trace - err - in - wrap - ~count - ~print:print_two_ops - ~name:"check conflicts between managers." - ~gen - (fun (ctxt_req, operation_req, operation_req2, mode) -> - let open Lwt_result_syntax in - let* infos = init_ctxt ctxt_req in - let* op1 = select_op operation_req infos in - let* op2 = select_op operation_req2 infos in - let* () = validate_ko_diagnostic ~mode infos [op1; op2] expect_failure in - return_true) - -(** Under 1M restriction, a batch of two operations cannot be replaced - by two single operations. *) -let batch_is_not_singles_tests = - let gen = - QCheck2.Gen.triple - (Generators.gen_ctxt_req ctxt_cstrs_default) - (Generators.gen_2_operation_req - (op_cstrs_default false) - revealed_subjects) - Generators.gen_mode - in - let expect_failure _ = return_unit in - wrap - ~count - ~print:print_ops_pair - ~name:"batch is not sequence of Single" - ~gen - (fun (ctxt_req, operation_req, mode) -> - let open Lwt_result_syntax in - let* infos = init_ctxt ctxt_req in - let* op1 = select_op (fst operation_req) infos in - let* op2 = select_op (snd operation_req) infos in - let source = contract_of (get_source infos) in - let* batch = - Op.batch_operations ~source (B infos.ctxt.block) [op1; op2] - in - let* (_ : infos) = validate_diagnostic ~mode infos [batch] in - let* () = validate_ko_diagnostic ~mode infos [op1; op2] expect_failure in - return_true) - -(** The applications of two covalid operations in a certain context - succeed, at least, to perform the fee payment of both, in whatever - application order. *) -let conflict_free_tests = - let gen = - QCheck2.Gen.quad - (Generators.gen_ctxt_req ctxt_cstrs_default) - (Generators.gen_operation_req (op_cstrs_default true) revealed_subjects) - (Generators.gen_operation_req (op_cstrs_default true) revealed_subjects) - Generators.gen_mode - in - wrap - ~count - ~print:print_two_ops - ~name:"under 1M, co-valid ops commute" - ~gen - (fun (ctxt_req, operation_req, operation_req', mode) -> - let open Lwt_result_syntax in - let* infos = init_ctxt ctxt_req in - let* op1 = select_op operation_req infos in - let infos2 = - { - infos with - accounts = - { - infos.accounts with - sources = - (match infos.accounts.del with - | None -> assert false - | Some s -> [s]); - }; - } - in - let* op2 = select_op operation_req' infos2 in - let* (_ : infos) = validate_diagnostic ~mode infos [op1; op2] in - let* (_ : infos) = validate_diagnostic ~mode infos [op2; op1] in - return_true) - -open Qcheck2_helpers - -let tests : (string * [`Quick | `Slow] * (unit -> unit Lwt.t)) trace = - qcheck_wrap_lwt - [ - positive_tests; - two_op_from_same_manager_tests; - batch_is_not_singles_tests; - conflict_free_tests; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("one-manager restriction", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/test_covalidity.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/validate/test_covalidity.ml deleted file mode 100644 index 2cda742b4ee7439a659e1817f3a350f62fedf578..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/test_covalidity.ml +++ /dev/null @@ -1,160 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic-Labs. *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (validate manager) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/validate/main.exe \ - -- --file test_covalidity.ml - Subject: Validation of operation. -*) -open Validate_helpers - -open Generator_descriptors -open Valid_operations_generators -open Protocol -open Alpha_context - -(** Values of number of bootstraps to create.*) - -let default_nb_bootstrap = 7 - -let nb_permutations = 30 - -let op_of_voting_period : Voting_period.kind -> op_kind = - let open Voting_period in - function - | Proposal -> KProposals - | Exploration -> KBallotExp - | Promotion -> KBallotProm - | _ -> assert false - -type seed_gen = Nonce | Vdf - -let pp_seed fmt = function - | Nonce -> Format.fprintf fmt "nonce" - | Vdf -> Format.fprintf fmt "vdf" - -let op_of_seed_gen = function Nonce -> KNonce | Vdf -> KVdf - -let is_not_preendorsement op = - let open Protocol.Alpha_context in - let (Operation_data {contents; _}) = op.protocol_data in - match contents with Single (Preendorsement _) -> false | _ -> true - -module OpkindMap = Map.Make (struct - type t = op_kind - - let compare = compare -end) - -let partition_op_kind op_kinds = - List.fold_left - (fun map op_kind -> - OpkindMap.update - op_kind - (function None -> Some 1 | Some c -> Some (succ c)) - map) - OpkindMap.empty - op_kinds - -let print_candidates candidates = - Format.printf - "@\n@[%d operations generated:@ %a@]@." - (List.length candidates) - Format.( - pp_print_list ~pp_sep:pp_print_cut (fun fmt (op, c) -> - Format.fprintf fmt "%d: %a" c pp_op_kind op)) - (List.map op_kind_of_packed_operation candidates - |> partition_op_kind |> OpkindMap.bindings) - -(** Test that for the set of covalid operations which kinds belongs to [ks] in a - state, any permutation is covalid and can be baked into a valid block. *) -let covalid_permutation_and_bake ks nb_bootstrap = - let open Lwt_result_syntax in - let* state, candidates = - covalid ks ~nb_bootstrap ~max_batch_size:Operation_generator.max_batch_size - in - print_candidates candidates ; - let* () = sequential_validate state.block candidates in - let rec loop = function - | 0 -> return_unit - | n -> - let operations = - QCheck2.Gen.shuffle_l candidates - |> QCheck2.Gen.generate1 - |> List.sort Protocol.Alpha_context.Operation.compare_by_passes - |> List.rev_filter is_not_preendorsement - in - (* Ensure that we can validate and apply this permutation *) - let* (_ : Block.t) = - Block.bake ~allow_manager_failures:true state.block ~operations - in - loop (pred n) - in - loop nb_permutations - -(** {2 Tests} *) - -let name voting_period reveal = - Format.asprintf - "scenario: '%a' period, '%a' seed" - Voting_period.pp_kind - voting_period - pp_seed - reveal - -(** Test [covalid_permutation_and_bake]. *) -let test_covalid voting_period seed_gen = - Generators.wrap - ~name:(name voting_period seed_gen) - ~gen:QCheck2.Gen.unit - (fun () -> - let open Lwt_result_syntax in - let ks = - op_of_voting_period voting_period - :: op_of_seed_gen seed_gen :: non_exclusive_kinds - in - let* () = covalid_permutation_and_bake ks default_nb_bootstrap in - return_true) - -let tests = - (* Create a list of all permutation of voting period and all - possible nonce generation *) - let voting_periods = [Voting_period.Proposal; Exploration; Promotion] in - let nonce_gens = [Nonce; Vdf] in - List.fold_left - (fun acc voting_period -> - List.fold_left - (fun acc nonce_gen -> test_covalid voting_period nonce_gen :: acc) - acc - nonce_gens) - [] - voting_periods - |> Qcheck2_helpers.qcheck_wrap_lwt - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("covalidity", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/test_manager_operation_validation.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/validate/test_manager_operation_validation.ml deleted file mode 100644 index 3a35c446bae0719a7c8f0fee230a2386f560e798..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/test_manager_operation_validation.ml +++ /dev/null @@ -1,626 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic-Labs. *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (validate manager) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/validate/main.exe \ - -- --file test_manager_operation_validation.ml - Subject: Validation of manager operation. -*) - -open Protocol -open Alpha_context -open Manager_operation_helpers - -(** {2 Negative tests assert the case where validate must fail} *) - -(** Validate fails if the gas limit is too low. - - This test asserts that the validation of a manager operation - with a too low gas limit fails at validate with an - [Gas_quota_exceeded_init_deserialize] error. - This test applies on manager operations that do not - consume gas in their specific part of validate. *) -let low_gas_limit_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error - Validate_errors.Manager.Gas_quota_exceeded_init_deserialize; - Environment.Ecoproto_error Raw_context.Operation_quota_exceeded; - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - validate_ko_diagnostic infos op expect_failure - -let test_low_gas_limit infos kind = - let open Lwt_result_syntax in - let* op = - select_op - { - (operation_req_default kind) with - gas_limit = Some Op.Low; - force_reveal = Some true; - } - infos - in - low_gas_limit_diagnostic infos [op] - -(** Validate fails if the gas limit is too high. - - This test asserts that the validation of a manager operation with - a gas limit too high fails at validate with an [Gas_limit_too_high] - error. It applies on every kind of manager operation. *) -let high_gas_limit_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Gas.Gas_limit_too_high] -> return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - validate_ko_diagnostic infos op expect_failure - -let test_high_gas_limit infos kind = - let open Lwt_result_syntax in - let* op = - select_op - { - (operation_req_default kind) with - force_reveal = Some true; - gas_limit = - Some (Op.Custom_gas (Gas.Arith.integral_of_int_exn 10_000_000)); - } - infos - in - high_gas_limit_diagnostic infos [op] - -(** Validate fails if the storage limit is too high. - - This test asserts that a manager operation with a storage limit - too high fails at validation with [Storage_limit_too_high] error. - It applies to every kind of manager operation. *) -let high_storage_limit_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Fees_storage.Storage_limit_too_high] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - validate_ko_diagnostic infos op expect_failure - -let test_high_storage_limit infos kind = - let open Lwt_result_syntax in - let* op = - select_op - { - (operation_req_default kind) with - force_reveal = Some true; - storage_limit = Some (Z.of_int max_int); - } - infos - in - high_storage_limit_diagnostic infos [op] - -(** Validate fails if the counter is in the future. - - This test asserts that the validation of - a manager operation with a counter in the - future -- aka greater than the successor of the manager counter - stored in the current context -- fails with [Counter_in_the_future] error. - It applies to every kind of manager operation. *) -let high_counter_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error (Contract_storage.Counter_in_the_future _)] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - validate_ko_diagnostic infos op expect_failure - -let test_high_counter infos kind = - let open Lwt_result_syntax in - let* op = - select_op - { - (operation_req_default kind) with - force_reveal = Some true; - counter = Some (Manager_counter.Internal_for_tests.of_int max_int); - } - infos - in - high_counter_diagnostic infos [op] - -(** Validate fails if the counter is in the past. - - This test asserts that the validation of a manager operation with a - counter in the past -- aka smaller than the successor of the - manager counter stored in the current context -- fails with - [Counter_in_the_past] error. It applies to every kind of manager - operation. *) -let low_counter_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error (Contract_storage.Counter_in_the_past _)] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - validate_ko_diagnostic infos op expect_failure - -let test_low_counter infos kind = - let open Lwt_result_syntax in - let* current_counter = - Context.Contract.counter - (B infos.ctxt.block) - (contract_of (get_source infos)) - in - let* op = - select_op - { - (operation_req_default kind) with - force_reveal = Some true; - counter = - Some (Manager_counter.Internal_for_tests.add current_counter (-1)); - } - infos - in - low_counter_diagnostic infos [op] - -(** Validate fails if the source is not allocated. - - This test asserts that the validation of a manager operation which - manager contract is not allocated fails with - [Empty_implicit_contract] error. It applies on every kind of - manager operation. *) -let not_allocated_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error (Contract_storage.Empty_implicit_contract _)] - -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - validate_ko_diagnostic infos op expect_failure - -let test_not_allocated infos kind = - let open Lwt_result_syntax in - let* op = - select_op - {(operation_req_default kind) with force_reveal = Some false} - { - infos with - accounts = {infos.accounts with sources = [Account.(new_account ())]}; - } - in - not_allocated_diagnostic infos [op] - -(** Validate fails if the source is unrevealed. - - This test asserts that a manager operation with an unrevealed source - contract fails at validation with [Unrevealed_manager_key]. - It applies on every kind of manager operation except [Revelation]. *) -let unrevealed_key_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error - (Contract_manager_storage.Unrevealed_manager_key _); - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - validate_ko_diagnostic infos op expect_failure - -let test_unrevealed_key infos kind = - let open Lwt_result_syntax in - let* op = - select_op - {(operation_req_default kind) with force_reveal = Some false} - infos - in - unrevealed_key_diagnostic infos [op] - -(** Validate fails if the source balance is not enough to pay the fees. - - This test asserts that validation of a manager operation fails if the - source balance is lesser than the manager operation fee. - It applies on every kind of manager operation. *) -let high_fee_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error (Contract_storage.Balance_too_low _); - Environment.Ecoproto_error (Tez_repr.Subtraction_underflow _); - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - validate_ko_diagnostic infos op expect_failure - -let test_high_fee infos kind = - let open Lwt_result_syntax in - let*? fee = Tez.(one +? default_fund) |> Environment.wrap_tzresult in - let* op = - select_op - { - (operation_req_default kind) with - force_reveal = Some true; - fee = Some fee; - } - infos - in - high_fee_diagnostic infos [op] - -(** Validate fails if the fee payment empties the balance of a - delegated implicit contract. - - This test asserts that in case that: - - the source is a delegated implicit contract, and - - the fee is the exact balance of source. - then, validate fails with [Empty_implicit_delegated_contract] error. - It applies to every kind of manager operation except [Revelation].*) -let emptying_delegated_implicit_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error - (Contract_storage.Empty_implicit_delegated_contract _); - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - validate_ko_diagnostic infos op expect_failure - -let test_empty_implicit infos kind = - let open Lwt_result_syntax in - let* fee = - Context.Contract.balance - (B infos.ctxt.block) - (contract_of (get_source infos)) - in - let* op = - select_op - { - (operation_req_default kind) with - force_reveal = Some false; - fee = Some fee; - } - infos - in - emptying_delegated_implicit_diagnostic infos [op] - -(** Validate fails if there is not enough available gas in the block. - - This test asserts that validate fails with: - - [Gas_limit_too_high;Block_quota_exceeded] in mempool mode, - - [Block_quota_exceeded] in other mode - with gas limit exceeds the available gas in the block. - It applies to every kind of manager operation. *) -let exceeding_block_gas_diagnostic ~mode (infos : infos) op = - let expect_failure errs = - match (errs, mode) with - | ( [Environment.Ecoproto_error Gas.Block_quota_exceeded], - (Construction | Application) ) -> - return_unit - | ( [ - Environment.Ecoproto_error Gas.Gas_limit_too_high; - Environment.Ecoproto_error Gas.Block_quota_exceeded; - ], - Mempool ) -> - (* In mempool_mode, batch that exceed [operation_gas_limit] needs - to be refused. [Gas.Block_quota_exceeded] only return a - temporary error. [Gas.Gas_limit_too_high], which is a - permanent error, is added to the error trace to ensure that - the batch is refused. *) - return_unit - | err, _ -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - validate_ko_diagnostic infos op expect_failure ~mode - -let test_exceeding_block_gas ~mode infos kind = - let open Lwt_result_syntax in - let* operation = - select_op - { - (operation_req_default kind) with - force_reveal = Some true; - gas_limit = - Some - (Op.Custom_gas - (Gas.Arith.add gb_limit Gas.Arith.(integral_of_int_exn 1))); - } - infos - in - exceeding_block_gas_diagnostic ~mode infos [operation] - -(** {2 Positive tests} *) - -(** Tests that validate succeeds when: - - it empties the balance of a self_delegated implicit source, - - it empties the balance of an undelegated implicit source, and - - in case: - - the counter is the successor of the one stored in the context, - - the fee is lesser than the balance, - - the storage limit is lesser than the maximum authorized storage, - - the gas limit is: - - lesser than the available gas in the block, - - less than the maximum gas consumable by an operation, and - - greater than the minimum gas consumable by an operation. - - Notice that in the first two cases only validate succeeds while - in the last case, the full application also succeeds. - In the case of emptying the balance of an undelegated implicit source, - we observe in the output context that the source is deallocated. - - Otherwise, we observe in the output context that: - - the counter is the successor of the one stored in the initial context, - - the balance is at least decreased by fee, - - the available gas in the block decreased at least gas limit. *) - -(** Fee payment*) -let test_validate infos kind = - let open Lwt_result_syntax in - let* op = - select_op - { - (operation_req_default kind) with - force_reveal = Some true; - amount = Some Tez.one; - } - infos - in - let* (_ : infos) = validate_diagnostic infos [op] in - return_unit - -(** Fee payment that emptying a self_delegated implicit. *) -let test_emptying_self_delegate infos kind = - let open Lwt_result_syntax in - let* fee = - Context.Contract.balance - (B infos.ctxt.block) - (contract_of (get_source infos)) - in - let* op = - select_op - { - (operation_req_default kind) with - force_reveal = Some false; - fee = Some fee; - } - infos - in - let* (_ : infos) = validate_diagnostic infos [op] in - return_unit - -let test_empty_undelegate infos kind = - let open Lwt_result_syntax in - let* fee = - Context.Contract.balance - (B infos.ctxt.block) - (contract_of (get_source infos)) - in - let* op = - select_op - { - (operation_req_default kind) with - force_reveal = Some true; - fee = Some fee; - gas_limit = Some Op.High; - } - infos - in - let* (_ : infos) = validate_diagnostic ~deallocated:true infos [op] in - return_unit - -(** No gas consumer with the minimal gas limit for manager operations - passes validate. *) -let test_low_gas_limit_no_consumer infos kind = - let open Lwt_result_syntax in - let* op = - select_op - { - (operation_req_default kind) with - force_reveal = Some true; - gas_limit = Some Op.Low; - } - infos - in - let* (_ : infos) = validate_diagnostic infos [op] in - return_unit - -(* Feature flags.*) - -(* Select the error according to the positionned flag. - We assume that only one feature is disabled. *) -let flag_expect_failure flags errs = - match errs with - | [ - Environment.Ecoproto_error Validate_errors.Manager.Sc_rollup_feature_disabled; - ] - when flags.scoru = false -> - return_unit - | [ - Environment.Ecoproto_error Validate_errors.Manager.Tx_rollup_feature_disabled; - ] - when flags.toru = false -> - return_unit - | [Environment.Ecoproto_error Dal_errors.Dal_feature_disabled] - when flags.dal = false -> - return_unit - | [ - Environment.Ecoproto_error Validate_errors.Manager.Zk_rollup_feature_disabled; - ] - when flags.zkru = false -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - -(* Tests that operations depending on feature flags are not valid - when the flag is set as disable. - - See [is_disabled] and the [flags] in `manager_operation_helpers`. - We assume that only one flag is set at false in flag. - - In order to forge Toru, Scoru or Dal operation when the correspondong - feature is disable, we use a [infos_op] with default requirements, - so that we have a Tx_rollup.t and a Sc_rollup.t. *) -let test_feature_flags infos kind = - let open Lwt_result_syntax in - let* counter = - Context.Contract.counter - (B infos.ctxt.block) - (contract_of (get_source infos)) - in - let* op = - select_op - { - {(operation_req_default kind) with force_reveal = Some true} with - counter = Some counter; - } - infos - in - let flags = infos.flags in - if is_disabled flags kind then - validate_ko_diagnostic infos [op] (flag_expect_failure flags) - else - let* (_ : infos) = validate_diagnostic infos [op] in - return_unit - -let tests = - let mk_default () = default_init_ctxt () in - let mk_reveal () = - init_ctxt {ctxt_req_default with reveal_accounts = false} - in - let mk_deleg () = default_ctxt_with_delegation () in - let mk_gas () = - init_ctxt {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} - in - let mk_self_deleg () = default_ctxt_with_self_delegation () in - let mk_flags flags () = - let open Lwt_result_syntax in - let* infos_op = default_init_ctxt () in - let* infos = default_init_with_flags flags in - let infos = - { - infos with - ctxt = - { - infos.ctxt with - sc_rollup = infos_op.ctxt.sc_rollup; - zk_rollup = infos_op.ctxt.zk_rollup; - }; - } - in - return infos - in - let all = subjects in - let gas_consum = gas_consumer_in_validate_subjects in - let not_gas_consum = not_gas_consumer_in_validate_subjects in - let revealed = revealed_subjects in - List.map - (fun (name, f, subjects, info_builder) -> - make_tztest name f subjects info_builder) - [ - (* Expected validation failure *) - ("gas limit too low", test_low_gas_limit, gas_consum, mk_default); - ("gas limit too high", test_high_gas_limit, all, mk_default); - ("storage limit too high", test_high_storage_limit, all, mk_default); - ("counter too high", test_high_counter, all, mk_default); - ("counter too low", test_low_counter, all, mk_default); - ("unallocated source", test_not_allocated, all, mk_default); - ("unrevealed source", test_unrevealed_key, revealed, mk_reveal); - ("balance too low for fee payment", test_high_fee, all, mk_default); - ("empty delegate source", test_empty_implicit, revealed, mk_deleg); - ( "too much gas consumption in block", - test_exceeding_block_gas ~mode:Construction, - all, - mk_gas ); - (* Expected validation success *) - ("fees are taken when valid", test_validate, all, mk_default); - ("empty self-delegate", test_emptying_self_delegate, all, mk_self_deleg); - ( "too much gas consumption in mempool", - test_exceeding_block_gas ~mode:Mempool, - all, - mk_gas ); - ("empty undelegated source", test_empty_undelegate, all, mk_default); - ( "minimal gas for manager", - test_low_gas_limit_no_consumer, - not_gas_consum, - mk_default ); - ("dal disabled", test_feature_flags, all, mk_flags disabled_dal); - ("toru disabled", test_feature_flags, all, mk_flags disabled_toru); - ("scoru disabled", test_feature_flags, all, mk_flags disabled_scoru); - ("zkru disabled", test_feature_flags, all, mk_flags disabled_zkru); - ] - -let () = - Alcotest_lwt.run - ~__FILE__ - Protocol.name - [("single manager validation", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/test_mempool.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/validate/test_mempool.ml deleted file mode 100644 index 180f7cbbc9dbbc616d374c83a93bc844ecef590c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/test_mempool.ml +++ /dev/null @@ -1,395 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/validate/main.exe \ - -- --file test_mempool.ml - Subject: Integration > Validate > Mempool mode -*) - -open Protocol -open Alpha_context -module Mempool = Mempool_validation - -let extract_values ctxt (b : Block.t) = - let predecessor_level = - Level.from_raw ctxt (Raw_level.of_int32_exn b.header.shell.level) - in - let fitness = - Fitness.from_raw b.header.shell.fitness |> function - | Ok v -> v - | Error _ -> assert false - in - let predecessor_round = Fitness.round fitness in - let predecessor_hash = b.header.shell.predecessor in - (predecessor_level, predecessor_round, predecessor_hash) - -let op_with_hash op = (Operation.hash_packed op, op) - -let expect_ok_added ~__LOC__ x = - match x with - | Ok (mempool, Mempool.Added) -> mempool - | _ -> Format.kasprintf Stdlib.failwith "%s: expected added" __LOC__ - -let expect_conflict ~__LOC__ x = - match (x : ('a, Mempool.add_error) result) with - | Error (Add_conflict _) -> () - | _ -> Format.kasprintf Stdlib.failwith "%s: expected conflict" __LOC__ - -let expect_conflict_handled ~__LOC__ kind x = - match (x : (Mempool.t * Mempool.add_result, Mempool.add_error) result) with - | Ok (mempool, kind') when kind = kind' -> mempool - | _ -> - Format.kasprintf Stdlib.failwith "%s: expected handled conflict" __LOC__ - -let handler_always_keep ~existing_operation:_ ~new_operation:_ = `Keep - -let handler_always_replace ~existing_operation:_ ~new_operation:_ = `Replace - -let assert_empty_mempool ~__LOC__ mempool = - let operations = Mempool.operations mempool in - Assert.equal_bool - ~loc:__LOC__ - true - (Environment.Operation_hash.Map.is_empty operations) - -let assert_operation_present_in_mempool ~__LOC__ mempool ophl = - let operations = Mempool.operations mempool in - let resulting_mempool_operations = - Environment.Operation_hash.Map.bindings operations - |> List.map fst - |> List.sort Operation_hash.compare - in - let expected_operations = List.sort Operation_hash.compare ophl in - Assert.assert_equal_list - ~loc:__LOC__ - Operation_hash.equal - "operations present in mempool" - Operation_hash.pp - resulting_mempool_operations - expected_operations - -let test_simple () = - let open Lwt_result_syntax in - let* block, (c1, c2) = Context.init2 () in - let* ctxt = - let+ incr = Incremental.begin_construction block in - Incremental.alpha_ctxt incr - in - let predecessor_level, predecessor_round, predecessor_hash = - extract_values ctxt block - in - let vs, mempool = - Mempool.init - ctxt - Chain_id.zero - ~predecessor_level - ~predecessor_round - ~predecessor_hash - in - let* op1 = Op.transaction (B block) c1 c2 Tez.one_cent in - let op1 = op_with_hash op1 in - let* op1' = Op.transaction (B block) c1 c2 Tez.one in - let op1' = op_with_hash op1' in - let* op2 = Op.transaction (B block) c2 c1 Tez.one in - let op2 = op_with_hash op2 in - let*! res = Mempool.add_operation vs mempool op1 in - let mempool = expect_ok_added ~__LOC__ res in - let*! res = Mempool.add_operation vs mempool op2 in - let mempool = expect_ok_added ~__LOC__ res in - let*! res = Mempool.add_operation vs mempool op1' in - let () = expect_conflict ~__LOC__ res in - return_unit - -let test_imcompatible_mempool () = - let open Lwt_result_syntax in - let* block, _ = Context.init1 ~consensus_threshold:0 () in - let* block = Block.bake block in - let* ctxt = - let+ incr = Incremental.begin_construction block in - Incremental.alpha_ctxt incr - in - let predecessor_level, predecessor_round, predecessor_hash = - extract_values ctxt block - in - let (_vs : Mempool.validation_info), mempool1 = - Mempool.init - ctxt - Chain_id.zero - ~predecessor_level - ~predecessor_round - ~predecessor_hash - in - (* Create a second mempool on a different block *) - let* block2 = Block.bake block in - let* ctxt2 = - let+ incr = Incremental.begin_construction block2 in - Incremental.alpha_ctxt incr - in - let predecessor_level, predecessor_round, predecessor_hash2 = - extract_values ctxt2 block2 - in - let (_vs : Mempool.validation_info), mempool2 = - Mempool.init - ctxt2 - Chain_id.zero - ~predecessor_level - ~predecessor_round - ~predecessor_hash:predecessor_hash2 - in - let () = - match Mempool.merge mempool1 mempool2 with - | Error Mempool.Incompatible_mempool -> () - | Error (Merge_conflict _) -> - Format.kasprintf - Stdlib.failwith - "%s: expected incompatible mempool" - __LOC__ - | Ok _ -> Format.kasprintf Stdlib.failwith "%s: expected conflict" __LOC__ - in - return_unit - -let test_merge () = - let open Lwt_result_syntax in - let* block, (c1, c2) = Context.init2 () in - let* ctxt = - let+ incr = Incremental.begin_construction block in - Incremental.alpha_ctxt incr - in - let predecessor_level, predecessor_round, predecessor_hash = - extract_values ctxt block - in - let vs, mempool_i = - Mempool.init - ctxt - Chain_id.zero - ~predecessor_level - ~predecessor_round - ~predecessor_hash - in - (* Build two mempool with a conflicting operation and check that the - merge fails and succeeds when a conflict handler is provided *) - let* op1 = Op.transaction (B block) c1 c2 Tez.one_cent in - let op1 = op_with_hash op1 in - let* op2 = Op.transaction (B block) c2 c1 Tez.one in - let op2 = op_with_hash op2 in - let*! res = Mempool.add_operation vs mempool_i op1 in - let mempool1 = expect_ok_added ~__LOC__ res in - let*! res = Mempool.add_operation vs mempool_i op2 in - let mempool2 = expect_ok_added ~__LOC__ res in - let merged_non_conflicting_mempool = - match Mempool.merge mempool1 mempool2 with - | Ok mempool -> mempool - | _ -> - Format.kasprintf Stdlib.failwith "%s: expected succesful merge" __LOC__ - in - let* op1' = Op.transaction (B block) c1 c2 Tez.one in - let op1' = op_with_hash op1' in - let*! res = Mempool.add_operation vs mempool_i op1' in - let mempool3 = expect_ok_added ~__LOC__ res in - let*! res = Mempool.add_operation vs mempool3 op2 in - let mempool3 = expect_ok_added ~__LOC__ res in - let () = - match Mempool.merge merged_non_conflicting_mempool mempool3 with - | Error (Merge_conflict _) -> () - | _ -> Format.kasprintf Stdlib.failwith "%s: expected conflict" __LOC__ - in - let merged_mempool_replace = - match - Mempool.merge - ~conflict_handler:handler_always_replace - merged_non_conflicting_mempool - mempool3 - with - | Ok mempool -> mempool - | _ -> - Format.kasprintf Stdlib.failwith "%s: expected succesful merge" __LOC__ - in - let* () = - assert_operation_present_in_mempool - ~__LOC__ - merged_mempool_replace - (List.map fst [op1'; op2]) - in - let merged_mempool_keep = - match - Mempool.merge - ~conflict_handler:handler_always_keep - merged_non_conflicting_mempool - mempool3 - with - | Ok mempool -> mempool - | _ -> - Format.kasprintf Stdlib.failwith "%s: expected succesful merge" __LOC__ - in - let* () = - assert_operation_present_in_mempool - ~__LOC__ - merged_mempool_keep - (List.map fst [op1; op2]) - in - (* Check that merging a mempool with itself is a success and returns - the identity *) - let* () = - match Mempool.merge mempool1 mempool1 with - | Ok mempool -> - let expected_operations = - Environment.Operation_hash.Map.bindings (Mempool.operations mempool1) - |> List.map fst - in - assert_operation_present_in_mempool ~__LOC__ mempool expected_operations - | Error _ -> assert false - in - return_unit - -let test_add_invalid_operation () = - let open Lwt_result_syntax in - let* block, c1 = Context.init1 () in - let* ctxt = - let+ incr = Incremental.begin_construction block in - Incremental.alpha_ctxt incr - in - let predecessor_level, predecessor_round, predecessor_hash = - extract_values ctxt block - in - let vs, mempool_i = - Mempool.init - ctxt - Chain_id.zero - ~predecessor_level - ~predecessor_round - ~predecessor_hash - in - let* op1 = Op.transaction (B block) c1 c1 ~gas_limit:Zero Tez.one_cent in - let op1 = op_with_hash op1 in - let*! res = Mempool.add_operation vs mempool_i op1 in - match res with - | Error (Mempool.Validation_error _) -> return_unit - | Error _ -> Stdlib.failwith "unexpected error" - | Ok _ -> Stdlib.failwith "unexpected success" - -let test_add_and_replace () = - let open Lwt_result_syntax in - let* block, (c1, c2) = Context.init2 () in - let* ctxt = - let+ incr = Incremental.begin_construction block in - Incremental.alpha_ctxt incr - in - let predecessor_level, predecessor_round, predecessor_hash = - extract_values ctxt block - in - let info, mempool_i = - Mempool.init - ctxt - Chain_id.zero - ~predecessor_level - ~predecessor_round - ~predecessor_hash - in - (* Try adding a conflicting operation using both handler strategy *) - let* op1 = Op.transaction (B block) c1 c2 Tez.one_cent in - let op1 = op_with_hash op1 in - let* op1' = Op.transaction (B block) c1 c2 Tez.one in - let op1' = op_with_hash op1' in - let*! res = Mempool.add_operation info mempool_i op1 in - let mempool = expect_ok_added ~__LOC__ res in - let*! res = Mempool.add_operation info mempool op1' in - let () = expect_conflict ~__LOC__ res in - let*! res = - Mempool.add_operation - ~conflict_handler:handler_always_keep - info - mempool - op1' - in - let final_mempool = expect_conflict_handled ~__LOC__ Unchanged res in - let* () = - assert_operation_present_in_mempool ~__LOC__ final_mempool [fst op1] - in - let*! res = - Mempool.add_operation - ~conflict_handler:handler_always_replace - info - mempool - op1' - in - let final_mempool = - expect_conflict_handled ~__LOC__ (Replaced {removed = fst op1}) res - in - let* () = - assert_operation_present_in_mempool ~__LOC__ final_mempool [fst op1'] - in - return_unit - -let test_remove_operation () = - let open Lwt_result_syntax in - let* block, (c1, c2) = Context.init2 () in - let* ctxt = - let+ incr = Incremental.begin_construction block in - Incremental.alpha_ctxt incr - in - let predecessor_level, predecessor_round, predecessor_hash = - extract_values ctxt block - in - let info, mempool_i = - Mempool.init - ctxt - Chain_id.zero - ~predecessor_level - ~predecessor_round - ~predecessor_hash - in - let* op1 = Op.transaction (B block) c1 c2 Tez.one_cent in - let op1 = op_with_hash op1 in - let* op2 = Op.transaction (B block) c1 c2 Tez.one in - let op2 = op_with_hash op2 in - (* Add one operation to the mempoolg *) - let*! res = Mempool.add_operation info mempool_i op1 in - let mempool = expect_ok_added ~__LOC__ res in - let* () = assert_operation_present_in_mempool ~__LOC__ mempool [fst op1] in - (* Try removing unknown operation and check that the mempool is unchanged *) - let mempool = Mempool.remove_operation mempool (fst op2) in - let* () = assert_operation_present_in_mempool ~__LOC__ mempool [fst op1] in - (* Try removing known operation and ensure that the mempool is empty *) - let empty_mempool = Mempool.remove_operation mempool (fst op1) in - assert_empty_mempool ~__LOC__ empty_mempool - -let tests = - [ - Tztest.tztest "simple" `Quick test_simple; - Tztest.tztest "incompatible mempool" `Quick test_imcompatible_mempool; - Tztest.tztest "merge" `Quick test_merge; - Tztest.tztest "adding invalid operation" `Quick test_add_invalid_operation; - Tztest.tztest - "adding operation with conflict handler" - `Quick - test_add_and_replace; - Tztest.tztest "remove operations" `Quick test_remove_operation; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("mempool", tests)] |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/test_sanity.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/validate/test_sanity.ml deleted file mode 100644 index 356a68c3d4a6054311fb21cca62ca70bba6ebd45..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/test_sanity.ml +++ /dev/null @@ -1,167 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic-Labs. *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (validate manager) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/validate/main.exe \ - -- --file test_sanity.ml - Subject: Validation of operation. -*) - -open Protocol -open Alpha_context -open Manager_operation_helpers - -(** The goal of this test is to ensure that [select_op] generate the - wanted kind of manager operation - - Note: if a new manager operation kind is added in the protocol, - [Manager_operation_helpers.manager_operation_kind] should be - extended. You will also have to extend - [Manager_operation_helpers.select_op] with a new `mk` for this new - operation. Finally the list [Manager_operation_helpers.subjects] - should also be extended to run the validate test on the new manager - operation kind. *) -let ensure_kind infos kind = - let open Lwt_result_syntax in - let* op = - select_op - {(operation_req_default kind) with force_reveal = Some false} - infos - in - let (Operation_data {contents; _}) = op.protocol_data in - match contents with - | Single (Manager_operation {operation; _}) -> ( - match (operation, kind) with - | Transaction _, K_Transaction - | Reveal _, K_Reveal - | Origination _, K_Origination - | Delegation _, K_Delegation - | Delegation _, K_Undelegation - | Delegation _, K_Self_delegation - | Register_global_constant _, K_Register_global_constant - | Set_deposits_limit _, K_Set_deposits_limit - | Update_consensus_key _, K_Update_consensus_key - | Increase_paid_storage _, K_Increase_paid_storage - | Transfer_ticket _, K_Transfer_ticket - | Sc_rollup_originate _, K_Sc_rollup_origination - | Sc_rollup_add_messages _, K_Sc_rollup_add_messages - | Sc_rollup_cement _, K_Sc_rollup_cement - | Sc_rollup_publish _, K_Sc_rollup_publish - | Sc_rollup_refute _, K_Sc_rollup_refute - | Sc_rollup_timeout _, K_Sc_rollup_timeout - | Sc_rollup_execute_outbox_message _, K_Sc_rollup_execute_outbox_message - | Sc_rollup_recover_bond _, K_Sc_rollup_recover_bond - | Dal_publish_slot_header _, K_Dal_publish_slot_header - | Zk_rollup_origination _, K_Zk_rollup_origination - | Zk_rollup_publish _, K_Zk_rollup_publish - | Zk_rollup_update _, K_Zk_rollup_update -> - return_unit - | ( ( Transaction _ | Origination _ | Register_global_constant _ - | Delegation _ | Set_deposits_limit _ | Update_consensus_key _ - | Increase_paid_storage _ | Reveal _ | Transfer_ticket _ - | Sc_rollup_originate _ | Sc_rollup_publish _ | Sc_rollup_cement _ - | Sc_rollup_add_messages _ | Sc_rollup_refute _ | Sc_rollup_timeout _ - | Sc_rollup_execute_outbox_message _ | Sc_rollup_recover_bond _ - | Dal_publish_slot_header _ | Zk_rollup_origination _ - | Zk_rollup_publish _ | Zk_rollup_update _ ), - _ ) -> - assert false) - | Single _ -> assert false - | Cons _ -> assert false - -let ensure_manager_operation_coverage () = - let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - List.iter_es (fun kind -> ensure_kind infos kind) subjects - -open Generator_descriptors -open Valid_operations_generators - -(** This test ensures that it exists a valid operation generator for - each operation. - - Note: When adding a new operation, one should refer to {! - Generator_descriptor} to see how to add its valid operation - generator. *) -let covalidation_sanity () = - let open Lwt_result_syntax in - let max_batch_size = 1 in - let nb_bootstrap = 7 in - List.iter_es - (fun kind -> - let* _, candidates = covalid [kind] ~nb_bootstrap ~max_batch_size in - match List.hd candidates with - | None -> - failwith "no candidates was generated for kind '%a'" pp_op_kind kind - | Some {protocol_data = Operation_data {contents; _}; _} -> ( - match (contents, kind) with - | Single (Preendorsement _), KPreendorsement -> return_unit - | Single (Preendorsement _), _ -> assert false - | Single (Endorsement _), KEndorsement -> return_unit - | Single (Endorsement _), _ -> assert false - | Single (Dal_attestation _), KDalattestation -> return_unit - | Single (Dal_attestation _), _ -> assert false - | Single (Seed_nonce_revelation _), KNonce -> return_unit - | Single (Seed_nonce_revelation _), _ -> assert false - | Single (Vdf_revelation _), KVdf -> return_unit - | Single (Vdf_revelation _), _ -> assert false - | Single (Double_endorsement_evidence _), KDbl_consensus -> - return_unit - | Single (Double_endorsement_evidence _), _ -> assert false - | Single (Double_preendorsement_evidence _), KDbl_consensus -> - return_unit - | Single (Double_preendorsement_evidence _), _ -> assert false - | Single (Double_baking_evidence _), KDbl_baking -> return_unit - | Single (Double_baking_evidence _), _ -> assert false - | Single (Activate_account _), KActivate -> return_unit - | Single (Activate_account _), _ -> assert false - | Single (Proposals _), KProposals -> return_unit - | Single (Proposals _), _ -> assert false - | Single (Ballot _), (KBallotExp | KBallotProm) -> return_unit - | Single (Ballot _), _ -> assert false - | Single (Drain_delegate _), KDrain -> return_unit - | Single (Drain_delegate _), _ -> assert false - | Single (Manager_operation _), KManager - | Cons (Manager_operation _, _), KManager -> - return_unit - | Single (Manager_operation _), _ | Cons (Manager_operation _, _), _ - -> - assert false - | Single (Failing_noop _), _ -> assert false)) - all_kinds - -let tests = - List.map - (fun (name, f) -> Tztest.tztest name `Quick f) - [ - ("manager operation coverage", ensure_manager_operation_coverage); - ("covalidation coverage", covalidation_sanity); - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("sanity checks", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/test_validation_batch.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/validate/test_validation_batch.ml deleted file mode 100644 index c84a8e59f1f99ea2ca758cec0ddf771e2ce1d96e..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/test_validation_batch.ml +++ /dev/null @@ -1,630 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic-Labs. *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (validate manager) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/integration/validate/main.exe \ - -- --file test_validation_batch.ml - Subject: Validation of batched manager operation. -*) - -open Protocol -open Alpha_context -open Manager_operation_helpers - -(** {2 Tests on operation batches} *) - -(** Revelation should not occur elsewhere than in first position - in a batch.*) -let batch_reveal_in_the_middle_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error - Validate_errors.Manager.Incorrect_reveal_position; - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - validate_ko_diagnostic infos op expect_failure - -let batch_in_the_middle infos kind1 kind2 = - let open Lwt_result_syntax in - let* counter = - Context.Contract.counter - (B infos.ctxt.block) - (contract_of (get_source infos)) - in - let counter = Manager_counter.succ counter in - let* operation1 = - select_op - { - (operation_req_default kind1) with - force_reveal = Some false; - counter = Some counter; - } - infos - in - let counter = Manager_counter.succ counter in - let* reveal = - mk_reveal - { - (operation_req_default K_Reveal) with - fee = Some Tez.one_mutez; - counter = Some counter; - } - infos - in - let counter = Manager_counter.succ counter in - let* operation2 = - select_op - { - (operation_req_default kind2) with - force_reveal = Some false; - counter = Some counter; - } - infos - in - let* batch = - Op.batch_operations - ~recompute_counters:false - ~source:(contract_of (get_source infos)) - (Context.B infos.ctxt.block) - [operation1; reveal; operation2] - in - batch_reveal_in_the_middle_diagnostic infos [batch] - -(** A batch of manager operation contains at most one Revelation.*) -let batch_two_reveals_diagnostic (infos : infos) op = - let expected_failure errs = - match errs with - | [ - Environment.Ecoproto_error - Validate_errors.Manager.Incorrect_reveal_position; - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - validate_ko_diagnostic infos op expected_failure - -let batch_two_reveals infos kind = - let open Lwt_result_syntax in - let* counter = - Context.Contract.counter - (B infos.ctxt.block) - (contract_of (get_source infos)) - in - let counter = Manager_counter.succ counter in - let* reveal = - mk_reveal - { - (operation_req_default K_Reveal) with - fee = Some Tez.one_mutez; - counter = Some counter; - } - infos - in - let counter = Manager_counter.succ counter in - let* reveal1 = - mk_reveal - { - (operation_req_default K_Reveal) with - fee = Some Tez.one_mutez; - counter = Some counter; - } - infos - in - let counter = Manager_counter.succ counter in - let* operation = - select_op - { - (operation_req_default kind) with - force_reveal = Some false; - counter = Some counter; - } - infos - in - let* batch = - Op.batch_operations - ~recompute_counters:false - ~source:(contract_of (get_source infos)) - (Context.B infos.ctxt.block) - [reveal; reveal1; operation] - in - batch_two_reveals_diagnostic infos [batch] - -(** Every manager operation in a batch concerns the same source.*) -let batch_two_sources_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Validate_errors.Manager.Inconsistent_sources] - -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - validate_ko_diagnostic infos op expect_failure - -let batch_two_sources infos kind1 kind2 = - let open Lwt_result_syntax in - let source = contract_of (get_source infos) in - let* counter = Context.Contract.counter (B infos.ctxt.block) source in - let counter = Manager_counter.succ counter in - let* operation1 = - select_op - { - (operation_req_default kind1) with - force_reveal = Some true; - counter = Some counter; - } - infos - in - let infos = - let source2 = - match infos.accounts.del with None -> assert false | Some s -> s - in - {infos with accounts = {infos.accounts with sources = [source2]}} - in - let* operation2 = - select_op - {(operation_req_default kind2) with force_reveal = Some false} - infos - in - let* batch = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [operation1; operation2] - in - batch_two_sources_diagnostic infos [batch] - -(** Counters in a batch should be a sequence from the successor of - the stored counter associated to source in the initial context. *) -let batch_incons_counters infos kind1 kind2 = - let open Lwt_result_syntax in - let source = contract_of (get_source infos) in - let* counter = Context.Contract.counter (B infos.ctxt.block) source in - let fee = Some Tez.one_mutez in - let op_infos = operation_req_default K_Reveal in - let op_infos = {{op_infos with fee} with counter = Some counter} in - let* reveal = mk_reveal op_infos infos in - let counter0 = counter in - let counter = Manager_counter.succ counter in - let counter2 = Manager_counter.succ counter in - let counter3 = Manager_counter.succ counter2 in - let operation counter kind = - select_op - { - (operation_req_default kind) with - counter = Some counter; - force_reveal = Some false; - } - infos - in - let op_counter = operation counter in - let op_counter0 = operation counter0 in - let op_counter2 = operation counter2 in - let op_counter3 = operation counter3 in - let* op1 = op_counter kind1 in - let* op2 = op_counter kind2 in - let* batch_same = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [reveal; op1; op2] - in - let* op1 = op_counter2 kind1 in - let* op2 = op_counter3 kind2 in - let* batch_in_the_future = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [reveal; op1; op2] - in - let* op1 = op_counter kind1 in - let* op2 = op_counter3 kind2 in - let* batch_missing_one = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [reveal; op1; op2] - in - let* op1 = op_counter2 kind1 in - let* op2 = op_counter kind2 in - let* batch_inverse = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [reveal; op1; op2] - in - let* op1 = op_counter0 kind1 in - let* op2 = op_counter kind2 in - let* batch_in_the_past = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [reveal; op1; op2] - in - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Validate_errors.Manager.Inconsistent_counters] - -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - let* i = Incremental.begin_construction infos.ctxt.block in - let* (_ : Incremental.t) = - Incremental.add_operation ~expect_failure i batch_same - in - let* (_ : Incremental.t) = - Incremental.add_operation ~expect_failure i batch_in_the_future - in - let* (_ : Incremental.t) = - Incremental.add_operation ~expect_failure i batch_missing_one - in - let* (_ : Incremental.t) = - Incremental.add_operation ~expect_failure i batch_inverse - in - let* (_ : Incremental.t) = - Incremental.add_operation ~expect_failure i batch_in_the_past - in - return_unit - -(** A batch that consumes all the balance for fees can only face the total - consumption at the end of the batch. *) -let batch_emptying_balance_in_the_middle infos kind1 kind2 = - let open Lwt_result_syntax in - let source = contract_of (get_source infos) in - let* counter = Context.Contract.counter (B infos.ctxt.block) source in - let* init_bal = Context.Contract.balance (B infos.ctxt.block) source in - let counter = counter in - let* reveal = - mk_reveal - {(operation_req_default K_Reveal) with counter = Some counter} - infos - in - let counter = Manager_counter.succ counter in - let operation fee = - select_op - { - (operation_req_default kind1) with - force_reveal = Some false; - counter = Some counter; - fee = Some fee; - } - infos - in - let counter = Manager_counter.succ counter in - let operation2 fee = - select_op - { - (operation_req_default kind2) with - force_reveal = Some false; - counter = Some counter; - fee = Some fee; - } - infos - in - let* op_case1 = operation init_bal in - let* op2_case1 = operation2 Tez.zero in - let* case1 = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [reveal; op_case1; op2_case1] - in - let* i = Incremental.begin_construction infos.ctxt.block in - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error (Contract_storage.Empty_implicit_contract _)] - -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - let* (_ : Incremental.t) = - Incremental.add_operation i case1 ~expect_failure - in - return_unit - -(** A batch that consumes all the balance for fees only at the end of - the batch passes validate.*) -let batch_empty_at_end infos kind1 kind2 = - let open Lwt_result_syntax in - let source = contract_of (get_source infos) in - let* counter = Context.Contract.counter (B infos.ctxt.block) source in - let* init_bal = Context.Contract.balance (B infos.ctxt.block) source in - let*? half_init_bal = Environment.wrap_tzresult @@ Tez.(init_bal /? 2L) in - let* reveal = - mk_reveal - {(operation_req_default K_Reveal) with counter = Some counter} - infos - in - let counter = Manager_counter.succ counter in - let operation fee = - select_op - { - (operation_req_default kind1) with - force_reveal = Some false; - counter = Some counter; - fee = Some fee; - } - infos - in - let counter = Manager_counter.succ counter in - let operation2 fee = - select_op - { - (operation_req_default kind2) with - force_reveal = Some false; - counter = Some counter; - fee = Some fee; - } - infos - in - let* op_case2 = operation Tez.zero in - let* op2_case2 = operation2 init_bal in - let* op_case3 = operation half_init_bal in - let* op2_case3 = operation2 half_init_bal in - let* case3 = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [reveal; op_case3; op2_case3] - in - let* case2 = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [reveal; op_case2; op2_case2] - in - let* (_ : infos) = validate_diagnostic ~deallocated:true infos [case2] in - let* (_ : infos) = validate_diagnostic ~deallocated:true infos [case3] in - return_unit - -(** Simple reveal followed by a transaction. *) -let batch_reveal_transaction infos = - let open Lwt_result_syntax in - let source = contract_of (get_source infos) in - let* counter = Context.Contract.counter (B infos.ctxt.block) source in - let counter = counter in - let fee = Tez.one_mutez in - let* reveal = - mk_reveal - { - (operation_req_default K_Reveal) with - fee = Some fee; - counter = Some counter; - } - infos - in - let counter = Manager_counter.succ counter in - let* transaction = - mk_transaction - { - (operation_req_default K_Reveal) with - counter = Some counter; - force_reveal = Some false; - } - infos - in - let* batch = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [reveal; transaction] - in - let* (_ : Incremental.t) = Incremental.begin_construction infos.ctxt.block in - let* (_ : infos) = validate_diagnostic infos [batch] in - return_unit - -(** A batch of manager operation must not exceed the initial available gas in the block. *) -let batch_exceeding_block_gas ~mempool_mode infos kind1 kind2 = - let open Lwt_result_syntax in - let source = contract_of (get_source infos) in - let* counter = Context.Contract.counter (B infos.ctxt.block) source in - let g_limit = Gas.Arith.add gb_limit Gas.Arith.(integral_of_int_exn 1) in - let half_limit = - Gas.Arith.add half_gb_limit Gas.Arith.(integral_of_int_exn 1) - in - let* reveal = - mk_reveal - {(operation_req_default K_Reveal) with counter = Some counter} - infos - in - let counter = Manager_counter.succ counter in - let operation gas_limit = - select_op - { - (operation_req_default kind1) with - force_reveal = Some false; - counter = Some counter; - gas_limit = Some (Custom_gas gas_limit); - } - infos - in - let counter = Manager_counter.succ counter in - let operation2 gas_limit = - select_op - { - (operation_req_default kind2) with - force_reveal = Some false; - counter = Some counter; - gas_limit = Some (Custom_gas gas_limit); - } - infos - in - let* op_case1 = operation g_limit in - let* op2_case1 = operation2 Gas.Arith.zero in - let* op_case2 = operation half_limit in - let* op2_case2 = operation2 g_limit in - let* op_case3 = operation half_limit in - let* op2_case3 = operation2 half_limit in - let* case1 = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [reveal; op_case1; op2_case1] - in - let* case3 = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [reveal; op_case3; op2_case3] - in - let* case2 = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [reveal; op_case2; op2_case2] - in - let* i = Incremental.begin_construction infos.ctxt.block ~mempool_mode in - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Gas.Block_quota_exceeded] - when not mempool_mode -> - return_unit - | [ - Environment.Ecoproto_error Gas.Gas_limit_too_high; - Environment.Ecoproto_error Gas.Block_quota_exceeded; - ] - when mempool_mode -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - let* (_ : Incremental.t) = - Incremental.add_operation i case1 ~expect_failure - in - let* (_ : Incremental.t) = - Incremental.add_operation i case3 ~expect_failure - in - let* (_ : Incremental.t) = - Incremental.add_operation i case2 ~expect_failure - in - return_unit - -let make_tztest_batched ?(fmt = Format.std_formatter) name test subjects - info_builder = - let open Lwt_result_syntax in - Tztest.tztest name `Quick (fun () -> - let* infos = info_builder () in - List.iter_es - (fun kind1 -> - let k1s = kind_to_string kind1 in - List.iter_es - (fun kind2 -> - Format.fprintf - fmt - "%s: [%s ; %s]@." - name - k1s - (kind_to_string kind2) ; - test infos kind1 kind2) - subjects) - subjects) - -let tests = - let open Lwt_result_syntax in - let mk_default () = default_init_ctxt () in - let mk_high_gas_limit () = - init_ctxt {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} - in - let revealed = revealed_subjects in - [ - ( Tztest.tztest "batch reveal and transaction" `Quick @@ fun () -> - let* infos = mk_default () in - batch_reveal_transaction infos ); - ] - @ List.map - (fun (name, f, subjects, info_builder) -> - make_tztest name f subjects info_builder) - [("batch two reveals", batch_two_reveals, revealed, mk_default)] - @ List.map - (fun (name, f, subjects, info_builder) -> - make_tztest_batched name f subjects info_builder) - [ - ("reveal in the middle", batch_in_the_middle, revealed, mk_default); - ("batch two sources", batch_two_sources, revealed, mk_default); - ("batch incons. counters", batch_incons_counters, revealed, mk_default); - ( "empty balance in middle of batch", - batch_emptying_balance_in_the_middle, - revealed, - mk_default ); - ( "empty balance at end of batch", - batch_empty_at_end, - revealed, - mk_default ); - ( "too much gas consumption", - batch_exceeding_block_gas ~mempool_mode:false, - revealed, - mk_high_gas_limit ); - ( "too much gas consumption (mempool)", - batch_exceeding_block_gas ~mempool_mode:true, - revealed, - mk_high_gas_limit ); - ] - -let () = - Alcotest_lwt.run - ~__FILE__ - Protocol.name - [("batched managers validation", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/valid_operations_generators.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/validate/valid_operations_generators.ml deleted file mode 100644 index 928bf9c6a8fc77818822cfbdee9810207dac20e1..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/valid_operations_generators.ml +++ /dev/null @@ -1,243 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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 -open Alpha_context -open Generator_descriptors - -(** {2 Building the Setup} *) - -(** Setup for generating valid operation of several kind of - operations. It gathers the following information to setup - {! Generator_descriptor.state} into which valid operations - can be generated: - - [nb_cycles] the total number of cycles to bake, - - [nb_blocks] the number of blocks to bake in the last cycle, - - [params] the constants required, and - - [prelude] that associates to each cycle to bake a list of - {! Generator_descriptors.descriptor} prelude functions. *) -type setup = { - prelude : - (int * (state -> (packed_operation list * state) tzresult Lwt.t) list) list; - nb_cycles : int; - nb_blocks : int; - params : Parameters.t; -} - -(** Select the prelude actions of a specific cycle in a setup prelude. *) -let prelude_on_cycle (c : int) - (actions : - (int * (state -> (packed_operation list * state) tzresult Lwt.t) list) - list) : (state -> (packed_operation list * state) tzresult Lwt.t) list = - match List.filter (fun (c1, _actions) -> c = c1) actions with - | (c1, actions) :: _ -> - assert (c = c1) ; - actions - | [] -> [] - -(** Knowing the total number of required cycles, normalize a prelude - on the list of the pair of a cycle and prelude actions. *) -let normalize_preludes nb_cycles (descr : descriptor) = - let normalize prelude = - match prelude with - | On n, actions -> [(nb_cycles - n, actions)] - | From n, actions -> - List.fold_left - (fun acc i -> acc @ [(nb_cycles - n + i, actions)]) - [] - (1 -- n) - in - let prim = normalize descr.prelude in - match descr.opt_prelude with - | Some prelude -> normalize prelude @ prim - | None -> prim - -(** Insert a normalized prelude in a prelude of a setup.*) -let rec insert_normalize_preludes - ((n, action) : - int * (state -> (packed_operation list * state) tzresult Lwt.t)) - (preludes : - (int * (state -> (packed_operation list * state) tzresult Lwt.t) list) - list) = - match preludes with - | [] -> [(n, [action])] - | (m, actions) :: rest -> - if m = n then (m, actions @ [action]) :: rest - else (m, actions) :: insert_normalize_preludes (n, action) rest - -(** Produce a setup prelude from a list of descriptor and a nb of - cycles*) -let compose_preludes nb_cycles descrs = - let normalized_preludes = List.map (normalize_preludes nb_cycles) descrs in - List.fold_left - (fun acc pre -> - List.fold_left (fun acc pr -> insert_normalize_preludes pr acc) acc pre) - [] - normalized_preludes - -(** Agregate the parameters of several {! Generator_descriptors.descriptor}.*) -let initiated_params descrs nb_accounts = - let consensus_committee_size = nb_accounts in - let initial_params = - Tezos_protocol_017_PtNairob_parameters.Default_parameters - .parameters_of_constants - { - Context.default_test_constants with - consensus_threshold = 0; - consensus_committee_size; - } - in - let descrs_params = List.map (fun descr -> descr.parameters) descrs in - List.fold_left (fun acc f -> f acc) initial_params descrs_params - -(** Make a [setup] from a list of {! Generator_descriptors.descriptor}. The required number of - cycles and number of blocks in the last cycle are the maximum of - required cycle and number of block in the descriptors list. The - prelude is the composition of the composition of the descriptors - preludes list -- see [compose_preludes]. The parameters are the agregation of the - descriptors parameters -- see [initiated_params]. *) -let setup_of descrs nb_accounts = - let params = initiated_params descrs nb_accounts in - let max_list l = List.fold_left max 0 l in - let required_cycle_list l = - List.map (fun descr -> descr.required_cycle params) l - in - let required_block_list l = - List.map (fun descr -> descr.required_block params) l - in - let sorted_descrs = - List.sort - (fun pre1 pre2 -> - Int.compare (pre1.required_cycle params) (pre2.required_cycle params)) - descrs - in - let nb_cycles = max_list (required_cycle_list descrs) in - let nb_blocks = max_list (required_block_list descrs) in - let prelude = compose_preludes nb_cycles sorted_descrs in - {prelude; nb_cycles; nb_blocks; params} - -(** From a number of accounts and a list of descriptors set up the - prelude state. - - Thanks to the setup computing for the list of descriptors -- see [setup_of] --, - initiates a context with the setup parameters, and the number of - accounts. Initiate a state that will be fulfilled during the - preludes. During the required number of cycles of the setup, bakes - each cycle with the setup prelude by selecting the actions to - perform on it. On the last cycle, bake the required number of - blocks of the setup. Finally, adds the delegates at the end of - the prelude in the state. *) -let init nb_accounts descrs = - let open Lwt_result_syntax in - let setup = setup_of descrs nb_accounts in - let* initial_block, bootstraps = - Context.init_with_parameters_n setup.params nb_accounts - in - let* voters = Context.Vote.get_listings (B initial_block) in - let* initial_voters = - List.map_es (fun (c, _) -> return (Contract.Implicit c)) voters - in - let my_bake selected_preludes_for_cycle state = - let* state, operations = - List.fold_left_es - (fun (state, ops) prelude -> - let+ ops', state = prelude state in - let ops = ops' @ ops in - (state, ops)) - (state, []) - selected_preludes_for_cycle - in - let b = state.block in - let operations = - List.sort (fun op1 op2 -> Operation.compare_by_passes op2 op1) operations - in - let+ block = Block.bake ~operations b in - {state with block; pred = Some b} - in - let my_bake_n cycle n state = - List.fold_left_es - (fun state _ -> - let selected_preludes = prelude_on_cycle cycle setup.prelude in - my_bake selected_preludes state) - state - (1 -- n) - in - let my_bake_until_cycle_end cycle state = - let current_level = state.block.Block.header.shell.level in - let current_level = - Int32.rem current_level setup.params.constants.blocks_per_cycle - in - let delta = - Int32.sub setup.params.constants.blocks_per_cycle current_level - in - my_bake_n cycle (Int32.to_int delta) state - in - let* state = - List.fold_left_es - (fun state cycle -> my_bake_until_cycle_end cycle state) - (init_state initial_block ~voters:initial_voters ~bootstraps) - (Stdlib.List.init setup.nb_cycles Fun.id) - in - let my_bake_n_default n state = - List.fold_left_es - (fun state _ -> - let pred = state.block in - let+ block = Block.bake state.block in - {state with block; pred = Some pred}) - state - (1 -- n) - in - let* state = - if setup.nb_blocks >= 1 then my_bake_n_default setup.nb_blocks state - else return state - in - return state - -(** In a state, generates all the valid operations of a list of kinds. *) -let candidates state kinds nb_bootstrap max_batch_size = - let open Lwt_result_syntax in - let* candidates = - List.fold_left_es - (fun acc k -> - let* candidates = - (descriptor_of k ~nb_bootstrap ~max_batch_size).candidates_generator - state - in - let acc = acc @ candidates in - return acc) - [] - kinds - in - return candidates - -(** From a list of kind of operations generates all the valid - operations of this kind and the generation state. *) -let covalid ks ~nb_bootstrap ~max_batch_size = - let open Lwt_result_syntax in - let* state = - init nb_bootstrap (descriptors_of ~nb_bootstrap ~max_batch_size ks) - in - let* candidates = candidates state ks nb_bootstrap max_batch_size in - return (state, candidates) diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/validate_helpers.ml b/src/proto_017_PtNairob/lib_protocol/test/integration/validate/validate_helpers.ml deleted file mode 100644 index 645163bbca10961c3dc1437c86c8a23cac73f292..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/validate/validate_helpers.ml +++ /dev/null @@ -1,397 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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 Registered_nonces = Nonce -open Protocol -open Alpha_context -module Manager = Manager_operation_helpers - -(** {2 Helpers} *) - -(** {3 Randomness } *) - -let gen_bounded_int min max = QCheck2.Gen.(generate1 @@ int_range min max) - -let pick_one l = QCheck2.Gen.(generate1 @@ oneofl l) - -let pick_n (n : int) (l : 'a list) : 'a list = - List.take_n n QCheck2.Gen.(generate1 @@ shuffle_l l) - -(** {3 Helpers for lists } *) - -let get_n l n = - assert (List.length l > n) ; - Stdlib.List.nth l n - -let mycombine l1 l2 = - let sz_dels = List.length l1 in - let sz_phs = List.length l2 in - let dels, phs = - if sz_dels = sz_phs then (l1, l2) - else if sz_dels < sz_phs then (l1, List.take_n sz_dels l2) - else (List.take_n sz_phs l1, l2) - in - Stdlib.List.combine dels phs - -(** {3 Global Values}*) - -let ballots = Vote.[Yay; Nay; Pass] - -let protos = - List.map - (fun s -> Protocol_hash.of_b58check_exn s) - [ - "ProtoALphaALphaALphaALphaALphaALphaALpha61322gcLUGH"; - "ProtoALphaALphaALphaALphaALphaALphaALphabc2a7ebx6WB"; - "ProtoALphaALphaALphaALphaALphaALphaALpha84efbeiF6cm"; - "ProtoALphaALphaALphaALphaALphaALphaALpha91249Z65tWS"; - "ProtoALphaALphaALphaALphaALphaALphaALpha537f5h25LnN"; - "ProtoALphaALphaALphaALphaALphaALphaALpha5c8fefgDYkr"; - "ProtoALphaALphaALphaALphaALphaALphaALpha3f31feSSarC"; - "ProtoALphaALphaALphaALphaALphaALphaALphabe31ahnkxSC"; - "ProtoALphaALphaALphaALphaALphaALphaALphabab3bgRb7zQ"; - "ProtoALphaALphaALphaALphaALphaALphaALphaf8d39cctbpk"; - "ProtoALphaALphaALphaALphaALphaALphaALpha3b981byuYxD"; - "ProtoALphaALphaALphaALphaALphaALphaALphaa116bccYowi"; - "ProtoALphaALphaALphaALphaALphaALphaALphacce68eHqboj"; - "ProtoALphaALphaALphaALphaALphaALphaALpha225c7YrWwR7"; - "ProtoALphaALphaALphaALphaALphaALphaALpha58743cJL6FG"; - "ProtoALphaALphaALphaALphaALphaALphaALphac91bcdvmJFR"; - "ProtoALphaALphaALphaALphaALphaALphaALpha1faaadhV7oW"; - "ProtoALphaALphaALphaALphaALphaALphaALpha98232gD94QJ"; - "ProtoALphaALphaALphaALphaALphaALphaALpha9d1d8cijvAh"; - "ProtoALphaALphaALphaALphaALphaALphaALphaeec52dKF6Gx"; - "ProtoALphaALphaALphaALphaALphaALphaALpha841f2cQqajX"; - ] - -type secret_account = { - blinded_public_key_hash : Blinded_public_key_hash.t; - account : Signature.Ed25519.Public_key_hash.t; - activation_code : Blinded_public_key_hash.activation_code; - amount : Tez.t; -} - -let secrets = - (* Exported from proto_alpha client - TODO : remove when relocated to lib_crypto *) - let read_key mnemonic email password = - match Tezos_client_base.Bip39.of_words mnemonic with - | None -> assert false - | Some t -> - (* TODO: unicode normalization (NFKD)... *) - let passphrase = Bytes.(cat (of_string email) (of_string password)) in - let sk = Tezos_client_base.Bip39.to_seed ~passphrase t in - let sk = Bytes.sub sk 0 32 in - let sk : Signature.Secret_key.t = - Ed25519 - (Data_encoding.Binary.of_bytes_exn - Signature.Ed25519.Secret_key.encoding - sk) - in - let pk = Signature.Secret_key.to_public_key sk in - let pkh = Signature.Public_key.hash pk in - (pkh, pk, sk) - in - List.map - (fun (mnemonic, secret, amount, pkh, password, email) -> - let pkh', pk, sk = read_key mnemonic email password in - let pkh = Signature.Ed25519.Public_key_hash.of_b58check_exn pkh in - assert (Signature.Public_key_hash.equal (Ed25519 pkh) pkh') ; - let activation_code = - Stdlib.Option.get - (Blinded_public_key_hash.activation_code_of_hex secret) - in - let bpkh = Blinded_public_key_hash.of_ed25519_pkh activation_code pkh in - let account = Account.{pkh = Ed25519 pkh; pk; sk} in - Account.add_account account ; - { - blinded_public_key_hash = bpkh; - account = pkh; - activation_code; - amount = - WithExceptions.Option.to_exn - ~none:(Invalid_argument "tez conversion") - (Tez.of_mutez (Int64.of_string amount)); - }) - [ - ( [ - "envelope"; - "hospital"; - "mind"; - "sunset"; - "cancel"; - "muscle"; - "leisure"; - "thumb"; - "wine"; - "market"; - "exit"; - "lucky"; - "style"; - "picnic"; - "success"; - ], - "0f39ed0b656509c2ecec4771712d9cddefe2afac", - "23932454669343", - "tz1MawerETND6bqJqx8GV3YHUrvMBCDasRBF", - "z0eZHQQGKt", - "cjgfoqmk.wpxnvnup@tezos.example.org" ); - ( [ - "flag"; - "quote"; - "will"; - "valley"; - "mouse"; - "chat"; - "hold"; - "prosper"; - "silk"; - "tent"; - "cruel"; - "cause"; - "demise"; - "bottom"; - "practice"; - ], - "41f98b15efc63fa893d61d7d6eee4a2ce9427ac4", - "72954577464032", - "tz1X4maqF9tC1Yn4jULjHRAyzjAtc25Z68TX", - "MHErskWPE6", - "oklmcktr.ztljnpzc@tezos.example.org" ); - ( [ - "library"; - "away"; - "inside"; - "paper"; - "wise"; - "focus"; - "sweet"; - "expose"; - "require"; - "change"; - "stove"; - "planet"; - "zone"; - "reflect"; - "finger"; - ], - "411dfef031eeecc506de71c9df9f8e44297cf5ba", - "217487035428349", - "tz1SWBY7rWMutEuWS54Pt33MkzAS6eWkUuTc", - "0AO6BzQNfN", - "ctgnkvqm.kvtiybky@tezos.example.org" ); - ( [ - "cruel"; - "fluid"; - "damage"; - "demand"; - "mimic"; - "above"; - "village"; - "alpha"; - "vendor"; - "staff"; - "absent"; - "uniform"; - "fire"; - "asthma"; - "milk"; - ], - "08d7d355bc3391d12d140780b39717d9f46fcf87", - "4092742372031", - "tz1amUjiZaevaxQy5wKn4SSRvVoERCip3nZS", - "9kbZ7fR6im", - "bnyxxzqr.tdszcvqb@tezos.example.org" ); - ( [ - "opera"; - "divorce"; - "easy"; - "myself"; - "idea"; - "aim"; - "dash"; - "scout"; - "case"; - "resource"; - "vote"; - "humor"; - "ticket"; - "client"; - "edge"; - ], - "9b7cad042fba557618bdc4b62837c5f125b50e56", - "17590039016550", - "tz1Zaee3QBtD4ErY1SzqUvyYTrENrExu6yQM", - "suxT5H09yY", - "iilkhohu.otnyuvna@tezos.example.org" ); - ( [ - "token"; - "similar"; - "ginger"; - "tongue"; - "gun"; - "sort"; - "piano"; - "month"; - "hotel"; - "vote"; - "undo"; - "success"; - "hobby"; - "shell"; - "cart"; - ], - "124c0ca217f11ffc6c7b76a743d867c8932e5afd", - "26322312350555", - "tz1geDUUhfXK1EMj7VQdRjug1MoFe6gHWnCU", - "4odVdLykaa", - "kwhlglvr.slriitzy@tezos.example.org" ); - ( [ - "shield"; - "warrior"; - "gorilla"; - "birth"; - "steak"; - "neither"; - "feel"; - "only"; - "liberty"; - "float"; - "oven"; - "extend"; - "pulse"; - "suffer"; - "vapor"; - ], - "ac7a2125beea68caf5266a647f24dce9fea018a7", - "244951387881443", - "tz1h3nY7jcZciJgAwRhWcrEwqfVp7VQoffur", - "A6yeMqBFG8", - "lvrmlbyj.yczltcxn@tezos.example.org" ); - ( [ - "waste"; - "open"; - "scan"; - "tip"; - "subway"; - "dance"; - "rent"; - "copper"; - "garlic"; - "laundry"; - "defense"; - "clerk"; - "another"; - "staff"; - "liar"; - ], - "2b3e94be133a960fa0ef87f6c0922c19f9d87ca2", - "80065050465525", - "tz1VzL4Xrb3fL3ckvqCWy6bdGMzU2w9eoRqs", - "oVZqpq60sk", - "rfodmrha.zzdndvyk@tezos.example.org" ); - ( [ - "fiber"; - "next"; - "property"; - "cradle"; - "silk"; - "obey"; - "gossip"; - "push"; - "key"; - "second"; - "across"; - "minimum"; - "nice"; - "boil"; - "age"; - ], - "dac31640199f2babc157aadc0021cd71128ca9ea", - "3569618927693", - "tz1RUHg536oRKhPLFfttcB5gSWAhh4E9TWjX", - "FfytQTTVbu", - "owecikdy.gxnyttya@tezos.example.org" ); - ( [ - "print"; - "labor"; - "budget"; - "speak"; - "poem"; - "diet"; - "chunk"; - "eternal"; - "book"; - "saddle"; - "pioneer"; - "ankle"; - "happy"; - "only"; - "exclude"; - ], - "bb841227f250a066eb8429e56937ad504d7b34dd", - "9034781424478", - "tz1M1LFbgctcPWxstrao9aLr2ECW1fV4pH5u", - "zknAl3lrX2", - "ettilrvh.zsrqrbud@tezos.example.org" ); - ] - -(** {3 Context Manipulations } *) - -let pick_two_endorsers ctxt = - let module V = Plugin.RPC.Validators in - Context.get_endorsers ctxt >>=? function - | a :: b :: _ -> return (a.V.consensus_key, b.V.consensus_key) - | _ -> assert false - -let pick_addr_endorser ctxt = - let module V = Plugin.RPC.Validators in - Context.get_endorsers ctxt >>=? function - | a :: _ -> return a.V.consensus_key - | _ -> assert false - -let init_params = - Tezos_protocol_017_PtNairob_parameters.Default_parameters - .parameters_of_constants - {Context.default_test_constants with consensus_threshold = 0} - -let delegates_of_block block = - let open Lwt_result_syntax in - let+ validators = Context.get_endorsers (B block) in - List.map - (fun Plugin.RPC.Validators.{consensus_key; slots; _} -> - (consensus_key, slots)) - validators - -(** Sequential validation of an operation list. *) -let sequential_validate ?(mempool_mode = true) block operations = - let open Lwt_result_syntax in - let* inc = Incremental.begin_construction ~mempool_mode block in - let* (_inc : Incremental.t) = - List.fold_left_es - (fun acc op -> Incremental.validate_operation acc op) - inc - operations - in - return_unit diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/wasm_kernel/README.md b/src/proto_017_PtNairob/lib_protocol/test/integration/wasm_kernel/README.md deleted file mode 100644 index 62f2267ad645a4bcad328af7c0044e41ad9bc59f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/wasm_kernel/README.md +++ /dev/null @@ -1,73 +0,0 @@ -# About -This folder contains example test kernels, used for running `SCORU WASM` integration tests. - -The test kernels have been built from [tezos/kernel](https://gitlab.com/trili/kernel.git), then manually edited to take into account a change in naming introduced by [this MR](https://gitlab.com/tezos/tezos/-/merge_requests/6914). - -```terminal -wasm2wat ${OLD_KERNEL} -o tmp.wat -sed -i -e 's/kernel_next/kernel_run/g' -e 's/rollup_safe_core/smart_rollup_core/g' tmp.wast -wat2wasm tmp.wat -o {OLD_KERNEL} -``` - -# Available kernels -It is possible to build the test kernels manually, and verify that they are bit-for-bit identical. - -## Prerequisites -You will need `docker`, `git` and `wasm-strip` installed, alongside either `bash` or `zsh`. -- `wasm-strip` is part of the [WebAssembly Binary Toolkit](https://github.com/WebAssembly/wabt). - -Next, clone the *tezos/kernel* repository: -``` shell -git clone https://gitlab.com/tezos/kernel.git wasm_kernel -cd wasm_kernel -``` -and then follow the instructions below for the required kernel. - -## [computation.wasm](./computation.wasm) -The computation kernel performs a simple computation (addition) on each call to its `kernel_run` entrypoint. -It keeps the result on the heap, and therefore uses the allocator. It makes no use of any *PVM host-capabilities*. - -It is designed to be small enough to be able to originate directly within a boot sector, but also large enough to be -used with the *gather-floppies* mechanism. - -To build the `computation.wasm` kernel, run the following from the checked-out `tezos/kernel` repo: -``` shell -git checkout 60e2dedc2b5debb9a6add98038e52e4cd0a358a6 - -# Load the required rust toolchain dockerfile -source scripts/cargo-docker.sh - -cargo build -p test_kernel --target wasm32-unknown-unknown --release \ - --no-default-features --features none,wee_alloc - -# computation_kernel.wasm is a 1.6M wasm binary. -cp target/wasm32-unknown-unknown/release/test_kernel.wasm computation_kernel.wasm - -# Strips binary down to 9.7K -wasm-strip computation_kernel.wasm -``` -# echo.wasm - -`echo.wasm` is the result of `wat2wasm echo.wast`. - -This simple kernel writes the external messages it receives in its outbox. - -To achieve that, it needs to take the encoding of the inputs into -account to extract the payload to push into the outbox. - -# tx-kernel.wasm -The `tx-kernel` is a TORU-like program for transacting in a wasm rollup. - -To build, run the following from the checked-out `tezos/kernel` repo: -```shell -git checkout 69f69144764dcd59dcc1fd144bf6e8f707f0431e - -# Load the required rust toolchain dockerfile -source scripts/cargo-docker.sh - -cargo make wasm-tx-kernel - -cp target/wasm32-unknown-unknown/release/kernel_core.wasm tx-kernel.wasm - -wasm-strip tx-kernel.wasm -``` diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/wasm_kernel/computation.wasm b/src/proto_017_PtNairob/lib_protocol/test/integration/wasm_kernel/computation.wasm deleted file mode 100644 index 1ea01d0f154dfd5fe8b8d2f6f0738629ccb9b23f..0000000000000000000000000000000000000000 Binary files a/src/proto_017_PtNairob/lib_protocol/test/integration/wasm_kernel/computation.wasm and /dev/null differ diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/wasm_kernel/echo.wasm b/src/proto_017_PtNairob/lib_protocol/test/integration/wasm_kernel/echo.wasm deleted file mode 100644 index 383db3bebf9adb36eac791f54ea6a70e18835827..0000000000000000000000000000000000000000 Binary files a/src/proto_017_PtNairob/lib_protocol/test/integration/wasm_kernel/echo.wasm and /dev/null differ diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/wasm_kernel/echo.wast b/src/proto_017_PtNairob/lib_protocol/test/integration/wasm_kernel/echo.wast deleted file mode 100644 index 99026dba63a0e414aaa49f87cd0c18a0c1c8a5f6..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/wasm_kernel/echo.wast +++ /dev/null @@ -1,106 +0,0 @@ -(module - - (type $read_t (func (param i32 i32 i32) (result i32))) - (type $write_t (func (param i32 i32) (result i32))) - (type $store_w_t (func (param i32 i32 i32 i32 i32) (result i32))) - - (import "smart_rollup_core" "read_input" (func $read_input (type $read_t))) - (import "smart_rollup_core" "write_output" (func $write_output (type $write_t))) - (import "smart_rollup_core" "store_write" - (func $store_write (type $store_w_t))) - - (data (i32.const 100) "/kernel/env/reboot") - (data (i32.const 120) "\00\01") ;;Start_of_level - (data (i32.const 122) "\00\02") ;;End_of_level - (data (i32.const 124) "\00\00") ;;Internal Transfer - (data (i32.const 126) "\01") ;;External - - (memory 1) - (export "mem" (memory 0)) - - (func $set_reboot_flag (param $input_offset i32) ;;location of input - (local $eol i32) - (local $input_header i32) - - (local.set $eol (i32.load16_u (i32.const 122))) - (local.set $input_header - (i32.load16_u (local.get $input_offset))) - (i32.ne (local.get $eol) (local.get $input_header)) - (if (then - (call $store_write - (i32.const 100) ;; offset - (i32.const 18) ;; key size - (i32.const 0) ;; offset in the durable storage page - (i32.const 100) ;; offset in memory for the value (placeholder here) - (i32.const 0)) ;; size of the value in memory (placeholder here) - (drop))) - ) - - ;; Internal message representation - ;; (see Data_encoding.Binary.describe Sc_rollup_inbox_message_repr.encoding): - ;; - Tag (1B) `t1` - ;; - Tag (1B) `t2` - ;; - Payload (variable) `payload`, expected as a Byte - ;; + Tag (1B) `tb` - ;; + Size (4B) `size_b` - ;; + bytes (variable) - ;; - Sender (20B) `sender` - ;; - Source (21B) `source` - ;; - Destination (20B) `destination` - ;; - ;; payload = len - (t1 + t2 + tb + size_b + sender + source + destination) - ;; ==> payload = len - (1 + 1 + 1 + 4 + 20 + 21 + 20) - ;; ==> payload = len - 68 - ;; and starts at offset 7 from the input - - (func $internal_payload_size (param $input_size i32) (result i32) - (i32.sub (local.get $input_size) (i32.const 68))) ;; tag - - (func $write_message (param $input_offset i32) (param $size i32) - (local $internal i32) - (local $external i32) - (local $message_tag i32) - (local $internal_transfer_tag i32) - (local $payload_size i32) - - (local.set $external (i32.load8_u (i32.const 126))) - (local.set $internal (i32.load16_u (i32.const 124))) - (local.set $message_tag - (i32.load8_u (local.get $input_offset))) - (local.set $internal_transfer_tag - (i32.load16_u (local.get $input_offset))) - (local.set $payload_size - (call $internal_payload_size (local.get $size))) - - (if - (i32.eq (local.get $message_tag) (local.get $external)) - (then - (call $write_output - (i32.add (local.get $input_offset) (i32.const 1)) ;;Remove the header - (i32.sub (local.get $size) (i32.const 1))) ;;Size without the header - (drop)) - (else - (if - (i32.eq (local.get $internal_transfer_tag) (local.get $internal)) - (then - (call $write_output ;;See comment for the internal message representation - (i32.add (local.get $input_offset) (i32.const 7)) - (local.get $payload_size)) - (drop)) - ) - ) - ) - ) - - (func (export "kernel_run") - (local $size i32) - (local.set $size (call $read_input - (i32.const 220) ;; info_addr - (i32.const 260) ;; dst - (i32.const 3600))) ;; max_bytes - - (call $write_message (i32.const 260) - (local.get $size)) - (call $set_reboot_flag (i32.const 260)) - ) -) diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/wasm_kernel/no_parse_bad_fingerprint.wasm b/src/proto_017_PtNairob/lib_protocol/test/integration/wasm_kernel/no_parse_bad_fingerprint.wasm deleted file mode 100644 index fba1f191b6ed6a5ddb68d628afa7d2ff06255a6f..0000000000000000000000000000000000000000 Binary files a/src/proto_017_PtNairob/lib_protocol/test/integration/wasm_kernel/no_parse_bad_fingerprint.wasm and /dev/null differ diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/wasm_kernel/no_parse_random.wasm b/src/proto_017_PtNairob/lib_protocol/test/integration/wasm_kernel/no_parse_random.wasm deleted file mode 100644 index a817ec8df9ad75e79b53236642c5fa768b130f6c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/integration/wasm_kernel/no_parse_random.wasm +++ /dev/null @@ -1 +0,0 @@ -¹£2º@ÐCöϯ(haS€PiáÈ9«û ªg&4 \ No newline at end of file diff --git a/src/proto_017_PtNairob/lib_protocol/test/integration/wasm_kernel/tx-kernel.wasm b/src/proto_017_PtNairob/lib_protocol/test/integration/wasm_kernel/tx-kernel.wasm deleted file mode 100644 index c67d6bbf46747fc97bb6e61658835c100d17bf98..0000000000000000000000000000000000000000 Binary files a/src/proto_017_PtNairob/lib_protocol/test/integration/wasm_kernel/tx-kernel.wasm and /dev/null differ diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/dune b/src/proto_017_PtNairob/lib_protocol/test/pbt/dune deleted file mode 100644 index 6f2377cf5a46d0427e54b20d48aac35da8035c52..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/dune +++ /dev/null @@ -1,82 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name src_proto_017_PtNairob_lib_protocol_test_pbt_tezt_lib) - (instrumentation (backend bisect_ppx)) - (libraries - tezt.core - octez-libs.base - octez-libs.micheline - octez-protocol-017-PtNairob-libs.client - tezos-protocol-017-PtNairob.protocol - octez-libs.tezos-context.merkle_proof_encoding - octez-libs.test-helpers - octez-protocol-017-PtNairob-libs.test-helpers - octez-alcotezt - qcheck-alcotest - tezos-benchmark - tezos-benchmark-017-PtNairob - tezos-benchmark-type-inference-017-PtNairob - octez-protocol-017-PtNairob-libs.smart-rollup - octez-libs.crypto-dal - octez-libs.base-test-helpers - tezos-protocol-017-PtNairob.parameters) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezt_core - -open Tezt_core.Base - -open Tezos_base.TzPervasives - -open Tezos_micheline - -open Tezos_client_017_PtNairob - -open Tezos_protocol_017_PtNairob - -open Tezos_test_helpers - -open Tezos_017_PtNairob_test_helpers - -open Octez_alcotezt - -open Tezos_benchmark_017_PtNairob - -open Tezos_benchmark_type_inference_017_PtNairob - -open Tezos_smart_rollup_017_PtNairob - -open Tezos_crypto_dal - -open Tezos_base_test_helpers - -open Tezos_protocol_017_PtNairob_parameters) - (modules - liquidity_baking_pbt - saturation_fuzzing - test_merkle_list - test_gas_properties - test_sampler - test_script_comparison - test_tez_repr - test_bitset - test_sc_rollup_tick_repr - test_sc_rollup_encoding - test_sc_rollup_inbox - test_refutation_game - test_carbonated_map - test_zk_rollup_encoding - test_dal_slot_proof - test_compare_operations - test_operation_encoding - test_bytes_conversion)) - -(executable - (name main) - (instrumentation (backend bisect_ppx --bisect-sigterm)) - (libraries - src_proto_017_PtNairob_lib_protocol_test_pbt_tezt_lib - tezt) - (link_flags - (:standard) - (:include %{workspace_root}/macos-link-flags.sexp)) - (modules main)) - -(rule - (alias runtest) - (package tezos-protocol-017-PtNairob-tests) - (enabled_if (<> false %{env:RUNTEZTALIAS=true})) - (action (run %{dep:./main.exe}))) - -(rule - (targets main.ml) - (action (with-stdout-to %{targets} (echo "let () = Tezt.Test.run ()")))) diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/liquidity_baking_pbt.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/liquidity_baking_pbt.ml deleted file mode 100644 index 5da5752cd547f92b5c7c329e21f6fb17f576697d..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/liquidity_baking_pbt.ml +++ /dev/null @@ -1,327 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: pbt for liquidity baking - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/pbt/main.exe \ - -- --file liquidity_baking_pbt.ml - Subject: Test liquidity baking contracts using randomly generated inputs. -*) - -open Protocol -open Alpha_context -open Liquidity_baking_machine - -(** We use the “machines†provided by the {! Liquidity_baking_machine} - module. Because using the [ConcreteMachine] (hence, the {! - ValidationMachine} too) is slow, we implement the following - test-suit architecture: - - - One {v QCheck2 v}-based test is used to validate consistency of - the {! SymbolicMachine} wrt. the [ConcreteMachine], thanks to - the {! ValidationMachine}. - - The rest of the tests use the {! SymbolicMachine} in order to be - more effective. *) - -(** [all_true l] waits for all promises of [l], and returns [true] iff - they all resolve to [true]. *) -let all_true = List.for_all_ep Fun.id - -let extract_qcheck_tzresult : unit tzresult Lwt.t -> bool = - fun p -> - match Lwt_main.run p with - | Ok () -> true - | Error err -> QCheck2.Test.fail_reportf "@\n%a@." pp_print_trace err - -let rec run_and_check check scenarios env state = - match scenarios with - | step :: rst -> - let state' = SymbolicMachine.step step env state in - assert (check state state') ; - run_and_check check rst env state' - | [] -> state - -let one_balance_decreases c env state state' = - let xtz = SymbolicMachine.get_xtz_balance c state in - let tzbtc = SymbolicMachine.get_tzbtc_balance c env state in - let lqt = SymbolicMachine.get_liquidity_balance c env state in - let xtz' = SymbolicMachine.get_xtz_balance c state' in - let tzbtc' = SymbolicMachine.get_tzbtc_balance c env state' in - let lqt' = SymbolicMachine.get_liquidity_balance c env state' in - xtz' < xtz || tzbtc' < tzbtc || lqt' < lqt - || (xtz' = xtz && tzbtc' = tzbtc && lqt' = lqt) - -let get_float_balances env state = - let xtz = - Int64.to_float @@ SymbolicMachine.get_xtz_balance env.cpmm_contract state - in - let tzbtc = - Int.to_float - @@ SymbolicMachine.get_tzbtc_balance env.cpmm_contract env state - in - let lqt = - Int.to_float @@ SymbolicMachine.get_cpmm_total_liquidity env state - in - (xtz, tzbtc, lqt) - -(** [is_remove_liquidity_consistent env state state'] returns [true] - iff, when the liquidity pool decreased in [state'], then the - fraction of tzbtc and xtz returned to the liquidity provider is - lesser or equal than the fraction of lqt burnt. *) -let is_remove_liquidity_consistent env state state' = - let xtz, tzbtc, lqt = get_float_balances env state in - let xtz', tzbtc', lqt' = get_float_balances env state' in - if lqt' < lqt then - let flqt = (lqt -. lqt') /. lqt in - let fxtz = (xtz -. xtz') /. xtz in - let ftzbtc = (tzbtc -. tzbtc') /. tzbtc in - fxtz <= flqt && ftzbtc <= flqt - else true - -(** [is_share_price_increasing env state state'] returns [true] iff - the product of supplies (tzbtc, and xtz) increases. - - See https://blog.nomadic-labs.com/progress-report-on-the-verification-of-liquidity-baking-smart-contracts.html#evolution-of-the-product-of-supplies *) -let is_share_price_increasing env state state' = - let xtz, tzbtc, lqt = get_float_balances env state in - let xtz', tzbtc', lqt' = get_float_balances env state' in - xtz *. tzbtc /. (lqt *. lqt) <= xtz' *. tzbtc' /. (lqt' *. lqt') - -(** [positive_pools env state] returns [true] iff the three pools of - the CPMM (as identified in [env]) are strictly positive in - [state]. *) -let positive_pools env state = - let xtz = SymbolicMachine.get_xtz_balance env.cpmm_contract state in - let tzbtc = SymbolicMachine.get_tzbtc_balance env.cpmm_contract env state in - let lqt = SymbolicMachine.get_cpmm_total_liquidity env state in - 0L < xtz && 0 < tzbtc && 0 < lqt - -(** [validate_xtz_balance c env (blk, state)] returns [true] iff the - tez balance for the contract [c] is the same in [blk] and in - [state]. *) -let validate_xtz_balance : - Contract.t -> ValidationMachine.t -> bool tzresult Lwt.t = - fun contract state -> - let open Lwt_result_syntax in - let* expected = ValidationMachine.Symbolic.get_xtz_balance contract state in - let* amount = ValidationMachine.Concrete.get_xtz_balance contract state in - return (amount = expected) - -(** [validate_tzbtc_balance c env (blk, state)] returns [true] iff the - tzbtc balance for the contract [c] is the same in [blk] and in - [state]. *) -let validate_tzbtc_balance : - Contract.t -> Contract.t env -> ValidationMachine.t -> bool tzresult Lwt.t = - fun contract env state -> - let open Lwt_result_syntax in - let* expected = - ValidationMachine.Symbolic.get_tzbtc_balance contract env state - in - let* amount = - ValidationMachine.Concrete.get_tzbtc_balance contract env state - in - return (expected = amount) - -(** [validate_liquidity_balance c env (blk, state)] returns [true] if - the contract [c] holds the same amount of liquidity in [blk] and - [state]. *) -let validate_liquidity_balance : - Contract.t -> Contract.t env -> ValidationMachine.t -> bool tzresult Lwt.t = - fun contract env state -> - let open Lwt_result_syntax in - let* expected = - ValidationMachine.Symbolic.get_liquidity_balance contract env state - in - let* amount = - ValidationMachine.Concrete.get_liquidity_balance contract env state - in - return (expected = amount) - -(** [validate_balances c env (blk, state)] returns true iff the - contract [c] holds the same amount of tez, tzbtc and liquidity in - [blk] and [state]. *) -let validate_balances : - Contract.t -> Contract.t env -> ValidationMachine.t -> bool tzresult Lwt.t = - fun contract env combined_state -> - all_true - [ - validate_xtz_balance contract combined_state; - validate_tzbtc_balance contract env combined_state; - validate_liquidity_balance contract env combined_state; - ] - -(** [validate_cpmm_total_liquidity env state] returns true iff the - CPMM has distributed the same amount of liquidity tokens in its - concrete and symbolic parts of [state]. *) -let validate_cpmm_total_liquidity env state = - let open Lwt_result_syntax in - let* concrete_cpmm_total_liquidity = - ValidationMachine.Concrete.get_cpmm_total_liquidity env state - in - let* ghost_cpmm_total_liquidity = - ValidationMachine.Symbolic.get_cpmm_total_liquidity env state - in - return (concrete_cpmm_total_liquidity = ghost_cpmm_total_liquidity) - -(** [validate_consistency env (blk, state)] checks if the accounts in - [env] (the CPMM and the implicit accounts) share the same balances - in [blk] and [state]. *) -let validate_consistency : - Contract.t env -> ValidationMachine.t -> bool tzresult Lwt.t = - (* We do not try to validate the xtz balance of [holder] in this - function. Indeed, they are hard to predict due to allocation - fees, and security deposits. *) - fun env state -> - all_true - (validate_cpmm_total_liquidity env state - :: validate_balances env.cpmm_contract env state - :: List.map - (fun account -> validate_balances account env state) - env.implicit_accounts) - -(** [validate_storage env blk] returns [true] iff the storage of the - CPMM contract is consistent wrt. to its actual balances (tez, - tzbtc, and liquidity). *) -let validate_storage : - Contract.t env -> ConcreteMachine.t -> bool tzresult Lwt.t = - fun env blk -> - let open Lwt_result_syntax in - let* cpmm_storage = - Cpmm_repr.Storage.get (B blk) ~contract:env.cpmm_contract - in - all_true - [ - (* 1. Check the CPMM's [xtzPool] is equal to the actual CPMM balance *) - (let* cpmm_xtz = ConcreteMachine.get_xtz_balance env.cpmm_contract blk in - return (cpmm_xtz = Tez.to_mutez cpmm_storage.xtzPool)); - (* 2. Check the CPMM’s [lqtTotal] is correct wrt. liquidity contract *) - (let* liquidity_storage = - Lqt_fa12_repr.Storage.get (B blk) ~contract:env.liquidity_contract - in - return (cpmm_storage.lqtTotal = liquidity_storage.totalSupply)); - (* 3. Check the CPMM’s [tokenPool] is correct *) - (let* cpmm_tzbtc = - ConcreteMachine.get_tzbtc_balance env.cpmm_contract env blk - in - return (Z.to_int cpmm_storage.tokenPool = cpmm_tzbtc)); - ] - -(** [machine_validation_tests] is a list of asynchronous tests aiming - at asserting the correctness and consistencies of the machines - themselves. *) -let machine_validation_tests = - let open Lwt_result_syntax in - [ - QCheck2.Test.make - ~count:10 - ~name:"Concrete/Symbolic Consistency" - ~print:Liquidity_baking_generator.print_scenario - (Liquidity_baking_generator.gen_scenario 1_000_000 1_000_000 10) - (fun (specs, scenario) -> - extract_qcheck_tzresult - (let invariant = validate_consistency in - let* state, env = ValidationMachine.build ~invariant specs in - let* (_ : ValidationMachine.t) = - ValidationMachine.run ~invariant scenario env state - in - return_unit)); - QCheck2.Test.make - ~count:10 - ~name:"Storage consistency" - ~print:Liquidity_baking_generator.print_scenario - (Liquidity_baking_generator.gen_scenario 1_000_000 1_000_000 10) - (fun (specs, scenario) -> - extract_qcheck_tzresult - (let invariant = validate_storage in - let* state, env = ConcreteMachine.build ~invariant specs in - let* (_ : Block.t) = - ConcreteMachine.run ~invariant scenario env state - in - return_unit)); - QCheck2.Test.make - ~count:50_000 - ~name:"Positive pools" - ~print:Liquidity_baking_generator.print_scenario - (Liquidity_baking_generator.gen_scenario 1_000_000 1_000_000 50) - (fun (specs, scenario) -> - extract_qcheck_tzresult - (let invariant = positive_pools in - let state, env = SymbolicMachine.build ~invariant specs in - let (_ : SymbolicMachine.t) = - SymbolicMachine.run ~invariant scenario env state - in - return_unit)); - ] - -(** [economic_tests] is a list of asynchronous tests aiming at - asserting the good economic properties of the Liquidity Baking - feature. *) -let economic_tests = - [ - QCheck2.Test.make - ~count:50_000 - ~name:"No global gain" - ~print:Liquidity_baking_generator.print_adversary_scenario - (Liquidity_baking_generator.gen_adversary_scenario 1_000_000 1_000_000 50) - (fun (specs, attacker, scenario) -> - let state, env = SymbolicMachine.build ~subsidy:0L specs in - let (_ : SymbolicMachine.t) = - run_and_check (one_balance_decreases attacker env) scenario env state - in - true); - QCheck2.Test.make - ~count:50_000 - ~name:"Remove liquidities is consistent" - ~print:Liquidity_baking_generator.print_scenario - (Liquidity_baking_generator.gen_scenario 1_000_000 1_000_000 50) - (fun (specs, scenario) -> - let state, env = SymbolicMachine.build ~subsidy:0L specs in - let (_ : SymbolicMachine.t) = - run_and_check (is_remove_liquidity_consistent env) scenario env state - in - true); - QCheck2.Test.make - ~count:50_000 - ~name:"Share price only increases" - ~print:Liquidity_baking_generator.print_scenario - (Liquidity_baking_generator.gen_scenario 1_000_000 1_000_000 50) - (fun (specs, scenario) -> - let state, env = SymbolicMachine.build ~subsidy:0L specs in - let (_ : SymbolicMachine.t) = - run_and_check (is_share_price_increasing env) scenario env state - in - true); - ] - -let () = - let open Qcheck2_helpers in - Alcotest.run - ~__FILE__ - Protocol.name - [ - ("Machines Cross-Validation", qcheck_wrap machine_validation_tests); - ("Economic Properties", qcheck_wrap economic_tests); - ] diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/saturation_fuzzing.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/saturation_fuzzing.ml deleted file mode 100644 index 535dc427ff61b14bc4aa6a202c261ccb9f7791e6..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/saturation_fuzzing.ml +++ /dev/null @@ -1,202 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol Library - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/pbt/main.exe \ - -- --file saturation_fuzzing.ml - Subject: Operations in Saturation_repr -*) - -open Protocol.Saturation_repr -open Qcheck2_helpers - -(** A generator that returns a [t] that cannot be [saturated] *) -let unsatured_gen = of_option_gen @@ QCheck2.Gen.(map of_int_opt int) - -(** The general generator for [t]: generates both unsaturated values - and [saturated]. *) -let t_gen : may_saturate t QCheck2.Gen.t = - QCheck2.Gen.(frequency [(1, return saturated); (4, unsatured_gen)]) - -(* Test. - * Tests that [add] commutes. - *) -let test_add_commutes = - QCheck2.Test.make - ~name:"t1 + t2 = t2 + t1" - (QCheck2.Gen.pair t_gen t_gen) - (fun (t1, t2) -> - let t1_plus_t2 = add t1 t2 in - let t2_plus_t1 = add t2 t1 in - qcheck_eq ~pp t1_plus_t2 t2_plus_t1) - -(* Test. - * Tests that [mul] commutes. - *) -let test_mul_commutes = - QCheck2.Test.make - ~name:"t1 * t2 = t2 * t1" - (QCheck2.Gen.pair t_gen t_gen) - (fun (t1, t2) -> - let t1_times_t2 = mul t1 t2 in - let t2_times_t1 = mul t2 t1 in - qcheck_eq ~pp t1_times_t2 t2_times_t1) - -(* Test. - * Tests that [zero] is neutral for [add]. - *) -let test_add_zero = - QCheck2.Test.make ~name:"t + 0 = t" t_gen (fun t -> - let t_plus_zero = add t zero in - qcheck_eq' ~pp ~expected:t ~actual:t_plus_zero ()) - -(* Test. - * Tests that t1 + t2 >= t1 - *) -let test_add_neq = - QCheck2.Test.make - ~name:"t1 + t2 >= t1" - (QCheck2.Gen.pair t_gen t_gen) - (fun (t1, t2) -> - let t1_plus_t2 = add t1 t2 in - t1_plus_t2 >= t1) - -(* Test. - * Tests that 1 is neutral for [mul]. - *) -let test_mul_one = - let one = safe_int 1 in - QCheck2.Test.make ~name:"t * 1 = t" t_gen (fun t -> - let t_times_one = mul t one in - qcheck_eq' ~pp ~expected:t ~actual:t_times_one ()) - -(* Test. - * Tests that [t] times [0] equals [0]. - *) -let test_mul_zero = - QCheck2.Test.make ~name:"t * 0 = 0" t_gen (fun t -> - let t_times_zero = mul t zero in - qcheck_eq' ~pp ~expected:zero ~actual:t_times_zero ()) - -(* Test. - * Tests that [t] [sub] [zero] equals [t]. - *) -let test_sub_zero = - QCheck2.Test.make ~name:"t - 0 = t" t_gen (fun t -> - let t_sub_zero = sub t zero in - qcheck_eq' ~pp ~expected:t ~actual:t_sub_zero ()) - -(* Test. - * Tests that [t] [sub] [t] equals [zero]. - *) -let test_sub_itself = - QCheck2.Test.make ~name:"t - t = 0" t_gen (fun t -> - let t_sub_t = sub t t in - qcheck_eq' ~pp ~expected:zero ~actual:t_sub_t ()) - -(* Test. - * Tests that t1 - t2 <= t1 - *) -let test_sub_neq = - QCheck2.Test.make - ~name:"t1 - t2 <= t1" - (QCheck2.Gen.pair t_gen t_gen) - (fun (t1, t2) -> - let t1_minus_t2 = sub t1 t2 in - t1_minus_t2 <= t1) - -(* Test. - * Tests that (t1 + t2) - t2 <= t1 - *) -let test_add_sub = - QCheck2.Test.make - ~name:"(t1 + t2) - t2 <= t1" - (QCheck2.Gen.pair t_gen t_gen) - (fun (t1, t2) -> - let lhs = sub (add t1 t2) t2 in - lhs <= t1) - -(* Test. - * Tests that (t1 - t2) + t2 >= t1 - *) -let test_sub_add = - QCheck2.Test.make - ~name:"(t1 - t2) + t2 >= t1" - (QCheck2.Gen.pair t_gen t_gen) - (fun (t1, t2) -> - let lhs = add (sub t1 t2) t2 in - lhs >= t1) - -(* Test. - * Tests that [saturated] >= t - *) -let test_leq_saturated = - QCheck2.Test.make ~name:"t <= saturated" t_gen (fun t -> saturated >= t) - -(* Test. - * Tests that [zero] <= t - *) -let test_geq_zero = QCheck2.Test.make ~name:"t >= 0" t_gen (fun t -> zero <= t) - -(* Test. - * Tests that [sqrt (t * t) = t] - *) -let test_squared_sqrt = - QCheck2.Test.make ~name:"sqrt t² = t" t_gen (fun t -> - mul t t = saturated || sqrt (mul t t) = t) - -(* Test. - * Tests that [(sqrt t) * (sqrt t) <= t] - *) -let test_sqrt_squared = - QCheck2.Test.make ~name:"(sqrt t)² <= t <= (succ (sqrt t))²" t_gen (fun t -> - mul (sqrt t) (sqrt t) <= t && t <= mul (succ (sqrt t)) (succ (sqrt t))) - -let tests_add = [test_add_commutes; test_add_zero; test_add_neq] - -let tests_mul = [test_mul_commutes; test_mul_one; test_mul_zero] - -let tests_sub = [test_sub_zero; test_sub_itself; test_sub_neq] - -let tests_add_sub = [test_add_sub; test_sub_add] - -let tests_boundaries = [test_leq_saturated; test_geq_zero] - -let tests_sqrt = [test_sqrt_squared; test_squared_sqrt] - -let () = - Alcotest.run - ~__FILE__ - Protocol.name - [ - ("add", qcheck_wrap tests_add); - ("mul", qcheck_wrap tests_mul); - ("sub", qcheck_wrap tests_sub); - ("add and sub", qcheck_wrap tests_add_sub); - ("sqrt", qcheck_wrap tests_sqrt); - ("<= and >=", qcheck_wrap tests_boundaries); - ] diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_bitset.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_bitset.ml deleted file mode 100644 index f7a58ba52e563d7b3be3282573a82ab78b451ac0..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_bitset.ml +++ /dev/null @@ -1,125 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol Library - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/pbt/main.exe \ - -- --file test_bitset.ml - Subject: Bitset structure -*) - -open Qcheck2_helpers -open Protocol.Bitset - -let gen_ofs = QCheck2.Gen.int_bound (64 * 10) - -let value_of res = - match res with - | Ok v -> v - | Error e -> - Alcotest.failf - "An unxpected error %a occurred when generating Bitset.t" - Environment.Error_monad.pp_trace - e - -let gen_storage = - let open QCheck2.Gen in - let* int_vector = list @@ int_bound 64 in - from_list int_vector |> value_of |> return - -let test_get_set (c, ofs) = - List.for_all - (fun ofs' -> - let open Result_syntax in - value_of - @@ let* c' = add c ofs in - let* v = mem c ofs' in - let* v' = mem c' ofs' in - return (if ofs = ofs' then v' = true else v = v')) - (0 -- 63) - -let test_inter (c1, c2) = - let c3 = inter c1 c2 in - List.for_all - (fun ofs -> - let open Result_syntax in - value_of - @@ let* v1 = mem c1 ofs in - let* v2 = mem c2 ofs in - let* v3 = mem c3 ofs in - return ((v1 && v2) = v3)) - (0 -- 63) - -let test_diff (c1, c2) = - let c3 = diff c1 c2 in - List.for_all - (fun ofs -> - let open Result_syntax in - value_of - @@ let* v1 = mem c1 ofs in - let* v2 = mem c2 ofs in - let* v3 = mem c3 ofs in - return ((v1 && not v2) = v3)) - (0 -- 63) - -let test_fill = - let two = Z.of_int 2 in - fun length -> - let f1 = fill ~length |> value_of |> to_z in - let f2 = from_list (0 -- (length - 1)) |> value_of |> to_z in - let f3 = Z.(pow two length |> pred) in - Z.equal f1 f2 && Z.equal f2 f3 - -let () = - Alcotest.run - ~__FILE__ - Protocol.name - [ - ( "quantity", - qcheck_wrap - [ - QCheck2.Test.make - ~count:10000 - ~name:"get set" - QCheck2.Gen.(pair gen_storage gen_ofs) - test_get_set; - QCheck2.Test.make - ~count:10000 - ~name:"inter" - QCheck2.Gen.(pair gen_storage gen_storage) - test_inter; - QCheck2.Test.make - ~count:10000 - ~name:"diff" - QCheck2.Gen.(pair gen_storage gen_storage) - test_diff; - QCheck2.Test.make - ~count:10000 - ~name:"fill" - QCheck2.Gen.(small_nat) - test_fill; - ] ); - ] diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_bytes_conversion.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_bytes_conversion.ml deleted file mode 100644 index 3e0c3762fca1ad2d7ab25a22499cc06ec6cf550b..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_bytes_conversion.ml +++ /dev/null @@ -1,215 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 DaiLambda, 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: pbt for bytes <=> nat/int conversions - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/pbt/main.exe \ - -- --file test_bytes_conversion.ml - Subject: Test the conversions between bytes and int/nat -*) - -let failwith = Stdlib.failwith - -open Protocol -open Script_int -open Script_bytes - -let gen_n = - let open QCheck2.Gen in - let* n1 = int in - let+ n2 = int in - Z.(abs (of_int n1 * of_int n2)) - -let gen_z = - let open QCheck2.Gen in - let* n1 = int in - let+ n2 = int in - Z.(of_int n1 * of_int n2) - -let gen_bytes = - let open QCheck2.Gen in - bytes_size small_nat - -let test_bytes_nat_conversion_unit () = - let test z h = - (* nat => bytes *) - let (`Hex h') = Hex.of_bytes (bytes_of_nat_be (abs (of_zint z))) in - if h <> h' then - failwith (Format.asprintf "%a => %s <> %s" Z.pp_print z h' h) ; - (* bytes => nat *) - let z' = to_zint @@ nat_of_bytes_be (Hex.to_bytes_exn (`Hex h)) in - if Z.Compare.(z <> z') then - failwith (Format.asprintf "%a <> %a <= %s" Z.pp_print z Z.pp_print z' h) ; - (* "00" ^ bytes => nat *) - let h'' = "00" ^ h in - let z'' = to_zint @@ nat_of_bytes_be (Hex.to_bytes_exn (`Hex h'')) in - if Z.Compare.(z <> z'') then - failwith (Format.asprintf "%a <> %a <= %s" Z.pp_print z Z.pp_print z' h) - in - let test' h = test (Z.of_string ("0x" ^ h)) h in - test (Z.of_int 0) "" ; - test' "123456" ; - test' "010000000000000000" - -(* Tests of nat => bytes *) -let test_bytes_of_nat_random () = - let gen = - let open QCheck2.Gen in - let* n = gen_n in - let+ leading_bytes = small_nat in - (n, leading_bytes) - in - QCheck_alcotest.to_alcotest - @@ QCheck2.Test.make ~name:"bytes_of_nat" gen - @@ fun (n, leading_zeros) -> - let bytes = bytes_of_nat_be @@ abs (of_zint n) in - (* [bytes_of_nat] encodes any [nat] to the shortest representation in [bytes], - without leading zeros. *) - if Bytes.length bytes > 0 then assert (Bytes.get bytes 0 <> '\000') ; - (* [nat_of_bytes @@ bytes_of_nat n = n] *) - Z.Compare.(to_zint (nat_of_bytes_be bytes) = n) - (* Leading zero chars do not affect the decoding *) - && - let leading_zeros = Bytes.make leading_zeros '\000' in - Z.Compare.(to_zint (nat_of_bytes_be (Bytes.cat leading_zeros bytes)) = n) - -(* Tests of bytes => nat *) -let test_nat_of_bytes_random () = - QCheck_alcotest.to_alcotest - @@ QCheck2.Test.make ~name:"nat_of_bytes" gen_bytes - @@ fun b -> - (* [nat_of_bytes] decodes any [bytes] to a [nat] *) - let n = nat_of_bytes_be b in - (* [bytes_of_nat] encodes the [nat] back to the original [bytes] - but without its leading zeros. - *) - Z.Compare.(to_zint n >= Z.zero) - && - let b' = bytes_of_nat_be n in - let diff = Bytes.length b - Bytes.length b' in - let leading_zeros = Bytes.make diff '\000' in - b = Bytes.cat leading_zeros b' - -let test_bytes_int_conversion_unit () = - let test z h = - let z = Z.of_string z in - (* int => bytes *) - let (`Hex h') = Hex.of_bytes (bytes_of_int_be (of_zint z)) in - if h <> h' then - failwith (Format.asprintf "%a => %s <> %s" Z.pp_print z h' h) ; - (* bytes => int *) - let z' = to_zint @@ int_of_bytes_be (Hex.to_bytes_exn (`Hex h)) in - if Z.Compare.(z <> z') then - failwith (Format.asprintf "%a <> %a <= %s" Z.pp_print z Z.pp_print z' h) ; - (* ("00"|"ff") ^ bytes => int - Adding 00 or ff prefixes (00 for positive and ff for negative ints) - must not change the decoding. *) - let h'' = if Z.Compare.(z < Z.zero) then "ff" ^ h else "00" ^ h in - let z'' = to_zint @@ int_of_bytes_be (Hex.to_bytes_exn (`Hex h'')) in - if Z.Compare.(z <> z'') then - failwith (Format.asprintf "%a <> %a <= %s" Z.pp_print z Z.pp_print z' h) - in - test "0" "" ; - test "1" "01" ; - test "-1" "ff" ; - test "127" "7f" ; - test "-128" "80" ; - test "128" "0080" ; - test "-129" "ff7f" ; - test "0x8000" "008000" ; - test "-33024" "ff7f00" ; - test "0x010000000000000000" "010000000000000000" ; - test "-0x010000000000000000" "ff0000000000000000" ; - test "0xcd9e7dbee9425ffc" "00cd9e7dbee9425ffc" (* once failed due to a bug *) - -(* Tests of int => bytes *) -let test_bytes_of_int_random () = - let gen = - let open QCheck2.Gen in - let* z = gen_z in - let+ leading_bytes = small_nat in - (z, leading_bytes) - in - QCheck_alcotest.to_alcotest - @@ QCheck2.Test.make ~name:"bytes_of_int" gen - @@ fun (z, leading_bytes) -> - (* [bytes_of_int] must encode any [int] to [bytes]. *) - let bytes = bytes_of_int_be @@ of_zint z in - (* [bytes_of_int] must return the shortest encoding: at most 1 char of zero - or '\255's at the head. *) - (if Bytes.length bytes >= 2 then - match (Bytes.get bytes 0, Bytes.get bytes 1) with - | '\000', '\000' | '\255', '\255' -> assert false - | _ -> ()) ; - (* [int_of_bytes @@ bytes_of_int z = z] *) - (let z' = to_zint @@ int_of_bytes_be bytes in - Z.Compare.(z = z')) - (* [int_of_bytes] must ignore the leading zeros for 0 and positive ints - and '\255's for negatives *) - && - let leading_bytes = - Bytes.make leading_bytes (if Z.Compare.(z < Z.zero) then '\255' else '\000') - in - Z.Compare.(to_zint @@ int_of_bytes_be (Bytes.cat leading_bytes bytes) = z) - -(* Tests of bytes => int *) -let test_int_of_bytes_random () = - QCheck_alcotest.to_alcotest - @@ QCheck2.Test.make ~name:"int_of_bytes" gen_bytes - @@ fun b -> - (* [int_of_bytes] decodes any [bytes] to a [int] *) - let i = int_of_bytes_be b in - (* [bytes_of_int] must encode the [int] back to the original [bytes] - but without its leading zeros for 0 and positive [int]s and '\255' - for negatives. *) - let b' = bytes_of_int_be i in - let diff = Bytes.length b - Bytes.length b' in - let leading_bytes = - Bytes.make diff (if Z.Compare.(to_zint i < Z.zero) then '\255' else '\000') - in - b = Bytes.cat leading_bytes b' - -let tests = - [ - ( "bytes_nat_conv", - [ - ("unit", `Quick, test_bytes_nat_conversion_unit); - test_bytes_of_nat_random (); - test_nat_of_bytes_random (); - ] ); - ( "bytes_int_conv", - [ - ("unit", `Quick, test_bytes_int_conversion_unit); - test_bytes_of_int_random (); - test_int_of_bytes_random (); - ] ); - ] - -let () = - Alcotest.run - ~__FILE__ - (Protocol.name ^ ": bytes and int/nat conversion ") - tests diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_carbonated_map.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_carbonated_map.ml deleted file mode 100644 index 568ec816747d3788145a5c744210c439338dcdf9..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_carbonated_map.ml +++ /dev/null @@ -1,548 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol Library - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/pbt/main.exe \ - -- --file test_carbonated_map.ml - Subject: Operations in Carbonated_map -*) - -open Qcheck2_helpers -open QCheck2 -open Protocol - -let new_ctxt () = - let open Lwt_result_syntax in - let* block, _contract = Context.init1 () in - let* incr = Incremental.begin_construction block in - return @@ Incremental.alpha_ctxt incr - -module Compare_int = struct - type t = int - - let compare = Int.compare - - let compare_cost _ = Saturation_repr.safe_int 10 -end - -module CM = - Carbonated_map.Make - (struct - type context = Alpha_context.context - - let consume = Alpha_context.Gas.consume - end) - (Compare_int) - -let unsafe_new_context () = - Result.value_f - ~default:(fun () -> Stdlib.failwith "Failed to create context") - (Lwt_main.run @@ new_ctxt ()) - -let int_map_gen = - let ctxt = unsafe_new_context () in - Gen.small_list (Gen.pair Gen.small_int Gen.small_int) - |> Gen.map (fun kvs -> - let merge_overlap ctxt x y = Ok (x + y, ctxt) in - match CM.of_list ctxt ~merge_overlap kvs with - | Ok (map, _) -> map - | Error _ -> Stdlib.failwith "Failed to construct map") - -let pp_int_map fmt map = - let open Lwt_result_wrap_syntax in - let pp = - Assert.pp_print_list (fun fmt (k, v) -> Format.fprintf fmt "(%d, %d)" k v) - in - Lwt_main.run - (let open Lwt_result_syntax in - let* ctxt = new_ctxt () in - let*?@ kvs, _ = CM.to_list ctxt map in - return kvs) - |> Result.value_f ~default:(fun () -> assert false) - |> Format.fprintf fmt "%a" pp - -let int_map_test name f = - Test.make - ~print:(Format.asprintf "%a" pp_int_map) - ~count:100 - ~name - int_map_gen - (fun map -> match f map with Ok b -> b | Error _ -> false) - -let int_map_pair_test name f = - Test.make - ~print:(fun (map1, map2) -> - Format.asprintf "(%a, %a)" pp_int_map map1 pp_int_map map2) - ~count:100 - ~name - (Gen.pair int_map_gen int_map_gen) - (fun (map1, map2) -> match f map1 map2 with Ok b -> b | Error _ -> false) - -let unit_test name f = - Alcotest.test_case name `Quick (fun () -> - match f () with Ok b -> assert b | _ -> assert false) - -type Environment.Error_monad.error += Dummy_error - -let dummy_fail = - Result.error (Environment.Error_monad.trace_of_error Dummy_error) - -let assert_map_contains ctxt map expected = - let open Result_syntax in - let* kvs, _ctxt = CM.to_list ctxt map in - Ok (List.sort compare kvs = List.sort compare expected) - -let assert_equal_map ctxt map expected = - let open Result_syntax in - let* kvs, ctxt = CM.to_list ctxt expected in - assert_map_contains ctxt map kvs - -(** Test that the size of an empty map is 0. *) -let test_empty = - unit_test "Size of empty map is 0" (fun () -> Ok (CM.size CM.empty = 0)) - -(** Test adding a new element *) -let test_update_add = - let open Result_syntax in - unit_test "Update add" @@ fun () -> - let ctxt = unsafe_new_context () in - let* map, ctxt = - CM.of_list - ctxt - ~merge_overlap:(fun _ _ _ -> dummy_fail) - [(1, 1); (2, 2); (3, 3)] - in - let update_replace ctxt key value map = - CM.update ctxt key (fun ctxt _ -> Ok (Some value, ctxt)) map - in - let* map, ctxt = update_replace ctxt 4 4 map in - assert_map_contains ctxt map [(1, 1); (2, 2); (3, 3); (4, 4)] - -(** Test replacing an existing element. *) -let test_update_replace = - let open Result_syntax in - unit_test "Update replace" @@ fun () -> - let ctxt = unsafe_new_context () in - let* map, ctxt = - CM.of_list - ctxt - ~merge_overlap:(fun _ _ _ -> dummy_fail) - [(1, 1); (2, 2); (3, 3)] - in - let update_replace ctxt key value map = - CM.update ctxt key (fun ctxt _ -> Ok (Some value, ctxt)) map - in - let* map, ctxt = update_replace ctxt 1 42 map in - assert_map_contains ctxt map [(1, 42); (2, 2); (3, 3)] - -(** Test merging when ignoring new overlapping keys. *) -let test_merge_overlaps_left = - let open Result_syntax in - unit_test "Merge overlaps left" @@ fun () -> - let ctxt = unsafe_new_context () in - let* map, ctxt = - CM.of_list - ctxt - ~merge_overlap:(fun ctxt left _ -> Ok (left, ctxt)) - [(1, 1); (2, 2); (3, 3); (1, 11); (2, 22); (3, 33); (4, 44)] - in - assert_map_contains ctxt map [(1, 1); (2, 2); (3, 3); (4, 44)] - -(** Test merging when replacing the element of a new overlapping key. *) -let test_merge_overlaps_right = - let open Result_syntax in - unit_test "Merge overlap replace" @@ fun () -> - let ctxt = unsafe_new_context () in - let* map, ctxt = - CM.of_list - ctxt - ~merge_overlap:(fun ctxt _ right -> Ok (right, ctxt)) - [(1, 1); (2, 2); (3, 3); (1, 11); (2, 22); (3, 33); (4, 44)] - in - assert_map_contains ctxt map [(1, 11); (2, 22); (3, 33); (4, 44)] - -(** Test merging when combining elements of overlapping keys. *) -let test_merge_overlaps_add = - let open Result_syntax in - unit_test "Merge overlap by adding" @@ fun () -> - let ctxt = unsafe_new_context () in - let* map, ctxt = - CM.of_list - ctxt - ~merge_overlap:(fun ctxt left right -> Ok (left + right, ctxt)) - [(1, 1); (2, 2); (3, 3); (1, 1); (2, 2); (3, 3); (4, 4)] - in - assert_map_contains ctxt map [(1, 2); (2, 4); (3, 6); (4, 4)] - -(** Test update with merging elements of new and existing keys by adding them. *) -let test_update_merge = - let open Result_syntax in - unit_test "Update with merge add" @@ fun () -> - let ctxt = unsafe_new_context () in - let* map, ctxt = - CM.of_list - ctxt - ~merge_overlap:(fun _ _ _ -> dummy_fail) - [(1, 1); (2, 2); (3, 3)] - in - let update_merge ctxt key new_value map = - CM.update - ctxt - key - (fun ctxt existing -> - match existing with - | None -> Ok (Some new_value, ctxt) - | Some old_value -> Ok (Some (new_value + old_value), ctxt)) - map - in - let* map, ctxt = update_merge ctxt 1 1 map in - let* map, ctxt = update_merge ctxt 4 4 map in - assert_map_contains ctxt map [(1, 2); (2, 2); (3, 3); (4, 4)] - -(** Test merging two maps when keeping the original value for overlapping keys. *) -let test_merge_map_keep_existing = - let open Result_syntax in - unit_test "Merge overlap keep existing" @@ fun () -> - let ctxt = unsafe_new_context () in - let* map1, ctxt = - CM.of_list - ctxt - ~merge_overlap:(fun _ _ _ -> dummy_fail) - [(1, "a"); (2, "b"); (3, "c")] - in - let* map2, ctxt = - CM.of_list - ctxt - ~merge_overlap:(fun _ _ _ -> dummy_fail) - [(2, "b'"); (3, "c'"); (4, "d'")] - in - let* map, ctxt = - CM.merge ctxt ~merge_overlap:(fun ctxt left _ -> Ok (left, ctxt)) map1 map2 - in - assert_map_contains ctxt map [(1, "a"); (2, "b"); (3, "c"); (4, "d'")] - -(** Test merging two maps when replacing the value for overlapping keys. *) -let test_merge_map_replace_existing = - let open Result_syntax in - unit_test "Merge overlap replace existing" @@ fun () -> - let ctxt = unsafe_new_context () in - let* map1, ctxt = - CM.of_list - ctxt - ~merge_overlap:(fun _ _ _ -> dummy_fail) - [(1, "a"); (2, "b"); (3, "c")] - in - let* map2, ctxt = - CM.of_list - ctxt - ~merge_overlap:(fun _ _ _ -> dummy_fail) - [(2, "b'"); (3, "c'"); (4, "d'")] - in - let* map, ctxt = - CM.merge - ctxt - ~merge_overlap:(fun ctxt _ right -> Ok (right, ctxt)) - map1 - map2 - in - assert_map_contains ctxt map [(1, "a"); (2, "b'"); (3, "c'"); (4, "d'")] - -(** Test deleting existing and non-existing keys. *) -let test_update_delete = - let open Result_syntax in - unit_test "Update delete" @@ fun () -> - let ctxt = unsafe_new_context () in - let* map, ctxt = - CM.of_list - ctxt - ~merge_overlap:(fun _ _ _ -> dummy_fail) - [(1, 1); (2, 2); (3, 3)] - in - let delete ctxt key map = - CM.update ctxt key (fun ctxt _ -> Ok (None, ctxt)) map - in - let* map, ctxt = delete ctxt 1 map in - let* map, ctxt = delete ctxt 4 map in - assert_map_contains ctxt map [(2, 2); (3, 3)] - -(** Test that merging [empty] with a map returns the same map. *) -let test_empty_left_identity_for_merge = - let open Result_syntax in - int_map_test "Empty map is left identity for merge" @@ fun map -> - let ctxt = unsafe_new_context () in - let* map', ctxt = - CM.merge ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) map CM.empty - in - assert_equal_map ctxt map map' - -(** Test that merging a map with [empty] returns the same map. *) -let test_empty_right_identity_for_merge = - let open Result_syntax in - int_map_test "Empty map is right identity for merge" @@ fun map -> - let ctxt = unsafe_new_context () in - let* map', ctxt = - CM.merge ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) CM.empty map - in - assert_equal_map ctxt map map' - -(** Test that [size] returns the number of key value pairs of a map. *) -let test_size = - let open Result_syntax in - int_map_test "Size returns the number of elements" @@ fun map -> - let ctxt = unsafe_new_context () in - let* kvs, _ = CM.to_list ctxt map in - Result.ok Compare.List_length_with.(kvs = CM.size map) - -(** Test that all keys of a map are found. *) -let test_find_existing = - let open Result_syntax in - int_map_test "Find all elements" @@ fun map -> - let ctxt = unsafe_new_context () in - let* kvs, _ = CM.to_list ctxt map in - let* (_ : CM.context) = - List.fold_left_e - (fun ctxt (k, v) -> - let* v_opt, ctxt = CM.find ctxt k map in - match v_opt with Some v' when v = v' -> Ok ctxt | _ -> dummy_fail) - ctxt - kvs - in - Ok true - -(** Test that find returns [None] for non-existing keys. *) -let test_find_non_existing = - let open Result_syntax in - int_map_test "Should not find non-existing" @@ fun map -> - let ctxt = unsafe_new_context () in - let* kvs, _ = CM.to_list ctxt map in - let key = 42 in - let* v_opt, _ = CM.find ctxt key map in - match List.find_opt (fun (k, _) -> k = key) kvs with - | Some (_, value) -> Ok (Some value = v_opt) - | None -> Ok (None = v_opt) - -(** Test that [to_list] followed by [of_list] returns the same map. *) -let test_to_list_of_list = - let open Result_syntax in - int_map_test "To-list/of-list roundtrip" @@ fun map -> - let ctxt = unsafe_new_context () in - let merge_overlap ctxt x y = Ok (x + y, ctxt) in - let* kvs, ctxt = CM.to_list ctxt map in - let* map', ctxt = CM.of_list ctxt ~merge_overlap kvs in - assert_equal_map ctxt map map' - -(** Test that merging two maps is equivalent to merging the concatenated - key-value lists of both maps. *) -let test_merge_against_list = - let open Result_syntax in - int_map_pair_test "Merge compared with list operation" @@ fun map1 map2 -> - let ctxt = unsafe_new_context () in - let merge_overlap ctxt x y = Ok (x + y, ctxt) in - let* kvs1, ctxt = CM.to_list ctxt map1 in - let* kvs2, ctxt = CM.to_list ctxt map2 in - let* map_merged1, ctxt = CM.merge ctxt ~merge_overlap map1 map2 in - let* map_merged2, ctxt = CM.of_list ~merge_overlap ctxt (kvs1 @ kvs2) in - assert_equal_map ctxt map_merged1 map_merged2 - -(** Test that merging a map with itself does not alter its size. *) -let test_size_merge_self = - let open Result_syntax in - int_map_test "Size should not change when map is merging with itself" - @@ fun map -> - let ctxt = unsafe_new_context () in - let size1 = CM.size map in - let* map2, _ = - CM.merge - ctxt - ~merge_overlap:(fun ctxt left right -> Ok (left + right, ctxt)) - map - map - in - let size2 = CM.size map2 in - Ok (size1 = size2) - -(** Test that merging with a failing merge operation yields an error. *) -let test_merge_fail = - int_map_test "Merging with failing merge-overlap" @@ fun map -> - let ctxt = unsafe_new_context () in - Result.ok - (match CM.merge ctxt ~merge_overlap:(fun _ _ _ -> dummy_fail) map map with - | Ok _ when CM.size map = 0 -> true - | Ok _ -> false - | Error _ -> true) - -(** Test that adding one key-value pair to a map increases its size by one iff - the key already exists. *) -let test_size_add_one = - let open Result_syntax in - int_map_test "Add a new element increases size by one" @@ fun map -> - let ctxt = unsafe_new_context () in - let key = 42 in - let* val_opt, ctxt = CM.find ctxt key map in - let* map', _ctxt = - CM.update - ctxt - key - (fun ctxt existing -> - match existing with - | None -> Ok (Some 42, ctxt) - | Some old_value -> Ok (Some old_value, ctxt)) - map - in - let size = CM.size map in - let size' = CM.size map' in - match val_opt with - | None -> Ok (size' = size + 1) - | Some _ -> Ok (size' = size) - -(** Test that mapping over a map is equivalent to mapping over the list of - key-value pairs and reconstructing the map. That is, the following diagram - commutes: - - [map] ----to_list---> [list] - | | - [map_e f] [List.map f] - | | - v v - [map] --- to_list --> [list] -*) -let test_map = - let open Result_syntax in - int_map_test "Test that map commutes with mapping over list" @@ fun map -> - let ctxt = unsafe_new_context () in - let* kvs, ctxt = CM.to_list ctxt map in - let* map', ctxt = CM.map_e ctxt (fun ctxt _ x -> Ok (x + 1, ctxt)) map in - let kvs' = List.map (fun (k, v) -> (k, v + 1)) kvs in - assert_map_contains ctxt map' kvs' - -(** Test that folding over an empty map does not invoke the accumulator - function. *) -let test_fold_empty = - let open Result_syntax in - unit_test "Fold empty" @@ fun () -> - let ctxt = unsafe_new_context () in - let* x, _ = CM.fold_e ctxt (fun _ctxt _acc _k _v -> dummy_fail) 0 CM.empty in - Ok (x = 0) - -(** Test that folding over a map is equivalent to folding over the corresponding - list of key-value pairs. That is, the following diagram commutes: - - [map] -- to_list --> [list] - | | - [fold_e f z] [List.fold_left f z] - | | - res <----- id -----> res -*) -let test_fold = - let open Result_syntax in - int_map_test "Test that fold commutes with folding over a list" @@ fun map -> - let ctxt = unsafe_new_context () in - let* kvs, ctxt = CM.to_list ctxt map in - let sum = List.fold_left (fun sum (k, v) -> k + v + sum) 0 kvs in - let* sum', _ = - CM.fold_e ctxt (fun ctxt sum k v -> Ok (k + v + sum, ctxt)) 0 map - in - Ok (sum = sum') - -(** Test that all key-value pairs can be collected by a fold. And that the - order is the same as for [to_list]. *) -let test_fold_to_list = - let open Result_syntax in - int_map_test "Test that fold collecting the elements agrees with to-list" - @@ fun map -> - let ctxt = unsafe_new_context () in - let* kvs, ctxt = CM.to_list ctxt map in - let* kvs', _ = - CM.fold_e ctxt (fun ctxt kvs k v -> Ok ((k, v) :: kvs, ctxt)) [] map - in - Ok (kvs = List.rev kvs') - -(** Test that mapping with a failing function fails iff the list is non-empty. *) -let test_map_fail = - int_map_test "Test map with failing function" @@ fun map -> - let ctxt = unsafe_new_context () in - Result.ok - (match CM.map_e ctxt (fun _ctxt _key _val -> dummy_fail) map with - | Ok _ when CM.size map = 0 -> true - | Error _ -> true - | Ok _ -> false) - -(** Test that removing an existing key from a map decreases its size by one. *) -let test_size_remove_one = - let open Result_syntax in - int_map_test "Remove new element decreases size by one" @@ fun map -> - let ctxt = unsafe_new_context () in - let* kvs, ctxt = CM.to_list ctxt map in - let key = match kvs with (k, _) :: _ -> k | _ -> 42 in - let* val_opt, ctxt = CM.find ctxt key map in - let* map', _ctxt = CM.update ctxt key (fun ctxt _ -> Ok (None, ctxt)) map in - let size = CM.size map in - let size' = CM.size map' in - match val_opt with - | None -> Ok (size' = size) - | Some _ -> Ok (size' = size - 1) - -let qcheck_tests = - [ - test_size; - test_to_list_of_list; - test_empty_left_identity_for_merge; - test_empty_right_identity_for_merge; - test_size_merge_self; - test_size_add_one; - test_size_remove_one; - test_merge_against_list; - test_merge_fail; - test_find_non_existing; - test_find_existing; - test_map; - test_fold; - test_fold_to_list; - test_map_fail; - ] - -let unit_tests = - [ - test_empty; - test_update_add; - test_update_replace; - test_merge_overlaps_left; - test_merge_overlaps_right; - test_merge_overlaps_add; - test_update_merge; - test_merge_map_keep_existing; - test_merge_map_replace_existing; - test_update_delete; - test_fold_empty; - ] - -let tests ~rand = qcheck_wrap ~rand qcheck_tests @ unit_tests - -let () = - (* Ensure deterministic results. *) - let rand = Random.State.make [|0x1337533D; 71287309; 397060904|] in - Alcotest.run ~__FILE__ Protocol.name [("Carbonated map", tests ~rand)] diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_compare_operations.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_compare_operations.ml deleted file mode 100644 index 456cc6d9255537711446c65c46a3359a41aeefd0..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_compare_operations.ml +++ /dev/null @@ -1,102 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (Operation compare) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/pbt/main.exe \ - -- --file test_compare_operations.ml - Subject: Valid operations Comparison -*) - -open Protocol -open Alpha_context -open Operation_generator -open QCheck2 - -let lt = -1 - -let gt = 1 - -let eq = 0 - -let cmp_op op1 op2 res = Compare.Int.equal (Operation.compare op1 op2) res - -(** A strict order has an equality predicate that is symmetric, - reflexive and transitive and an lt (and gt) predicates that is - antisymmetric and transitive. - - Testing that Operation.compare is a strict order on - operations is then testing that it is symmetric, transitive and - reflexive, when Operation.compare x y = 0; that it is transitive - when Operation.compare x y = -1 and Operation.compare x y = -1; and - that Operation.compare x y = - (Operation.compare y x) when differ - from 0. *) -let eq_sym op1 op2 = if cmp_op op1 op2 eq then assert (cmp_op op2 op1 eq) - -let eq_refl op = assert (cmp_op op op eq) - -let eq_trans op1 op2 op3 = - if cmp_op op1 op2 eq && cmp_op op2 op3 eq then assert (cmp_op op1 op3 eq) - -let lt_antisym op1 op2 = if cmp_op op1 op2 lt then assert (cmp_op op2 op1 gt) - -let lt_trans op1 op2 op3 = - if cmp_op op1 op2 lt && cmp_op op2 op3 lt then assert (cmp_op op1 op3 lt) - -let gt_trans op1 op2 op3 = - if cmp_op op1 op2 gt && cmp_op op2 op3 gt then assert (cmp_op op1 op3 gt) - -let gt_antisym op1 op2 = if cmp_op op1 op2 gt then assert (cmp_op op2 op1 lt) - -(** Testing that Operation.compare is a strict order on operations. *) -let strorder op1 op2 op3 = - eq_sym op1 op2 ; - eq_refl op1 ; - eq_trans op1 op2 op3 ; - lt_antisym op1 op2 ; - lt_trans op1 op2 op3 ; - gt_trans op1 op2 op3 ; - gt_antisym op1 op2 - -let test_compare_is_strorder = - Test.make - ~name:"Compare operations is a strict total order" - (Gen.triple generate_operation generate_operation generate_operation) - (fun ((k1, op1), (k2, op2), (k3, op3)) -> - try - strorder op1 op2 op3 ; - true - with exn -> - Format.eprintf "%a vs. %a vs. %a@." pp_kind k1 pp_kind k2 pp_kind k3 ; - raise exn) - -let tests = [test_compare_is_strorder] - -let () = - Alcotest.run - ~__FILE__ - Protocol.name - [("Compare_operations", Qcheck2_helpers.qcheck_wrap tests)] diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_dal_slot_proof.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_dal_slot_proof.ml deleted file mode 100644 index 398a6735105f751880b2f7a504f089d82896a3f3..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_dal_slot_proof.ml +++ /dev/null @@ -1,260 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: PBT for refutation proofs of Dal - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/pbt/main.exe \ - -- --file test_dal_slot_proof.ml - Subject: Refutation proof-related functions of Dal -*) - -open Protocol - -module Make (Parameters : sig - val name : string - - val count : int - - val dal_parameters : Alpha_context.Constants.Parametric.dal -end) = -struct - module ARG = struct - include Parameters - - let cryptobox = - Lazy.from_fun @@ fun () -> - WithExceptions.Result.get_ok ~loc:__LOC__ - @@ Dal_helpers.mk_cryptobox Parameters.dal_parameters.cryptobox_parameters - end - - open Dal_helpers.Make (ARG) - - (* Introduce some intermediate types. *) - - (** The slot is not confirmed (skipped) iff the boolean is [true]. *) - type slot_skipped = bool - - type level = int - - type slots = level * slot_skipped list - - type levels = slots list - - (** Given a list of {!levels}, where each element is of type {!slots} = {!slot} - list, and where each slot is a boolean, this function populates an - empty slots_history skip list and a corresponding history_cache as follows: - - the function starts from a given [start_level] (default is 1) - - levels are incremented by 2 (to allow having levels without confirmed slots - for test purpose). - - every element in the list of levels represents the slots of a single level. - - each slot of a given level is not confirmed iff the boolean is true. *) - let populate_slots_history (levels_data : levels) = - let open Result_syntax in - (* Make and insert a slot. *) - let slot_data = - Bytes.init - Parameters.(dal_parameters.cryptobox_parameters.slot_size) - (fun _i -> 'x') - in - let* polynomial = dal_mk_polynomial_from_slot slot_data in - let cryptobox = Lazy.force ARG.cryptobox in - let* commitment = dal_commit cryptobox polynomial in - let add_slot level sindex (cell, cache, slots_info) skip_slot = - let index = - Option.value_f - (Dal_slot_index_repr.of_int_opt sindex) - ~default:(fun () -> assert false) - in - let slot = - Dal_slot_repr.Header.{id = {published_level = level; index}; commitment} - in - let* cell, cache = - if skip_slot then return (cell, cache) - else - Dal_slot_repr.History.add_confirmed_slot_headers cell cache [slot] - |> Environment.wrap_tzresult - in - return (cell, cache, (polynomial, slot, skip_slot) :: slots_info) - in - (* Insert the slots of a level. *) - let add_slots accu (level, slots_data) = - (* We start at level one, and we skip even levels for test purpose (which - means that no DAL slot is confirmed for them). *) - let curr_level = Raw_level_repr.of_int32_exn (Int32.of_int level) in - List.fold_left_i_e (add_slot curr_level) accu slots_data - in - (* Insert the slots of all the levels. *) - let add_levels = List.fold_left_e add_slots in - add_levels (genesis_history, genesis_history_cache, []) levels_data - - (** This function returns the (correct) information of a page to - prove that it is confirmed, or None if the page's slot is skipped. *) - let request_confirmed_page (poly, slot, skip_slot) = - let open Result_syntax in - if skip_slot then - (* We cannot check that a page of an unconfirmed slot is confirmed. *) - return None - else - let* page_info, page_id = mk_page_info slot poly in - return @@ Some (page_info, page_id) - - (** This function returns information of a page to prove that it is - unconfirmed, if the page's slot is skipped, the information look correct - (but the slot is not confirmed). Otherwise, we increment the publish_level - field to simulate a non confirmed slot (as for even levels, no slot is - confirmed. See {!populate_slots_history}). *) - let request_unconfirmed_page unconfirmed_level (poly, slot, skip_slot) = - let open Result_syntax in - (* If the slot is unconfirmed, we test that a page belonging to it is not - confirmed. If the slot is confirmed, we check that the page of the - slot at the next level is unconfirmed (since we insert levels without - any confirmed slot). *) - let level = - let open Dal_slot_repr.Header in - if skip_slot then slot.id.published_level else unconfirmed_level - in - let* _page_info, page_id = mk_page_info ~level slot poly in - (* We should not provide the page's info if we want to build an - unconfirmation proof. *) - return @@ Some (None, page_id) - - (** This helper function allows to test DAL's {!produce_proof} and - {!verify_proof} functions, using the data constructed from - {!populate_slots_history} above. *) - let helper_check_pbt_pages last_cell last_cache slots_info ~page_to_request - ~check_produce ~check_verify = - let open Lwt_result_syntax in - List.iter_es - (fun item -> - let*? mk_test = page_to_request item in - match mk_test with - | None -> return_unit - | Some (page_info, page_id) -> - produce_and_verify_proof - last_cell - ~get_history:(get_history last_cache) - ~page_info - ~page_id - ~check_produce - ~check_verify) - slots_info - - (** Making some confirmation pages tests for slots that are confirmed. *) - let test_confirmed_pages (levels_data : levels) = - let open Lwt_result_syntax in - let*? last_cell, last_cache, slots_info = - populate_slots_history levels_data - in - helper_check_pbt_pages - last_cell - last_cache - slots_info - ~page_to_request:request_confirmed_page - ~check_produce:(successful_check_produce_result ~__LOC__ `Confirmed) - ~check_verify:(successful_check_verify_result ~__LOC__ `Confirmed) - - (** Making some unconfirmation pages tests for slots that are confirmed. *) - let test_unconfirmed_pages (levels_data : levels) = - let open Lwt_result_syntax in - let*? last_cell, last_cache, slots_info = - populate_slots_history levels_data - in - let unconfirmed_level = - let last_level = - List.last (0, []) levels_data - |> fst |> Int32.of_int |> Raw_level_repr.of_int32_exn - in - Raw_level_repr.succ last_level - in - helper_check_pbt_pages - last_cell - last_cache - slots_info - ~page_to_request:(request_unconfirmed_page unconfirmed_level) - ~check_produce:(successful_check_produce_result ~__LOC__ `Unconfirmed) - ~check_verify:(successful_check_verify_result ~__LOC__ `Unconfirmed) - - let tests = - let gen_dal_config : levels QCheck2.Gen.t = - QCheck2.Gen.( - let nb_slots = 10 -- 20 in - let nb_levels = 4 -- 8 in - let gaps_between_levels = 1 -- 20 in - (* The slot is confirmed iff the boolean is true *) - let slot = bool in - let slots = list_size nb_slots slot in - (* For each level, we generate the gap/delta w.r.t. the previous level, - and the slots' flags (confirmed or not). *) - let* l = list_size nb_levels (pair gaps_between_levels slots) in - (* We compute the list of slots with explicit levels instead levels - gaps. *) - let rl, _level = - List.fold_left - (fun (acc, prev_level) (delta_level, slots) -> - let level = prev_level + delta_level in - ((level, slots) :: acc, level)) - ([], 0) - l - in - return @@ List.rev rl) - in - [ - Tztest.tztest_qcheck2 - ~name:"Pbt tests: confirmed pages" - ~count:Parameters.count - gen_dal_config - test_confirmed_pages; - Tztest.tztest_qcheck2 - ~name:"Pbt tests: unconfirmed pages" - ~count:Parameters.count - gen_dal_config - test_unconfirmed_pages; - ] - - let tests = - [ - ( Format.sprintf - "[%s: %s] Dal slots refutation" - Protocol.name - Parameters.name, - tests ); - ] -end - -let () = - let open Tezos_protocol_017_PtNairob_parameters.Default_parameters in - let module Test = Make (struct - let name = "test" - - let count = 5 - - let dal_parameters = constants_test.dal - end) in - Alcotest_lwt.run - ~__FILE__ - (Protocol.name ^ ": Dal slots refutation game") - Test.tests - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_gas_properties.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_gas_properties.ml deleted file mode 100644 index cfa59556041ff88f4bf0b4578ee42e23b688e299..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_gas_properties.ml +++ /dev/null @@ -1,144 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (gas properties) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/pbt/main.exe \ - -- --file test_gas_properties.ml - Subject: Arithmetic properties around gas. -*) - -open Protocol -open Qcheck2_helpers - -(** Extract a Tezos result for compatibility with QCheck2. *) -let extract_qcheck_result = function - | Ok pure_result -> pure_result - | Error err -> - Format.printf "@\n%a@." Environment.Error_monad.pp_trace err ; - false - -(** [Gas.free] is the neutral element of gas addition: [any_cost +@ Gas.free = Gas.free +@ any_cost = any_cost]. *) -let test_free_neutral (start, any_cost) = - let open Alpha_context in - extract_qcheck_result - (let open Result_syntax in - let* free_first = Gas.consume start Gas.free in - let* branch1 = Gas.consume free_first any_cost in - let* cost_first = Gas.consume start any_cost in - let+ branch2 = Gas.consume cost_first Gas.free in - let equal_consumption_from_start t1 t2 = - Gas.Arith.( - qcheck_eq - ~pp - ~eq:equal - (Gas.consumed ~since:start ~until:t1) - (Gas.consumed ~since:start ~until:t2)) - in - equal_consumption_from_start branch1 branch2 - && equal_consumption_from_start branch1 cost_first) - -(** Consuming [Gas.free] is equivalent to consuming nothing. *) -let test_free_consumption start = - let open Alpha_context in - extract_qcheck_result - (let open Result_syntax in - let+ after_empty_consumption = Gas.consume start Gas.free in - Gas.Arith.( - qcheck_eq - ~pp - ~eq:equal - (Gas.consumed ~since:start ~until:after_empty_consumption) - zero)) - -(** Consuming [cost1] then [cost2] is equivalent to consuming - [Gas.(cost1 +@ cost2)]. *) -let test_consume_commutes (start, cost1, cost2) = - let open Alpha_context in - extract_qcheck_result - (let open Result_syntax in - let* after_cost1 = Gas.consume start cost1 in - let* branch1 = Gas.consume after_cost1 cost2 in - let+ branch2 = Gas.consume start Gas.(cost1 +@ cost2) in - Gas.Arith.( - qcheck_eq - ~pp - ~eq:equal - (Gas.consumed ~since:start ~until:branch1) - (Gas.consumed ~since:start ~until:branch2))) - -(** Arbitrary context with a gas limit of 100_000_000. *) -let context_gen : Alpha_context.t QCheck2.Gen.t = - QCheck2.Gen.return - (Lwt_main.run - (let open Lwt_result_syntax in - let* b, _contract = Context.init1 () in - let+ inc = Incremental.begin_construction b in - Alpha_context.Gas.set_limit - (Incremental.alpha_ctxt inc) - Alpha_context.Gas.Arith.(fp (integral_of_int_exn 100_000_000))) - |> function - | Ok a -> a - | Error _ -> assert false) - -(** This arbitrary could be improved (pretty printer and shrinker) if there was a way to convert a [cost] back to an [int]. Otherwise one needs to write a custom [arbitrary] instance, but I wanted to stick to the former design of this test for the time being. *) -let gas_cost_gen : Alpha_context.Gas.cost QCheck2.Gen.t = - let open Alpha_context.Gas in - let open QCheck2.Gen in - let rand = 0 -- 1000 in - let safe_rand = map Saturation_repr.safe_int rand in - oneof - [ - map atomic_step_cost safe_rand; - map step_cost safe_rand; - map alloc_cost safe_rand; - map alloc_bytes_cost rand; - map alloc_mbytes_cost rand; - map read_bytes_cost rand; - map write_bytes_cost rand; - ] - -let tests = - [ - QCheck2.Test.make - ~count:1000 - ~name:"Consuming commutes" - QCheck2.Gen.(triple context_gen gas_cost_gen gas_cost_gen) - test_consume_commutes; - QCheck2.Test.make - ~count:1000 - ~name:"Consuming [free] consumes nothing" - context_gen - test_free_consumption; - QCheck2.Test.make - ~count:1000 - ~name:"[free] is the neutral element of Gas addition" - QCheck2.Gen.(pair context_gen gas_cost_gen) - test_free_neutral; - ] - -let () = - Alcotest.run ~__FILE__ Protocol.name [("gas properties", qcheck_wrap tests)] diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_merkle_list.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_merkle_list.ml deleted file mode 100644 index ec0acc9039a65d8da47b89a684725456c117cf57..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_merkle_list.ml +++ /dev/null @@ -1,126 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol Library - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/pbt/main.exe \ - -- --file test_merkle_list.ml - Subject: Tx rollup l2 encoding -*) - -open Qcheck2_helpers - -(* ------ generators -------------------------------------------------------- *) - -let input : bytes list QCheck2.Gen.t = - let open QCheck2.Gen in - list_size (2 -- 100) bytes_gen - -let valid_pos l = - let open QCheck2.Gen in - let* pos = 0 -- (List.length l - 1) in - return pos - -let invalid_pos l = - let open QCheck2.Gen in - let* choice = bool in - let* pos = - if choice then -20 -- -1 - else - let len = List.length l in - len -- (2 * len) - in - return pos - -let input_and_pos : (int * bytes list) QCheck2.Gen.t = - let open QCheck2.Gen in - let* l = input in - let* pos = valid_pos l in - return (pos, l) - -let input_and_pos_and_wrong_pos : (int * int * bytes list) QCheck2.Gen.t = - let open QCheck2.Gen in - let* l = input in - let* pos = valid_pos l in - let* wrong_pos = invalid_pos l in - return (pos, wrong_pos, l) - -(* ------ tests ------------------------------------------------------------- *) - -let test_scons_scons_tr_equiv ~count = - let open Merkle_list_helper in - QCheck2.Test.make ~count ~name:"scons_scons_tr_equiv" input (fun input -> - let snoc = List.fold_left snoc nil input in - let snoc_tr = List.fold_left snoc_tr nil input in - Internal_for_tests.equal snoc snoc_tr) - -let test_scons_compute_equiv ~count = - let open Merkle_list_helper in - QCheck2.Test.make ~count ~name:"scons_compute_equiv" input (fun input -> - let snoc = List.fold_left snoc nil input |> root in - let compute = compute input in - Hash.equal snoc compute) - -let ok_exn = function Ok x -> x | Error _ -> raise (Invalid_argument "ok_exn") - -let test_check_path ~count = - let open Merkle_list_helper in - QCheck2.Test.make ~count ~name:"check_path" input_and_pos (fun (pos, input) -> - let tree = List.fold_left snoc nil input in - let hash = root tree in - let path = ok_exn @@ compute_path tree pos in - ok_exn @@ check_path path pos (Stdlib.List.nth input pos) hash) - -let test_check_path_wrong ~count = - let open Merkle_list_helper in - QCheck2.Test.make - ~count - ~name:"check_path_wrong" - input_and_pos_and_wrong_pos - (fun (pos, wrong_pos, input) -> - let tree = List.fold_left snoc nil input in - let hash = root tree in - let path = ok_exn @@ compute_path tree pos in - match check_path path wrong_pos (Stdlib.List.nth input pos) hash with - | Ok b -> not b - | Error _ -> true) - -let () = - let qcheck_wrap = qcheck_wrap ~rand:(Random.State.make_self_init ()) in - Alcotest.run - ~__FILE__ - Protocol.name - [ - ( "scons_equiv", - qcheck_wrap - [ - test_scons_scons_tr_equiv ~count:1000; - test_scons_compute_equiv ~count:1000; - ] ); - ( "check_path", - qcheck_wrap - [test_check_path ~count:1000; test_check_path_wrong ~count:1000] ); - ] diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_operation_encoding.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_operation_encoding.ml deleted file mode 100644 index 0fac8a9e36660d61a158f5efb323f4062a68d10a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_operation_encoding.ml +++ /dev/null @@ -1,67 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol Library - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/pbt/main.exe \ - -- --file test_operation_encoding.ml - Subject: Encoding for operations -*) - -open Protocol -open QCheck2 -open Qcheck2_helpers - -(** {2 Generators} *) -let generate_operation = - let open Gen in - let+ _kind, (_hash, op) = Operation_generator.generate_operation in - op - -(** {2 Tests} *) - -let test_operation = - let open Alpha_context in - let gen = generate_operation in - let eq {shell = s1; protocol_data = Operation_data d1} - {shell = s2; protocol_data = Operation_data d2} = - let o1 : _ Operation.t = {shell = s1; protocol_data = d1} in - let o2 : _ Operation.t = {shell = s2; protocol_data = d2} in - match Operation.equal o1 o2 with None -> false | Some Eq -> true - in - test_roundtrip - ~count:2000 - ~title:"Operation.t" - ~gen - ~eq - Alpha_context.Operation.encoding - -let () = - let qcheck_wrap = qcheck_wrap ~rand:(Random.State.make_self_init ()) in - Alcotest.run - ~__FILE__ - (Protocol.name ^ ": Operation_encoding") - [(": roundtrip", qcheck_wrap [test_operation])] diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_refutation_game.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_refutation_game.ml deleted file mode 100644 index ee9d1c9af89326aab896f44fa02d39c7dee1ddc2..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_refutation_game.ml +++ /dev/null @@ -1,1810 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* Copyright (c) 2022 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: PBT for the SCORU refutation game - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/pbt/main.exe \ - -- --file test_refutation_game.ml - Subject: SCORU refutation game -*) -open Protocol - -open Alpha_context -open Sc_rollup -open Qcheck2_helpers -open Sc_rollup_helpers - -(** {2 Utils} *) - -let qcheck_make_lwt = qcheck_make_lwt ~extract:Lwt_main.run - -let qcheck_make_lwt_res ?print ?count ~name ~gen f = - qcheck_make_result - ~pp_error:Error_monad.pp_print_trace - ?print - ?count - ~name - ~gen - (fun a -> Lwt_main.run (f a)) - -let tick_to_int_exn ?(__LOC__ = __LOC__) t = - WithExceptions.Option.get ~loc:__LOC__ (Tick.to_int t) - -let tick_of_int_exn ?(__LOC__ = __LOC__) n = - WithExceptions.Option.get ~loc:__LOC__ (Tick.of_int n) - -let number_of_ticks_of_int64_exn ?(__LOC__ = __LOC__) n = - WithExceptions.Option.get ~loc:__LOC__ (Number_of_ticks.of_value n) - -let game_status_of_refute_op_result = function - | [ - Apply_results.Operation_metadata - { - contents = - Single_result - (Manager_operation_result - { - operation_result = - Applied (Sc_rollup_refute_result {game_status; _}); - _; - }); - }; - ] -> - game_status - | _ -> assert false - -let list_assoc (key : Tick.t) list = List.assoc ~equal:( = ) key list - -let print_dissection_chunk = Format.asprintf "%a" Dissection_chunk.pp - -let print_dissection = Format.asprintf "%a" Game.pp_dissection - -let print_our_states _ = "" - -(** Assert that the computation fails with the given message. *) -let assert_fails_with ~__LOC__ (res : unit Environment.Error_monad.tzresult) - expected_err = - match res with - | Error trace -> - let expected_trace = - Environment.Error_monad.trace_of_error expected_err - in - if expected_trace = trace then Lwt.return true - else - let pp = Environment.Error_monad.pp_trace in - QCheck2.Test.fail_reportf - "@[Expected reason: %a@;Actual reason: %a@]" - pp - expected_trace - pp - trace - | Ok () -> Lwt.return false - -let initial_of_dissection dissection = - List.hd dissection |> WithExceptions.Option.get ~loc:__LOC__ - -(** Modify the last section of a dissection. *) -let rec modify_stop f dissection = - match dissection with - | [] -> assert false - | [chunk] -> [f chunk] - | x :: xs -> - let xs = modify_stop f xs in - x :: xs - -(** Modify the first section of a dissection. *) -let modify_start f dissection = - match dissection with - | chunk :: xs -> f chunk :: xs - | [] -> (* The dissection can not be empty. *) assert false - -(** Checks that the [dissection] is valid regarding the function - {!Sc_rollup_game_repr.check_dissection}. *) -let valid_dissection ~default_number_of_sections ~start_chunk ~stop_chunk - dissection = - Game.Internal_for_tests.check_dissection - ~default_number_of_sections - ~start_chunk - ~stop_chunk - dissection - |> Result.is_ok - -(** [disputed_sections ~our_states dissection] returns the list of sections - in the [dissection] on which the player dissecting disagree with. - It uses [our_states], an assoc list between tick and state hashes to - compare opponent's claims against our point of view. *) -let disputed_sections ~our_states dissection = - let agree_on_state tick their_state = - let our_state = list_assoc tick our_states in - Option.equal State_hash.equal our_state their_state - in - let rec traverse acc = function - | Dissection_chunk.( - {state_hash = their_start_state; tick = start_tick} as a) - :: ({state_hash = their_stop_state; tick = stop_tick} as b) - :: dissection -> - let rst = b :: dissection in - if agree_on_state start_tick their_start_state then - (* It's a disputed section if we agree on the start state but disagree - on the stop. *) - if agree_on_state stop_tick their_stop_state then traverse acc rst - else - let disputed_section = (a, b) in - traverse (disputed_section :: acc) rst - else traverse acc rst - | _ -> acc - in - traverse [] dissection - -let pick_disputed_sections disputed_sections = - QCheck2.Gen.oneofl disputed_sections - -let single_tick_disputed_sections disputed_sections = - List.filter_map - (fun disputed_section -> - let Dissection_chunk.({tick = a_tick; _}, {tick = b_tick; _}) = - disputed_section - in - let distance = Tick.distance a_tick b_tick in - if Z.Compare.(distance = Z.one) then Some disputed_section else None) - disputed_sections - -let final_dissection ~our_states dissection = - let disputed_sections = disputed_sections ~our_states dissection in - let single_tick_disputed_sections = - single_tick_disputed_sections disputed_sections - in - Compare.List_length_with.(single_tick_disputed_sections > 0) - -(** Build a non-random dissection from [start_chunk] to [stop_chunk] using - [our_states] as the state hashes for each tick. *) -let build_dissection ~number_of_sections ~start_chunk ~stop_chunk ~our_states = - let open Lwt_result_syntax in - let state_of_tick ?start_state:_ tick = - return @@ list_assoc tick our_states - in - let state_hash_of_eval_state = Fun.id in - let our_stop_chunk = - Dissection_chunk. - {stop_chunk with state_hash = list_assoc stop_chunk.tick our_states} - in - (* TODO: https://gitlab.com/tezos/tezos/-/issues/3491 - - This dissection's building does not check the number of sections. Checks should - be added to verify that we don't generate invalid dissection and test the - incorrect cases. *) - Lwt_main.run - @@ let*! r = - Game_helpers.( - make_dissection - ~state_of_tick - ~state_hash_of_eval_state - ~start_chunk - ~our_stop_chunk - @@ default_new_dissection - ~start_chunk - ~our_stop_chunk - ~default_number_of_sections:number_of_sections) - in - Lwt.return @@ WithExceptions.Result.get_ok ~loc:__LOC__ r - -let originate_rollup originator block = - let open Lwt_result_syntax in - let* origination_operation, sc_rollup = - Sc_rollup_helpers.origination_op (B block) originator Kind.Example_arith - in - let* block = Block.bake ~operations:[origination_operation] block in - let* inbox = Context.Sc_rollup.inbox (B block) in - let+ genesis_info = Context.Sc_rollup.genesis_info (B block) sc_rollup in - (block, sc_rollup, inbox, genesis_info) - -(** [create_ctxt ()] creates a context where an arith rollup was originated, - and both [account1] and [account2] owns enough tez to stake on a - commitment. *) -let create_ctxt () = - WithExceptions.Result.get_ok ~loc:__LOC__ - @@ Lwt_main.run - @@ - let open Lwt_result_syntax in - let* block, (account1, account2, account3) = - Context.init3 - ~sc_rollup_enable:true - ~sc_rollup_arith_pvm_enable:true - ~consensus_threshold:0 - ~bootstrap_balances:[100_000_000_000L; 100_000_000_000L; 100_000_000_000L] - () - in - let* block, sc_rollup, inbox, genesis_info = - originate_rollup account3 block - in - return (block, sc_rollup, inbox, genesis_info, (account1, account2, account3)) - -(** {2 Context free generators} *) - -(** Generate a {!State_hash.t}. - - We use a dirty hack {!QCheck2.Gen.make_primitive} to remove the - automatic shrinking. Shrinking on the states in a dissection can - be confusing, it can leads to a shrunk list with the same states in - each cell. -*) -let gen_random_hash = - let open QCheck2.Gen in - let gen = - let* x = bytes_fixed_gen 32 in - return @@ State_hash.of_bytes_exn x - in - (* This is not beautiful, but there is currently no other way to - remove the shrinker. *) - make_primitive - ~gen:(fun rand -> generate1 ~rand gen) - ~shrink:(fun _ -> Seq.empty) - -(** Generate the number of sections in the dissection. *) -let gen_num_sections = - let open Tezos_protocol_017_PtNairob_parameters.Default_parameters in - let testnet = constants_test.sc_rollup.number_of_sections_in_dissection in - let mainnet = constants_mainnet.sc_rollup.number_of_sections_in_dissection in - let sandbox = constants_sandbox.sc_rollup.number_of_sections_in_dissection in - QCheck2.Gen.( - frequency - [(5, pure mainnet); (4, pure testnet); (2, pure sandbox); (1, 4 -- 100)]) - -(** Generate a tick. *) -let gen_tick ?(lower_bound = 0) ?(upper_bound = 10_000) () = - let open QCheck2.Gen in - let+ tick = lower_bound -- upper_bound in - tick_of_int_exn ~__LOC__ tick - -(** Generate two chunks consisting in valid boundaries for a dissection *) -let gen_wasm_pvm_dissection_boundaries kind = - let open QCheck2.Gen in - let open Alpha_context in - let* broken = bool in - let* state_hash = gen_random_hash in - let* base = Z.of_int <$> 0 -- 10_000 in - let* len = - Z.of_int - <$> - match kind with - | `Kernel_run -> pure 1 - | `Short -> 2 -- 32 - | `Large -> 1_000 -- 10_000 - in - let+ offset = - if broken then 1 -- Z.to_int Sc_rollup.Wasm_2_0_0PVM.ticks_per_snapshot - else pure 0 - in - let start_tick = - Sc_rollup.Tick.of_z @@ Z.(base * Sc_rollup.Wasm_2_0_0PVM.ticks_per_snapshot) - in - let stop_tick = - Sc_rollup.Tick.of_z - @@ Z.( - ((base + len) * Sc_rollup.Wasm_2_0_0PVM.ticks_per_snapshot) - + Z.of_int offset) - in - let start_chunk = - Sc_rollup.Dissection_chunk. - {tick = start_tick; state_hash = Some State_hash.zero} - in - let stop_chunk = - Sc_rollup.Dissection_chunk.{tick = stop_tick; state_hash = Some state_hash} - in - (start_chunk, stop_chunk) - -(** [gen_arith_pvm_messages ~gen_size] is a `correct list` generator. - It generates a list of strings that are either integers or `+` to be - consumed by the arithmetic PVM. - If a `+` is found then the previous two element of the stack are poped - then added and the result is pushed to the stack. In particular, - lists like `[1 +]` are incorrect. *) -let gen_arith_pvm_messages ~gen_size = - let open QCheck2.Gen in - (* To preserve the correctness invariant, genlist is a recursive generator - that produce a pair `(stack_size, state_list)` where state_list is a - correct list of integers and `+` and consuming it will produce a `stack` - of length `stack_size`. - For example a result can be `(3, [1; 2; +; 3; +; 2; 2; +; 1;]). - Consuming the list will produce the stack`[6; 4; 1]` which has length 3. *) - let produce_inputs self fuel = - match fuel with - | 0 -> map (fun x -> (1, [string_of_int x])) small_nat - | n -> - (* The generator has two branches. - 1. with frequency 1 adds integers to state_list and increases the - corresponding stack_size. - 2. With frequency 2, at each step, it looks at the inductive result - [(self (n - 1)) = (stack_size, state_list)]. - - If the stack_size is smaller than 2 then it adds an integer to the - state_list and increases the stack_size. Otherwise, it adds a plus - to the state_list and decreases the stack_size. *) - frequency - [ - ( 2, - map2 - (fun x (stack_size, state_list) -> - if stack_size >= 2 then (stack_size - 1, "+" :: state_list) - else (stack_size + 1, string_of_int x :: state_list)) - small_nat - (self (n / 2)) ); - ( 1, - map2 - (fun x (i, y) -> (i + 1, string_of_int x :: y)) - small_nat - (self (n / 2)) ); - ] - in - let+ inputs = sized_size gen_size @@ fix produce_inputs in - snd inputs |> List.rev |> String.concat " " - -(** Generate a list of level and associated arith pvm messages. *) -let gen_arith_pvm_payloads_for_levels ~start_level ~max_level = - gen_payloads_for_levels - ~start_level - ~max_level - (gen_arith_pvm_messages ~gen_size:(QCheck2.Gen.pure 0)) - -(** Dissection helpers and tests *) -module Dissection = struct - (** Generate an initial *valid* dissection. The validity comes from a - mirrored implementation of {!Sc_rollup_game_repr.initial}. *) - let gen_initial_dissection ?ticks () = - let open QCheck2.Gen in - let* child_state = gen_random_hash and* parent_state = gen_random_hash in - let* ticks = - let+ ticks = - match ticks with - | None -> frequency [(1, pure 0); (9, 1 -- 1_000)] - | Some distance -> pure distance - in - Z.of_int ticks - in - let* initial_tick = gen_tick () in - if Z.Compare.(ticks = Z.zero) then - pure - [ - Dissection_chunk.{state_hash = Some child_state; tick = initial_tick}; - Dissection_chunk.{state_hash = None; tick = Tick.next initial_tick}; - ] - else - let tick = Tick.jump initial_tick ticks in - pure - [ - Dissection_chunk.{state_hash = Some parent_state; tick = initial_tick}; - Dissection_chunk.{state_hash = Some child_state; tick}; - Dissection_chunk.{state_hash = None; tick = Tick.next tick}; - ] - - (** Generate a *valid* dissection. - It returns the dissection alongside the dissected start_chunk and - stop_chunk, but also the number of sections used to generate the - dissection. *) - let gen_dissection ~number_of_sections ~our_states dissection = - let open QCheck2.Gen in - let disputed_sections = disputed_sections ~our_states dissection in - assert (Compare.List_length_with.(disputed_sections > 0)) ; - let+ start_chunk, stop_chunk = pick_disputed_sections disputed_sections in - let dissection = - build_dissection ~number_of_sections ~start_chunk ~stop_chunk ~our_states - in - (dissection, start_chunk, stop_chunk) - - let gen_initial_dissection_ticks = QCheck2.Gen.(0 -- 1_000) - - let gen_nonfinal_initial_dissection_ticks = QCheck2.Gen.(3 -- 1_000) - - (** Given an initial tick and state_hash: generates random state hashes for - every others [ticks]. - Having [our_states] provide the state hashes you believe to - be true. You can then generate a dissection from another one when - you disagree with some sections. *) - let gen_our_states start_chunk ticks = - let open QCheck2.Gen in - let Dissection_chunk.{tick = initial_tick; state_hash = initial_state_hash} - = - start_chunk - in - let initial_state_hash = - WithExceptions.Option.get ~loc:__LOC__ initial_state_hash - in - let initial_tick_int = tick_to_int_exn initial_tick in - let rec aux acc i = - if i < 0 then return acc - else if i = 0 then return ((initial_tick, initial_state_hash) :: acc) - else - let* state_hash = gen_random_hash in - let tick = tick_of_int_exn (i + initial_tick_int) in - aux ((tick, state_hash) :: acc) (i - 1) - in - aux [] ticks - - (** {3 Dissection tests} *) - - let count = 300 - - (** Test the validity of dissection generated by {!gen_dissection} on - an initial dissection generated by {!gen_initial_dissection}. - It is a self test that'll help detect issues in subsequent tests; - in case the generator does not produce valid dissections. *) - let test_valid_gen_dissection = - let open QCheck2 in - let gen = - let open Gen in - let* number_of_sections = gen_num_sections in - let* ticks = gen_initial_dissection_ticks in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - if final_dissection ~our_states dissection then - (* The initial dissection could not be dissected. *) - return (dissection, None, number_of_sections, our_states) - else - let* new_dissection, start_hash, stop_hash = - gen_dissection ~number_of_sections ~our_states dissection - in - return - ( dissection, - Some (new_dissection, start_hash, stop_hash), - number_of_sections, - our_states ) - in - let print = - Print.( - quad - print_dissection - (option - (triple - print_dissection - print_dissection_chunk - print_dissection_chunk)) - int - print_our_states) - in - qcheck_make_lwt - ~count - ~name:"gen_dissection produces a valid dissection" - ~print - ~gen - (fun (dissection, new_dissection, default_number_of_sections, our_states) - -> - let open Lwt_syntax in - match new_dissection with - | None -> return (final_dissection ~our_states dissection) - | Some (new_dissection, start_chunk, stop_chunk) -> - return - @@ valid_dissection - ~default_number_of_sections - ~start_chunk - ~stop_chunk - new_dissection) - - (** Truncate a [dissection] and expect the - {!Sc_rollup_game_repr.check_dissection} to fail with an invalid - number of sections, where [expected_number_of_sections] is expected. *) - let truncate_and_check_error dissection start_chunk stop_chunk - default_number_of_sections expected_number_of_sections = - let truncated_dissection = - match dissection with - | x :: _ :: z :: rst -> x :: z :: rst - | _ -> - (* If the dissection is valid, this case can not be reached. *) - assert false - in - let expected_len = Z.of_int expected_number_of_sections in - let expected_reason = - Dissection_chunk.Dissection_number_of_sections_mismatch - {expected = expected_len; given = Z.pred expected_len} - in - assert_fails_with - ~__LOC__ - (Game.Internal_for_tests.check_dissection - ~default_number_of_sections - ~start_chunk - ~stop_chunk - truncated_dissection) - expected_reason - - (** Test that if a dissection is smaller than the default number of - sections, the length is equal to (distance + 1) of the dissected - section. *) - let test_truncated_small_dissection = - let open QCheck2 in - qcheck_make_lwt - ~count - ~name: - "distance < nb_of_sections => (len dissection = succ (dist dissection))" - ~gen: - (let open Gen in - let* number_of_sections = gen_num_sections in - let* ticks = 3 -- (number_of_sections - 1) in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_hash, stop_hash = - gen_dissection ~number_of_sections ~our_states dissection - in - return (new_dissection, start_hash, stop_hash, number_of_sections, ticks)) - (fun ( dissection, - start_chunk, - stop_chunk, - default_number_of_sections, - distance ) -> - let expected_len = distance in - truncate_and_check_error - dissection - start_chunk - stop_chunk - default_number_of_sections - expected_len) - - (** Test that if the distance in the dissected section is larger than - the default number of sections, the dissection length is exactly the - default number of sections. *) - let test_truncated_large_dissection = - let open QCheck2 in - qcheck_make_lwt - ~count - ~name:"distance >= nb_of_sections => (len dissection = nb_of_sections" - ~gen: - (let open Gen in - let* number_of_sections = gen_num_sections in - let* ticks = number_of_sections -- 1_000 in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_chunk, stop_chunk = - gen_dissection ~number_of_sections ~our_states dissection - in - return (new_dissection, start_chunk, stop_chunk, number_of_sections)) - (fun (dissection, start_chunk, stop_chunk, default_number_of_sections) -> - truncate_and_check_error - dissection - start_chunk - stop_chunk - default_number_of_sections - default_number_of_sections) - - (** Test that we can not change the start chunk of a section when we produce - a dissection. *) - let test_immutable_start_chunk = - let open QCheck2 in - qcheck_make_lwt - ~count - ~name:"dissection.start_chunk can not change" - ~gen: - (let open Gen in - let* number_of_sections = gen_num_sections in - let* ticks = gen_nonfinal_initial_dissection_ticks in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_chunk, stop_chunk = - gen_dissection ~number_of_sections ~our_states dissection - in - let* new_state_hash = gen_random_hash in - return - ( new_dissection, - start_chunk, - stop_chunk, - number_of_sections, - new_state_hash )) - (fun ( dissection, - start_chunk, - stop_chunk, - default_number_of_sections, - new_state_hash ) -> - (* Check that we can not change the start hash. *) - let dissection_with_different_start = - modify_start - (fun chunk -> - Dissection_chunk.{chunk with state_hash = Some new_state_hash}) - dissection - in - assert_fails_with - ~__LOC__ - (Game.Internal_for_tests.check_dissection - ~default_number_of_sections - ~start_chunk - ~stop_chunk - dissection_with_different_start) - (Dissection_chunk.Dissection_start_hash_mismatch - {expected = start_chunk.state_hash; given = Some new_state_hash})) - - (** Test that we can not produce a dissection that agrees with the stop hash. - Otherwise, there would be nothing to dispute. *) - let test_stop_hash_must_change = - let open QCheck2 in - qcheck_make_lwt - ~count - ~name:"dissection.stop_chunk must change" - ~gen: - (let open Gen in - let* number_of_sections = gen_num_sections in - let* ticks = gen_nonfinal_initial_dissection_ticks in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_chunk, stop_chunk = - gen_dissection ~number_of_sections ~our_states dissection - in - return (new_dissection, start_chunk, stop_chunk, number_of_sections)) - (fun (dissection, start_chunk, stop_chunk, default_number_of_sections) -> - let open Lwt_syntax in - let check_failure_on_same_stop_hash stop_hash = - let invalid_dissection = - modify_stop - (fun chunk -> - Dissection_chunk.{chunk with state_hash = stop_hash}) - dissection - in - let stop_chunk = - Dissection_chunk.{stop_chunk with state_hash = stop_hash} - in - assert_fails_with - ~__LOC__ - (Game.Internal_for_tests.check_dissection - ~default_number_of_sections - ~start_chunk - ~stop_chunk - invalid_dissection) - (Dissection_chunk.Dissection_stop_hash_mismatch stop_hash) - in - let* b1 = check_failure_on_same_stop_hash None in - let* b2 = check_failure_on_same_stop_hash stop_chunk.state_hash in - return (b1 && b2)) - - (** Test that we can not produce a dissection modifying the starting - end last point of a section. *) - let test_immutable_start_and_stop_ticks = - let open QCheck2 in - qcheck_make_lwt - ~count - ~name: - "start_chunk.tick and stop_chunk.tick can not change in the dissection" - ~gen: - (let open Gen in - let* number_of_sections = gen_num_sections in - let* ticks = gen_nonfinal_initial_dissection_ticks in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_chunk, stop_chunk = - gen_dissection ~number_of_sections ~our_states dissection - in - return (new_dissection, start_chunk, stop_chunk, number_of_sections)) - (fun (dissection, start_chunk, stop_chunk, default_number_of_sections) -> - let open Lwt_syntax in - let expected_error dissection = - match (List.hd dissection, List.last_opt dissection) with - | Some Dissection_chunk.{tick = a_tick; _}, Some {tick = b_tick; _} -> - Dissection_chunk.Dissection_edge_ticks_mismatch - { - dissection_start_tick = a_tick; - dissection_stop_tick = b_tick; - chunk_start_tick = start_chunk.tick; - chunk_stop_tick = stop_chunk.tick; - } - | _ -> assert false - in - let modify_tick modify_X dissection = - let invalid_dissection = - modify_X - (fun chunk -> - Dissection_chunk.{chunk with tick = Tick.next chunk.tick}) - dissection - in - let expected_error = expected_error invalid_dissection in - assert_fails_with - ~__LOC__ - (Game.Internal_for_tests.check_dissection - ~default_number_of_sections - ~start_chunk - ~stop_chunk - invalid_dissection) - expected_error - in - (* We modify the start tick and expect the failure. *) - let* b1 = modify_tick modify_start dissection in - (* We modify the stop tick and expect the failure. *) - let* b2 = modify_tick modify_stop dissection in - return (b1 && b2)) - - (** Test that a valid dissection must have a proper distribution of the - sections. That is, a section should not be geq than half of the - dissected section's distance. *) - let test_badly_distributed_dissection = - let open QCheck2 in - qcheck_make_lwt - ~count - ~name:"dissection must be well distributed" - ~gen: - (let open Gen in - (* The test is not general enough to support all kind of number of - sections. *) - let number_of_sections = - Tezos_protocol_017_PtNairob_parameters.Default_parameters - .constants_mainnet - .sc_rollup - .number_of_sections_in_dissection - in - let* picked_section = 0 -- (number_of_sections - 2) in - let* ticks = 100 -- 1_000 in - let* dissection = gen_initial_dissection ~ticks () in - let* our_states = - gen_our_states (initial_of_dissection dissection) (succ ticks) - in - let* new_dissection, start_chunk, stop_chunk = - gen_dissection ~number_of_sections ~our_states dissection - in - return - ( new_dissection, - start_chunk, - stop_chunk, - number_of_sections, - picked_section )) - (fun ( dissection, - start_chunk, - stop_chunk, - default_number_of_sections, - picked_section ) -> - (* We put a distance of [1] in every section. Then, we put the - distance's left in the [picked_section], it will create - an invalid section. *) - let distance = - Z.succ @@ Tick.distance start_chunk.tick stop_chunk.tick - in - let max_section_length = - Z.(distance - of_int default_number_of_sections) - in - let section_length = Z.one in - - (* Replace the distance of the first [k] sections by [section_length]. - In practice, when [k = 0], we're at the last section of the - dissection. *) - let rec replace_distances tick k = function - | a :: b :: xs -> - let b, tick = - if k = 0 then - let tick = Tick.jump tick max_section_length in - (Dissection_chunk.{b with tick}, tick) - else - let tick = Tick.jump tick section_length in - (Dissection_chunk.{b with tick}, tick) - in - a :: replace_distances tick (k - 1) (b :: xs) - | xs -> xs - in - let invalid_dissection = - replace_distances start_chunk.tick picked_section dissection - in - let dist = Tick.distance start_chunk.tick stop_chunk.tick in - let half_dist = Z.div dist (Z.of_int 2) in - assert_fails_with - ~__LOC__ - (Game.Internal_for_tests.check_dissection - ~default_number_of_sections - ~start_chunk - ~stop_chunk - invalid_dissection) - (Dissection_chunk.Dissection_invalid_distribution half_dist)) - - let tests = - ( "Dissection", - qcheck_wrap - [ - test_valid_gen_dissection; - test_truncated_small_dissection; - test_truncated_large_dissection; - test_immutable_start_chunk; - test_stop_hash_must_change; - test_immutable_start_and_stop_ticks; - test_badly_distributed_dissection; - ] ) -end - -(** {2. ArithPVM utils} *) - -module ArithPVM = Arith_pvm - -module Arith_test_pvm = struct - include ArithPVM - - let initial_state () = - let open Lwt_syntax in - let empty = Sc_rollup_helpers.make_empty_tree () in - let* state = initial_state ~empty in - let* state = install_boot_sector state "" in - return state - - let initial_hash = - let open Lwt_syntax in - let* state = initial_state () in - state_hash state - - let consume_fuel = Option.map pred - - let continue_with_fuel ~our_states ~(tick : int) fuel state f = - let open Lwt_syntax in - match fuel with - | Some 0 -> return (state, fuel, tick, our_states) - | _ -> f tick our_states (consume_fuel fuel) state - - (* TODO: https://gitlab.com/tezos/tezos/-/issues/3498 - - the following is almost the same code as in the rollup node, expect that it - creates the association list (tick, state_hash). *) - let eval_until_input ~fuel ~our_states start_tick state = - let open Lwt_syntax in - let rec go ~our_states fuel (tick : int) state = - let* input_request = is_input_state state in - match fuel with - | Some 0 -> return (state, fuel, tick, our_states) - | None | Some _ -> ( - match input_request with - | No_input_required -> - let* state = eval state in - let* state_hash = state_hash state in - let our_states = (tick, state_hash) :: our_states in - go ~our_states (consume_fuel fuel) (tick + 1) state - | Needs_reveal (Request_dal_page _pid) -> - (* TODO/DAL: https://gitlab.com/tezos/tezos/-/issues/4160 - We assume that there are no confirmed Dal slots. - We'll reuse the infra to provide Dal pages in the future. *) - let input = Sc_rollup.(Reveal (Dal_page None)) in - let* state = set_input input state in - let* state_hash = state_hash state in - let our_states = (tick, state_hash) :: our_states in - go ~our_states (consume_fuel fuel) (tick + 1) state - | Needs_reveal (Reveal_raw_data _) - | Needs_reveal Reveal_metadata - | Initial | First_after _ -> - return (state, fuel, tick, our_states)) - in - go ~our_states fuel start_tick state - - let eval_metadata ~fuel ~our_states tick state ~metadata = - let open Lwt_syntax in - continue_with_fuel ~our_states ~tick fuel state - @@ fun tick our_states fuel state -> - let input = Sc_rollup.(Reveal (Metadata metadata)) in - let* state = set_input input state in - let* state_hash = state_hash state in - let our_states = (tick, state_hash) :: our_states in - let tick = succ tick in - return (state, fuel, tick, our_states) - - let feed_input ~fuel ~our_states ~tick state input = - let open Lwt_syntax in - let* state, fuel, tick, our_states = - eval_until_input ~fuel ~our_states tick state - in - continue_with_fuel ~our_states ~tick fuel state - @@ fun tick our_states fuel state -> - let* state = set_input input state in - let* state_hash = state_hash state in - let our_states = (tick, state_hash) :: our_states in - let tick = tick + 1 in - let* state, fuel, tick, our_states = - eval_until_input ~fuel ~our_states tick state - in - return (state, fuel, tick, our_states) - - let eval_inbox ?fuel ~inputs ~tick state = - let open Lwt_result_syntax in - List.fold_left_es - (fun (state, fuel, tick, our_states) input -> - let*! state, fuel, tick, our_states = - feed_input ~fuel ~our_states ~tick state input - in - return (state, fuel, tick, our_states)) - (state, fuel, tick, []) - inputs - - let eval_inputs ~metadata ?fuel inputs_per_levels = - let open Lwt_result_syntax in - let*! state = initial_state () in - let*! state_hash = state_hash state in - let tick = 0 in - let our_states = [(tick, state_hash)] in - let tick = succ tick in - (* 1. We evaluate the boot sector. *) - let*! state, fuel, tick, our_states = - eval_until_input ~fuel ~our_states tick state - in - (* 2. We evaluate the metadata. *) - let*! state, fuel, tick, our_states = - eval_metadata ~fuel ~our_states tick state ~metadata - in - (* 3. We evaluate the inbox. *) - let* state, _fuel, tick, our_states = - List.fold_left_es - (fun (state, fuel, tick, our_states) inputs -> - let* state, fuel, tick, our_states' = - eval_inbox ?fuel ~inputs ~tick state - in - return (state, fuel, tick, our_states @ our_states')) - (state, fuel, tick, our_states) - inputs_per_levels - in - let our_states = - List.sort (fun (x, _) (y, _) -> Compare.Int.compare x y) our_states - in - let our_states = - List.map - (fun (tick_int, state) -> (tick_of_int_exn tick_int, state)) - our_states - in - let tick = tick_of_int_exn tick in - return (state, tick, our_states) -end - -let construct_inbox_proto block list_of_messages contract = - Sc_rollup_helpers.Protocol_inbox_with_ctxt.fill_inbox - block - list_of_messages - contract - -(** Construct the inbox for the protocol side. *) -let construct_inbox_proto block list_of_messages contract = - WithExceptions.Result.get_ok ~loc:__LOC__ - @@ Lwt_main.run - @@ construct_inbox_proto block list_of_messages contract - -(** Kind of strategy a player can play - - The cheaters will have their own version of inputs. This way, they - can produce valid proofs regarding their inboxes, but discarded by - the protocol. -*) -type strategy = - | Random (** A random player will execute its own random vision of inputs. *) - | Perfect - (** A perfect player, never lies, always win. - GSW 73-9 2014-2015 mindset. *) - | Lazy (** A lazy player will not execute all messages. *) - | Eager (** A eager player will not cheat until a certain point. *) - | Keen (** A keen player will execute more messages. *) - | SOL_hater (** A SOL hater will not execute the SOL input. *) - | EOL_hater (** A EOL hater will not execute the EOL input. *) - | Info_hater (** A Info per level hater will corrupt the infos. *) - | Nostalgic - (** A nostalgic player will execute messages at origination level. *) - -let pp_strategy fmt = function - | Random -> Format.pp_print_string fmt "Random" - | Perfect -> Format.pp_print_string fmt "Perfect" - | Lazy -> Format.pp_print_string fmt "Lazy" - | Eager -> Format.pp_print_string fmt "Eager" - | Keen -> Format.pp_print_string fmt "Keen" - | SOL_hater -> Format.pp_print_string fmt "SOL hater" - | EOL_hater -> Format.pp_print_string fmt "EOL hater" - | Info_hater -> Format.pp_print_string fmt "Info per level hater" - | Nostalgic -> Format.pp_print_string fmt "Nostalgic" - -type player = { - pkh : Signature.Public_key_hash.t; - contract : Contract.t; - strategy : strategy; - game_player : Game.player; -} - -let pp_player ppf {pkh; contract = _; strategy; game_player} = - Format.fprintf - ppf - "pkh: %a@,strategy: %a@,game_player: %s" - Signature.Public_key_hash.pp_short - pkh - pp_strategy - strategy - (if Game.player_equal game_player Alice then "Alice" else "Bob") - -type player_client = { - player : player; - states : (Tick.t * State_hash.t) list; - final_tick : Tick.t; - inbox : Sc_rollup_helpers.Node_inbox.t; - payloads_per_levels : payloads_per_level list; - metadata : Metadata.t; - context : Tezos_context_memory.Context_binary.t; -} - -let pp_player_client ppf - { - player; - states = _; - final_tick; - inbox = _; - payloads_per_levels = _; - metadata = _; - context = _; - } = - Format.fprintf - ppf - "@[player:@,%a@]@,final tick: %a@" - pp_player - player - Tick.pp - final_tick - -module Player_client = struct - let empty_memory_ctxt id = - let open Lwt_syntax in - Lwt_main.run - @@ let+ index = Tezos_context_memory.Context_binary.init id in - Tezos_context_memory.Context_binary.empty index - - (** Construct an inbox based on [list_of_messages] in the player context. *) - let construct_inbox ~inbox list_of_messages = - let history = Sc_rollup.Inbox.History.empty ~capacity:10000L in - let payloads_histories = Payloads_histories.empty in - WithExceptions.Result.get_ok ~loc:__LOC__ - @@ Sc_rollup_helpers.Node_inbox.fill_inbox - ~inbox_creation_level:Raw_level.root - {inbox; history; payloads_histories} - list_of_messages - - (** Generate [our_states] for [payloads_per_levels] based on the strategy. - It needs [start_level] and [max_level] in case it will need to generate - new inputs. *) - let gen_our_states ~metadata strategy ~start_level ~max_level - payloads_per_levels = - let open QCheck2.Gen in - let eval_inputs (payloads_per_levels : payloads_per_level list) = - Lwt_main.run - @@ - let open Lwt_result_syntax in - let inputs_per_levels = - List.map (fun {inputs; _} -> inputs) payloads_per_levels - in - let*! r = Arith_test_pvm.eval_inputs ~metadata inputs_per_levels in - Lwt.return @@ WithExceptions.Result.get_ok ~loc:__LOC__ r - in - match strategy with - | Perfect -> - (* The perfect player does not lie, evaluates correctly the inputs. *) - let _state, tick, our_states = eval_inputs payloads_per_levels in - return (tick, our_states, payloads_per_levels) - | Random -> - (* Random player generates its own list of inputs. *) - let* new_payloads_per_levels = - gen_arith_pvm_payloads_for_levels ~start_level ~max_level - in - let _state, tick, our_states = eval_inputs new_payloads_per_levels in - return (tick, our_states, new_payloads_per_levels) - | Lazy -> - (* Lazy player removes inputs from [payloads_per_levels]. *) - let n = List.length payloads_per_levels in - let* remove_k = 1 -- n in - let new_inputs = List.take_n (n - remove_k) payloads_per_levels in - let _state, tick, our_states = eval_inputs new_inputs in - return (tick, our_states, new_inputs) - | Eager -> - (* Eager player executes correctly the inbox until a certain point. *) - let* corrupt_at_level = 0 -- (List.length payloads_per_levels - 1) in - let payloads_per_level = - Stdlib.List.nth payloads_per_levels corrupt_at_level - |> fun {payloads; _} -> List.length payloads - in - let* corrupt_at_k = 0 -- payloads_per_level in - let payloads_per_levels = - List.mapi - (fun l payloads_per_level -> - if l = corrupt_at_level then - let inputs = - List.mapi - (fun k input -> - if k = corrupt_at_k then - make_input - ~inbox_level:(Raw_level.of_int32_exn 42l) - ~message_counter:(Z.of_int 42) - (make_external_inbox_message "foo") - else input) - payloads_per_level.inputs - in - {payloads_per_level with inputs} - else payloads_per_level) - payloads_per_levels - in - let _state, tick, our_states = eval_inputs payloads_per_levels in - return (tick, our_states, payloads_per_levels) - | Keen -> - (* Keen player will add more inputs. *) - let* offset = 1 -- 5 in - let* new_payloads_per_levels = - gen_arith_pvm_payloads_for_levels - ~start_level:max_level - ~max_level:(max_level + offset) - in - let new_payloads_per_levels = - payloads_per_levels @ new_payloads_per_levels - in - let _state, tick, our_states = eval_inputs new_payloads_per_levels in - return (tick, our_states, new_payloads_per_levels) - | SOL_hater -> - let new_payloads_per_levels = - List.map - (fun payloads_per_level -> - { - payloads_per_level with - inputs = Stdlib.List.tl payloads_per_level.inputs; - }) - payloads_per_levels - in - let _state, tick, our_states = eval_inputs new_payloads_per_levels in - return (tick, our_states, new_payloads_per_levels) - | EOL_hater -> - let new_payloads_per_levels = - List.map - (fun payloads_per_level -> - let inputs = - let rev_inputs = List.rev payloads_per_level.inputs in - let without_eol = Stdlib.List.tl rev_inputs in - List.rev without_eol - in - {payloads_per_level with inputs}) - payloads_per_levels - in - let _state, tick, our_states = eval_inputs new_payloads_per_levels in - return (tick, our_states, new_payloads_per_levels) - | Info_hater -> - let* corrupt_at_l = 0 -- List.length payloads_per_levels in - let dumb_timestamp = Timestamp.of_seconds 42L in - let dumb_predecessor = Block_hash.zero in - - let new_payloads_per_levels = - List.mapi - (fun l payloads_per_level -> - if l = corrupt_at_l then - { - payloads_per_level with - predecessor_timestamp = dumb_timestamp; - predecessor = dumb_predecessor; - } - else payloads_per_level) - payloads_per_levels - in - let _state, tick, our_states = eval_inputs new_payloads_per_levels in - return (tick, our_states, new_payloads_per_levels) - | Nostalgic -> - (* [payloads_per_levels] starts at [orignation_level + 1], the nostalgic - player will execute messages at [origination_level]. *) - let* messages = - small_list (gen_arith_pvm_messages ~gen_size:(pure 0)) - in - let payloads_at_origination = - Sc_rollup_helpers.wrap_messages metadata.origination_level messages - in - let new_payloads_per_levels = - payloads_at_origination :: payloads_per_levels - in - let _state, tick, our_states = eval_inputs new_payloads_per_levels in - return (tick, our_states, new_payloads_per_levels) - - (** [gen ~inbox ~rollup ~origination_level ~start_level ~max_level player - payloads_per_levels] generates a {!player_client} based on - its {!player.strategy}. *) - let gen ~inbox ~rollup ~origination_level ~start_level ~max_level player - payloads_per_levels = - let open QCheck2.Gen in - let ctxt = empty_memory_ctxt "foo" in - let metadata = Sc_rollup.Metadata.{address = rollup; origination_level} in - let* tick, our_states, payloads_per_levels = - gen_our_states - ~metadata - player.strategy - ~start_level - ~max_level - payloads_per_levels - in - let inbox = construct_inbox ~inbox payloads_per_levels in - return - { - player; - final_tick = tick; - states = our_states; - inbox; - payloads_per_levels; - metadata; - context = ctxt; - } -end - -(** [create_commitment ~predecessor ~inbox_level ~our_states] creates - a commitment using [our_states] as the vision of ticks. *) -let create_commitment ~predecessor ~inbox_level ~our_states = - let open Lwt_syntax in - let inbox_level = Int32.of_int inbox_level |> Raw_level.of_int32_exn in - let+ compressed_state = - match List.last_opt our_states with - | None -> - (* No tick evaluated. *) - Arith_test_pvm.initial_hash - | Some (_, state) -> return state - in - - let number_of_ticks = - match our_states with - | [] -> Number_of_ticks.zero - | _ -> - List.length our_states - 1 - |> Int64.of_int |> number_of_ticks_of_int64_exn - in - Commitment.{compressed_state; inbox_level; predecessor; number_of_ticks} - -(** [operation_publish_commitment block rollup lcc inbox_level p1_client] - creates a commitment and stake on it. *) -let operation_publish_commitment ctxt rollup predecessor inbox_level - player_client = - let open Lwt_result_syntax in - let*! commitment = - create_commitment ~predecessor ~inbox_level ~our_states:player_client.states - in - let* op = - Op.sc_rollup_publish ctxt player_client.player.contract rollup commitment - in - return (op, commitment) - -(** [build_proof ~player_client start_tick game] builds a valid proof - regarding the vision [player_client] has. The proof refutes the - [start_tick]. *) -let build_proof ~player_client start_tick (game : Game.t) = - let open Lwt_result_syntax in - (* No messages are added between [game.start_level] and the current level - so we can take the existing inbox of players. Otherwise, we should find the - inbox of [start_level]. *) - let Sc_rollup_helpers.Node_inbox.{payloads_histories; history; inbox} = - player_client.inbox - in - let get_payloads_history witness_hash = - Payloads_histories.find witness_hash payloads_histories - |> WithExceptions.Option.get ~loc:__LOC__ - |> Lwt.return - in - let history_proof = Inbox.old_levels_messages inbox in - (* We start a game on a commitment that starts at [Tick.initial], the fuel - is necessarily [start_tick]. *) - let fuel = tick_to_int_exn start_tick in - let metadata = player_client.metadata in - let inputs_per_levels = - List.map (fun {inputs; _} -> inputs) player_client.payloads_per_levels - in - let*! r = Arith_test_pvm.eval_inputs ~metadata ~fuel inputs_per_levels in - let state, _, _ = WithExceptions.Result.get_ok ~loc:__LOC__ r in - let module P = struct - include Arith_test_pvm - - let initial_state ~empty:_ = initial_state () - - let context = player_client.context - - let state = state - - let reveal _ = assert false - - module Inbox_with_history = struct - let inbox = history_proof - - let get_history inbox = Inbox.History.find inbox history |> Lwt.return - - let get_payloads_history = get_payloads_history - end - - (* FIXME/DAL-REFUTATION: https://gitlab.com/tezos/tezos/-/issues/3992 - Extend refutation game to handle Dal refutation case. *) - module Dal_with_history = struct - let confirmed_slots_history = Dal.Slots_history.genesis - - let get_history _hash = Lwt.return_none - - let page_info = None - - let dal_parameters = - Default_parameters.constants_test.dal.cryptobox_parameters - - let dal_attestation_lag = - Default_parameters.constants_test.dal.attestation_lag - end - end in - let*! proof = Sc_rollup.Proof.produce ~metadata (module P) game.inbox_level in - return (WithExceptions.Result.get_ok ~loc:__LOC__ proof) - -(** [next_move ~number_of_sections ~player_client game] produces - the next move in the refutation game. - - If there is a disputed section where the distance is one tick, it - produces a proof. Otherwise, provides another dissection. -*) -let next_move ~player_client (game : Game.t) = - let open Lwt_result_syntax in - match game.game_state with - | Dissecting {dissection; default_number_of_sections} -> ( - let disputed_sections = - disputed_sections ~our_states:player_client.states dissection - in - assert (Compare.List_length_with.(disputed_sections > 0)) ; - let single_tick_disputed_sections = - single_tick_disputed_sections disputed_sections - in - match single_tick_disputed_sections with - | (start_chunk, _stop_chunk) :: _ -> - let tick = start_chunk.tick in - let+ proof = build_proof ~player_client tick game in - Game.(Move {choice = tick; step = Proof proof}) - | [] -> - (* If we reach this case, there is necessarily a disputed section. *) - let start_chunk, stop_chunk = Stdlib.List.hd disputed_sections in - let dissection = - build_dissection - ~number_of_sections:default_number_of_sections - ~start_chunk - ~stop_chunk - ~our_states:player_client.states - in - return - Game.( - Move {choice = start_chunk.tick; step = Dissection dissection})) - | Final_move {agreed_start_chunk; refuted_stop_chunk = _} -> - let tick = agreed_start_chunk.tick in - let+ proof = build_proof ~player_client tick game in - Game.(Move {choice = tick; step = Proof proof}) - -type game_result_for_tests = Defender_wins | Refuter_wins - -(** Play until there is an {!game_result_for_tests}. - - A game result can happen if: - - A valid refutation was provided to the protocol and it succeeded to - win the game. - - A player played an invalid refutation and was rejected by the - protocol. -*) -let play_until_game_result ~refuter_client ~defender_client ~rollup block = - let rec play ~player_turn ~opponent block = - let open Lwt_result_syntax in - let* games = - Context.Sc_rollup.ongoing_games_for_staker - (B block) - rollup - player_turn.player.pkh - in - let game_opt = List.hd games in - let game, _, _ = WithExceptions.Option.get ~loc:__LOC__ game_opt in - let* refutation = next_move ~player_client:player_turn game in - let* incr = Incremental.begin_construction block in - let* operation_refutation = - Op.sc_rollup_refute - (I incr) - player_turn.player.contract - rollup - opponent.player.pkh - refutation - in - let* incr = Incremental.add_operation incr operation_refutation in - match game_status_of_refute_op_result (Incremental.rev_tickets incr) with - | Ongoing -> - let* block = Incremental.finalize_block incr in - play ~player_turn:opponent ~opponent:player_turn block - | Ended (Loser {reason = _; loser}) -> - if loser = Account.pkh_of_contract_exn refuter_client.player.contract - then return Defender_wins - else return Refuter_wins - | Ended Draw -> - QCheck2.Test.fail_reportf "Game ended in a draw, which is unexpected" - in - play ~player_turn:refuter_client ~opponent:defender_client block - -(** Generate two {!player}s with a given strategy. *) -let make_players ~p1_strategy ~contract1 ~p2_strategy ~contract2 = - let pkh1 = Account.pkh_of_contract_exn contract1 in - let pkh2 = Account.pkh_of_contract_exn contract2 in - let ({alice; bob = _} : Game.Index.t) = Game.Index.make pkh1 pkh2 in - let player1, player2 = - if Signature.Public_key_hash.equal alice pkh1 then Game.(Alice, Bob) - else Game.(Bob, Alice) - in - ( { - pkh = pkh1; - contract = contract1; - strategy = p1_strategy; - game_player = player1; - }, - { - pkh = pkh2; - contract = contract2; - strategy = p2_strategy; - game_player = player2; - } ) - -(** [gen_game ~p1_strategy ~p2_strategy] generates a context where a rollup - was originated. - It generates inputs for the rollup, and creates the players' interpretation - of these inputs in a {!player_client} for [p1_strategy] and [p2_strategy]. -*) -let gen_game ~p1_strategy ~p2_strategy = - let open QCheck2.Gen in - (* If there is no good player, we do not care about the result. *) - assert (p1_strategy = Perfect || p2_strategy = Perfect) ; - let block, rollup, inbox, genesis_info, (contract1, contract2, contract3) = - create_ctxt () - in - let p1, p2 = make_players ~p1_strategy ~contract1 ~p2_strategy ~contract2 in - - (* Create a context with a rollup originated. *) - let commitment_period = - Tezos_protocol_017_PtNairob_parameters.Default_parameters.constants_mainnet - .sc_rollup - .commitment_period_in_blocks - in - let origination_level = - Raw_level.to_int32 genesis_info.level |> Int32.to_int - in - let start_level = origination_level + 1 in - let max_level = start_level + commitment_period in - let* payloads_per_levels = - gen_arith_pvm_payloads_for_levels ~start_level ~max_level - in - - let block, payloads_per_levels = - construct_inbox_proto block payloads_per_levels contract3 - in - - let* p1_client = - Player_client.gen - ~inbox - ~origination_level:genesis_info.level - ~start_level - ~max_level - ~rollup - p1 - payloads_per_levels - in - let* p2_client = - Player_client.gen - ~inbox - ~origination_level:genesis_info.level - ~start_level - ~max_level - ~rollup - p2 - payloads_per_levels - in - let* p1_start = bool in - let commitment_level = origination_level + commitment_period in - return - ( block, - rollup, - commitment_level, - genesis_info.commitment_hash, - p1_client, - p2_client, - p1_start, - payloads_per_levels ) - -(** Shrinker is really slow. Deactivating it. *) -let gen_game ~p1_strategy ~p2_strategy = - let open QCheck2.Gen in - make_primitive - ~gen:(fun rand -> generate1 ~rand (gen_game ~p1_strategy ~p2_strategy)) - ~shrink:(fun _ -> Seq.empty) - -(** [prepare_game block rollup lcc commitment_level p1_client p2_client contract - list_of_messages] prepares a context where [p1_client] and [p2_client] - are in conflict for one commitment. *) -let prepare_game ~p1_start block rollup lcc commitment_level p1_client p2_client - = - let open Lwt_result_syntax in - let* p1_op, p1_commitment = - operation_publish_commitment (B block) rollup lcc commitment_level p1_client - in - let* p2_op, p2_commitment = - operation_publish_commitment (B block) rollup lcc commitment_level p2_client - in - let commit_then_commit_and_refute ~defender_op ~refuter_op refuter - refuter_commitment defender defender_commitment = - let refutation = - Sc_rollup.Game.Start - { - player_commitment_hash = - Sc_rollup.Commitment.hash_uncarbonated refuter_commitment; - opponent_commitment_hash = - Sc_rollup.Commitment.hash_uncarbonated defender_commitment; - } - in - let* start_game = - Op.sc_rollup_refute - (B block) - refuter.player.contract - rollup - defender.player.pkh - refutation - in - let* refuter_batch = - Op.batch_operations - ~recompute_counters:true - ~source:refuter.player.contract - (B block) - [refuter_op; start_game] - in - let* block = Block.bake ~operations:[defender_op; refuter_batch] block in - return (block, refuter, defender) - in - if p1_start then - commit_then_commit_and_refute - ~defender_op:p2_op - ~refuter_op:p1_op - p1_client - p1_commitment - p2_client - p2_commitment - else - commit_then_commit_and_refute - ~defender_op:p1_op - ~refuter_op:p2_op - p2_client - p2_commitment - p1_client - p1_commitment - -let check_distribution = function - | fst :: snd :: rst -> - let open Dissection_chunk in - let dist = Tick.distance fst.tick snd.tick in - let _, min_len, max_len = - List.fold_left - (fun (previous_tick, min_len, max_len) chunk -> - let dist = Tick.distance previous_tick chunk.tick in - (* We only consider length that are greater or equal than - the snapshot size. The last one may not be as big, if - the PVM was stuck. *) - if Compare.Z.(dist < Sc_rollup.Wasm_2_0_0PVM.ticks_per_snapshot) - then (chunk.tick, min_len, max_len) - else (chunk.tick, Z.min min_len dist, Z.max max_len dist)) - (snd.tick, dist, dist) - rst - in - Z.(max_len - min_len <= Sc_rollup.Wasm_2_0_0PVM.ticks_per_snapshot) - | _ -> true - -let test_wasm_dissection name kind = - qcheck_make_lwt_res - ~count:1_000_000 - ~name - ~print:(fun (start_chunk, stop_chunk) -> - Format.asprintf - "dissection from %a to %a" - Dissection_chunk.pp - start_chunk - Dissection_chunk.pp - stop_chunk) - ~gen:(gen_wasm_pvm_dissection_boundaries kind) - (fun (start_chunk, stop_chunk) -> - let open Lwt_result_syntax in - let+ dissection = - Game_helpers.( - make_dissection - ~state_of_tick:(fun ?start_state:_ _ -> - return_some Sc_rollup.State_hash.zero) - ~state_hash_of_eval_state:Fun.id - ~start_chunk - ~our_stop_chunk:stop_chunk - @@ Wasm.new_dissection - ~start_chunk - ~our_stop_chunk:stop_chunk - ~default_number_of_sections:32) - in - if kind <> `Kernel_run then assert (check_distribution dissection) ; - match - Wasm_2_0_0PVM.Protocol_implementation.check_dissection - ~default_number_of_sections:32 - ~start_chunk - ~stop_chunk:{stop_chunk with state_hash = Some State_hash.zero} - dissection - with - | Ok () -> true - | Error e -> - Format.printf - "dissection %a caused errors %a\n" - Game.pp_dissection - dissection - Environment.Error_monad.pp_trace - e ; - false) - -(** Create a test of [p1_strategy] against [p2_strategy]. One of them - must be a {!Perfect} player, otherwise, we do not care about which - cheater wins. *) -let test_game ?(count = 10) ~p1_strategy ~p2_strategy () = - let name = - Format.asprintf - "%a against %a" - pp_strategy - p1_strategy - pp_strategy - p2_strategy - in - qcheck_make_lwt_res - ~print: - (fun ( _block, - _rollup, - _commitment_level, - _lcc, - p1_client, - p2_client, - p1_start, - _payloads_per_levels ) -> - Format.asprintf - "@[@,@[p1:@,%a@]@,@[p2:@,%a@]@,%s@,@]" - pp_player_client - p1_client - pp_player_client - p2_client - (if p1_start then "p1" else "p2")) - ~count - ~name - ~gen:(gen_game ~p1_strategy ~p2_strategy) - (fun ( block, - rollup, - commitment_level, - lcc, - p1_client, - p2_client, - p1_start, - _list_of_messages ) -> - let open Lwt_result_syntax in - (* Otherwise, there is no conflict. *) - QCheck2.assume - (not - (let p1_head = List.last_opt p1_client.states in - let p2_head = List.last_opt p2_client.states in - Option.equal - (fun (t1, state_hash1) (t2, state_hash2) -> - Tick.equal t1 t2 && State_hash.equal state_hash1 state_hash2) - p1_head - p2_head)) ; - let* block, refuter, defender = - prepare_game - ~p1_start - block - rollup - lcc - commitment_level - p1_client - p2_client - in - let* game_result = - play_until_game_result - ~rollup - ~refuter_client:refuter - ~defender_client:defender - block - in - match game_result with - | Defender_wins -> return (defender.player.strategy = Perfect) - | Refuter_wins -> return (refuter.player.strategy = Perfect)) - -let test_perfect_against_random = - test_game ~p1_strategy:Perfect ~p2_strategy:Random () - -let test_perfect_against_lazy = - test_game ~p1_strategy:Perfect ~p2_strategy:Lazy () - -let test_perfect_against_eager = - test_game ~p1_strategy:Perfect ~p2_strategy:Eager () - -let test_perfect_against_keen = - test_game ~p1_strategy:Perfect ~p2_strategy:Keen () - -let test_perfect_against_sol_hater = - test_game ~p1_strategy:Perfect ~p2_strategy:SOL_hater () - -let test_perfect_against_eol_hater = - test_game ~p1_strategy:Perfect ~p2_strategy:EOL_hater () - -let _test_perfect_against_info_hater = - test_game ~p1_strategy:Perfect ~p2_strategy:Info_hater () - -let test_perfect_against_nostalgic = - test_game ~p1_strategy:Perfect ~p2_strategy:Nostalgic ~count:5 () - -(* This test will behave as a regression test. *) -let test_cut_at_level = - let open QCheck2 in - Test.make - ~name:"cut at level properly cuts" - ~print:(fun (origination_level, commit_inbox_level, input_level) -> - Format.asprintf - "origination_level: %a, commit_inbox_level: %a, input_level: %a" - Raw_level_repr.pp - origination_level - Raw_level_repr.pp - commit_inbox_level - Raw_level_repr.pp - input_level) - Gen.( - let level = - map - (fun i -> Raw_level_repr.of_int32_exn (Int32.of_int i)) - (0 -- 1_000_000) - in - triple level level level) - (fun (origination_level, commit_inbox_level, input_level) -> - let input : Sc_rollup_PVM_sig.input = - Inbox_message - { - inbox_level = input_level; - message_counter = Z.zero; - payload = Sc_rollup_inbox_message_repr.unsafe_of_string "foo"; - } - in - let input_cut = - Sc_rollup_proof_repr.Internal_for_tests.cut_at_level - ~origination_level - ~commit_inbox_level - input - in - let should_be_none = - Raw_level_repr.( - input_level <= origination_level || commit_inbox_level < input_level) - in - match input_cut with - | Some _input -> not should_be_none - | None -> should_be_none) - -let tests = - ( "Refutation", - qcheck_wrap - [ - test_wasm_dissection "dissection is one kernel_run" `Kernel_run; - test_wasm_dissection "dissection shorter than 32 kernel_run" `Short; - test_wasm_dissection "dissection larger than 32 kernel_run" `Large; - test_perfect_against_random; - test_perfect_against_lazy; - test_perfect_against_keen; - test_perfect_against_eager; - test_perfect_against_sol_hater; - test_perfect_against_eol_hater; - (* TODO: https://gitlab.com/tezos/tezos/-/issues/6839 - an issue with the generator / assume of this test makes it run for ~15 minutes. - Disactivating until we find the root cause. *) - (* test_perfect_against_info_hater; *) - test_perfect_against_nostalgic; - test_cut_at_level; - ] ) - -(** {2 Entry point} *) - -let tests = [tests; Dissection.tests] - -let () = Alcotest.run ~__FILE__ (Protocol.name ^ ": Refutation_game") tests diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_sampler.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_sampler.ml deleted file mode 100644 index e33e7d9746c70f7c712c279e0e6535604455d7f0..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_sampler.ml +++ /dev/null @@ -1,271 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol Library - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/pbt/main.exe \ - -- --file test_sampler.ml - Subject: Operations in Saturation_repr -*) - -open Qcheck2_helpers -open Protocol.Sampler - -(* ------------------------------------------------------------------------- *) -(* Helpers *) - -module Int = struct - include Int - - let hash = Hashtbl.hash -end - -let equal_array elt_eq arr1 arr2 = - Array.length arr1 = Array.length arr2 - && Stdlib.List.for_all2 elt_eq (Array.to_list arr1) (Array.to_list arr2) - -(* Support of a distribution on Z (sorted, with potential duplicates) *) -let support cmp array = - Array.to_seq array |> Seq.map fst |> List.of_seq |> List.sort cmp - |> Array.of_list - -(* Support of a distribution on Z (sorted, without duplicates) *) -let support_uniq cmp array = - Array.to_seq array |> Seq.map fst |> List.of_seq |> List.sort_uniq cmp - |> Array.of_list - -module type Std = sig - type t - - val equal : t -> t -> bool - - val compare : t -> t -> int - - val hash : t -> int -end - -module Helpers = struct - let sample_n_times (total : int) sample = - let rec loop n acc = - if n = 0 then acc - else - let res = sample () in - loop (n - 1) (res :: acc) - in - loop total [] - - let empirical_distribution : - type a. - (module Std with type t = a) -> - nsamples:int -> - (unit -> a) -> - (a * int) array = - fun (module H) ~nsamples sampler -> - let module Table = Hashtbl.Make (H) in - let samples = sample_n_times nsamples sampler in - let table = Table.create 127 in - List.iter - (fun sample -> - let count = Option.value ~default:0 (Table.find table sample) in - Table.replace table sample (count + 1)) - samples ; - let result = Table.to_seq table |> Array.of_seq in - (* check that the support of [result] has no duplicate elements (should - be true since we use [replace]). *) - assert ( - equal_array - H.equal - (support H.compare result) - (support_uniq H.compare result)) ; - result -end - -let normalize : ('a * int) array -> ('a * Q.t) array = - fun empirical -> - let total = - Array.fold_left - (fun acc (_, weight) -> Z.add (Z.of_int weight) acc) - Z.zero - empirical - in - Array.map (fun (n, weight) -> (n, Q.(Z.of_int weight /// total))) empirical - -let pp_dist pp fmtr dist = - let l = Array.to_list dist in - Format.pp_print_list - ~pp_sep:(fun fmtr () -> Format.fprintf fmtr ",") - (fun fmtr (elt, w) -> Format.fprintf fmtr "(%a, %f)" pp elt (Q.to_float w)) - fmtr - l - -let linf (dist : ('a * Q.t) array) pmf = - Array.fold_left (fun acc (n, q) -> Q.(max acc (abs (pmf n - q)))) Q.zero dist - -(* ------------------------------------------------------------------------- *) - -let state = - Random.State.make - [| - 0x1337533D; - 71287309; - 666932349; - 719132214; - 461480042; - 387006837; - 443018964; - 450865457; - 901711679; - 833353016; - 397060904; - |] - -module Make_test (Mass : sig - include Internal_for_tests.SMass - - val to_float : t -> float -end) (S : sig - val sample : int_bound:int -> mass_bound:Mass.t -> int * Mass.t -end) = -struct - let make p = - let module Probability = Internal_for_tests.Make (Mass) in - let measure = List.mapi (fun i p -> (i, p)) p in - let total_mass = List.fold_left Mass.add Mass.zero p in - let state = Probability.create measure in - let sampler = Probability.sample state in - let empirical = - normalize - @@ Helpers.empirical_distribution - (module Int) - ~nsamples:5_000_000 - (fun () -> sampler S.sample) - in - (* We need to rescale the empirical to match that the total mass is not necessarily one. *) - let empirical = - let rescaling = Q.of_float (Mass.to_float total_mass) in - Array.map (fun (x, q) -> (x, Q.mul q rescaling)) empirical - in - (* map the mass to Q to better measure the error *) - let truth = - let array = - measure |> List.to_seq - |> Seq.map (fun (_, mass) -> Q.of_float (Mass.to_float mass)) - |> Array.of_seq - in - fun i -> array.(i) - in - let error = linf empirical truth in - let max_error = 0.001 *. Mass.to_float total_mass in - if not Q.(error < Q.of_float max_error) then - QCheck2.Test.fail_reportf - "didn't converge (%f)@.%a" - (Q.to_float error) - (pp_dist Format.pp_print_int) - empirical ; - true -end - -(* Testing the alias sampler with float-valued measures *) - -module Probability_mass_float : Internal_for_tests.SMass with type t = float = -struct - type t = float - - let encoding = Data_encoding.float - - let zero = 0.0 - - let of_int = float_of_int - - let mul = ( *. ) - - let add = ( +. ) - - let sub = ( -. ) - - let ( = ) = Float.equal - - let ( <= ) (x : t) (y : t) = x <= y - - let ( < ) (x : t) (y : t) = x < y -end - -module Test_float = - Make_test - (struct - include Probability_mass_float - - let to_float x = x - end) - (struct - let sample ~int_bound ~mass_bound = - (Random.State.int state int_bound, Random.State.float state mass_bound) - end) - -(* Testing the alias sampler with Z-valued measures *) - -module Probability_mass_z : Internal_for_tests.SMass with type t = Z.t = struct - let encoding = Data_encoding.z - - include Z - include Z.Compare -end - -module Test_z = - Make_test - (struct - include Probability_mass_z - - let to_float = Z.to_float - end) - (struct - let sample ~int_bound ~mass_bound = - ( Random.State.int state int_bound, - Z.of_int64 (Random.State.int64 state (Z.to_int64 mass_bound)) ) - end) - -let qcheck_wrap = qcheck_wrap ~rand:state - -let alias_float_test = - QCheck2.Test.make - ~count:100 - ~name:"alias_float" - QCheck2.Gen.(list_size (int_range 1 20) pfloat) - Test_float.make - -let alias_z_test = - QCheck2.Test.make - ~count:100 - ~name:"alias_z" - QCheck2.Gen.( - list_size (int_range 1 20) (nat >>= fun n -> return (Z.of_int n))) - Test_z.make - -let () = - Alcotest.run - ~__FILE__ - Protocol.name - [("sampling", qcheck_wrap [alias_float_test; alias_z_test])] diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_sc_rollup_encoding.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_sc_rollup_encoding.ml deleted file mode 100644 index be7d755a9c35d732eb7f39884f8c883e48bae3d5..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_sc_rollup_encoding.ml +++ /dev/null @@ -1,297 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol Library - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/pbt/main.exe \ - -- --file test_sc_rollup_encoding.ml - Subject: SC rollup encoding -*) - -open Protocol -open QCheck2 -open Qcheck2_helpers - -(** {2 Generators} *) - -let gen_state_hash = - let open Gen in - let* bytes = bytes_fixed_gen Sc_rollup_repr.State_hash.size in - return (Sc_rollup_repr.State_hash.of_bytes_exn bytes) - -let gen_inbox_level = - let open Gen in - let* level = map Int32.abs int32 in - (* There is no inbox for level [0l]. *) - let level = if level = 0l then 1l else level in - return (Raw_level_repr.of_int32_exn level) - -let gen_start_level = - let open Gen in - let* level = map Int32.abs int32 in - let start_level = Raw_level_repr.of_int32_exn level in - return start_level - -let gen_commitment_hash = - let open Gen in - let* bytes = bytes_fixed_gen Sc_rollup_commitment_repr.Hash.size in - return (Sc_rollup_commitment_repr.Hash.of_bytes_exn bytes) - -let gen_number_of_ticks = - let open Gen in - let open Sc_rollup_repr.Number_of_ticks in - let* v = int64_range_gen min_value max_value in - return (WithExceptions.Option.get ~loc:__LOC__ (of_value v)) - -let gen_commitment = - let open Gen in - let* compressed_state = gen_state_hash - and* inbox_level = gen_inbox_level - and* predecessor = gen_commitment_hash - and* number_of_ticks = gen_number_of_ticks in - return - Sc_rollup_commitment_repr. - {compressed_state; inbox_level; predecessor; number_of_ticks} - -let gen_versioned_commitment = - let open Gen in - let* commitment = gen_commitment in - return (Sc_rollup_commitment_repr.to_versioned commitment) - -let gen_player = Gen.oneofl Sc_rollup_game_repr.[Alice; Bob] - -let gen_inbox level = - let open Gen in - let gen_msg = small_string ~gen:printable in - let* hd = gen_msg in - let* tail = small_list gen_msg in - let payloads = hd :: tail in - let witness_and_inbox = - let open Result_syntax in - let inbox = Sc_rollup_helpers.dumb_init_repr level in - Environment.wrap_tzresult - @@ - let witness = Sc_rollup_inbox_repr.init_witness_no_history in - let witness = - Sc_rollup_inbox_repr.add_info_per_level_no_history - ~predecessor_timestamp:Time.Protocol.epoch - ~predecessor:Block_hash.zero - witness - in - let* input_messages = - List.map_e - (fun msg -> Sc_rollup_inbox_message_repr.(serialize (External msg))) - payloads - in - let* witness = - Sc_rollup_inbox_repr.add_messages_no_history input_messages witness - in - return (Sc_rollup_inbox_repr.finalize_inbox_level_no_history inbox witness) - in - return - @@ (witness_and_inbox |> function - | Ok v -> v - | Error e -> - Stdlib.failwith (Format.asprintf "%a" Error_monad.pp_print_trace e)) - -module Index = Dal_slot_index_repr - -let gen_dal_slots_history () = - let open Gen in - let open Dal_slot_repr in - (* Generate a list of (level * confirmed slot ID). *) - let* list = small_list (pair small_nat small_nat) in - let list = - List.rev_map - (fun (level, slot_index) -> - let published_level = - Raw_level_repr.( - (* use succ to avoid having a published_level = 0, as it's the - genesis cell's level in the skip list. *) - succ @@ try of_int32_exn (Int32.of_int level) with _ -> root) - in - let index = - Index.of_int_opt slot_index |> Option.value ~default:Index.zero - in - Header.{id = {published_level; index}; commitment = Commitment.zero}) - list - in - let list = - (* Sort the list in the right ordering before adding slots to slots_history. *) - List.sort_uniq - (fun {Header.id = a; _} {id = b; _} -> - let c = Raw_level_repr.compare a.published_level b.published_level in - if c <> 0 then c else Index.compare a.index b.index) - list - in - History.(add_confirmed_slot_headers_no_cache genesis list) |> function - | Ok v -> return v - | Error e -> - return - @@ Stdlib.failwith - (Format.asprintf "%a" Error_monad.pp_print_trace - @@ Environment.wrap_tztrace e) - -let gen_inbox_history_proof inbox_level = - let open Gen in - let* inbox = gen_inbox inbox_level in - return (Sc_rollup_inbox_repr.take_snapshot inbox) - -let gen_tick = - let open Gen in - let* t = small_nat in - match Sc_rollup_tick_repr.of_int t with - | None -> assert false - | Some r -> return r - -let gen_dissection_chunk = - let open Gen in - let* state_hash = opt gen_state_hash in - let+ tick = gen_tick in - Sc_rollup_dissection_chunk_repr.{state_hash; tick} - -let gen_dissection = - let open Gen in - small_list gen_dissection_chunk - -let gen_game_state = - let open Sc_rollup_game_repr in - let open Gen in - let gen_dissecting = - let* dissection = gen_dissection in - let+ default_number_of_sections = int_range 4 100 in - Dissecting {dissection; default_number_of_sections} - in - let gen_final_move = - let* agreed_start_chunk = gen_dissection_chunk in - let+ refuted_stop_chunk = gen_dissection_chunk in - Final_move {agreed_start_chunk; refuted_stop_chunk} - in - oneof [gen_dissecting; gen_final_move] - -let gen_game = - let open Gen in - let* turn = gen_player in - let* inbox_level = gen_inbox_level in - let* start_level = gen_start_level in - let* inbox_snapshot = gen_inbox_history_proof inbox_level in - let* dal_snapshot = gen_dal_slots_history () in - let* game_state = gen_game_state in - return - Sc_rollup_game_repr. - {turn; dal_snapshot; inbox_snapshot; start_level; inbox_level; game_state} - -let gen_conflict = - let open Gen in - let other = Sc_rollup_repr.Staker.zero in - let* their_commitment = gen_commitment in - let* our_commitment = gen_commitment in - let* parent_commitment = gen_commitment_hash in - return - Sc_rollup_refutation_storage. - {other; their_commitment; our_commitment; parent_commitment} - -let gen_rollup = - let open QCheck2.Gen in - let* bytes = bytes_fixed_gen Sc_rollup_repr.Address.size in - return (Sc_rollup_repr.Address.hash_bytes [bytes]) - -let gen_inbox_message = - let open Gen in - let open Sc_rollup_inbox_message_repr in - let gen_external = - let+ s = small_string ~gen:printable in - External s - in - let gen_sol = return (Internal Start_of_level) in - let gen_eol = return (Internal End_of_level) in - let gen_deposit = - (* We won't test the encoding of these values. It's out of scope. *) - let payload = Script_repr.unit in - let sender = Contract_hash.zero in - let source = Signature.Public_key_hash.zero in - (* But the encoding of the rollup's address is our problem. *) - let+ destination = gen_rollup in - Internal (Transfer {payload; sender; source; destination}) - in - oneof [gen_external; gen_sol; gen_eol; gen_deposit] - -(** {2 Tests} *) - -let test_commitment = - test_roundtrip - ~count:1_000 - ~title:"Sc_rollup_commitment.t" - ~gen:gen_commitment - ~eq:( = ) - Sc_rollup_commitment_repr.encoding - -let test_versioned_commitment = - test_roundtrip - ~count:1_000 - ~title:"Sc_rollup_commitment.versioned" - ~gen:gen_versioned_commitment - ~eq:( = ) - Sc_rollup_commitment_repr.versioned_encoding - -let test_game = - test_roundtrip - ~count:1_000 - ~title:"Sc_rollup_game.t" - ~gen:gen_game - ~eq:Sc_rollup_game_repr.equal - Sc_rollup_game_repr.encoding - -let test_conflict = - test_roundtrip - ~count:1_000 - ~title:"Sc_rollup_refutation_storage.conflict" - ~gen:gen_conflict - ~eq:( = ) - Sc_rollup_refutation_storage.conflict_encoding - -let test_inbox_message = - test_roundtrip - ~count:1_000 - ~title:"Sc_rollup_inbox_message_repr.t" - ~gen:gen_inbox_message - ~eq:( = ) - Sc_rollup_inbox_message_repr.encoding - -let tests = - [ - test_commitment; - test_versioned_commitment; - test_game; - test_conflict; - test_inbox_message; - ] - -let () = - Alcotest.run - ~__FILE__ - (Protocol.name ^ ": SC rollup encoding") - [(": roundtrip", qcheck_wrap tests)] diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_sc_rollup_inbox.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_sc_rollup_inbox.ml deleted file mode 100644 index b14dc29d449c2c8ef63d761725b1a3a7f660b4b7..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_sc_rollup_inbox.ml +++ /dev/null @@ -1,77 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol Library - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/pbt/main.exe \ - -- --file test_sc_rollup_inbox.ml - Subject: Smart rollup inbox -*) - -open Protocol -open Qcheck2_helpers - -let gen_block_hash = - let open QCheck2.Gen in - let gen = - let+ b = bytes_fixed_gen Block_hash.size in - Block_hash.of_bytes_exn b - in - (* This is not beautiful, but there is currently no other way to - remove the shrinker. *) - make_primitive - ~gen:(fun rand -> generate1 ~rand gen) - ~shrink:(fun _ -> Seq.empty) - -let gen_time = - let open QCheck2.Gen in - let+ s = int64 in - Time.Protocol.of_seconds s - -let gen_add_info_per_level = - let open QCheck2.Gen in - let* predecessor_timestamp = gen_time in - let* predecessor = gen_block_hash in - return (predecessor_timestamp, predecessor) - -let test_add_info_per_level = - QCheck2.Test.make - ~count:10_000 - ~name:"test_add_info_per_level" - gen_add_info_per_level - @@ fun (predecessor_timestamp, predecessor) -> - (* Test that we can indeed serialize the [Info_per_level] message for these - inputs *) - let _bytes = - Sc_rollup_inbox_message_repr.info_per_level_serialized - ~predecessor_timestamp - ~predecessor - in - true - -let tests = [test_add_info_per_level] - -let () = Alcotest.run ~__FILE__ Protocol.name [("safety", qcheck_wrap tests)] diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_sc_rollup_tick_repr.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_sc_rollup_tick_repr.ml deleted file mode 100644 index 65196293dc47aef4cc76a737fcbce07b266b994e..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_sc_rollup_tick_repr.ml +++ /dev/null @@ -1,110 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol Library - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/pbt/main.exe \ - -- --file test_sc_rollup_tick_repr.ml - Subject: Operations in Tick_repr -*) - -open Protocol.Alpha_context.Sc_rollup -open QCheck2 - -(** A generator for ticks *) -let tick = - let open Gen in - let+ n = nat in - Option.value ~default:Tick.initial (Tick.of_int n) - -(** For all x, x = initial \/ x > initial. *) -let test_initial_is_bottom = - Test.make ~name:"x = initial \\/ x > initial" tick @@ fun x -> - Tick.(x = initial || x > initial) - -(** For all x, next x > x. *) -let test_next_is_monotonic = - Test.make ~name:"next x > x" tick @@ fun x -> Tick.(next x > x) - -(** Distance from self to self is zero *) -let test_distance_from_self = - Test.make ~name:"distance from x to x is 0" tick (fun x -> - Z.(equal (Tick.distance x x) zero)) - -(** Distance from non-self is non-zero. *) -let test_distance_from_non_self = - Test.make - ~name:"distance from non-self is non-zero" - (Gen.pair tick tick) - (fun (x, y) -> - let dist = Tick.distance x y in - if x = y then Compare.Z.(dist = Z.zero) else Compare.Z.(dist <> Z.zero)) - -(** Distance is symmetric . *) -let test_distance_symmetry = - Test.make - ~name:"distance is a distance (symmetry)" - (Gen.pair tick tick) - (fun (x, y) -> Z.(equal (Tick.distance x y) (Tick.distance y x))) - -(** Distance satisfies triangular inequality. *) -let test_distance_triangle_inequality = - Test.make - ~name:"distance is a distance (triangle inequality)" - (Gen.triple tick tick tick) - (fun (x, y, z) -> - Tick.(Z.(geq (distance x y + distance y z) (distance x z)))) - -(** Test that [of_int x = Some t] iff [x >= 0] *) -let test_of_int = - Test.make ~name:"of_int only accepts natural numbers" Gen.int (fun x -> - match Tick.of_int x with None -> x < 0 | Some _ -> x >= 0) - -(** Test [of_int o to_int = identity]. *) -let test_of_int_to_int = - Test.make ~name:"to_int o of_int = identity" tick @@ fun x -> - Tick.( - match to_int x with - | None -> (* by the tick generator definition. *) assert false - | Some i -> ( match of_int i with Some y -> y = x | None -> false)) - -let tests = - [ - test_next_is_monotonic; - test_initial_is_bottom; - test_distance_from_self; - test_distance_from_non_self; - test_distance_symmetry; - test_distance_triangle_inequality; - test_of_int; - test_of_int_to_int; - ] - -let () = - Alcotest.run - ~__FILE__ - Protocol.name - [("Tick_repr", Qcheck2_helpers.qcheck_wrap tests)] diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_script_comparison.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_script_comparison.ml deleted file mode 100644 index e8c9c3266913e2085217034839689cee2de24d97..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_script_comparison.ml +++ /dev/null @@ -1,355 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021-2022 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Script_comparison - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/pbt/main.exe \ - -- --file test_script_comparison.ml - Subject: PBT of the Script_comparable.compare_comparable function. -*) - -open Protocol -open Alpha_context -open Script_typed_ir -open Qcheck2_helpers - -(* Reference implementation *) - -let normalize_compare c = - let open Compare.Int in - if c > 0 then 1 else if c < 0 then -1 else 0 - -(* This reference implementation of the Michelson comparison function is a - simplified version of the Script_ir_translator.compare_comparable function - that was used in the Florence protocol, before a refactoring broke it in - Granada. *) -let rec reference_compare_comparable : type a. a comparable_ty -> a -> a -> int - = - fun ty x y -> - match (ty, x, y) with - | Unit_t, (), () -> 0 - | Never_t, _, _ -> . - | Signature_t, x, y -> normalize_compare @@ Script_signature.compare x y - | String_t, x, y -> normalize_compare @@ Script_string.compare x y - | Bool_t, x, y -> normalize_compare @@ Compare.Bool.compare x y - | Mutez_t, x, y -> normalize_compare @@ Tez.compare x y - | Key_hash_t, x, y -> - normalize_compare @@ Signature.Public_key_hash.compare x y - | Key_t, x, y -> normalize_compare @@ Signature.Public_key.compare x y - | Int_t, x, y -> normalize_compare @@ Script_int.compare x y - | Nat_t, x, y -> normalize_compare @@ Script_int.compare x y - | Timestamp_t, x, y -> normalize_compare @@ Script_timestamp.compare x y - | Address_t, x, y -> - normalize_compare @@ Script_comparable.compare_address x y - | Tx_rollup_l2_address_t, x, y -> - normalize_compare @@ Script_comparable.compare_tx_rollup_l2_address x y - | Bytes_t, x, y -> normalize_compare @@ Compare.Bytes.compare x y - | Chain_id_t, x, y -> normalize_compare @@ Script_chain_id.compare x y - | Pair_t (tl, tr, _, YesYes), (lx, rx), (ly, ry) -> - let cl = reference_compare_comparable tl lx ly in - if Compare.Int.(cl = 0) then reference_compare_comparable tr rx ry else cl - | Or_t (tl, _, _, YesYes), L x, L y -> reference_compare_comparable tl x y - | Or_t _, L _, R _ -> -1 - | Or_t _, R _, L _ -> 1 - | Or_t (_, tr, _, YesYes), R x, R y -> reference_compare_comparable tr x y - | Option_t _, None, None -> 0 - | Option_t _, None, Some _ -> -1 - | Option_t _, Some _, None -> 1 - | Option_t (t, _, Yes), Some x, Some y -> reference_compare_comparable t x y - -(* Generation of one to three values of the same comparable type. *) - -type ex_comparable_data = - | Ex_comparable_data : 'a comparable_ty * 'a -> ex_comparable_data - -type ex_comparable_data_2 = - | Ex_comparable_data_2 : 'a comparable_ty * 'a * 'a -> ex_comparable_data_2 - -type ex_comparable_data_3 = - | Ex_comparable_data_3 : - 'a comparable_ty * 'a * 'a * 'a - -> ex_comparable_data_3 - -(* We use the Michelson samplers from lib_benchmark and turn them into QCheck2 - generators *) -module Parameters = struct - let atom_size_range : Tezos_benchmark.Base_samplers.range = - {min = 0; max = 10} - - let other_size : Tezos_benchmark.Base_samplers.range = {min = 0; max = 100} - - let parameters : Michelson_samplers.parameters = - { - base_parameters = - { - int_size = atom_size_range; - string_size = atom_size_range; - bytes_size = atom_size_range; - }; - list_size = other_size; - set_size = other_size; - map_size = other_size; - } -end - -module Crypto_samplers = -Tezos_benchmark.Crypto_samplers.Make_finite_key_pool (struct - let size = 1000 - - let algo = `Default -end) - -module Samplers : Michelson_samplers.S = - Michelson_samplers.Make (Parameters) (Crypto_samplers) - -let ex_comparable_data_sampler : - ex_comparable_data Tezos_benchmark.Base_samplers.sampler = - fun random_state -> - let size = - Tezos_benchmark.Base_samplers.sample_in_interval - ~range:{min = 1; max = 20} - random_state - in - let (Ex_comparable_ty ty) = - Samplers.Random_type.m_comparable_type ~size random_state - in - let x = Samplers.Random_value.comparable ty random_state in - Ex_comparable_data (ty, x) - -let ex_comparable_data_2_sampler : - ex_comparable_data_2 Tezos_benchmark.Base_samplers.sampler = - fun random_state -> - let size = - Tezos_benchmark.Base_samplers.sample_in_interval - ~range:{min = 1; max = 20} - random_state - in - let (Ex_comparable_ty ty) = - Samplers.Random_type.m_comparable_type ~size random_state - in - let x = Samplers.Random_value.comparable ty random_state in - let y = Samplers.Random_value.comparable ty random_state in - Ex_comparable_data_2 (ty, x, y) - -let ex_comparable_data_3_sampler : - ex_comparable_data_3 Tezos_benchmark.Base_samplers.sampler = - fun random_state -> - let size = - Tezos_benchmark.Base_samplers.sample_in_interval - ~range:{min = 1; max = 20} - random_state - in - let (Ex_comparable_ty ty) = - Samplers.Random_type.m_comparable_type ~size random_state - in - let x = Samplers.Random_value.comparable ty random_state in - let y = Samplers.Random_value.comparable ty random_state in - let z = Samplers.Random_value.comparable ty random_state in - Ex_comparable_data_3 (ty, x, y, z) - -let comparable_data_generator = - QCheck2.Gen.make_primitive ~gen:ex_comparable_data_sampler ~shrink:(fun _ -> - Seq.empty) - -let comparable_data_2_generator = - QCheck2.Gen.make_primitive ~gen:ex_comparable_data_2_sampler ~shrink:(fun _ -> - Seq.empty) - -let comparable_data_3_generator = - QCheck2.Gen.make_primitive ~gen:ex_comparable_data_3_sampler ~shrink:(fun _ -> - Seq.empty) - -(* We need a context because packing (used in one of the tests) and unparsing - (used for pretty-printing error messages) Michelson data are carbonated - operations. But since we don't care about gas consumption here we use the - same value of type context everywhere instead of threading it through the - error monad. *) - -let assert_ok = function Ok x -> x | Error _ -> assert false - -let assert_return x = assert_ok (Lwt_main.run x) - -let ctxt = - assert_return - (let open Lwt_result_syntax in - let* b, _cs = Context.init3 () in - let* v = Incremental.begin_construction b in - return (Incremental.alpha_ctxt v)) - -let unparse_comparable_ty ty = - Micheline.strip_locations - (fst (assert_ok Script_ir_unparser.(unparse_ty ~loc:() ctxt ty))) - -let unparse_comparable_data ty x = - fst (assert_return Script_ir_translator.(unparse_data ctxt Readable ty x)) - -let pack_comparable_data ty x = - fst (assert_return Script_ir_translator.(pack_data ctxt ty x)) - -let unpack_comparable_data ty bytes = - fst (assert_return (Script_interpreter_defs.unpack ctxt ~ty ~bytes)) - -let pp_comparable_ty fmt ty = - Michelson_v1_printer.print_expr fmt (unparse_comparable_ty ty) - -let pp_comparable_data ty fmt x = - Michelson_v1_printer.print_expr fmt (unparse_comparable_data ty x) - -let pp ty x y pp_c fmt c = - Format.fprintf - fmt - "Compare(ty=%a, %a, %a) = %a" - pp_comparable_ty - ty - (pp_comparable_data ty) - x - (pp_comparable_data ty) - y - pp_c - c - -let compare_through_pack ty x y = - Bytes.compare (pack_comparable_data ty x) (pack_comparable_data ty y) = 0 - -let qcheck_compare_comparable ~expected ty x y = - qcheck_eq - ~pp:(pp ty x y Format.pp_print_int) - expected - (Script_comparable.compare_comparable ty x y) - -let qcheck_compare_comparable_eq ~expected ty x y = - qcheck_eq - ~pp:(pp ty x y Format.pp_print_bool) - expected - (Script_comparable.compare_comparable ty x y = 0) - -(* Test. - * Tests that compare_comparable returns the same values than the reference - * implementation. - *) -let test_compatible_with_reference = - QCheck2.Test.make - ~name:"compatible_with_reference" - comparable_data_2_generator - (fun (Ex_comparable_data_2 (ty, x, y)) -> - qcheck_compare_comparable - ~expected:(reference_compare_comparable ty x y) - ty - x - y) - -(* Test. - * Tests that compare_comparable returns 0 iff packing then comparing the - * resulting bytes returns 0. - *) -let test_compatible_with_packing = - QCheck2.Test.make - ~name:"compatible_with_packing" - comparable_data_2_generator - (fun (Ex_comparable_data_2 (ty, x, y)) -> - qcheck_compare_comparable_eq - ~expected:(compare_through_pack ty x y) - ty - x - y) - -(* Test. - * Tests that compare_comparable is reflexive. - *) -let test_reflexivity = - QCheck2.Test.make - ~name:"reflexivity" - comparable_data_generator - (fun (Ex_comparable_data (ty, x)) -> - qcheck_compare_comparable ~expected:0 ty x x) - -(* Test. - * Tests that compare_comparable is symmetric. - *) -let test_symmetry = - QCheck2.Test.make - ~name:"symmetry" - comparable_data_2_generator - (fun (Ex_comparable_data_2 (ty, x, y)) -> - qcheck_compare_comparable - ~expected:(-Script_comparable.compare_comparable ty x y) - ty - y - x) - -(* Test. - * Tests that compare_comparable is transitive. - *) -let test_transitivity = - QCheck2.Test.make - ~name:"transitivity" - comparable_data_3_generator - (fun (Ex_comparable_data_3 (ty, x, y, z)) -> - let cxy = Script_comparable.compare_comparable ty x y in - let cyz = Script_comparable.compare_comparable ty y z in - match (cxy, cyz) with - | 0, n | n, 0 -> qcheck_compare_comparable ~expected:n ty x z - | -1, -1 -> qcheck_compare_comparable ~expected:(-1) ty x z - | 1, 1 -> qcheck_compare_comparable ~expected:1 ty x z - | _ -> QCheck2.assume_fail ()) - -(* Test. - * Tests the round-trip property for PACK and UNPACK (modulo compare_comparable). - *) -let test_pack_unpack = - QCheck2.Test.make - ~count:100_000 - (* We run this test on many more cases than the default (100) because this - is a very important property. Packing and then unpacking happens each - time data is sent from a contract to another and also each time storage - is saved at the end of a smart contract call and restored at the next - call of the same contract. Also, injectivity of packing (which is a - direct consequence of this) is an important property for big maps - (because the keys are packed and then hashed). *) - ~name:"pack_unpack" - comparable_data_generator - (fun (Ex_comparable_data (ty, x)) -> - let oty = - match option_t (-1) ty with Ok ty -> ty | Error _ -> assert false - in - qcheck_eq - ~cmp:(Script_comparable.compare_comparable oty) - ~pp:(pp_comparable_data oty) - (Some x) - (unpack_comparable_data ty (pack_comparable_data ty x))) - -let () = - Alcotest.run - ~__FILE__ - Protocol.name - [ - ("compatible_with_reference", qcheck_wrap [test_compatible_with_reference]); - ("compatible_with_packing", qcheck_wrap [test_compatible_with_packing]); - ("reflexivity", qcheck_wrap [test_reflexivity]); - ("symmetry", qcheck_wrap [test_symmetry]); - ("transitivity", qcheck_wrap [test_transitivity]); - ("pack_unpack", qcheck_wrap [test_pack_unpack]); - ] diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_tez_repr.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_tez_repr.ml deleted file mode 100644 index c02de8b0313ef1d93fe75db6b9e780c038dc1155..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_tez_repr.ml +++ /dev/null @@ -1,137 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol Library - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/pbt/main.exe \ - -- --file test_tez_repr.ml - Subject: Operations in Tez_repr -*) - -open Protocol.Alpha_context -open Test_tez - -let z_mutez_min = Z.zero - -let z_mutez_max = Z.of_int64 Int64.max_int - -let tez_to_z (tez : Tez.t) : Z.t = Z.of_int64 (Tez.to_mutez tez) - -let z_in_mutez_bounds (z : Z.t) : bool = - Z.Compare.(z_mutez_min <= z && z <= z_mutez_max) - -let compare (c' : Z.t) (c : Tez.t tzresult) : bool = - match (z_in_mutez_bounds @@ c', c) with - | true, Ok c -> - Qcheck2_helpers.qcheck_eq' - ~pp:Z.pp_print - ~expected:c' - ~actual:(tez_to_z c) - () - | true, Error _ -> - QCheck2.Test.fail_reportf - "@[Results are in Z bounds, but tez operation fails.@]" - | false, Ok _ -> - QCheck2.Test.fail_reportf - "@[Results are not in Z bounds, but tez operation did not fail.@]" - | false, Error _ -> true - -(* [prop_binop f f' (a, b)] compares the function [f] in Tez with a model - function function [f'] in [Z]. - - If [f' a' b'] falls outside Tez bounds, it is true if [f a b] has - failed. If not, it it is true if [f a b = f' a' b'] where [a'] - (resp. [b']) are [a] (resp. [b']) in [Z]. *) -let prop_binop (f : Tez.t -> Tez.t -> Tez.t tzresult) (f' : Z.t -> Z.t -> Z.t) - ((a, b) : Tez.t * Tez.t) : bool = - compare (f' (tez_to_z a) (tez_to_z b)) (f a b) - -(* [prop_binop64 f f' (a, b)] is as [prop_binop] but for binary operations - where the second operand is of type [int64]. *) -let prop_binop64 (f : Tez.t -> int64 -> Tez.t tzresult) (f' : Z.t -> Z.t -> Z.t) - ((a, b) : Tez.t * int64) : bool = - compare (f' (tez_to_z a) (Z.of_int64 b)) (f a b) - -(** Generator for int64 by conversion from int32 *) -let gen_int64_of32 : int64 QCheck2.Gen.t = - QCheck2.Gen.(map Int64.of_int32 int32) - -(** Generator for int64 mixing small positive integers, - int64s from int32 and arbitrary int64 with equal frequency *) -let gen_int64_sizes : int64 QCheck2.Gen.t = - let open QCheck2.Gen in - oneof [map Int64.of_int (int_range (-10) 10); gen_int64_of32; int64] - -(** Generator for positive int64, mixing small positive integers, - int64s from int32 and arbitrary int64 with equal frequency *) -let gen_ui64_sizes : int64 QCheck2.Gen.t = - let open QCheck2.Gen in - map - (fun i -> - let v = if i = Int64.min_int then Int64.max_int else Int64.abs i in - assert (v >= 0L) ; - v) - gen_int64_sizes - -(** Generator for tez based on [gen_tez_sizes] *) -let gen_tez_sizes = - let open QCheck2.Gen in - map Tez.of_mutez_exn gen_ui64_sizes - -let test_coherent_mul = - QCheck2.Test.make - ~name:"Tez.(*?) is coherent w.r.t. Z.(*)" - QCheck2.Gen.(pair gen_tez_sizes gen_ui64_sizes) - (prop_binop64 ( *? ) Z.( * )) - -let test_coherent_sub = - QCheck2.Test.make - ~name:"Tez.(-?) is coherent w.r.t. Z.(-)" - QCheck2.Gen.(pair gen_tez_sizes gen_tez_sizes) - (prop_binop ( -? ) Z.( - )) - -let test_coherent_add = - QCheck2.Test.make - ~name:"Tez.(+?) is coherent w.r.t. Z.(+)" - QCheck2.Gen.(pair gen_tez_sizes gen_tez_sizes) - (prop_binop ( +? ) Z.( + )) - -let test_coherent_div = - QCheck2.Test.make - ~name:"Tez.(/?) is coherent w.r.t. Z.(/)" - QCheck2.Gen.(pair gen_tez_sizes gen_ui64_sizes) - (fun (a, b) -> - QCheck2.assume (b > 0L) ; - prop_binop64 ( /? ) Z.( / ) (a, b)) - -let tests = - [test_coherent_mul; test_coherent_sub; test_coherent_add; test_coherent_div] - -let () = - Alcotest.run - ~__FILE__ - Protocol.name - [("Tez_repr", Qcheck2_helpers.qcheck_wrap tests)] diff --git a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_zk_rollup_encoding.ml b/src/proto_017_PtNairob/lib_protocol/test/pbt/test_zk_rollup_encoding.ml deleted file mode 100644 index 1e4fceb958973ddf8e29c283c8f1830c76455d1f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/pbt/test_zk_rollup_encoding.ml +++ /dev/null @@ -1,230 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol Library - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/pbt/main.exe \ - -- --file test_zk_rollup_encoding.ml - Subject: Zk rollup encodings -*) - -open Protocol -open QCheck2 -open Qcheck2_helpers - -(* Generators *) - -let gen_zkr_address = - let open Gen in - let+ bytes = bytes_fixed_gen Zk_rollup_repr.Address.size in - Zk_rollup_repr.Address.of_bytes_exn bytes - -let gen_scalar = - let s = Bls12_381.Fr.random () in - Gen.return s - -let gen_l2_state = - let open Gen in - array gen_scalar - -(* Number of operations in each private batch *) -let batch_size = 10 - -(* We use fixed values for Plonk types, because it's interface - doesn't expose a quick and safe way to create them randomly. *) -module Operator = Dummy_zk_rollup.Operator (struct - let batch_size = batch_size -end) - -let nat64 = int64_range_gen 0L Int64.max_int - -let gen_zkr_account = - let open Gen in - let open Zk_rollup_account_repr in - let* state = gen_l2_state in - let _prover_pp, public_parameters = Lazy.force Operator.lazy_pp in - let circuits_info = SMap.of_seq (Kzg.SMap.to_seq Operator.circuits) in - let* nb_ops = nat in - let static = - { - public_parameters; - state_length = Array.length state; - circuits_info; - nb_ops; - } - in - let* paid_l2_operations_storage_space = nat in - let+ used_l2_operations_storage_space = - map Z.of_int @@ int_bound paid_l2_operations_storage_space - in - let dynamic = - { - state; - paid_l2_operations_storage_space = - Z.of_int paid_l2_operations_storage_space; - used_l2_operations_storage_space; - } - in - {static; dynamic} - -let gen_ticket_hash = - let open Gen in - let+ bytes = bytes_fixed_gen Script_expr_hash.size in - Ticket_hash_repr.of_bytes_exn bytes - -let gen_pkh = - let pkh, _, _ = Signature.generate_key ~algo:Ed25519 () in - Gen.return pkh - -let gen_z = - let open Gen in - sized @@ fun n -> map Z.of_bits (string_size (return n)) - -let gen_l2_op = - let open Gen in - let* op_code = nat in - let* price = - map2 - (fun id amount -> Zk_rollup_operation_repr.{id; amount}) - gen_ticket_hash - gen_z - in - let* l1_dst = gen_pkh in - let* rollup_id = gen_zkr_address in - let+ payload = array gen_scalar in - Zk_rollup_operation_repr.{op_code; price; l1_dst; rollup_id; payload} - -let gen_pending_list = - let open Gen in - let open Zk_rollup_repr in - let of_length next_index = function - | 0 -> Empty {next_index} - | length -> Pending {next_index; length} - in - map2 of_length nat64 uint16 - -(* Data-encoding roundtrip tests *) - -let test_roundtrip_address = - test_roundtrip - ~count:1_000 - ~title:"Zk_rollup.t" - ~gen:gen_zkr_address - ~eq:( = ) - Zk_rollup_repr.Address.encoding - -let test_roundtrip_state = - test_roundtrip - ~count:1_000 - ~title:"Zk_rollup_state_repr.t" - ~gen:gen_l2_state - ~eq:( = ) - Zk_rollup_state_repr.encoding - -let eq_account acc0 acc1 = - let open Zk_rollup_account_repr in - let pp_to_bytes pp = - Data_encoding.Binary.to_bytes_exn - Environment.Plonk.public_parameters_encoding - pp - in - acc0.dynamic = acc1.dynamic - && acc0.static.state_length = acc1.static.state_length - && acc0.static.circuits_info = acc1.static.circuits_info - && acc0.static.nb_ops = acc1.static.nb_ops - && pp_to_bytes acc0.static.public_parameters - = pp_to_bytes acc1.static.public_parameters - -let test_roundtrip_account = - test_roundtrip - ~count:1_000 - ~title:"Zk_rollup_account_repr.t" - ~gen:gen_zkr_account - ~eq:eq_account - Zk_rollup_account_repr.encoding - -let test_roundtrip_operation = - test_roundtrip - ~count:1_000 - ~title:"Zk_rollup_operation_repr.t" - ~gen:gen_l2_op - ~eq:( = ) - Zk_rollup_operation_repr.encoding - -let test_roundtrip_pending_list = - test_roundtrip - ~count:1_000 - ~title:"Zk_rollup_repr.pending_list" - ~gen:gen_pending_list - ~eq:( = ) - Zk_rollup_repr.pending_list_encoding - -let tests_roundtrip = - [ - test_roundtrip_address; - test_roundtrip_state; - test_roundtrip_account; - test_roundtrip_operation; - test_roundtrip_pending_list; - ] - -(* Scalar conversion tests *) - -let test_to_scalar ~count ~title ~gen to_scalar = - QCheck2.Test.make - ~count - ~name:(Format.asprintf "to_scalar %s" title) - gen - (fun input -> - try - ignore @@ to_scalar input ; - true - with _ -> false) - -let test_address_to_scalar = - test_to_scalar - ~count:1_000 - ~title:"Zk_rollup_repr.t" - ~gen:gen_zkr_address - Zk_rollup_repr.to_scalar - -let test_operation_to_scalar = - test_to_scalar - ~count:1_000 - ~title:"Zk_rollup_operation.t" - ~gen:gen_l2_op - Zk_rollup_operation_repr.to_scalar_array - -let tests_to_scalar = [test_address_to_scalar; test_operation_to_scalar] - -let () = - Alcotest.run - ~__FILE__ - (Protocol.name ^ ": ZK rollup encoding") - [ - (": roundtrip", qcheck_wrap tests_roundtrip); - (": to_scalar", qcheck_wrap tests_to_scalar); - ] diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/accounts.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/accounts.tz deleted file mode 100644 index e18e30ac5d572038ebffd8652d167fe626989806..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/accounts.tz +++ /dev/null @@ -1,67 +0,0 @@ -{ parameter - (or (key_hash %Initialize) - (pair %Withdraw (key %from) (pair (mutez %withdraw_amount) (signature %sig)))) ; - storage (map :stored_balance key_hash mutez) ; - code { DUP ; - CAR ; - IF_LEFT - { DUP ; - DIP 2 { CDR %stored_balance ; DUP } ; - DIP { SWAP } ; - GET @opt_prev_balance ; - { IF_NONE - { DIP { AMOUNT ; SOME } ; UPDATE ; NIL operation ; PAIR } - { RENAME @previous_balance ; - AMOUNT ; - ADD ; - SOME ; - SWAP ; - UPDATE ; - NIL operation ; - PAIR } } } - { DUP ; - DUP ; - DUP ; - DUP ; - CAR %from ; - DIP 2 - { { CDR ; CAR %withdraw_amount } ; PACK ; BLAKE2B @signed_amount } ; - DIP { { CDR ; CDR %sig } } ; - CHECK_SIGNATURE ; - IF {} { PUSH string "Bad signature" ; FAILWITH } ; - DIP 2 { CDR %stored_balance ; DUP } ; - CAR %from ; - HASH_KEY @from_hash ; - DUP ; - DIP { DIP { SWAP } ; SWAP } ; - GET ; - IF_NONE - { PUSH string "Account does not exist" ; PAIR ; FAILWITH } - { RENAME @previous_balance ; - DIP { DROP } ; - DUP ; - DIP 2 { DUP ; { CDR ; CAR %withdraw_amount } ; DUP } ; - DIP { { COMPARE ; LT @not_enough } } ; - SWAP ; - IF { PUSH string "Not enough funds" ; FAILWITH } - { SUB_MUTEZ @new_balance ; - { IF_NONE { { UNIT ; FAILWITH } } {} } ; - DIP { DUP ; DIP { SWAP } } ; - DUP ; - PUSH @zero mutez 0 ; - { COMPARE ; EQ @null_balance } ; - IF { DROP ; NONE @new_balance mutez } { SOME @new_balance } ; - SWAP ; - CAR %from ; - HASH_KEY @from_hash ; - UPDATE ; - SWAP ; - DUP ; - { CDR ; CAR %withdraw_amount } ; - DIP { CAR %from ; HASH_KEY @from_hash ; IMPLICIT_ACCOUNT @from_account } ; - UNIT ; - TRANSFER_TOKENS @withdraw_transfer_op ; - NIL operation ; - SWAP ; - CONS ; - PAIR } } } } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/append.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/append.tz deleted file mode 100644 index 7e57150a302e632d756ccbfa80b28db37ca399d1..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/append.tz +++ /dev/null @@ -1,10 +0,0 @@ -{ parameter (pair (list int) (list int)) ; - storage (list int) ; - code { CAR ; - UNPAIR ; - NIL int ; - SWAP ; - ITER { CONS } ; - ITER { CONS } ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/auction.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/auction.tz deleted file mode 100644 index cc5d87f8cbecd663fc4867ccad6d0214b2d5bcd2..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/auction.tz +++ /dev/null @@ -1,30 +0,0 @@ -{ parameter key_hash ; - storage (pair timestamp (pair mutez key_hash)) ; - code { DUP ; - { CDR ; CAR } ; - DUP ; - NOW ; - { COMPARE ; GT } ; - IF { { UNIT ; FAILWITH } } {} ; - SWAP ; - DUP ; - CAR ; - DIP { { CDR ; CDR } } ; - AMOUNT ; - PAIR ; - SWAP ; - DIP { SWAP ; PAIR } ; - DUP ; - CAR ; - AMOUNT ; - { COMPARE ; LE } ; - IF { { UNIT ; FAILWITH } } {} ; - DUP ; - CAR ; - DIP { CDR ; IMPLICIT_ACCOUNT } ; - UNIT ; - TRANSFER_TOKENS ; - NIL operation ; - SWAP ; - CONS ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/big_map_union.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/big_map_union.tz deleted file mode 100644 index c50e2e1d130a5ec429c158e8da746c01dfb82f11..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/big_map_union.tz +++ /dev/null @@ -1,14 +0,0 @@ -{ parameter (list (pair string int)) ; - storage (pair (big_map string int) unit) ; - code { { UNPAIR ; DIP { UNPAIR } } ; - ITER { UNPAIR ; - DUP 3 ; - DUP 2 ; - GET ; - IF_NONE { PUSH int 0 } {} ; - SWAP ; - DIP { ADD ; SOME } ; - UPDATE } ; - PAIR ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/check_signature.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/check_signature.tz deleted file mode 100644 index 35ca4070d45097f22fc3c31c859e68695125155a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/check_signature.tz +++ /dev/null @@ -1,11 +0,0 @@ -{ parameter key ; - storage (pair signature string) ; - code { DUP ; - DUP ; - DIP { CDR ; DUP ; CAR ; DIP { CDR ; PACK } } ; - CAR ; - CHECK_SIGNATURE ; - IF {} { { UNIT ; FAILWITH } } ; - CDR ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/comb-get.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/comb-get.tz deleted file mode 100644 index 7a6f7b6a361a025245f7a079c25514babd6c9fb1..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/comb-get.tz +++ /dev/null @@ -1,27 +0,0 @@ -{ parameter (pair nat nat nat unit) ; - storage unit ; - code { CAR ; - DUP ; - CAR ; - PUSH nat 1 ; - { { COMPARE ; EQ } ; IF {} { { UNIT ; FAILWITH } } } ; - DUP ; - GET 1 ; - PUSH nat 1 ; - { { COMPARE ; EQ } ; IF {} { { UNIT ; FAILWITH } } } ; - DUP ; - GET 3 ; - PUSH nat 4 ; - { { COMPARE ; EQ } ; IF {} { { UNIT ; FAILWITH } } } ; - DUP ; - GET 5 ; - PUSH nat 2 ; - { { COMPARE ; EQ } ; IF {} { { UNIT ; FAILWITH } } } ; - DUP ; - GET 6 ; - UNIT ; - { { COMPARE ; EQ } ; IF {} { { UNIT ; FAILWITH } } } ; - DROP ; - UNIT ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/comb-set.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/comb-set.tz deleted file mode 100644 index a8c1dc5c2e7f5898c6157026e19ea9812ac61650..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/comb-set.tz +++ /dev/null @@ -1,13 +0,0 @@ -{ parameter unit ; - storage (pair nat nat nat unit) ; - code { CDR ; - PUSH nat 2 ; - UPDATE 1 ; - PUSH nat 12 ; - UPDATE 3 ; - PUSH nat 8 ; - UPDATE 5 ; - UNIT ; - UPDATE 6 ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/concat.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/concat.tz deleted file mode 100644 index ffc97335652b0e304695d20c8a60e468d0cfa6c0..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/concat.tz +++ /dev/null @@ -1,9 +0,0 @@ -{ parameter string ; - storage string ; - code { DUP ; - DIP { CDR ; NIL string ; SWAP ; CONS } ; - CAR ; - CONS ; - CONCAT ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/conditionals.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/conditionals.tz deleted file mode 100644 index 7eea2f774d76abd4fc7470ce22ed019bc37a69a0..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/conditionals.tz +++ /dev/null @@ -1,12 +0,0 @@ -{ parameter (or string (option int)) ; - storage string ; - code { CAR ; - IF_LEFT - {} - { IF_NONE - { { UNIT ; FAILWITH } } - { PUSH int 0 ; - { COMPARE ; GT } ; - IF { { UNIT ; FAILWITH } } { PUSH string "" } } } ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/cps_fact.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/cps_fact.tz deleted file mode 100644 index 58a77dd722e8809275da66f3366bb1ec880cb67a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/cps_fact.tz +++ /dev/null @@ -1,28 +0,0 @@ -{ storage nat ; - parameter nat ; - code { UNPAIR ; - DIP { SELF ; - ADDRESS ; - SENDER ; - { COMPARE ; EQ ; IF {} { DROP ; PUSH @storage nat 1 } } } ; - DUP ; - PUSH nat 1 ; - { COMPARE ; - GE ; - IF { DROP ; NIL operation ; PAIR } - { PUSH nat 1 ; - SWAP ; - SUB @parameter ; - ISNAT ; - IF_NONE - { NIL operation ; PAIR } - { DUP ; - DIP { PUSH nat 1 ; ADD ; MUL @storage } ; - SWAP ; - DIP { DIP { SELF ; PUSH mutez 0 } ; - TRANSFER_TOKENS ; - NIL operation ; - SWAP ; - CONS } ; - SWAP ; - PAIR } } } } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/dign.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/dign.tz deleted file mode 100644 index bb325b83d9790643c2605c986a700c326d818608..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/dign.tz +++ /dev/null @@ -1,11 +0,0 @@ -{ parameter (pair (pair (pair (pair nat nat) nat) nat) nat) ; - storage nat ; - code { CAR ; - UNPAIR ; - UNPAIR ; - UNPAIR ; - UNPAIR ; - DIG 4 ; - DIP { DROP ; DROP ; DROP ; DROP } ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/dipn.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/dipn.tz deleted file mode 100644 index a320bd5b60aaa802a1e3c38740f2138b03a9f15d..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/dipn.tz +++ /dev/null @@ -1,15 +0,0 @@ -{ parameter (pair (pair (pair (pair nat nat) nat) nat) nat) ; - storage nat ; - code { CAR ; - UNPAIR ; - UNPAIR ; - UNPAIR ; - UNPAIR ; - DIP 5 { PUSH nat 6 } ; - DROP ; - DROP ; - DROP ; - DROP ; - DROP ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/dugn.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/dugn.tz deleted file mode 100644 index 17c3aba6949ab3611605a10a0d0129059308a282..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/dugn.tz +++ /dev/null @@ -1,14 +0,0 @@ -{ parameter (pair (pair (pair (pair nat nat) nat) nat) nat) ; - storage nat ; - code { CAR ; - UNPAIR ; - UNPAIR ; - UNPAIR ; - UNPAIR ; - DUG 4 ; - DROP ; - DROP ; - DROP ; - DROP ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/ediv.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/ediv.tz deleted file mode 100644 index 018ee512ff47ebd0d354c0c270cb07500d148f73..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/ediv.tz +++ /dev/null @@ -1,28 +0,0 @@ -{ parameter (pair int int) ; - storage - (pair (option (pair int nat)) - (option (pair int nat)) - (option (pair int nat)) - (option (pair nat nat))) ; - code { CAR ; - DUP ; - UNPAIR ; - ABS ; - DIP { ABS } ; - EDIV ; - SWAP ; - DUP ; - UNPAIR ; - ABS ; - EDIV ; - SWAP ; - DUP ; - UNPAIR ; - DIP { ABS } ; - EDIV ; - SWAP ; - UNPAIR ; - EDIV ; - { DIP 2 { PAIR } ; DIP { PAIR } ; PAIR } ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/faucet.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/faucet.tz deleted file mode 100644 index 00c69a330a6935197390aa162c119f3557216187..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/faucet.tz +++ /dev/null @@ -1,17 +0,0 @@ -{ parameter key_hash ; - storage timestamp ; - code { UNPAIR ; - SWAP ; - PUSH int 300 ; - ADD @FIVE_MINUTES_LATER ; - NOW ; - { { COMPARE ; GE } ; IF {} { { UNIT ; FAILWITH } } } ; - IMPLICIT_ACCOUNT ; - PUSH mutez 1000000 ; - UNIT ; - TRANSFER_TOKENS ; - NIL operation ; - SWAP ; - CONS ; - DIP { NOW } ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/get_and_update_map.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/get_and_update_map.tz deleted file mode 100644 index ec3bcd0f60b5f39ab96945599f49576afd14b85a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/get_and_update_map.tz +++ /dev/null @@ -1,7 +0,0 @@ -{ parameter string ; - storage (pair (option nat) (map string nat)) ; - code { { UNPAIR ; DIP { UNPAIR } } ; - GET_AND_UPDATE ; - PAIR ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/if.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/if.tz deleted file mode 100644 index 0b9e463b64408822415ac3e5ea2347c29b4edd96..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/if.tz +++ /dev/null @@ -1,7 +0,0 @@ -{ parameter bool ; - storage (option bool) ; - code { CAR ; - IF { PUSH bool True } { PUSH bool False } ; - SOME ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/insertion_sort.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/insertion_sort.tz deleted file mode 100644 index 79f41696956f09dec53e227353c8ec029b60391c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/insertion_sort.tz +++ /dev/null @@ -1,21 +0,0 @@ -{ parameter (list int) ; - storage (list int) ; - code { CAR ; - NIL int ; - SWAP ; - ITER { SWAP ; - DIP 2 { NIL int } ; - PUSH bool True ; - LOOP { IF_CONS - { SWAP ; - DIP { DUP ; DIP 2 { DUP } ; DIP { { COMPARE ; LT } } ; SWAP } ; - SWAP ; - IF { DIP { SWAP ; DIP { CONS } } ; PUSH bool True } - { SWAP ; CONS ; PUSH bool False } } - { NIL int ; PUSH bool False } } ; - SWAP ; - CONS ; - SWAP ; - ITER { CONS } } ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/list_map_block.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/list_map_block.tz deleted file mode 100644 index f2f66dd307661da97e42e81ff8b20a80f5cbc18a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/list_map_block.tz +++ /dev/null @@ -1,9 +0,0 @@ -{ parameter (list int) ; - storage (list int) ; - code { CAR ; - PUSH int 0 ; - SWAP ; - MAP { DIP { DUP } ; ADD ; DIP { PUSH int 1 ; ADD } } ; - NIL operation ; - PAIR ; - DIP { DROP } } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/loop_left.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/loop_left.tz deleted file mode 100644 index d491a1b3292067577360792cdcf4d18524d4d0c7..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/loop_left.tz +++ /dev/null @@ -1,16 +0,0 @@ -{ parameter (list string) ; - storage (list string) ; - code { CAR ; - NIL string ; - SWAP ; - PAIR ; - LEFT (list string) ; - LOOP_LEFT - { DUP ; - CAR ; - DIP { CDR } ; - IF_CONS - { SWAP ; DIP { CONS } ; PAIR ; LEFT (list string) } - { RIGHT (pair (list string) (list string)) } } ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/opt_map.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/opt_map.tz deleted file mode 100644 index 51feb91f44ac382bcebc23b0606f54872f98c178..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/opt_map.tz +++ /dev/null @@ -1,12 +0,0 @@ -{ - parameter int; - storage (option int); - code { - UNPAIR; - SWAP ; - MAP { DIP { DUP } ; ADD ; } ; - DIP { DROP } ; - NIL operation ; - PAIR ; - } -} diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/packunpack.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/packunpack.tz deleted file mode 100644 index 8f08146fe0b6095f81180cdc8843f10c26090857..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/packunpack.tz +++ /dev/null @@ -1,13 +0,0 @@ -{ parameter (pair (pair (pair string (list int)) (set nat)) bytes) ; - storage unit ; - code { CAR ; - UNPAIR ; - DIP { DUP } ; - PACK ; - { { COMPARE ; EQ } ; IF {} { { UNIT ; FAILWITH } } } ; - UNPACK (pair (pair string (list int)) (set nat)) ; - { IF_NONE { { UNIT ; FAILWITH } } {} } ; - DROP ; - UNIT ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/pexec.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/pexec.tz deleted file mode 100644 index 9211a7b9c7a0b808b305d12562d4a60f0a41f725..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/pexec.tz +++ /dev/null @@ -1,9 +0,0 @@ -{ parameter nat ; - storage nat ; - code { LAMBDA (pair nat nat) nat { UNPAIR ; ADD } ; - SWAP ; - UNPAIR ; - DIP { APPLY } ; - EXEC ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/rec_id_unit.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/rec_id_unit.tz deleted file mode 100644 index ae143d1c2a8aa2d35463230f7d236680ac387e72..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/rec_id_unit.tz +++ /dev/null @@ -1,9 +0,0 @@ -{parameter unit; - storage unit; - code { CAR ; - LAMBDA_REC unit unit - {DIP {DROP}}; - SWAP; - EXEC; - NIL operation; - PAIR}} diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/reverse_loop.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/reverse_loop.tz deleted file mode 100644 index c73aa3408bb19459e5751a9f2a34c87fbdde8bb0..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/reverse_loop.tz +++ /dev/null @@ -1,12 +0,0 @@ -{ parameter (list string) ; - storage (list string) ; - code { CAR ; - NIL string ; - SWAP ; - PUSH bool True ; - LOOP { IF_CONS - { SWAP ; DIP { CONS } ; PUSH bool True } - { NIL string ; PUSH bool False } } ; - DROP ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/set_delegate.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/set_delegate.tz deleted file mode 100644 index 560682be4b51c044ef6b5275bd799b20e56bab9d..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/set_delegate.tz +++ /dev/null @@ -1,3 +0,0 @@ -{ parameter (option key_hash) ; - storage unit ; - code { UNPAIR ; SET_DELEGATE ; DIP { NIL operation } ; CONS ; PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/shifts.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/shifts.tz deleted file mode 100644 index 94886af646e4a7ef8c456791476c2c8dd0bb17c1..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/shifts.tz +++ /dev/null @@ -1,7 +0,0 @@ -{ parameter (or (pair nat nat) (pair nat nat)) ; - storage (option nat) ; - code { CAR ; - IF_LEFT { UNPAIR ; LSL } { UNPAIR ; LSR } ; - SOME ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/spawn_identities.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/spawn_identities.tz deleted file mode 100644 index 00480de0ef086a587d2fd76eedd33aba4a6d9b3c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/spawn_identities.tz +++ /dev/null @@ -1,28 +0,0 @@ -{ parameter nat ; - storage (list address) ; - code { DUP ; - CAR ; - DIP { CDR ; NIL operation } ; - PUSH bool True ; - LOOP { DUP ; - PUSH nat 0 ; - { COMPARE ; EQ } ; - IF { PUSH bool False } - { PUSH nat 1 ; - SWAP ; - SUB ; - ABS ; - PUSH string "init" ; - PUSH mutez 5000000 ; - NONE key_hash ; - CREATE_CONTRACT - { parameter string ; - storage string ; - code { CAR ; NIL operation ; PAIR } } ; - SWAP ; - DIP { SWAP ; DIP { CONS } } ; - SWAP ; - DIP { SWAP ; DIP { CONS } } ; - PUSH bool True } } ; - DROP ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/ticket_join.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/ticket_join.tz deleted file mode 100644 index b29c396b84978f48a0b4aa66f1eb8420cbe253ce..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/ticket_join.tz +++ /dev/null @@ -1,10 +0,0 @@ -{ parameter (ticket nat) ; - storage (option (ticket nat)) ; - code { UNPAIR ; - SWAP ; - IF_NONE - {} - { PAIR ; JOIN_TICKETS ; { IF_NONE { { UNIT ; FAILWITH } } {} } } ; - SOME ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/ticket_split.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/ticket_split.tz deleted file mode 100644 index 817c1711331f2682c021214b40a7f2594930fd54..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/ticket_split.tz +++ /dev/null @@ -1,21 +0,0 @@ -{ parameter (ticket nat) ; - storage unit ; - code { CAR ; - PUSH (pair nat nat) (Pair 1 2) ; - SWAP ; - SPLIT_TICKET ; - { IF_NONE { { UNIT ; FAILWITH } } {} } ; - UNPAIR ; - READ_TICKET ; - { CDR ; CDR } ; - PUSH nat 1 ; - { { COMPARE ; EQ } ; IF {} { { UNIT ; FAILWITH } } } ; - DROP ; - READ_TICKET ; - { CDR ; CDR } ; - PUSH nat 2 ; - { { COMPARE ; EQ } ; IF {} { { UNIT ; FAILWITH } } } ; - DROP ; - UNIT ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/view_fib.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/view_fib.tz deleted file mode 100644 index 51b308e07948013614155e2e3887337cd36d935b..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/view_fib.tz +++ /dev/null @@ -1,6 +0,0 @@ -{ parameter (pair nat address) ; - storage nat ; - code { CAR ; - UNPAIR ; - VIEW "fib" nat ; - { IF_NONE { { UNIT ; FAILWITH } } { NIL operation ; PAIR } } } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/view_toplevel_lib.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/view_toplevel_lib.tz deleted file mode 100644 index 4cefa5f7fd62ac68592389ddf455f8b4ffdec1fd..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/view_toplevel_lib.tz +++ /dev/null @@ -1,80 +0,0 @@ -{ parameter nat ; - storage nat ; - code { CAR ; NIL operation ; PAIR } ; - view "add" nat nat { UNPAIR ; ADD } ; - view "id" nat (pair nat nat) {} ; - view "test_failwith" nat (pair nat nat) { FAILWITH } ; - view "step_constants" - unit - (pair (pair mutez mutez) (pair (pair address address) address)) - { DROP ; - SOURCE ; - SENDER ; - SELF_ADDRESS ; - PAIR ; - PAIR ; - BALANCE ; - AMOUNT ; - PAIR ; - PAIR } ; - view "succ" - (pair nat address) - nat - { CAR ; - UNPAIR ; - PUSH nat 1 ; - ADD ; - PAIR ; - DUP ; - CDR ; - SWAP ; - VIEW "is_twenty" nat ; - { IF_NONE { { UNIT ; FAILWITH } } {} } } ; - view "is_twenty" - (pair nat address) - nat - { CAR ; - DUP ; - CAR ; - PUSH nat 20 ; - COMPARE ; - EQ ; - IF { CAR } - { DUP ; - CDR ; - SWAP ; - VIEW "succ" nat ; - { IF_NONE { { UNIT ; FAILWITH } } {} } } } ; - view "fib" - nat - nat - { CAR ; - DUP ; - PUSH nat 0 ; - COMPARE ; - EQ ; - IF {} - { DUP ; - PUSH nat 1 ; - COMPARE ; - EQ ; - IF {} - { DUP ; - PUSH nat 1 ; - SWAP ; - SUB ; - ABS ; - SELF_ADDRESS ; - SWAP ; - VIEW "fib" nat ; - { IF_NONE - { { UNIT ; FAILWITH } } - { SWAP ; - PUSH nat 2 ; - SWAP ; - SUB ; - ABS ; - SELF_ADDRESS ; - SWAP ; - VIEW "fib" nat ; - { IF_NONE { { UNIT ; FAILWITH } } { ADD } } } } } } } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/xor.tz b/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/xor.tz deleted file mode 100644 index 6989394c999218967142a566353aa92a04b848db..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/contracts/xor.tz +++ /dev/null @@ -1,7 +0,0 @@ -{ parameter (or (pair bool bool) (pair nat nat)) ; - storage (option (or bool nat)) ; - code { CAR ; - IF_LEFT { UNPAIR ; XOR ; LEFT nat } { UNPAIR ; XOR ; RIGHT bool } ; - SOME ; - NIL operation ; - PAIR } } diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/dune b/src/proto_017_PtNairob/lib_protocol/test/regression/dune deleted file mode 100644 index 492d41ae2ce17d67cc7903392885848a8ef6be0e..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/dune +++ /dev/null @@ -1,52 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name src_proto_017_PtNairob_lib_protocol_test_regression_tezt_lib) - (instrumentation (backend bisect_ppx)) - (libraries - tezt.core - octez-libs.base - tezt-tezos - tezos-protocol-017-PtNairob.protocol - octez-protocol-017-PtNairob-libs.client - octez-protocol-017-PtNairob-libs.plugin - octez-protocol-017-PtNairob-libs.test-helpers - octez-libs.micheline) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezt_core - -open Tezt_core.Base - -open Tezos_base.TzPervasives - -open Tezt_tezos - -open Tezos_protocol_017_PtNairob - -open Tezos_client_017_PtNairob - -open Tezos_protocol_plugin_017_PtNairob - -open Tezos_017_PtNairob_test_helpers - -open Tezos_micheline) - (modules test_logging)) - -(executable - (name main) - (instrumentation (backend bisect_ppx --bisect-sigterm)) - (libraries - src_proto_017_PtNairob_lib_protocol_test_regression_tezt_lib - tezt) - (link_flags - (:standard) - (:include %{workspace_root}/macos-link-flags.sexp)) - (modules main)) - -(rule - (alias runtest) - (package tezos-protocol-017-PtNairob-tests) - (deps - (glob_files contracts/*.tz) - (glob_files expected/test_logging.ml/*.out)) - (enabled_if (<> false %{env:RUNTEZTALIAS=true})) - (action (run %{dep:./main.exe}))) - -(rule - (targets main.ml) - (action (with-stdout-to %{targets} (echo "let () = Tezt.Test.run ()")))) diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/accounts.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/accounts.out deleted file mode 100644 index ff82d9219dfb7f3933d72b69091ffffbf802cda4..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/accounts.out +++ /dev/null @@ -1,166 +0,0 @@ - -trace - - DUP (interp) @ location: 15 - [ (Pair (Left "[PUBLIC_KEY_HASH]") {}) ] - - DUP (entry) @ location: 15 - [ (Pair (Left "[PUBLIC_KEY_HASH]") {}) ] - - log/CAR (exit) @ location: 15 - [ (Pair (Left "[PUBLIC_KEY_HASH]") {}) - (Pair (Left "[PUBLIC_KEY_HASH]") {}) ] - - CAR (entry) @ location: 16 - [ (Pair (Left "[PUBLIC_KEY_HASH]") {}) - (Pair (Left "[PUBLIC_KEY_HASH]") {}) ] - - log/IF_LEFT (exit) @ location: 16 - [ (Left "[PUBLIC_KEY_HASH]") - (Pair (Left "[PUBLIC_KEY_HASH]") {}) ] - - IF_LEFT (entry) @ location: 17 - [ (Left "[PUBLIC_KEY_HASH]") - (Pair (Left "[PUBLIC_KEY_HASH]") {}) ] - - log/DUP (exit) @ location: 17 - [ "[PUBLIC_KEY_HASH]" - (Pair (Left "[PUBLIC_KEY_HASH]") {}) ] - - DUP (entry) @ location: 19 - [ "[PUBLIC_KEY_HASH]" - (Pair (Left "[PUBLIC_KEY_HASH]") {}) ] - - log/DIP (exit) @ location: 19 - [ "[PUBLIC_KEY_HASH]" - "[PUBLIC_KEY_HASH]" - (Pair (Left "[PUBLIC_KEY_HASH]") {}) ] - - DIP (entry) @ location: 20 - [ "[PUBLIC_KEY_HASH]" - "[PUBLIC_KEY_HASH]" - (Pair (Left "[PUBLIC_KEY_HASH]") {}) ] - - log/CDR (exit) @ location: 20 - [ (Pair (Left "[PUBLIC_KEY_HASH]") {}) ] - - CDR (entry) @ location: 23 - [ (Pair (Left "[PUBLIC_KEY_HASH]") {}) ] - - log/DUP (exit) @ location: 23 - [ {} ] - - DUP (entry) @ location: 24 - [ {} ] - - log/[halt] (exit) @ location: 24 - [ {} - {} ] - - [halt] (entry) @ location: 22 - [ {} - {} ] - - control: KCons - - PUSH (entry) @ location: 20 - [ {} - {} ] - - log/PUSH (exit) @ location: 20 - [ "[PUBLIC_KEY_HASH]" - {} - {} ] - - PUSH (entry) @ location: 20 - [ "[PUBLIC_KEY_HASH]" - {} - {} ] - - log/log/log/DIP (exit) @ location: 20 - [ "[PUBLIC_KEY_HASH]" - "[PUBLIC_KEY_HASH]" - {} - {} ] - - log/DIP (exit) @ location: 20 - [ "[PUBLIC_KEY_HASH]" - "[PUBLIC_KEY_HASH]" - {} - {} ] - - DIP (entry) @ location: 25 - [ "[PUBLIC_KEY_HASH]" - "[PUBLIC_KEY_HASH]" - {} - {} ] - - log/SWAP (exit) @ location: 25 - [ "[PUBLIC_KEY_HASH]" - {} - {} ] - - SWAP (entry) @ location: 27 - [ "[PUBLIC_KEY_HASH]" - {} - {} ] - - log/[halt] (exit) @ location: 27 - [ {} - "[PUBLIC_KEY_HASH]" - {} ] - - [halt] (entry) @ location: 27 - [ {} - "[PUBLIC_KEY_HASH]" - {} ] - - control: KUndip - - control: KCons - - log/GET (exit) @ location: 25 - [ "[PUBLIC_KEY_HASH]" - {} - "[PUBLIC_KEY_HASH]" - {} ] - - GET (entry) @ location: 28 - [ "[PUBLIC_KEY_HASH]" - {} - "[PUBLIC_KEY_HASH]" - {} ] - - log/IF_NONE (exit) @ location: 28 - [ None - "[PUBLIC_KEY_HASH]" - {} ] - - IF_NONE (entry) @ location: 30 - [ None - "[PUBLIC_KEY_HASH]" - {} ] - - log/DIP (exit) @ location: 30 - [ "[PUBLIC_KEY_HASH]" - {} ] - - DIP (entry) @ location: 32 - [ "[PUBLIC_KEY_HASH]" - {} ] - - log/AMOUNT (exit) @ location: 32 - [ {} ] - - AMOUNT (entry) @ location: 34 - [ {} ] - - log/SOME (exit) @ location: 34 - [ 0 - {} ] - - SOME (entry) @ location: 35 - [ 0 - {} ] - - log/[halt] (exit) @ location: 35 - [ (Some 0) - {} ] - - [halt] (entry) @ location: 33 - [ (Some 0) - {} ] - - control: KUndip - - control: KCons - - log/UPDATE (exit) @ location: 32 - [ "[PUBLIC_KEY_HASH]" - (Some 0) - {} ] - - UPDATE (entry) @ location: 36 - [ "[PUBLIC_KEY_HASH]" - (Some 0) - {} ] - - log/NIL (exit) @ location: 36 - [ { Elt "[PUBLIC_KEY_HASH]" 0 } ] - - NIL (entry) @ location: 37 - [ { Elt "[PUBLIC_KEY_HASH]" 0 } ] - - log/PAIR (exit) @ location: 37 - [ {} - { Elt "[PUBLIC_KEY_HASH]" 0 } ] - - PAIR (entry) @ location: 39 - [ {} - { Elt "[PUBLIC_KEY_HASH]" 0 } ] - - log/[halt] (exit) @ location: 39 - [ (Pair {} { Elt "[PUBLIC_KEY_HASH]" 0 }) ] - - [halt] (entry) @ location: 14 - [ (Pair {} { Elt "[PUBLIC_KEY_HASH]" 0 }) ] - - control: KCons - - log/[halt] (exit) @ location: 30 - [ (Pair {} { Elt "[PUBLIC_KEY_HASH]" 0 }) ] - - [halt] (entry) @ location: 14 - [ (Pair {} { Elt "[PUBLIC_KEY_HASH]" 0 }) ] - - control: KCons - - log/[halt] (exit) @ location: 17 - [ (Pair {} { Elt "[PUBLIC_KEY_HASH]" 0 }) ] - - [halt] (entry) @ location: 14 - [ (Pair {} { Elt "[PUBLIC_KEY_HASH]" 0 }) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/append.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/append.out deleted file mode 100644 index b573fc597191d31fbcf379a654d92683977b74f0..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/append.out +++ /dev/null @@ -1,135 +0,0 @@ - -trace - - CAR (interp) @ location: 12 - [ (Pair (Pair { 7 ; 8 ; 9 } { 4 ; 5 ; 6 }) { 1 ; 2 ; 3 }) ] - - CAR (entry) @ location: 12 - [ (Pair (Pair { 7 ; 8 ; 9 } { 4 ; 5 ; 6 }) { 1 ; 2 ; 3 }) ] - - log/UNPAIR (exit) @ location: 12 - [ (Pair { 7 ; 8 ; 9 } { 4 ; 5 ; 6 }) ] - - UNPAIR (entry) @ location: 13 - [ (Pair { 7 ; 8 ; 9 } { 4 ; 5 ; 6 }) ] - - log/NIL (exit) @ location: 13 - [ { 7 ; 8 ; 9 } - { 4 ; 5 ; 6 } ] - - NIL (entry) @ location: 14 - [ { 7 ; 8 ; 9 } - { 4 ; 5 ; 6 } ] - - log/SWAP (exit) @ location: 14 - [ {} - { 7 ; 8 ; 9 } - { 4 ; 5 ; 6 } ] - - SWAP (entry) @ location: 16 - [ {} - { 7 ; 8 ; 9 } - { 4 ; 5 ; 6 } ] - - log/ITER (exit) @ location: 16 - [ { 7 ; 8 ; 9 } - {} - { 4 ; 5 ; 6 } ] - - ITER (entry) @ location: 17 - [ { 7 ; 8 ; 9 } - {} - { 4 ; 5 ; 6 } ] - - control: KIter - - log/CONS (exit) @ location: 17 - [ 7 - {} - { 4 ; 5 ; 6 } ] - - CONS (entry) @ location: 19 - [ 7 - {} - { 4 ; 5 ; 6 } ] - - log/[halt] (exit) @ location: 19 - [ { 7 } - { 4 ; 5 ; 6 } ] - - [halt] (entry) @ location: 17 - [ { 7 } - { 4 ; 5 ; 6 } ] - - control: KIter - - log/CONS (exit) @ location: 17 - [ 8 - { 7 } - { 4 ; 5 ; 6 } ] - - CONS (entry) @ location: 19 - [ 8 - { 7 } - { 4 ; 5 ; 6 } ] - - log/[halt] (exit) @ location: 19 - [ { 8 ; 7 } - { 4 ; 5 ; 6 } ] - - [halt] (entry) @ location: 17 - [ { 8 ; 7 } - { 4 ; 5 ; 6 } ] - - control: KIter - - log/CONS (exit) @ location: 17 - [ 9 - { 8 ; 7 } - { 4 ; 5 ; 6 } ] - - CONS (entry) @ location: 19 - [ 9 - { 8 ; 7 } - { 4 ; 5 ; 6 } ] - - log/[halt] (exit) @ location: 19 - [ { 9 ; 8 ; 7 } - { 4 ; 5 ; 6 } ] - - [halt] (entry) @ location: 17 - [ { 9 ; 8 ; 7 } - { 4 ; 5 ; 6 } ] - - control: KIter - - control: KCons - - log/ITER (exit) @ location: 17 - [ { 9 ; 8 ; 7 } - { 4 ; 5 ; 6 } ] - - ITER (entry) @ location: 20 - [ { 9 ; 8 ; 7 } - { 4 ; 5 ; 6 } ] - - control: KIter - - log/CONS (exit) @ location: 20 - [ 9 - { 4 ; 5 ; 6 } ] - - CONS (entry) @ location: 22 - [ 9 - { 4 ; 5 ; 6 } ] - - log/[halt] (exit) @ location: 22 - [ { 9 ; 4 ; 5 ; 6 } ] - - [halt] (entry) @ location: 20 - [ { 9 ; 4 ; 5 ; 6 } ] - - control: KIter - - log/CONS (exit) @ location: 20 - [ 8 - { 9 ; 4 ; 5 ; 6 } ] - - CONS (entry) @ location: 22 - [ 8 - { 9 ; 4 ; 5 ; 6 } ] - - log/[halt] (exit) @ location: 22 - [ { 8 ; 9 ; 4 ; 5 ; 6 } ] - - [halt] (entry) @ location: 20 - [ { 8 ; 9 ; 4 ; 5 ; 6 } ] - - control: KIter - - log/CONS (exit) @ location: 20 - [ 7 - { 8 ; 9 ; 4 ; 5 ; 6 } ] - - CONS (entry) @ location: 22 - [ 7 - { 8 ; 9 ; 4 ; 5 ; 6 } ] - - log/[halt] (exit) @ location: 22 - [ { 7 ; 8 ; 9 ; 4 ; 5 ; 6 } ] - - [halt] (entry) @ location: 20 - [ { 7 ; 8 ; 9 ; 4 ; 5 ; 6 } ] - - control: KIter - - control: KCons - - log/NIL (exit) @ location: 20 - [ { 7 ; 8 ; 9 ; 4 ; 5 ; 6 } ] - - NIL (entry) @ location: 23 - [ { 7 ; 8 ; 9 ; 4 ; 5 ; 6 } ] - - log/PAIR (exit) @ location: 23 - [ {} - { 7 ; 8 ; 9 ; 4 ; 5 ; 6 } ] - - PAIR (entry) @ location: 25 - [ {} - { 7 ; 8 ; 9 ; 4 ; 5 ; 6 } ] - - log/[halt] (exit) @ location: 25 - [ (Pair {} { 7 ; 8 ; 9 ; 4 ; 5 ; 6 }) ] - - [halt] (entry) @ location: 11 - [ (Pair {} { 7 ; 8 ; 9 ; 4 ; 5 ; 6 }) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/auction.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/auction.out deleted file mode 100644 index 4b6dfefc1ebee51722f9ecb9118db1003a549981..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/auction.out +++ /dev/null @@ -1,415 +0,0 @@ - -trace - - DUP (interp) @ location: 11 - [ (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") ] - - DUP (entry) @ location: 11 - [ (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") ] - - log/CDR (exit) @ location: 11 - [ (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") ] - - CDR (entry) @ location: 13 - [ (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") ] - - log/CAR (exit) @ location: 13 - [ (Pair "[TIMESTAMP]" 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") ] - - CAR (entry) @ location: 14 - [ (Pair "[TIMESTAMP]" 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") ] - - log/DUP (exit) @ location: 14 - [ "[TIMESTAMP]" - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") ] - - DUP (entry) @ location: 15 - [ "[TIMESTAMP]" - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") ] - - log/NOW (exit) @ location: 15 - [ "[TIMESTAMP]" - "[TIMESTAMP]" - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") ] - - NOW (entry) @ location: 16 - [ "[TIMESTAMP]" - "[TIMESTAMP]" - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") ] - - log/COMPARE (exit) @ location: 16 - [ "[TIMESTAMP]" - "[TIMESTAMP]" - "[TIMESTAMP]" - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") ] - - COMPARE (entry) @ location: 18 - [ "[TIMESTAMP]" - "[TIMESTAMP]" - "[TIMESTAMP]" - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") ] - - log/GT (exit) @ location: 18 - [ -1 - "[TIMESTAMP]" - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") ] - - GT (entry) @ location: 19 - [ -1 - "[TIMESTAMP]" - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") ] - - log/IF (exit) @ location: 19 - [ False - "[TIMESTAMP]" - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") ] - - IF (entry) @ location: 20 - [ False - "[TIMESTAMP]" - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") ] - - log/[halt] (exit) @ location: 20 - [ "[TIMESTAMP]" - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") ] - - [halt] (entry) @ location: 26 - [ "[TIMESTAMP]" - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") ] - - control: KCons - - log/SWAP (exit) @ location: 20 - [ "[TIMESTAMP]" - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") ] - - SWAP (entry) @ location: 26 - [ "[TIMESTAMP]" - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") ] - - log/DUP (exit) @ location: 26 - [ (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - DUP (entry) @ location: 27 - [ (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - log/CAR (exit) @ location: 27 - [ (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - CAR (entry) @ location: 28 - [ (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - log/DIP (exit) @ location: 28 - [ "[PUBLIC_KEY_HASH]" - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - DIP (entry) @ location: 29 - [ "[PUBLIC_KEY_HASH]" - (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - log/CDR (exit) @ location: 29 - [ (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - CDR (entry) @ location: 32 - [ (Pair "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" - 50000000 - "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - log/CDR (exit) @ location: 32 - [ (Pair "[TIMESTAMP]" 50000000 "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - CDR (entry) @ location: 33 - [ (Pair "[TIMESTAMP]" 50000000 "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - log/[halt] (exit) @ location: 33 - [ (Pair 50000000 "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - [halt] (entry) @ location: 31 - [ (Pair 50000000 "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - control: KUndip - - control: KCons - - log/AMOUNT (exit) @ location: 29 - [ "[PUBLIC_KEY_HASH]" - (Pair 50000000 "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - AMOUNT (entry) @ location: 34 - [ "[PUBLIC_KEY_HASH]" - (Pair 50000000 "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - log/PAIR (exit) @ location: 34 - [ 100000000 - "[PUBLIC_KEY_HASH]" - (Pair 50000000 "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - PAIR (entry) @ location: 35 - [ 100000000 - "[PUBLIC_KEY_HASH]" - (Pair 50000000 "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - log/SWAP (exit) @ location: 35 - [ (Pair 100000000 "[PUBLIC_KEY_HASH]") - (Pair 50000000 "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - SWAP (entry) @ location: 36 - [ (Pair 100000000 "[PUBLIC_KEY_HASH]") - (Pair 50000000 "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - log/DIP (exit) @ location: 36 - [ (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair 100000000 "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - DIP (entry) @ location: 37 - [ (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair 100000000 "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - log/SWAP (exit) @ location: 37 - [ (Pair 100000000 "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - SWAP (entry) @ location: 39 - [ (Pair 100000000 "[PUBLIC_KEY_HASH]") - "[TIMESTAMP]" ] - - log/PAIR (exit) @ location: 39 - [ "[TIMESTAMP]" - (Pair 100000000 "[PUBLIC_KEY_HASH]") ] - - PAIR (entry) @ location: 40 - [ "[TIMESTAMP]" - (Pair 100000000 "[PUBLIC_KEY_HASH]") ] - - log/[halt] (exit) @ location: 40 - [ (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - [halt] (entry) @ location: 38 - [ (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - control: KUndip - - control: KCons - - log/DUP (exit) @ location: 37 - [ (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - DUP (entry) @ location: 41 - [ (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - log/CAR (exit) @ location: 41 - [ (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - CAR (entry) @ location: 42 - [ (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - log/AMOUNT (exit) @ location: 42 - [ 50000000 - (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - AMOUNT (entry) @ location: 43 - [ 50000000 - (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - log/COMPARE (exit) @ location: 43 - [ 100000000 - 50000000 - (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - COMPARE (entry) @ location: 45 - [ 100000000 - 50000000 - (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - log/LE (exit) @ location: 45 - [ 1 - (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - LE (entry) @ location: 46 - [ 1 - (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - log/IF (exit) @ location: 46 - [ False - (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - IF (entry) @ location: 47 - [ False - (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - log/[halt] (exit) @ location: 47 - [ (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - [halt] (entry) @ location: 53 - [ (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - control: KCons - - log/DUP (exit) @ location: 47 - [ (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - DUP (entry) @ location: 53 - [ (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - log/CAR (exit) @ location: 53 - [ (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - CAR (entry) @ location: 54 - [ (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - log/DIP (exit) @ location: 54 - [ 50000000 - (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - DIP (entry) @ location: 55 - [ 50000000 - (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - log/CDR (exit) @ location: 55 - [ (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - CDR (entry) @ location: 57 - [ (Pair 50000000 "[PUBLIC_KEY_HASH]") - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - log/IMPLICIT_ACCOUNT (exit) @ location: 57 - [ "[PUBLIC_KEY_HASH]" - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - IMPLICIT_ACCOUNT (entry) @ location: 58 - [ "[PUBLIC_KEY_HASH]" - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - log/[halt] (exit) @ location: 58 - [ "[PUBLIC_KEY_HASH]" - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - [halt] (entry) @ location: 56 - [ "[PUBLIC_KEY_HASH]" - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 55 - [ 50000000 - "[PUBLIC_KEY_HASH]" - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - PUSH (entry) @ location: 59 - [ 50000000 - "[PUBLIC_KEY_HASH]" - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - log/TRANSFER_TOKENS (exit) @ location: 59 - [ Unit - 50000000 - "[PUBLIC_KEY_HASH]" - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - TRANSFER_TOKENS (entry) @ location: 60 - [ Unit - 50000000 - "[PUBLIC_KEY_HASH]" - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - log/NIL (exit) @ location: 60 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000180e1eb170000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - NIL (entry) @ location: 61 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000180e1eb170000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - log/SWAP (exit) @ location: 61 - [ {} - 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000180e1eb170000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - SWAP (entry) @ location: 63 - [ {} - 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000180e1eb170000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - log/CONS (exit) @ location: 63 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000180e1eb170000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 - {} - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - CONS (entry) @ location: 64 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000180e1eb170000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 - {} - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - log/PAIR (exit) @ location: 64 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000180e1eb170000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 } - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - PAIR (entry) @ location: 65 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000180e1eb170000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 } - (Pair "[TIMESTAMP]" 100000000 "[PUBLIC_KEY_HASH]") ] - - log/[halt] (exit) @ location: 65 - [ (Pair { 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000180e1eb170000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 } - "[TIMESTAMP]" - 100000000 - "[PUBLIC_KEY_HASH]") ] - - [halt] (entry) @ location: 10 - [ (Pair { 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000180e1eb170000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 } - "[TIMESTAMP]" - 100000000 - "[PUBLIC_KEY_HASH]") ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/big_map_union.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/big_map_union.out deleted file mode 100644 index d3d7a2bfc45c5755b6c2632d175558d92d3cd51f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/big_map_union.out +++ /dev/null @@ -1,499 +0,0 @@ - -trace - - UNPAIR (interp) @ location: 15 - [ (Pair { Pair "string" 12 ; Pair "abc" 99 ; Pair "def" 3 } { Elt "123" 123 } Unit) ] - - UNPAIR (entry) @ location: 15 - [ (Pair { Pair "string" 12 ; Pair "abc" 99 ; Pair "def" 3 } { Elt "123" 123 } Unit) ] - - log/DIP (exit) @ location: 15 - [ { Pair "string" 12 ; Pair "abc" 99 ; Pair "def" 3 } - (Pair { Elt "123" 123 } Unit) ] - - DIP (entry) @ location: 16 - [ { Pair "string" 12 ; Pair "abc" 99 ; Pair "def" 3 } - (Pair { Elt "123" 123 } Unit) ] - - log/UNPAIR (exit) @ location: 16 - [ (Pair { Elt "123" 123 } Unit) ] - - UNPAIR (entry) @ location: 18 - [ (Pair { Elt "123" 123 } Unit) ] - - log/[halt] (exit) @ location: 18 - [ { Elt "123" 123 } - Unit ] - - [halt] (entry) @ location: 18 - [ { Elt "123" 123 } - Unit ] - - control: KUndip - - control: KCons - - log/ITER (exit) @ location: 16 - [ { Pair "string" 12 ; Pair "abc" 99 ; Pair "def" 3 } - { Elt "123" 123 } - Unit ] - - ITER (entry) @ location: 19 - [ { Pair "string" 12 ; Pair "abc" 99 ; Pair "def" 3 } - { Elt "123" 123 } - Unit ] - - control: KIter - - log/UNPAIR (exit) @ location: 19 - [ (Pair "string" 12) - { Elt "123" 123 } - Unit ] - - UNPAIR (entry) @ location: 21 - [ (Pair "string" 12) - { Elt "123" 123 } - Unit ] - - log/DUP (exit) @ location: 21 - [ "string" - 12 - { Elt "123" 123 } - Unit ] - - DUP (entry) @ location: 22 - [ "string" - 12 - { Elt "123" 123 } - Unit ] - - log/DUP (exit) @ location: 22 - [ { Elt "123" 123 } - "string" - 12 - { Elt "123" 123 } - Unit ] - - DUP (entry) @ location: 24 - [ { Elt "123" 123 } - "string" - 12 - { Elt "123" 123 } - Unit ] - - log/GET (exit) @ location: 24 - [ "string" - { Elt "123" 123 } - "string" - 12 - { Elt "123" 123 } - Unit ] - - GET (entry) @ location: 26 - [ "string" - { Elt "123" 123 } - "string" - 12 - { Elt "123" 123 } - Unit ] - - log/IF_NONE (exit) @ location: 26 - [ None - "string" - 12 - { Elt "123" 123 } - Unit ] - - IF_NONE (entry) @ location: 27 - [ None - "string" - 12 - { Elt "123" 123 } - Unit ] - - log/PUSH (exit) @ location: 27 - [ "string" - 12 - { Elt "123" 123 } - Unit ] - - PUSH (entry) @ location: 29 - [ "string" - 12 - { Elt "123" 123 } - Unit ] - - log/[halt] (exit) @ location: 29 - [ 0 - "string" - 12 - { Elt "123" 123 } - Unit ] - - [halt] (entry) @ location: 33 - [ 0 - "string" - 12 - { Elt "123" 123 } - Unit ] - - control: KCons - - log/SWAP (exit) @ location: 27 - [ 0 - "string" - 12 - { Elt "123" 123 } - Unit ] - - SWAP (entry) @ location: 33 - [ 0 - "string" - 12 - { Elt "123" 123 } - Unit ] - - log/DIP (exit) @ location: 33 - [ "string" - 0 - 12 - { Elt "123" 123 } - Unit ] - - DIP (entry) @ location: 34 - [ "string" - 0 - 12 - { Elt "123" 123 } - Unit ] - - log/ADD (exit) @ location: 34 - [ 0 - 12 - { Elt "123" 123 } - Unit ] - - ADD (entry) @ location: 36 - [ 0 - 12 - { Elt "123" 123 } - Unit ] - - log/SOME (exit) @ location: 36 - [ 12 - { Elt "123" 123 } - Unit ] - - SOME (entry) @ location: 37 - [ 12 - { Elt "123" 123 } - Unit ] - - log/[halt] (exit) @ location: 37 - [ (Some 12) - { Elt "123" 123 } - Unit ] - - [halt] (entry) @ location: 35 - [ (Some 12) - { Elt "123" 123 } - Unit ] - - control: KUndip - - control: KCons - - log/UPDATE (exit) @ location: 34 - [ "string" - (Some 12) - { Elt "123" 123 } - Unit ] - - UPDATE (entry) @ location: 38 - [ "string" - (Some 12) - { Elt "123" 123 } - Unit ] - - log/[halt] (exit) @ location: 38 - [ { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - [halt] (entry) @ location: 19 - [ { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - control: KIter - - log/UNPAIR (exit) @ location: 19 - [ (Pair "abc" 99) - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - UNPAIR (entry) @ location: 21 - [ (Pair "abc" 99) - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - log/DUP (exit) @ location: 21 - [ "abc" - 99 - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - DUP (entry) @ location: 22 - [ "abc" - 99 - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - log/DUP (exit) @ location: 22 - [ { Elt "123" 123 ; Elt "string" 12 } - "abc" - 99 - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - DUP (entry) @ location: 24 - [ { Elt "123" 123 ; Elt "string" 12 } - "abc" - 99 - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - log/GET (exit) @ location: 24 - [ "abc" - { Elt "123" 123 ; Elt "string" 12 } - "abc" - 99 - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - GET (entry) @ location: 26 - [ "abc" - { Elt "123" 123 ; Elt "string" 12 } - "abc" - 99 - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - log/IF_NONE (exit) @ location: 26 - [ None - "abc" - 99 - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - IF_NONE (entry) @ location: 27 - [ None - "abc" - 99 - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - log/PUSH (exit) @ location: 27 - [ "abc" - 99 - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - PUSH (entry) @ location: 29 - [ "abc" - 99 - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - log/[halt] (exit) @ location: 29 - [ 0 - "abc" - 99 - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - [halt] (entry) @ location: 33 - [ 0 - "abc" - 99 - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - control: KCons - - log/SWAP (exit) @ location: 27 - [ 0 - "abc" - 99 - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - SWAP (entry) @ location: 33 - [ 0 - "abc" - 99 - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - log/DIP (exit) @ location: 33 - [ "abc" - 0 - 99 - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - DIP (entry) @ location: 34 - [ "abc" - 0 - 99 - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - log/ADD (exit) @ location: 34 - [ 0 - 99 - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - ADD (entry) @ location: 36 - [ 0 - 99 - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - log/SOME (exit) @ location: 36 - [ 99 - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - SOME (entry) @ location: 37 - [ 99 - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - log/[halt] (exit) @ location: 37 - [ (Some 99) - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - [halt] (entry) @ location: 35 - [ (Some 99) - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - control: KUndip - - control: KCons - - log/UPDATE (exit) @ location: 34 - [ "abc" - (Some 99) - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - UPDATE (entry) @ location: 38 - [ "abc" - (Some 99) - { Elt "123" 123 ; Elt "string" 12 } - Unit ] - - log/[halt] (exit) @ location: 38 - [ { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - [halt] (entry) @ location: 19 - [ { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - control: KIter - - log/UNPAIR (exit) @ location: 19 - [ (Pair "def" 3) - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - UNPAIR (entry) @ location: 21 - [ (Pair "def" 3) - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - log/DUP (exit) @ location: 21 - [ "def" - 3 - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - DUP (entry) @ location: 22 - [ "def" - 3 - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - log/DUP (exit) @ location: 22 - [ { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - "def" - 3 - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - DUP (entry) @ location: 24 - [ { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - "def" - 3 - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - log/GET (exit) @ location: 24 - [ "def" - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - "def" - 3 - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - GET (entry) @ location: 26 - [ "def" - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - "def" - 3 - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - log/IF_NONE (exit) @ location: 26 - [ None - "def" - 3 - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - IF_NONE (entry) @ location: 27 - [ None - "def" - 3 - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - log/PUSH (exit) @ location: 27 - [ "def" - 3 - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - PUSH (entry) @ location: 29 - [ "def" - 3 - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - log/[halt] (exit) @ location: 29 - [ 0 - "def" - 3 - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - [halt] (entry) @ location: 33 - [ 0 - "def" - 3 - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - control: KCons - - log/SWAP (exit) @ location: 27 - [ 0 - "def" - 3 - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - SWAP (entry) @ location: 33 - [ 0 - "def" - 3 - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - log/DIP (exit) @ location: 33 - [ "def" - 0 - 3 - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - DIP (entry) @ location: 34 - [ "def" - 0 - 3 - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - log/ADD (exit) @ location: 34 - [ 0 - 3 - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - ADD (entry) @ location: 36 - [ 0 - 3 - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - log/SOME (exit) @ location: 36 - [ 3 - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - SOME (entry) @ location: 37 - [ 3 - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - log/[halt] (exit) @ location: 37 - [ (Some 3) - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - [halt] (entry) @ location: 35 - [ (Some 3) - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - control: KUndip - - control: KCons - - log/UPDATE (exit) @ location: 34 - [ "def" - (Some 3) - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - UPDATE (entry) @ location: 38 - [ "def" - (Some 3) - { Elt "123" 123 ; Elt "abc" 99 ; Elt "string" 12 } - Unit ] - - log/[halt] (exit) @ location: 38 - [ { Elt "123" 123 ; Elt "abc" 99 ; Elt "def" 3 ; Elt "string" 12 } - Unit ] - - [halt] (entry) @ location: 19 - [ { Elt "123" 123 ; Elt "abc" 99 ; Elt "def" 3 ; Elt "string" 12 } - Unit ] - - control: KIter - - control: KCons - - log/PAIR (exit) @ location: 19 - [ { Elt "123" 123 ; Elt "abc" 99 ; Elt "def" 3 ; Elt "string" 12 } - Unit ] - - PAIR (entry) @ location: 39 - [ { Elt "123" 123 ; Elt "abc" 99 ; Elt "def" 3 ; Elt "string" 12 } - Unit ] - - log/NIL (exit) @ location: 39 - [ (Pair { Elt "123" 123 ; Elt "abc" 99 ; Elt "def" 3 ; Elt "string" 12 } Unit) ] - - NIL (entry) @ location: 40 - [ (Pair { Elt "123" 123 ; Elt "abc" 99 ; Elt "def" 3 ; Elt "string" 12 } Unit) ] - - log/PAIR (exit) @ location: 40 - [ {} - (Pair { Elt "123" 123 ; Elt "abc" 99 ; Elt "def" 3 ; Elt "string" 12 } Unit) ] - - PAIR (entry) @ location: 42 - [ {} - (Pair { Elt "123" 123 ; Elt "abc" 99 ; Elt "def" 3 ; Elt "string" 12 } Unit) ] - - log/[halt] (exit) @ location: 42 - [ (Pair {} { Elt "123" 123 ; Elt "abc" 99 ; Elt "def" 3 ; Elt "string" 12 } Unit) ] - - [halt] (entry) @ location: 13 - [ (Pair {} { Elt "123" 123 ; Elt "abc" 99 ; Elt "def" 3 ; Elt "string" 12 } Unit) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/check_signature.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/check_signature.out deleted file mode 100644 index c817cebfc749224cd6a446e7ecb93e7462e75a61..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/check_signature.out +++ /dev/null @@ -1,230 +0,0 @@ - -trace - - DUP (interp) @ location: 9 - [ (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - DUP (entry) @ location: 9 - [ (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - log/DUP (exit) @ location: 9 - [ (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - DUP (entry) @ location: 10 - [ (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - log/DIP (exit) @ location: 10 - [ (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - DIP (entry) @ location: 11 - [ (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - log/CDR (exit) @ location: 11 - [ (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - CDR (entry) @ location: 13 - [ (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - log/DUP (exit) @ location: 13 - [ (Pair "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - DUP (entry) @ location: 14 - [ (Pair "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - log/CAR (exit) @ location: 14 - [ (Pair "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") - (Pair "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - CAR (entry) @ location: 15 - [ (Pair "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") - (Pair "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - log/DIP (exit) @ location: 15 - [ "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - (Pair "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - DIP (entry) @ location: 16 - [ "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - (Pair "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - log/CDR (exit) @ location: 16 - [ (Pair "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - CDR (entry) @ location: 18 - [ (Pair "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - log/PACK (exit) @ location: 18 - [ "TEZOS" - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - PACK (entry) @ location: 19 - [ "TEZOS" - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - log/[halt] (exit) @ location: 19 - [ 0x05010000000554455a4f53 - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - [halt] (entry) @ location: 17 - [ 0x05010000000554455a4f53 - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 16 - [ "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - 0x05010000000554455a4f53 - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - [halt] (entry) @ location: 12 - [ "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - 0x05010000000554455a4f53 - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - control: KUndip - - control: KCons - - log/CAR (exit) @ location: 11 - [ (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - 0x05010000000554455a4f53 - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - CAR (entry) @ location: 20 - [ (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - 0x05010000000554455a4f53 - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - log/CHECK_SIGNATURE (exit) @ location: 20 - [ "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - 0x05010000000554455a4f53 - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - CHECK_SIGNATURE (entry) @ location: 21 - [ "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - 0x05010000000554455a4f53 - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - log/IF (exit) @ location: 21 - [ True - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - IF (entry) @ location: 22 - [ True - (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - log/[halt] (exit) @ location: 22 - [ (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - [halt] (entry) @ location: 28 - [ (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - control: KCons - - log/CDR (exit) @ location: 22 - [ (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - CDR (entry) @ location: 28 - [ (Pair "[PUBLIC_KEY]" - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - log/NIL (exit) @ location: 28 - [ (Pair "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - NIL (entry) @ location: 29 - [ (Pair "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - log/PAIR (exit) @ location: 29 - [ {} - (Pair "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - PAIR (entry) @ location: 31 - [ {} - (Pair "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - log/[halt] (exit) @ location: 31 - [ (Pair {} - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - [halt] (entry) @ location: 8 - [ (Pair {} - "edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1" - "TEZOS") ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/comb-get.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/comb-get.out deleted file mode 100644 index 9bba705816e2af6f5d6b6c094e05d72e6c59bda4..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/comb-get.out +++ /dev/null @@ -1,234 +0,0 @@ - -trace - - CAR (interp) @ location: 11 - [ (Pair (Pair 1 4 2 Unit) Unit) ] - - CAR (entry) @ location: 11 - [ (Pair (Pair 1 4 2 Unit) Unit) ] - - log/DUP (exit) @ location: 11 - [ (Pair 1 4 2 Unit) ] - - DUP (entry) @ location: 12 - [ (Pair 1 4 2 Unit) ] - - log/CAR (exit) @ location: 12 - [ (Pair 1 4 2 Unit) - (Pair 1 4 2 Unit) ] - - CAR (entry) @ location: 13 - [ (Pair 1 4 2 Unit) - (Pair 1 4 2 Unit) ] - - log/PUSH (exit) @ location: 13 - [ 1 - (Pair 1 4 2 Unit) ] - - PUSH (entry) @ location: 14 - [ 1 - (Pair 1 4 2 Unit) ] - - log/COMPARE (exit) @ location: 14 - [ 1 - 1 - (Pair 1 4 2 Unit) ] - - COMPARE (entry) @ location: 19 - [ 1 - 1 - (Pair 1 4 2 Unit) ] - - log/EQ (exit) @ location: 19 - [ 0 - (Pair 1 4 2 Unit) ] - - EQ (entry) @ location: 20 - [ 0 - (Pair 1 4 2 Unit) ] - - log/IF (exit) @ location: 20 - [ True - (Pair 1 4 2 Unit) ] - - IF (entry) @ location: 21 - [ True - (Pair 1 4 2 Unit) ] - - log/[halt] (exit) @ location: 21 - [ (Pair 1 4 2 Unit) ] - - [halt] (entry) @ location: 27 - [ (Pair 1 4 2 Unit) ] - - control: KCons - - log/DUP (exit) @ location: 21 - [ (Pair 1 4 2 Unit) ] - - DUP (entry) @ location: 27 - [ (Pair 1 4 2 Unit) ] - - log/GET (exit) @ location: 27 - [ (Pair 1 4 2 Unit) - (Pair 1 4 2 Unit) ] - - GET (entry) @ location: 28 - [ (Pair 1 4 2 Unit) - (Pair 1 4 2 Unit) ] - - log/PUSH (exit) @ location: 28 - [ 1 - (Pair 1 4 2 Unit) ] - - PUSH (entry) @ location: 30 - [ 1 - (Pair 1 4 2 Unit) ] - - log/COMPARE (exit) @ location: 30 - [ 1 - 1 - (Pair 1 4 2 Unit) ] - - COMPARE (entry) @ location: 35 - [ 1 - 1 - (Pair 1 4 2 Unit) ] - - log/EQ (exit) @ location: 35 - [ 0 - (Pair 1 4 2 Unit) ] - - EQ (entry) @ location: 36 - [ 0 - (Pair 1 4 2 Unit) ] - - log/IF (exit) @ location: 36 - [ True - (Pair 1 4 2 Unit) ] - - IF (entry) @ location: 37 - [ True - (Pair 1 4 2 Unit) ] - - log/[halt] (exit) @ location: 37 - [ (Pair 1 4 2 Unit) ] - - [halt] (entry) @ location: 43 - [ (Pair 1 4 2 Unit) ] - - control: KCons - - log/DUP (exit) @ location: 37 - [ (Pair 1 4 2 Unit) ] - - DUP (entry) @ location: 43 - [ (Pair 1 4 2 Unit) ] - - log/GET (exit) @ location: 43 - [ (Pair 1 4 2 Unit) - (Pair 1 4 2 Unit) ] - - GET (entry) @ location: 44 - [ (Pair 1 4 2 Unit) - (Pair 1 4 2 Unit) ] - - log/PUSH (exit) @ location: 44 - [ 4 - (Pair 1 4 2 Unit) ] - - PUSH (entry) @ location: 46 - [ 4 - (Pair 1 4 2 Unit) ] - - log/COMPARE (exit) @ location: 46 - [ 4 - 4 - (Pair 1 4 2 Unit) ] - - COMPARE (entry) @ location: 51 - [ 4 - 4 - (Pair 1 4 2 Unit) ] - - log/EQ (exit) @ location: 51 - [ 0 - (Pair 1 4 2 Unit) ] - - EQ (entry) @ location: 52 - [ 0 - (Pair 1 4 2 Unit) ] - - log/IF (exit) @ location: 52 - [ True - (Pair 1 4 2 Unit) ] - - IF (entry) @ location: 53 - [ True - (Pair 1 4 2 Unit) ] - - log/[halt] (exit) @ location: 53 - [ (Pair 1 4 2 Unit) ] - - [halt] (entry) @ location: 59 - [ (Pair 1 4 2 Unit) ] - - control: KCons - - log/DUP (exit) @ location: 53 - [ (Pair 1 4 2 Unit) ] - - DUP (entry) @ location: 59 - [ (Pair 1 4 2 Unit) ] - - log/GET (exit) @ location: 59 - [ (Pair 1 4 2 Unit) - (Pair 1 4 2 Unit) ] - - GET (entry) @ location: 60 - [ (Pair 1 4 2 Unit) - (Pair 1 4 2 Unit) ] - - log/PUSH (exit) @ location: 60 - [ 2 - (Pair 1 4 2 Unit) ] - - PUSH (entry) @ location: 62 - [ 2 - (Pair 1 4 2 Unit) ] - - log/COMPARE (exit) @ location: 62 - [ 2 - 2 - (Pair 1 4 2 Unit) ] - - COMPARE (entry) @ location: 67 - [ 2 - 2 - (Pair 1 4 2 Unit) ] - - log/EQ (exit) @ location: 67 - [ 0 - (Pair 1 4 2 Unit) ] - - EQ (entry) @ location: 68 - [ 0 - (Pair 1 4 2 Unit) ] - - log/IF (exit) @ location: 68 - [ True - (Pair 1 4 2 Unit) ] - - IF (entry) @ location: 69 - [ True - (Pair 1 4 2 Unit) ] - - log/[halt] (exit) @ location: 69 - [ (Pair 1 4 2 Unit) ] - - [halt] (entry) @ location: 75 - [ (Pair 1 4 2 Unit) ] - - control: KCons - - log/DUP (exit) @ location: 69 - [ (Pair 1 4 2 Unit) ] - - DUP (entry) @ location: 75 - [ (Pair 1 4 2 Unit) ] - - log/GET (exit) @ location: 75 - [ (Pair 1 4 2 Unit) - (Pair 1 4 2 Unit) ] - - GET (entry) @ location: 76 - [ (Pair 1 4 2 Unit) - (Pair 1 4 2 Unit) ] - - log/PUSH (exit) @ location: 76 - [ Unit - (Pair 1 4 2 Unit) ] - - PUSH (entry) @ location: 78 - [ Unit - (Pair 1 4 2 Unit) ] - - log/COMPARE (exit) @ location: 78 - [ Unit - Unit - (Pair 1 4 2 Unit) ] - - COMPARE (entry) @ location: 81 - [ Unit - Unit - (Pair 1 4 2 Unit) ] - - log/EQ (exit) @ location: 81 - [ 0 - (Pair 1 4 2 Unit) ] - - EQ (entry) @ location: 82 - [ 0 - (Pair 1 4 2 Unit) ] - - log/IF (exit) @ location: 82 - [ True - (Pair 1 4 2 Unit) ] - - IF (entry) @ location: 83 - [ True - (Pair 1 4 2 Unit) ] - - log/[halt] (exit) @ location: 83 - [ (Pair 1 4 2 Unit) ] - - [halt] (entry) @ location: 89 - [ (Pair 1 4 2 Unit) ] - - control: KCons - - log/DROP (exit) @ location: 83 - [ (Pair 1 4 2 Unit) ] - - DROP (entry) @ location: 89 - [ (Pair 1 4 2 Unit) ] - - log/PUSH (exit) @ location: 89 - [ ] - - PUSH (entry) @ location: 90 - [ ] - - log/NIL (exit) @ location: 90 - [ Unit ] - - NIL (entry) @ location: 91 - [ Unit ] - - log/PAIR (exit) @ location: 91 - [ {} - Unit ] - - PAIR (entry) @ location: 93 - [ {} - Unit ] - - log/[halt] (exit) @ location: 93 - [ (Pair {} Unit) ] - - [halt] (entry) @ location: 10 - [ (Pair {} Unit) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/comb-set.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/comb-set.out deleted file mode 100644 index f9f1eab6ed02b654de14edbb75b2431a73b1b82a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/comb-set.out +++ /dev/null @@ -1,61 +0,0 @@ - -trace - - CDR (interp) @ location: 11 - [ (Pair Unit 1 4 2 Unit) ] - - CDR (entry) @ location: 11 - [ (Pair Unit 1 4 2 Unit) ] - - log/PUSH (exit) @ location: 11 - [ (Pair 1 4 2 Unit) ] - - PUSH (entry) @ location: 12 - [ (Pair 1 4 2 Unit) ] - - log/UPDATE (exit) @ location: 12 - [ 2 - (Pair 1 4 2 Unit) ] - - UPDATE (entry) @ location: 15 - [ 2 - (Pair 1 4 2 Unit) ] - - log/PUSH (exit) @ location: 15 - [ (Pair 2 4 2 Unit) ] - - PUSH (entry) @ location: 17 - [ (Pair 2 4 2 Unit) ] - - log/UPDATE (exit) @ location: 17 - [ 12 - (Pair 2 4 2 Unit) ] - - UPDATE (entry) @ location: 20 - [ 12 - (Pair 2 4 2 Unit) ] - - log/PUSH (exit) @ location: 20 - [ (Pair 2 12 2 Unit) ] - - PUSH (entry) @ location: 22 - [ (Pair 2 12 2 Unit) ] - - log/UPDATE (exit) @ location: 22 - [ 8 - (Pair 2 12 2 Unit) ] - - UPDATE (entry) @ location: 25 - [ 8 - (Pair 2 12 2 Unit) ] - - log/PUSH (exit) @ location: 25 - [ (Pair 2 12 8 Unit) ] - - PUSH (entry) @ location: 27 - [ (Pair 2 12 8 Unit) ] - - log/UPDATE (exit) @ location: 27 - [ Unit - (Pair 2 12 8 Unit) ] - - UPDATE (entry) @ location: 28 - [ Unit - (Pair 2 12 8 Unit) ] - - log/NIL (exit) @ location: 28 - [ (Pair 2 12 8 Unit) ] - - NIL (entry) @ location: 30 - [ (Pair 2 12 8 Unit) ] - - log/PAIR (exit) @ location: 30 - [ {} - (Pair 2 12 8 Unit) ] - - PAIR (entry) @ location: 32 - [ {} - (Pair 2 12 8 Unit) ] - - log/[halt] (exit) @ location: 32 - [ (Pair {} 2 12 8 Unit) ] - - [halt] (entry) @ location: 10 - [ (Pair {} 2 12 8 Unit) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/concat.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/concat.out deleted file mode 100644 index 27c3dbb0623790e7875d5679a459d48b53526a3d..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/concat.out +++ /dev/null @@ -1,69 +0,0 @@ - -trace - - DUP (interp) @ location: 7 - [ (Pair "abcd" "efgh") ] - - DUP (entry) @ location: 7 - [ (Pair "abcd" "efgh") ] - - log/DIP (exit) @ location: 7 - [ (Pair "abcd" "efgh") - (Pair "abcd" "efgh") ] - - DIP (entry) @ location: 8 - [ (Pair "abcd" "efgh") - (Pair "abcd" "efgh") ] - - log/CDR (exit) @ location: 8 - [ (Pair "abcd" "efgh") ] - - CDR (entry) @ location: 10 - [ (Pair "abcd" "efgh") ] - - log/NIL (exit) @ location: 10 - [ "efgh" ] - - NIL (entry) @ location: 11 - [ "efgh" ] - - log/SWAP (exit) @ location: 11 - [ {} - "efgh" ] - - SWAP (entry) @ location: 13 - [ {} - "efgh" ] - - log/CONS (exit) @ location: 13 - [ "efgh" - {} ] - - CONS (entry) @ location: 14 - [ "efgh" - {} ] - - log/[halt] (exit) @ location: 14 - [ { "efgh" } ] - - [halt] (entry) @ location: 9 - [ { "efgh" } ] - - control: KUndip - - control: KCons - - log/CAR (exit) @ location: 8 - [ (Pair "abcd" "efgh") - { "efgh" } ] - - CAR (entry) @ location: 15 - [ (Pair "abcd" "efgh") - { "efgh" } ] - - log/CONS (exit) @ location: 15 - [ "abcd" - { "efgh" } ] - - CONS (entry) @ location: 16 - [ "abcd" - { "efgh" } ] - - log/CONCAT (exit) @ location: 16 - [ { "abcd" ; "efgh" } ] - - CONCAT (entry) @ location: 17 - [ { "abcd" ; "efgh" } ] - - log/NIL (exit) @ location: 17 - [ "abcdefgh" ] - - NIL (entry) @ location: 18 - [ "abcdefgh" ] - - log/PAIR (exit) @ location: 18 - [ {} - "abcdefgh" ] - - PAIR (entry) @ location: 20 - [ {} - "abcdefgh" ] - - log/[halt] (exit) @ location: 20 - [ (Pair {} "abcdefgh") ] - - [halt] (entry) @ location: 6 - [ (Pair {} "abcdefgh") ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/conditionals.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/conditionals.out deleted file mode 100644 index cdf6a97298a5ee569ea4b79492c3a731f95c339c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/conditionals.out +++ /dev/null @@ -1,66 +0,0 @@ - -trace - - CAR (interp) @ location: 10 - [ (Pair (Right (Some 23)) "") ] - - CAR (entry) @ location: 10 - [ (Pair (Right (Some 23)) "") ] - - log/IF_LEFT (exit) @ location: 10 - [ (Right (Some 23)) ] - - IF_LEFT (entry) @ location: 11 - [ (Right (Some 23)) ] - - log/IF_NONE (exit) @ location: 11 - [ (Some 23) ] - - IF_NONE (entry) @ location: 14 - [ (Some 23) ] - - log/PUSH (exit) @ location: 14 - [ 23 ] - - PUSH (entry) @ location: 20 - [ 23 ] - - log/COMPARE (exit) @ location: 20 - [ 0 - 23 ] - - COMPARE (entry) @ location: 24 - [ 0 - 23 ] - - log/GT (exit) @ location: 24 - [ -1 ] - - GT (entry) @ location: 25 - [ -1 ] - - log/IF (exit) @ location: 25 - [ False ] - - IF (entry) @ location: 26 - [ False ] - - log/PUSH (exit) @ location: 26 - [ ] - - PUSH (entry) @ location: 32 - [ ] - - log/[halt] (exit) @ location: 32 - [ "" ] - - [halt] (entry) @ location: 35 - [ "" ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ "" ] - - [halt] (entry) @ location: 35 - [ "" ] - - control: KCons - - log/[halt] (exit) @ location: 14 - [ "" ] - - [halt] (entry) @ location: 35 - [ "" ] - - control: KCons - - log/NIL (exit) @ location: 11 - [ "" ] - - NIL (entry) @ location: 35 - [ "" ] - - log/PAIR (exit) @ location: 35 - [ {} - "" ] - - PAIR (entry) @ location: 37 - [ {} - "" ] - - log/[halt] (exit) @ location: 37 - [ (Pair {} "") ] - - [halt] (entry) @ location: 9 - [ (Pair {} "") ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/cps_fact.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/cps_fact.out deleted file mode 100644 index aba8d782b45726aab0faa2cbe86fd8f4ae7e3b89..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/cps_fact.out +++ /dev/null @@ -1,276 +0,0 @@ - -trace - - UNPAIR (interp) @ location: 7 - [ (Pair 2 60) ] - - UNPAIR (entry) @ location: 7 - [ (Pair 2 60) ] - - log/DIP (exit) @ location: 7 - [ 2 - 60 ] - - DIP (entry) @ location: 8 - [ 2 - 60 ] - - log/SELF (exit) @ location: 8 - [ 60 ] - - SELF (entry) @ location: 10 - [ 60 ] - - log/ADDRESS (exit) @ location: 10 - [ "[CONTRACT_HASH]" - 60 ] - - ADDRESS (entry) @ location: 11 - [ "[CONTRACT_HASH]" - 60 ] - - log/SENDER (exit) @ location: 11 - [ "[CONTRACT_HASH]" - 60 ] - - SENDER (entry) @ location: 12 - [ "[CONTRACT_HASH]" - 60 ] - - log/COMPARE (exit) @ location: 12 - [ "[PUBLIC_KEY_HASH]" - "[CONTRACT_HASH]" - 60 ] - - COMPARE (entry) @ location: 14 - [ "[PUBLIC_KEY_HASH]" - "[CONTRACT_HASH]" - 60 ] - - log/EQ (exit) @ location: 14 - [ -1 - 60 ] - - EQ (entry) @ location: 15 - [ -1 - 60 ] - - log/IF (exit) @ location: 15 - [ False - 60 ] - - IF (entry) @ location: 16 - [ False - 60 ] - - log/DROP (exit) @ location: 16 - [ 60 ] - - DROP (entry) @ location: 19 - [ 60 ] - - log/PUSH (exit) @ location: 19 - [ ] - - PUSH (entry) @ location: 20 - [ ] - - log/[halt] (exit) @ location: 20 - [ 1 ] - - [halt] (entry) @ location: 9 - [ 1 ] - - control: KCons - - log/[halt] (exit) @ location: 16 - [ 1 ] - - [halt] (entry) @ location: 9 - [ 1 ] - - control: KUndip - - control: KCons - - log/DUP (exit) @ location: 8 - [ 2 - 1 ] - - DUP (entry) @ location: 23 - [ 2 - 1 ] - - log/PUSH (exit) @ location: 23 - [ 2 - 2 - 1 ] - - PUSH (entry) @ location: 24 - [ 2 - 2 - 1 ] - - log/COMPARE (exit) @ location: 24 - [ 1 - 2 - 2 - 1 ] - - COMPARE (entry) @ location: 28 - [ 1 - 2 - 2 - 1 ] - - log/GE (exit) @ location: 28 - [ -1 - 2 - 1 ] - - GE (entry) @ location: 29 - [ -1 - 2 - 1 ] - - log/IF (exit) @ location: 29 - [ False - 2 - 1 ] - - IF (entry) @ location: 30 - [ False - 2 - 1 ] - - log/PUSH (exit) @ location: 30 - [ 2 - 1 ] - - PUSH (entry) @ location: 37 - [ 2 - 1 ] - - log/SWAP (exit) @ location: 37 - [ 1 - 2 - 1 ] - - SWAP (entry) @ location: 40 - [ 1 - 2 - 1 ] - - log/SUB (exit) @ location: 40 - [ 2 - 1 - 1 ] - - SUB (entry) @ location: 41 - [ 2 - 1 - 1 ] - - log/ISNAT (exit) @ location: 41 - [ 1 - 1 ] - - ISNAT (entry) @ location: 42 - [ 1 - 1 ] - - log/IF_NONE (exit) @ location: 42 - [ (Some 1) - 1 ] - - IF_NONE (entry) @ location: 43 - [ (Some 1) - 1 ] - - log/DUP (exit) @ location: 43 - [ 1 - 1 ] - - DUP (entry) @ location: 49 - [ 1 - 1 ] - - log/DIP (exit) @ location: 49 - [ 1 - 1 - 1 ] - - DIP (entry) @ location: 50 - [ 1 - 1 - 1 ] - - log/PUSH (exit) @ location: 50 - [ 1 - 1 ] - - PUSH (entry) @ location: 52 - [ 1 - 1 ] - - log/ADD (exit) @ location: 52 - [ 1 - 1 - 1 ] - - ADD (entry) @ location: 55 - [ 1 - 1 - 1 ] - - log/MUL (exit) @ location: 55 - [ 2 - 1 ] - - MUL (entry) @ location: 56 - [ 2 - 1 ] - - log/[halt] (exit) @ location: 56 - [ 2 ] - - [halt] (entry) @ location: 51 - [ 2 ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 50 - [ 1 - 2 ] - - SWAP (entry) @ location: 57 - [ 1 - 2 ] - - log/DIP (exit) @ location: 57 - [ 2 - 1 ] - - DIP (entry) @ location: 58 - [ 2 - 1 ] - - log/DIP (exit) @ location: 58 - [ 1 ] - - DIP (entry) @ location: 60 - [ 1 ] - - log/SELF (exit) @ location: 60 - [ ] - - SELF (entry) @ location: 62 - [ ] - - log/PUSH (exit) @ location: 62 - [ "[CONTRACT_HASH]" ] - - PUSH (entry) @ location: 63 - [ "[CONTRACT_HASH]" ] - - log/[halt] (exit) @ location: 63 - [ 0 - "[CONTRACT_HASH]" ] - - [halt] (entry) @ location: 61 - [ 0 - "[CONTRACT_HASH]" ] - - control: KUndip - - control: KCons - - log/TRANSFER_TOKENS (exit) @ location: 60 - [ 1 - 0 - "[CONTRACT_HASH]" ] - - TRANSFER_TOKENS (entry) @ location: 66 - [ 1 - 0 - "[CONTRACT_HASH]" ] - - log/NIL (exit) @ location: 66 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000100014828e9aa0b3e6e970da0515b5c5d8ccf5028758900ff00000000020001 ] - - NIL (entry) @ location: 67 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000100014828e9aa0b3e6e970da0515b5c5d8ccf5028758900ff00000000020001 ] - - log/SWAP (exit) @ location: 67 - [ {} - 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000100014828e9aa0b3e6e970da0515b5c5d8ccf5028758900ff00000000020001 ] - - SWAP (entry) @ location: 69 - [ {} - 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000100014828e9aa0b3e6e970da0515b5c5d8ccf5028758900ff00000000020001 ] - - log/CONS (exit) @ location: 69 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000100014828e9aa0b3e6e970da0515b5c5d8ccf5028758900ff00000000020001 - {} ] - - CONS (entry) @ location: 70 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000100014828e9aa0b3e6e970da0515b5c5d8ccf5028758900ff00000000020001 - {} ] - - log/[halt] (exit) @ location: 70 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000100014828e9aa0b3e6e970da0515b5c5d8ccf5028758900ff00000000020001 } ] - - [halt] (entry) @ location: 59 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000100014828e9aa0b3e6e970da0515b5c5d8ccf5028758900ff00000000020001 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 58 - [ 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000100014828e9aa0b3e6e970da0515b5c5d8ccf5028758900ff00000000020001 } ] - - SWAP (entry) @ location: 71 - [ 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000100014828e9aa0b3e6e970da0515b5c5d8ccf5028758900ff00000000020001 } ] - - log/PAIR (exit) @ location: 71 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000100014828e9aa0b3e6e970da0515b5c5d8ccf5028758900ff00000000020001 } - 2 ] - - PAIR (entry) @ location: 72 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000100014828e9aa0b3e6e970da0515b5c5d8ccf5028758900ff00000000020001 } - 2 ] - - log/[halt] (exit) @ location: 72 - [ (Pair { 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000100014828e9aa0b3e6e970da0515b5c5d8ccf5028758900ff00000000020001 } - 2) ] - - [halt] (entry) @ location: 6 - [ (Pair { 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000100014828e9aa0b3e6e970da0515b5c5d8ccf5028758900ff00000000020001 } - 2) ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ (Pair { 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000100014828e9aa0b3e6e970da0515b5c5d8ccf5028758900ff00000000020001 } - 2) ] - - [halt] (entry) @ location: 6 - [ (Pair { 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000100014828e9aa0b3e6e970da0515b5c5d8ccf5028758900ff00000000020001 } - 2) ] - - control: KCons - - log/[halt] (exit) @ location: 30 - [ (Pair { 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000100014828e9aa0b3e6e970da0515b5c5d8ccf5028758900ff00000000020001 } - 2) ] - - [halt] (entry) @ location: 6 - [ (Pair { 0x014828e9aa0b3e6e970da0515b5c5d8ccf502875890000000100014828e9aa0b3e6e970da0515b5c5d8ccf5028758900ff00000000020001 } - 2) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/dign.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/dign.out deleted file mode 100644 index 298723394bff8fd24ed9e28062590e1a23c2f082..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/dign.out +++ /dev/null @@ -1,107 +0,0 @@ - -trace - - CAR (interp) @ location: 15 - [ (Pair (Pair (Pair (Pair (Pair 0 1) 2) 3) 4) 7) ] - - CAR (entry) @ location: 15 - [ (Pair (Pair (Pair (Pair (Pair 0 1) 2) 3) 4) 7) ] - - log/UNPAIR (exit) @ location: 15 - [ (Pair (Pair (Pair (Pair 0 1) 2) 3) 4) ] - - UNPAIR (entry) @ location: 16 - [ (Pair (Pair (Pair (Pair 0 1) 2) 3) 4) ] - - log/UNPAIR (exit) @ location: 16 - [ (Pair (Pair (Pair 0 1) 2) 3) - 4 ] - - UNPAIR (entry) @ location: 17 - [ (Pair (Pair (Pair 0 1) 2) 3) - 4 ] - - log/UNPAIR (exit) @ location: 17 - [ (Pair (Pair 0 1) 2) - 3 - 4 ] - - UNPAIR (entry) @ location: 18 - [ (Pair (Pair 0 1) 2) - 3 - 4 ] - - log/UNPAIR (exit) @ location: 18 - [ (Pair 0 1) - 2 - 3 - 4 ] - - UNPAIR (entry) @ location: 19 - [ (Pair 0 1) - 2 - 3 - 4 ] - - log/DIG (exit) @ location: 19 - [ 0 - 1 - 2 - 3 - 4 ] - - DIG (entry) @ location: 20 - [ 0 - 1 - 2 - 3 - 4 ] - - log/DIP (exit) @ location: 20 - [ 4 - 0 - 1 - 2 - 3 ] - - DIP (entry) @ location: 22 - [ 4 - 0 - 1 - 2 - 3 ] - - log/DROP (exit) @ location: 22 - [ 0 - 1 - 2 - 3 ] - - DROP (entry) @ location: 24 - [ 0 - 1 - 2 - 3 ] - - log/DROP (exit) @ location: 24 - [ 1 - 2 - 3 ] - - DROP (entry) @ location: 25 - [ 1 - 2 - 3 ] - - log/DROP (exit) @ location: 25 - [ 2 - 3 ] - - DROP (entry) @ location: 26 - [ 2 - 3 ] - - log/DROP (exit) @ location: 26 - [ 3 ] - - DROP (entry) @ location: 27 - [ 3 ] - - log/[halt] (exit) @ location: 27 - [ ] - - [halt] (entry) @ location: 23 - [ ] - - control: KUndip - - control: KCons - - log/NIL (exit) @ location: 22 - [ 4 ] - - NIL (entry) @ location: 28 - [ 4 ] - - log/PAIR (exit) @ location: 28 - [ {} - 4 ] - - PAIR (entry) @ location: 30 - [ {} - 4 ] - - log/[halt] (exit) @ location: 30 - [ (Pair {} 4) ] - - [halt] (entry) @ location: 14 - [ (Pair {} 4) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/dipn.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/dipn.out deleted file mode 100644 index 45246f777c924f99c285a2af0349dbd3bdf1e7e0..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/dipn.out +++ /dev/null @@ -1,165 +0,0 @@ - -trace - - CAR (interp) @ location: 15 - [ (Pair (Pair (Pair (Pair (Pair 0 1) 2) 3) 4) 7) ] - - CAR (entry) @ location: 15 - [ (Pair (Pair (Pair (Pair (Pair 0 1) 2) 3) 4) 7) ] - - log/UNPAIR (exit) @ location: 15 - [ (Pair (Pair (Pair (Pair 0 1) 2) 3) 4) ] - - UNPAIR (entry) @ location: 16 - [ (Pair (Pair (Pair (Pair 0 1) 2) 3) 4) ] - - log/UNPAIR (exit) @ location: 16 - [ (Pair (Pair (Pair 0 1) 2) 3) - 4 ] - - UNPAIR (entry) @ location: 17 - [ (Pair (Pair (Pair 0 1) 2) 3) - 4 ] - - log/UNPAIR (exit) @ location: 17 - [ (Pair (Pair 0 1) 2) - 3 - 4 ] - - UNPAIR (entry) @ location: 18 - [ (Pair (Pair 0 1) 2) - 3 - 4 ] - - log/UNPAIR (exit) @ location: 18 - [ (Pair 0 1) - 2 - 3 - 4 ] - - UNPAIR (entry) @ location: 19 - [ (Pair 0 1) - 2 - 3 - 4 ] - - log/DIP (exit) @ location: 19 - [ 0 - 1 - 2 - 3 - 4 ] - - DIP (entry) @ location: 20 - [ 0 - 1 - 2 - 3 - 4 ] - - log/PUSH (exit) @ location: 20 - [ ] - - PUSH (entry) @ location: 23 - [ ] - - log/[halt] (exit) @ location: 23 - [ 6 ] - - [halt] (entry) @ location: 23 - [ 6 ] - - control: KCons - - PUSH (entry) @ location: 20 - [ 6 ] - - log/PUSH (exit) @ location: 20 - [ 4 - 6 ] - - PUSH (entry) @ location: 20 - [ 4 - 6 ] - - log/PUSH (exit) @ location: 20 - [ 3 - 4 - 6 ] - - PUSH (entry) @ location: 20 - [ 3 - 4 - 6 ] - - log/PUSH (exit) @ location: 20 - [ 2 - 3 - 4 - 6 ] - - PUSH (entry) @ location: 20 - [ 2 - 3 - 4 - 6 ] - - log/PUSH (exit) @ location: 20 - [ 1 - 2 - 3 - 4 - 6 ] - - PUSH (entry) @ location: 20 - [ 1 - 2 - 3 - 4 - 6 ] - - log/log/log/DROP (exit) @ location: 20 - [ 0 - 1 - 2 - 3 - 4 - 6 ] - - log/DROP (exit) @ location: 20 - [ 0 - 1 - 2 - 3 - 4 - 6 ] - - DROP (entry) @ location: 26 - [ 0 - 1 - 2 - 3 - 4 - 6 ] - - log/DROP (exit) @ location: 26 - [ 1 - 2 - 3 - 4 - 6 ] - - DROP (entry) @ location: 27 - [ 1 - 2 - 3 - 4 - 6 ] - - log/DROP (exit) @ location: 27 - [ 2 - 3 - 4 - 6 ] - - DROP (entry) @ location: 28 - [ 2 - 3 - 4 - 6 ] - - log/DROP (exit) @ location: 28 - [ 3 - 4 - 6 ] - - DROP (entry) @ location: 29 - [ 3 - 4 - 6 ] - - log/DROP (exit) @ location: 29 - [ 4 - 6 ] - - DROP (entry) @ location: 30 - [ 4 - 6 ] - - log/NIL (exit) @ location: 30 - [ 6 ] - - NIL (entry) @ location: 31 - [ 6 ] - - log/PAIR (exit) @ location: 31 - [ {} - 6 ] - - PAIR (entry) @ location: 33 - [ {} - 6 ] - - log/[halt] (exit) @ location: 33 - [ (Pair {} 6) ] - - [halt] (entry) @ location: 14 - [ (Pair {} 6) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/dugn.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/dugn.out deleted file mode 100644 index b782243a82af2108f815121a3b42bd81b1828afc..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/dugn.out +++ /dev/null @@ -1,97 +0,0 @@ - -trace - - CAR (interp) @ location: 15 - [ (Pair (Pair (Pair (Pair (Pair 0 1) 2) 3) 4) 7) ] - - CAR (entry) @ location: 15 - [ (Pair (Pair (Pair (Pair (Pair 0 1) 2) 3) 4) 7) ] - - log/UNPAIR (exit) @ location: 15 - [ (Pair (Pair (Pair (Pair 0 1) 2) 3) 4) ] - - UNPAIR (entry) @ location: 16 - [ (Pair (Pair (Pair (Pair 0 1) 2) 3) 4) ] - - log/UNPAIR (exit) @ location: 16 - [ (Pair (Pair (Pair 0 1) 2) 3) - 4 ] - - UNPAIR (entry) @ location: 17 - [ (Pair (Pair (Pair 0 1) 2) 3) - 4 ] - - log/UNPAIR (exit) @ location: 17 - [ (Pair (Pair 0 1) 2) - 3 - 4 ] - - UNPAIR (entry) @ location: 18 - [ (Pair (Pair 0 1) 2) - 3 - 4 ] - - log/UNPAIR (exit) @ location: 18 - [ (Pair 0 1) - 2 - 3 - 4 ] - - UNPAIR (entry) @ location: 19 - [ (Pair 0 1) - 2 - 3 - 4 ] - - log/DUG (exit) @ location: 19 - [ 0 - 1 - 2 - 3 - 4 ] - - DUG (entry) @ location: 20 - [ 0 - 1 - 2 - 3 - 4 ] - - log/DROP (exit) @ location: 20 - [ 1 - 2 - 3 - 4 - 0 ] - - DROP (entry) @ location: 22 - [ 1 - 2 - 3 - 4 - 0 ] - - log/DROP (exit) @ location: 22 - [ 2 - 3 - 4 - 0 ] - - DROP (entry) @ location: 23 - [ 2 - 3 - 4 - 0 ] - - log/DROP (exit) @ location: 23 - [ 3 - 4 - 0 ] - - DROP (entry) @ location: 24 - [ 3 - 4 - 0 ] - - log/DROP (exit) @ location: 24 - [ 4 - 0 ] - - DROP (entry) @ location: 25 - [ 4 - 0 ] - - log/NIL (exit) @ location: 25 - [ 0 ] - - NIL (entry) @ location: 26 - [ 0 ] - - log/PAIR (exit) @ location: 26 - [ {} - 0 ] - - PAIR (entry) @ location: 28 - [ {} - 0 ] - - log/[halt] (exit) @ location: 28 - [ (Pair {} 0) ] - - [halt] (entry) @ location: 14 - [ (Pair {} 0) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/ediv.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/ediv.out deleted file mode 100644 index a951089c45cafa2761eb7f76c146d1b598285174..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/ediv.out +++ /dev/null @@ -1,272 +0,0 @@ - -trace - - CAR (interp) @ location: 25 - [ (Pair (Pair 127 11) None None None None) ] - - CAR (entry) @ location: 25 - [ (Pair (Pair 127 11) None None None None) ] - - log/DUP (exit) @ location: 25 - [ (Pair 127 11) ] - - DUP (entry) @ location: 26 - [ (Pair 127 11) ] - - log/UNPAIR (exit) @ location: 26 - [ (Pair 127 11) - (Pair 127 11) ] - - UNPAIR (entry) @ location: 27 - [ (Pair 127 11) - (Pair 127 11) ] - - log/ABS (exit) @ location: 27 - [ 127 - 11 - (Pair 127 11) ] - - ABS (entry) @ location: 28 - [ 127 - 11 - (Pair 127 11) ] - - log/DIP (exit) @ location: 28 - [ 127 - 11 - (Pair 127 11) ] - - DIP (entry) @ location: 29 - [ 127 - 11 - (Pair 127 11) ] - - log/ABS (exit) @ location: 29 - [ 11 - (Pair 127 11) ] - - ABS (entry) @ location: 31 - [ 11 - (Pair 127 11) ] - - log/[halt] (exit) @ location: 31 - [ 11 - (Pair 127 11) ] - - [halt] (entry) @ location: 31 - [ 11 - (Pair 127 11) ] - - control: KUndip - - control: KCons - - log/EDIV (exit) @ location: 29 - [ 127 - 11 - (Pair 127 11) ] - - EDIV (entry) @ location: 32 - [ 127 - 11 - (Pair 127 11) ] - - log/SWAP (exit) @ location: 32 - [ (Some (Pair 11 6)) - (Pair 127 11) ] - - SWAP (entry) @ location: 33 - [ (Some (Pair 11 6)) - (Pair 127 11) ] - - log/DUP (exit) @ location: 33 - [ (Pair 127 11) - (Some (Pair 11 6)) ] - - DUP (entry) @ location: 34 - [ (Pair 127 11) - (Some (Pair 11 6)) ] - - log/UNPAIR (exit) @ location: 34 - [ (Pair 127 11) - (Pair 127 11) - (Some (Pair 11 6)) ] - - UNPAIR (entry) @ location: 35 - [ (Pair 127 11) - (Pair 127 11) - (Some (Pair 11 6)) ] - - log/ABS (exit) @ location: 35 - [ 127 - 11 - (Pair 127 11) - (Some (Pair 11 6)) ] - - ABS (entry) @ location: 36 - [ 127 - 11 - (Pair 127 11) - (Some (Pair 11 6)) ] - - log/EDIV (exit) @ location: 36 - [ 127 - 11 - (Pair 127 11) - (Some (Pair 11 6)) ] - - EDIV (entry) @ location: 37 - [ 127 - 11 - (Pair 127 11) - (Some (Pair 11 6)) ] - - log/SWAP (exit) @ location: 37 - [ (Some (Pair 11 6)) - (Pair 127 11) - (Some (Pair 11 6)) ] - - SWAP (entry) @ location: 38 - [ (Some (Pair 11 6)) - (Pair 127 11) - (Some (Pair 11 6)) ] - - log/DUP (exit) @ location: 38 - [ (Pair 127 11) - (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - DUP (entry) @ location: 39 - [ (Pair 127 11) - (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - log/UNPAIR (exit) @ location: 39 - [ (Pair 127 11) - (Pair 127 11) - (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - UNPAIR (entry) @ location: 40 - [ (Pair 127 11) - (Pair 127 11) - (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - log/DIP (exit) @ location: 40 - [ 127 - 11 - (Pair 127 11) - (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - DIP (entry) @ location: 41 - [ 127 - 11 - (Pair 127 11) - (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - log/ABS (exit) @ location: 41 - [ 11 - (Pair 127 11) - (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - ABS (entry) @ location: 43 - [ 11 - (Pair 127 11) - (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - log/[halt] (exit) @ location: 43 - [ 11 - (Pair 127 11) - (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - [halt] (entry) @ location: 43 - [ 11 - (Pair 127 11) - (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - control: KUndip - - control: KCons - - log/EDIV (exit) @ location: 41 - [ 127 - 11 - (Pair 127 11) - (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - EDIV (entry) @ location: 44 - [ 127 - 11 - (Pair 127 11) - (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - log/SWAP (exit) @ location: 44 - [ (Some (Pair 11 6)) - (Pair 127 11) - (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - SWAP (entry) @ location: 45 - [ (Some (Pair 11 6)) - (Pair 127 11) - (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - log/UNPAIR (exit) @ location: 45 - [ (Pair 127 11) - (Some (Pair 11 6)) - (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - UNPAIR (entry) @ location: 46 - [ (Pair 127 11) - (Some (Pair 11 6)) - (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - log/EDIV (exit) @ location: 46 - [ 127 - 11 - (Some (Pair 11 6)) - (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - EDIV (entry) @ location: 47 - [ 127 - 11 - (Some (Pair 11 6)) - (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - log/DIP (exit) @ location: 47 - [ (Some (Pair 11 6)) - (Some (Pair 11 6)) - (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - DIP (entry) @ location: 49 - [ (Some (Pair 11 6)) - (Some (Pair 11 6)) - (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - log/PAIR (exit) @ location: 49 - [ (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - PAIR (entry) @ location: 52 - [ (Some (Pair 11 6)) - (Some (Pair 11 6)) ] - - log/[halt] (exit) @ location: 52 - [ (Pair (Some (Pair 11 6)) (Some (Pair 11 6))) ] - - [halt] (entry) @ location: 52 - [ (Pair (Some (Pair 11 6)) (Some (Pair 11 6))) ] - - control: KCons - - PUSH (entry) @ location: 49 - [ (Pair (Some (Pair 11 6)) (Some (Pair 11 6))) ] - - log/PUSH (exit) @ location: 49 - [ (Some (Pair 11 6)) - (Pair (Some (Pair 11 6)) (Some (Pair 11 6))) ] - - PUSH (entry) @ location: 49 - [ (Some (Pair 11 6)) - (Pair (Some (Pair 11 6)) (Some (Pair 11 6))) ] - - log/log/log/DIP (exit) @ location: 49 - [ (Some (Pair 11 6)) - (Some (Pair 11 6)) - (Pair (Some (Pair 11 6)) (Some (Pair 11 6))) ] - - log/DIP (exit) @ location: 49 - [ (Some (Pair 11 6)) - (Some (Pair 11 6)) - (Pair (Some (Pair 11 6)) (Some (Pair 11 6))) ] - - DIP (entry) @ location: 53 - [ (Some (Pair 11 6)) - (Some (Pair 11 6)) - (Pair (Some (Pair 11 6)) (Some (Pair 11 6))) ] - - log/PAIR (exit) @ location: 53 - [ (Some (Pair 11 6)) - (Pair (Some (Pair 11 6)) (Some (Pair 11 6))) ] - - PAIR (entry) @ location: 55 - [ (Some (Pair 11 6)) - (Pair (Some (Pair 11 6)) (Some (Pair 11 6))) ] - - log/[halt] (exit) @ location: 55 - [ (Pair (Some (Pair 11 6)) (Some (Pair 11 6)) (Some (Pair 11 6))) ] - - [halt] (entry) @ location: 55 - [ (Pair (Some (Pair 11 6)) (Some (Pair 11 6)) (Some (Pair 11 6))) ] - - control: KUndip - - control: KCons - - log/PAIR (exit) @ location: 53 - [ (Some (Pair 11 6)) - (Pair (Some (Pair 11 6)) (Some (Pair 11 6)) (Some (Pair 11 6))) ] - - PAIR (entry) @ location: 56 - [ (Some (Pair 11 6)) - (Pair (Some (Pair 11 6)) (Some (Pair 11 6)) (Some (Pair 11 6))) ] - - log/NIL (exit) @ location: 56 - [ (Pair (Some (Pair 11 6)) (Some (Pair 11 6)) (Some (Pair 11 6)) (Some (Pair 11 6))) ] - - NIL (entry) @ location: 57 - [ (Pair (Some (Pair 11 6)) (Some (Pair 11 6)) (Some (Pair 11 6)) (Some (Pair 11 6))) ] - - log/PAIR (exit) @ location: 57 - [ {} - (Pair (Some (Pair 11 6)) (Some (Pair 11 6)) (Some (Pair 11 6)) (Some (Pair 11 6))) ] - - PAIR (entry) @ location: 59 - [ {} - (Pair (Some (Pair 11 6)) (Some (Pair 11 6)) (Some (Pair 11 6)) (Some (Pair 11 6))) ] - - log/[halt] (exit) @ location: 59 - [ (Pair {} (Some (Pair 11 6)) (Some (Pair 11 6)) (Some (Pair 11 6)) (Some (Pair 11 6))) ] - - [halt] (entry) @ location: 24 - [ (Pair {} (Some (Pair 11 6)) (Some (Pair 11 6)) (Some (Pair 11 6)) (Some (Pair 11 6))) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/faucet.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/faucet.out deleted file mode 100644 index 702128601876b1f05d88efd064424e2591df2835..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/faucet.out +++ /dev/null @@ -1,122 +0,0 @@ - -trace - - UNPAIR (interp) @ location: 7 - [ (Pair "[PUBLIC_KEY_HASH]" "[TIMESTAMP]") ] - - UNPAIR (entry) @ location: 7 - [ (Pair "[PUBLIC_KEY_HASH]" "[TIMESTAMP]") ] - - log/SWAP (exit) @ location: 7 - [ "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" ] - - SWAP (entry) @ location: 8 - [ "[PUBLIC_KEY_HASH]" - "[TIMESTAMP]" ] - - log/PUSH (exit) @ location: 8 - [ "[TIMESTAMP]" - "[PUBLIC_KEY_HASH]" ] - - PUSH (entry) @ location: 9 - [ "[TIMESTAMP]" - "[PUBLIC_KEY_HASH]" ] - - log/ADD (exit) @ location: 9 - [ 300 - "[TIMESTAMP]" - "[PUBLIC_KEY_HASH]" ] - - ADD (entry) @ location: 12 - [ 300 - "[TIMESTAMP]" - "[PUBLIC_KEY_HASH]" ] - - log/NOW (exit) @ location: 12 - [ "[TIMESTAMP]" - "[PUBLIC_KEY_HASH]" ] - - NOW (entry) @ location: 13 - [ "[TIMESTAMP]" - "[PUBLIC_KEY_HASH]" ] - - log/COMPARE (exit) @ location: 13 - [ "[TIMESTAMP]" - "[TIMESTAMP]" - "[PUBLIC_KEY_HASH]" ] - - COMPARE (entry) @ location: 16 - [ "[TIMESTAMP]" - "[TIMESTAMP]" - "[PUBLIC_KEY_HASH]" ] - - log/GE (exit) @ location: 16 - [ 1 - "[PUBLIC_KEY_HASH]" ] - - GE (entry) @ location: 17 - [ 1 - "[PUBLIC_KEY_HASH]" ] - - log/IF (exit) @ location: 17 - [ True - "[PUBLIC_KEY_HASH]" ] - - IF (entry) @ location: 18 - [ True - "[PUBLIC_KEY_HASH]" ] - - log/[halt] (exit) @ location: 18 - [ "[PUBLIC_KEY_HASH]" ] - - [halt] (entry) @ location: 24 - [ "[PUBLIC_KEY_HASH]" ] - - control: KCons - - log/IMPLICIT_ACCOUNT (exit) @ location: 18 - [ "[PUBLIC_KEY_HASH]" ] - - IMPLICIT_ACCOUNT (entry) @ location: 24 - [ "[PUBLIC_KEY_HASH]" ] - - log/PUSH (exit) @ location: 24 - [ "[PUBLIC_KEY_HASH]" ] - - PUSH (entry) @ location: 25 - [ "[PUBLIC_KEY_HASH]" ] - - log/PUSH (exit) @ location: 25 - [ 1000000 - "[PUBLIC_KEY_HASH]" ] - - PUSH (entry) @ location: 28 - [ 1000000 - "[PUBLIC_KEY_HASH]" ] - - log/TRANSFER_TOKENS (exit) @ location: 28 - [ Unit - 1000000 - "[PUBLIC_KEY_HASH]" ] - - TRANSFER_TOKENS (entry) @ location: 29 - [ Unit - 1000000 - "[PUBLIC_KEY_HASH]" ] - - log/NIL (exit) @ location: 29 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000001c0843d0000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 ] - - NIL (entry) @ location: 30 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000001c0843d0000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 ] - - log/SWAP (exit) @ location: 30 - [ {} - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000001c0843d0000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 ] - - SWAP (entry) @ location: 32 - [ {} - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000001c0843d0000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 ] - - log/CONS (exit) @ location: 32 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000001c0843d0000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 - {} ] - - CONS (entry) @ location: 33 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000001c0843d0000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 - {} ] - - log/DIP (exit) @ location: 33 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000001c0843d0000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 } ] - - DIP (entry) @ location: 34 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000001c0843d0000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 } ] - - log/NOW (exit) @ location: 34 - [ ] - - NOW (entry) @ location: 36 - [ ] - - log/[halt] (exit) @ location: 36 - [ "[TIMESTAMP]" ] - - [halt] (entry) @ location: 36 - [ "[TIMESTAMP]" ] - - control: KUndip - - control: KCons - - log/PAIR (exit) @ location: 34 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000001c0843d0000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 } - "[TIMESTAMP]" ] - - PAIR (entry) @ location: 37 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000001c0843d0000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 } - "[TIMESTAMP]" ] - - log/[halt] (exit) @ location: 37 - [ (Pair { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000001c0843d0000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 } - "[TIMESTAMP]") ] - - [halt] (entry) @ location: 6 - [ (Pair { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000001c0843d0000dac9f52543da1aed0bc1d6b46bf7c10db7014cd600 } - "[TIMESTAMP]") ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/get_and_update_map.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/get_and_update_map.out deleted file mode 100644 index 43f1a2d3b72dbdee79a2a2b767370bd95a8058aa..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/get_and_update_map.out +++ /dev/null @@ -1,53 +0,0 @@ - -trace - - UNPAIR (interp) @ location: 13 - [ (Pair "abc" (Some 321) { Elt "def" 123 }) ] - - UNPAIR (entry) @ location: 13 - [ (Pair "abc" (Some 321) { Elt "def" 123 }) ] - - log/DIP (exit) @ location: 13 - [ "abc" - (Pair (Some 321) { Elt "def" 123 }) ] - - DIP (entry) @ location: 14 - [ "abc" - (Pair (Some 321) { Elt "def" 123 }) ] - - log/UNPAIR (exit) @ location: 14 - [ (Pair (Some 321) { Elt "def" 123 }) ] - - UNPAIR (entry) @ location: 16 - [ (Pair (Some 321) { Elt "def" 123 }) ] - - log/[halt] (exit) @ location: 16 - [ (Some 321) - { Elt "def" 123 } ] - - [halt] (entry) @ location: 16 - [ (Some 321) - { Elt "def" 123 } ] - - control: KUndip - - control: KCons - - log/GET_AND_UPDATE (exit) @ location: 14 - [ "abc" - (Some 321) - { Elt "def" 123 } ] - - GET_AND_UPDATE (entry) @ location: 17 - [ "abc" - (Some 321) - { Elt "def" 123 } ] - - log/PAIR (exit) @ location: 17 - [ None - { Elt "abc" 321 ; Elt "def" 123 } ] - - PAIR (entry) @ location: 18 - [ None - { Elt "abc" 321 ; Elt "def" 123 } ] - - log/NIL (exit) @ location: 18 - [ (Pair None { Elt "abc" 321 ; Elt "def" 123 }) ] - - NIL (entry) @ location: 19 - [ (Pair None { Elt "abc" 321 ; Elt "def" 123 }) ] - - log/PAIR (exit) @ location: 19 - [ {} - (Pair None { Elt "abc" 321 ; Elt "def" 123 }) ] - - PAIR (entry) @ location: 21 - [ {} - (Pair None { Elt "abc" 321 ; Elt "def" 123 }) ] - - log/[halt] (exit) @ location: 21 - [ (Pair {} None { Elt "abc" 321 ; Elt "def" 123 }) ] - - [halt] (entry) @ location: 11 - [ (Pair {} None { Elt "abc" 321 ; Elt "def" 123 }) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/if.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/if.out deleted file mode 100644 index ab18612e58e6ac0ec17741050b38e8f1a33ce3d8..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/if.out +++ /dev/null @@ -1,38 +0,0 @@ - -trace - - CAR (interp) @ location: 8 - [ (Pair True None) ] - - CAR (entry) @ location: 8 - [ (Pair True None) ] - - log/IF (exit) @ location: 8 - [ True ] - - IF (entry) @ location: 9 - [ True ] - - log/PUSH (exit) @ location: 9 - [ ] - - PUSH (entry) @ location: 11 - [ ] - - log/[halt] (exit) @ location: 11 - [ True ] - - [halt] (entry) @ location: 18 - [ True ] - - control: KCons - - log/SOME (exit) @ location: 9 - [ True ] - - SOME (entry) @ location: 18 - [ True ] - - log/NIL (exit) @ location: 18 - [ (Some True) ] - - NIL (entry) @ location: 19 - [ (Some True) ] - - log/PAIR (exit) @ location: 19 - [ {} - (Some True) ] - - PAIR (entry) @ location: 21 - [ {} - (Some True) ] - - log/[halt] (exit) @ location: 21 - [ (Pair {} (Some True)) ] - - [halt] (entry) @ location: 7 - [ (Pair {} (Some True)) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/insertion_sort.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/insertion_sort.out deleted file mode 100644 index d9dc483d45897c23a0088a855e07e437190bf129..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/insertion_sort.out +++ /dev/null @@ -1,6541 +0,0 @@ - -trace - - CAR (interp) @ location: 9 - [ (Pair { 8 ; 3 ; 2 ; 7 ; 6 ; 9 ; 5 ; 1 ; 4 ; 0 } {}) ] - - CAR (entry) @ location: 9 - [ (Pair { 8 ; 3 ; 2 ; 7 ; 6 ; 9 ; 5 ; 1 ; 4 ; 0 } {}) ] - - log/NIL (exit) @ location: 9 - [ { 8 ; 3 ; 2 ; 7 ; 6 ; 9 ; 5 ; 1 ; 4 ; 0 } ] - - NIL (entry) @ location: 10 - [ { 8 ; 3 ; 2 ; 7 ; 6 ; 9 ; 5 ; 1 ; 4 ; 0 } ] - - log/SWAP (exit) @ location: 10 - [ {} - { 8 ; 3 ; 2 ; 7 ; 6 ; 9 ; 5 ; 1 ; 4 ; 0 } ] - - SWAP (entry) @ location: 12 - [ {} - { 8 ; 3 ; 2 ; 7 ; 6 ; 9 ; 5 ; 1 ; 4 ; 0 } ] - - log/ITER (exit) @ location: 12 - [ { 8 ; 3 ; 2 ; 7 ; 6 ; 9 ; 5 ; 1 ; 4 ; 0 } - {} ] - - ITER (entry) @ location: 13 - [ { 8 ; 3 ; 2 ; 7 ; 6 ; 9 ; 5 ; 1 ; 4 ; 0 } - {} ] - - control: KIter - - log/SWAP (exit) @ location: 13 - [ 8 - {} ] - - SWAP (entry) @ location: 15 - [ 8 - {} ] - - log/DIP (exit) @ location: 15 - [ {} - 8 ] - - DIP (entry) @ location: 16 - [ {} - 8 ] - - log/NIL (exit) @ location: 16 - [ ] - - NIL (entry) @ location: 19 - [ ] - - log/[halt] (exit) @ location: 19 - [ {} ] - - [halt] (entry) @ location: 19 - [ {} ] - - control: KCons - - PUSH (entry) @ location: 16 - [ {} ] - - log/PUSH (exit) @ location: 16 - [ 8 - {} ] - - PUSH (entry) @ location: 16 - [ 8 - {} ] - - log/log/log/PUSH (exit) @ location: 16 - [ {} - 8 - {} ] - - log/PUSH (exit) @ location: 16 - [ {} - 8 - {} ] - - PUSH (entry) @ location: 21 - [ {} - 8 - {} ] - - log/LOOP (exit) @ location: 21 - [ True - {} - 8 - {} ] - - LOOP (entry) @ location: 66 - [ True - {} - 8 - {} ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ {} - 8 - {} ] - - IF_CONS (entry) @ location: 26 - [ {} - 8 - {} ] - - log/NIL (exit) @ location: 26 - [ 8 - {} ] - - NIL (entry) @ location: 61 - [ 8 - {} ] - - log/PUSH (exit) @ location: 61 - [ {} - 8 - {} ] - - PUSH (entry) @ location: 63 - [ {} - 8 - {} ] - - log/[halt] (exit) @ location: 63 - [ False - {} - 8 - {} ] - - [halt] (entry) @ location: 66 - [ False - {} - 8 - {} ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ False - {} - 8 - {} ] - - [halt] (entry) @ location: 66 - [ False - {} - 8 - {} ] - - control: KLoop_in - - control: KCons - - log/SWAP (exit) @ location: 66 - [ {} - 8 - {} ] - - SWAP (entry) @ location: 66 - [ {} - 8 - {} ] - - log/CONS (exit) @ location: 66 - [ 8 - {} - {} ] - - CONS (entry) @ location: 67 - [ 8 - {} - {} ] - - log/SWAP (exit) @ location: 67 - [ { 8 } - {} ] - - SWAP (entry) @ location: 68 - [ { 8 } - {} ] - - log/ITER (exit) @ location: 68 - [ {} - { 8 } ] - - ITER (entry) @ location: 69 - [ {} - { 8 } ] - - control: KIter - - control: KCons - - log/[halt] (exit) @ location: 69 - [ { 8 } ] - - [halt] (entry) @ location: 13 - [ { 8 } ] - - control: KIter - - log/SWAP (exit) @ location: 13 - [ 3 - { 8 } ] - - SWAP (entry) @ location: 15 - [ 3 - { 8 } ] - - log/DIP (exit) @ location: 15 - [ { 8 } - 3 ] - - DIP (entry) @ location: 16 - [ { 8 } - 3 ] - - log/NIL (exit) @ location: 16 - [ ] - - NIL (entry) @ location: 19 - [ ] - - log/[halt] (exit) @ location: 19 - [ {} ] - - [halt] (entry) @ location: 19 - [ {} ] - - control: KCons - - PUSH (entry) @ location: 16 - [ {} ] - - log/PUSH (exit) @ location: 16 - [ 3 - {} ] - - PUSH (entry) @ location: 16 - [ 3 - {} ] - - log/log/log/PUSH (exit) @ location: 16 - [ { 8 } - 3 - {} ] - - log/PUSH (exit) @ location: 16 - [ { 8 } - 3 - {} ] - - PUSH (entry) @ location: 21 - [ { 8 } - 3 - {} ] - - log/LOOP (exit) @ location: 21 - [ True - { 8 } - 3 - {} ] - - LOOP (entry) @ location: 66 - [ True - { 8 } - 3 - {} ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 8 } - 3 - {} ] - - IF_CONS (entry) @ location: 26 - [ { 8 } - 3 - {} ] - - log/SWAP (exit) @ location: 26 - [ 8 - {} - 3 - {} ] - - SWAP (entry) @ location: 28 - [ 8 - {} - 3 - {} ] - - log/DIP (exit) @ location: 28 - [ {} - 8 - 3 - {} ] - - DIP (entry) @ location: 29 - [ {} - 8 - 3 - {} ] - - log/DUP (exit) @ location: 29 - [ 8 - 3 - {} ] - - DUP (entry) @ location: 31 - [ 8 - 3 - {} ] - - log/DIP (exit) @ location: 31 - [ 8 - 8 - 3 - {} ] - - DIP (entry) @ location: 32 - [ 8 - 8 - 3 - {} ] - - log/DUP (exit) @ location: 32 - [ 3 - {} ] - - DUP (entry) @ location: 35 - [ 3 - {} ] - - log/[halt] (exit) @ location: 35 - [ 3 - 3 - {} ] - - [halt] (entry) @ location: 35 - [ 3 - 3 - {} ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 3 - 3 - {} ] - - log/PUSH (exit) @ location: 32 - [ 8 - 3 - 3 - {} ] - - PUSH (entry) @ location: 32 - [ 8 - 3 - 3 - {} ] - - log/log/log/DIP (exit) @ location: 32 - [ 8 - 8 - 3 - 3 - {} ] - - log/DIP (exit) @ location: 32 - [ 8 - 8 - 3 - 3 - {} ] - - DIP (entry) @ location: 36 - [ 8 - 8 - 3 - 3 - {} ] - - log/COMPARE (exit) @ location: 36 - [ 8 - 3 - 3 - {} ] - - COMPARE (entry) @ location: 39 - [ 8 - 3 - 3 - {} ] - - log/LT (exit) @ location: 39 - [ 1 - 3 - {} ] - - LT (entry) @ location: 40 - [ 1 - 3 - {} ] - - log/[halt] (exit) @ location: 40 - [ False - 3 - {} ] - - [halt] (entry) @ location: 38 - [ False - 3 - {} ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 8 - False - 3 - {} ] - - SWAP (entry) @ location: 41 - [ 8 - False - 3 - {} ] - - log/[halt] (exit) @ location: 41 - [ False - 8 - 3 - {} ] - - [halt] (entry) @ location: 30 - [ False - 8 - 3 - {} ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ {} - False - 8 - 3 - {} ] - - SWAP (entry) @ location: 42 - [ {} - False - 8 - 3 - {} ] - - log/IF (exit) @ location: 42 - [ False - {} - 8 - 3 - {} ] - - IF (entry) @ location: 43 - [ False - {} - 8 - 3 - {} ] - - log/SWAP (exit) @ location: 43 - [ {} - 8 - 3 - {} ] - - SWAP (entry) @ location: 55 - [ {} - 8 - 3 - {} ] - - log/CONS (exit) @ location: 55 - [ 8 - {} - 3 - {} ] - - CONS (entry) @ location: 56 - [ 8 - {} - 3 - {} ] - - log/PUSH (exit) @ location: 56 - [ { 8 } - 3 - {} ] - - PUSH (entry) @ location: 57 - [ { 8 } - 3 - {} ] - - log/[halt] (exit) @ location: 57 - [ False - { 8 } - 3 - {} ] - - [halt] (entry) @ location: 66 - [ False - { 8 } - 3 - {} ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ False - { 8 } - 3 - {} ] - - [halt] (entry) @ location: 66 - [ False - { 8 } - 3 - {} ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ False - { 8 } - 3 - {} ] - - [halt] (entry) @ location: 66 - [ False - { 8 } - 3 - {} ] - - control: KLoop_in - - control: KCons - - log/SWAP (exit) @ location: 66 - [ { 8 } - 3 - {} ] - - SWAP (entry) @ location: 66 - [ { 8 } - 3 - {} ] - - log/CONS (exit) @ location: 66 - [ 3 - { 8 } - {} ] - - CONS (entry) @ location: 67 - [ 3 - { 8 } - {} ] - - log/SWAP (exit) @ location: 67 - [ { 3 ; 8 } - {} ] - - SWAP (entry) @ location: 68 - [ { 3 ; 8 } - {} ] - - log/ITER (exit) @ location: 68 - [ {} - { 3 ; 8 } ] - - ITER (entry) @ location: 69 - [ {} - { 3 ; 8 } ] - - control: KIter - - control: KCons - - log/[halt] (exit) @ location: 69 - [ { 3 ; 8 } ] - - [halt] (entry) @ location: 13 - [ { 3 ; 8 } ] - - control: KIter - - log/SWAP (exit) @ location: 13 - [ 2 - { 3 ; 8 } ] - - SWAP (entry) @ location: 15 - [ 2 - { 3 ; 8 } ] - - log/DIP (exit) @ location: 15 - [ { 3 ; 8 } - 2 ] - - DIP (entry) @ location: 16 - [ { 3 ; 8 } - 2 ] - - log/NIL (exit) @ location: 16 - [ ] - - NIL (entry) @ location: 19 - [ ] - - log/[halt] (exit) @ location: 19 - [ {} ] - - [halt] (entry) @ location: 19 - [ {} ] - - control: KCons - - PUSH (entry) @ location: 16 - [ {} ] - - log/PUSH (exit) @ location: 16 - [ 2 - {} ] - - PUSH (entry) @ location: 16 - [ 2 - {} ] - - log/log/log/PUSH (exit) @ location: 16 - [ { 3 ; 8 } - 2 - {} ] - - log/PUSH (exit) @ location: 16 - [ { 3 ; 8 } - 2 - {} ] - - PUSH (entry) @ location: 21 - [ { 3 ; 8 } - 2 - {} ] - - log/LOOP (exit) @ location: 21 - [ True - { 3 ; 8 } - 2 - {} ] - - LOOP (entry) @ location: 66 - [ True - { 3 ; 8 } - 2 - {} ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 3 ; 8 } - 2 - {} ] - - IF_CONS (entry) @ location: 26 - [ { 3 ; 8 } - 2 - {} ] - - log/SWAP (exit) @ location: 26 - [ 3 - { 8 } - 2 - {} ] - - SWAP (entry) @ location: 28 - [ 3 - { 8 } - 2 - {} ] - - log/DIP (exit) @ location: 28 - [ { 8 } - 3 - 2 - {} ] - - DIP (entry) @ location: 29 - [ { 8 } - 3 - 2 - {} ] - - log/DUP (exit) @ location: 29 - [ 3 - 2 - {} ] - - DUP (entry) @ location: 31 - [ 3 - 2 - {} ] - - log/DIP (exit) @ location: 31 - [ 3 - 3 - 2 - {} ] - - DIP (entry) @ location: 32 - [ 3 - 3 - 2 - {} ] - - log/DUP (exit) @ location: 32 - [ 2 - {} ] - - DUP (entry) @ location: 35 - [ 2 - {} ] - - log/[halt] (exit) @ location: 35 - [ 2 - 2 - {} ] - - [halt] (entry) @ location: 35 - [ 2 - 2 - {} ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 2 - 2 - {} ] - - log/PUSH (exit) @ location: 32 - [ 3 - 2 - 2 - {} ] - - PUSH (entry) @ location: 32 - [ 3 - 2 - 2 - {} ] - - log/log/log/DIP (exit) @ location: 32 - [ 3 - 3 - 2 - 2 - {} ] - - log/DIP (exit) @ location: 32 - [ 3 - 3 - 2 - 2 - {} ] - - DIP (entry) @ location: 36 - [ 3 - 3 - 2 - 2 - {} ] - - log/COMPARE (exit) @ location: 36 - [ 3 - 2 - 2 - {} ] - - COMPARE (entry) @ location: 39 - [ 3 - 2 - 2 - {} ] - - log/LT (exit) @ location: 39 - [ 1 - 2 - {} ] - - LT (entry) @ location: 40 - [ 1 - 2 - {} ] - - log/[halt] (exit) @ location: 40 - [ False - 2 - {} ] - - [halt] (entry) @ location: 38 - [ False - 2 - {} ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 3 - False - 2 - {} ] - - SWAP (entry) @ location: 41 - [ 3 - False - 2 - {} ] - - log/[halt] (exit) @ location: 41 - [ False - 3 - 2 - {} ] - - [halt] (entry) @ location: 30 - [ False - 3 - 2 - {} ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ { 8 } - False - 3 - 2 - {} ] - - SWAP (entry) @ location: 42 - [ { 8 } - False - 3 - 2 - {} ] - - log/IF (exit) @ location: 42 - [ False - { 8 } - 3 - 2 - {} ] - - IF (entry) @ location: 43 - [ False - { 8 } - 3 - 2 - {} ] - - log/SWAP (exit) @ location: 43 - [ { 8 } - 3 - 2 - {} ] - - SWAP (entry) @ location: 55 - [ { 8 } - 3 - 2 - {} ] - - log/CONS (exit) @ location: 55 - [ 3 - { 8 } - 2 - {} ] - - CONS (entry) @ location: 56 - [ 3 - { 8 } - 2 - {} ] - - log/PUSH (exit) @ location: 56 - [ { 3 ; 8 } - 2 - {} ] - - PUSH (entry) @ location: 57 - [ { 3 ; 8 } - 2 - {} ] - - log/[halt] (exit) @ location: 57 - [ False - { 3 ; 8 } - 2 - {} ] - - [halt] (entry) @ location: 66 - [ False - { 3 ; 8 } - 2 - {} ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ False - { 3 ; 8 } - 2 - {} ] - - [halt] (entry) @ location: 66 - [ False - { 3 ; 8 } - 2 - {} ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ False - { 3 ; 8 } - 2 - {} ] - - [halt] (entry) @ location: 66 - [ False - { 3 ; 8 } - 2 - {} ] - - control: KLoop_in - - control: KCons - - log/SWAP (exit) @ location: 66 - [ { 3 ; 8 } - 2 - {} ] - - SWAP (entry) @ location: 66 - [ { 3 ; 8 } - 2 - {} ] - - log/CONS (exit) @ location: 66 - [ 2 - { 3 ; 8 } - {} ] - - CONS (entry) @ location: 67 - [ 2 - { 3 ; 8 } - {} ] - - log/SWAP (exit) @ location: 67 - [ { 2 ; 3 ; 8 } - {} ] - - SWAP (entry) @ location: 68 - [ { 2 ; 3 ; 8 } - {} ] - - log/ITER (exit) @ location: 68 - [ {} - { 2 ; 3 ; 8 } ] - - ITER (entry) @ location: 69 - [ {} - { 2 ; 3 ; 8 } ] - - control: KIter - - control: KCons - - log/[halt] (exit) @ location: 69 - [ { 2 ; 3 ; 8 } ] - - [halt] (entry) @ location: 13 - [ { 2 ; 3 ; 8 } ] - - control: KIter - - log/SWAP (exit) @ location: 13 - [ 7 - { 2 ; 3 ; 8 } ] - - SWAP (entry) @ location: 15 - [ 7 - { 2 ; 3 ; 8 } ] - - log/DIP (exit) @ location: 15 - [ { 2 ; 3 ; 8 } - 7 ] - - DIP (entry) @ location: 16 - [ { 2 ; 3 ; 8 } - 7 ] - - log/NIL (exit) @ location: 16 - [ ] - - NIL (entry) @ location: 19 - [ ] - - log/[halt] (exit) @ location: 19 - [ {} ] - - [halt] (entry) @ location: 19 - [ {} ] - - control: KCons - - PUSH (entry) @ location: 16 - [ {} ] - - log/PUSH (exit) @ location: 16 - [ 7 - {} ] - - PUSH (entry) @ location: 16 - [ 7 - {} ] - - log/log/log/PUSH (exit) @ location: 16 - [ { 2 ; 3 ; 8 } - 7 - {} ] - - log/PUSH (exit) @ location: 16 - [ { 2 ; 3 ; 8 } - 7 - {} ] - - PUSH (entry) @ location: 21 - [ { 2 ; 3 ; 8 } - 7 - {} ] - - log/LOOP (exit) @ location: 21 - [ True - { 2 ; 3 ; 8 } - 7 - {} ] - - LOOP (entry) @ location: 66 - [ True - { 2 ; 3 ; 8 } - 7 - {} ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 2 ; 3 ; 8 } - 7 - {} ] - - IF_CONS (entry) @ location: 26 - [ { 2 ; 3 ; 8 } - 7 - {} ] - - log/SWAP (exit) @ location: 26 - [ 2 - { 3 ; 8 } - 7 - {} ] - - SWAP (entry) @ location: 28 - [ 2 - { 3 ; 8 } - 7 - {} ] - - log/DIP (exit) @ location: 28 - [ { 3 ; 8 } - 2 - 7 - {} ] - - DIP (entry) @ location: 29 - [ { 3 ; 8 } - 2 - 7 - {} ] - - log/DUP (exit) @ location: 29 - [ 2 - 7 - {} ] - - DUP (entry) @ location: 31 - [ 2 - 7 - {} ] - - log/DIP (exit) @ location: 31 - [ 2 - 2 - 7 - {} ] - - DIP (entry) @ location: 32 - [ 2 - 2 - 7 - {} ] - - log/DUP (exit) @ location: 32 - [ 7 - {} ] - - DUP (entry) @ location: 35 - [ 7 - {} ] - - log/[halt] (exit) @ location: 35 - [ 7 - 7 - {} ] - - [halt] (entry) @ location: 35 - [ 7 - 7 - {} ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 7 - 7 - {} ] - - log/PUSH (exit) @ location: 32 - [ 2 - 7 - 7 - {} ] - - PUSH (entry) @ location: 32 - [ 2 - 7 - 7 - {} ] - - log/log/log/DIP (exit) @ location: 32 - [ 2 - 2 - 7 - 7 - {} ] - - log/DIP (exit) @ location: 32 - [ 2 - 2 - 7 - 7 - {} ] - - DIP (entry) @ location: 36 - [ 2 - 2 - 7 - 7 - {} ] - - log/COMPARE (exit) @ location: 36 - [ 2 - 7 - 7 - {} ] - - COMPARE (entry) @ location: 39 - [ 2 - 7 - 7 - {} ] - - log/LT (exit) @ location: 39 - [ -1 - 7 - {} ] - - LT (entry) @ location: 40 - [ -1 - 7 - {} ] - - log/[halt] (exit) @ location: 40 - [ True - 7 - {} ] - - [halt] (entry) @ location: 38 - [ True - 7 - {} ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 2 - True - 7 - {} ] - - SWAP (entry) @ location: 41 - [ 2 - True - 7 - {} ] - - log/[halt] (exit) @ location: 41 - [ True - 2 - 7 - {} ] - - [halt] (entry) @ location: 30 - [ True - 2 - 7 - {} ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ { 3 ; 8 } - True - 2 - 7 - {} ] - - SWAP (entry) @ location: 42 - [ { 3 ; 8 } - True - 2 - 7 - {} ] - - log/IF (exit) @ location: 42 - [ True - { 3 ; 8 } - 2 - 7 - {} ] - - IF (entry) @ location: 43 - [ True - { 3 ; 8 } - 2 - 7 - {} ] - - log/DIP (exit) @ location: 43 - [ { 3 ; 8 } - 2 - 7 - {} ] - - DIP (entry) @ location: 45 - [ { 3 ; 8 } - 2 - 7 - {} ] - - log/SWAP (exit) @ location: 45 - [ 2 - 7 - {} ] - - SWAP (entry) @ location: 47 - [ 2 - 7 - {} ] - - log/DIP (exit) @ location: 47 - [ 7 - 2 - {} ] - - DIP (entry) @ location: 48 - [ 7 - 2 - {} ] - - log/CONS (exit) @ location: 48 - [ 2 - {} ] - - CONS (entry) @ location: 50 - [ 2 - {} ] - - log/[halt] (exit) @ location: 50 - [ { 2 } ] - - [halt] (entry) @ location: 50 - [ { 2 } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 48 - [ 7 - { 2 } ] - - [halt] (entry) @ location: 46 - [ 7 - { 2 } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 45 - [ { 3 ; 8 } - 7 - { 2 } ] - - PUSH (entry) @ location: 51 - [ { 3 ; 8 } - 7 - { 2 } ] - - log/[halt] (exit) @ location: 51 - [ True - { 3 ; 8 } - 7 - { 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 3 ; 8 } - 7 - { 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ True - { 3 ; 8 } - 7 - { 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 3 ; 8 } - 7 - { 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ True - { 3 ; 8 } - 7 - { 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 3 ; 8 } - 7 - { 2 } ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 3 ; 8 } - 7 - { 2 } ] - - IF_CONS (entry) @ location: 26 - [ { 3 ; 8 } - 7 - { 2 } ] - - log/SWAP (exit) @ location: 26 - [ 3 - { 8 } - 7 - { 2 } ] - - SWAP (entry) @ location: 28 - [ 3 - { 8 } - 7 - { 2 } ] - - log/DIP (exit) @ location: 28 - [ { 8 } - 3 - 7 - { 2 } ] - - DIP (entry) @ location: 29 - [ { 8 } - 3 - 7 - { 2 } ] - - log/DUP (exit) @ location: 29 - [ 3 - 7 - { 2 } ] - - DUP (entry) @ location: 31 - [ 3 - 7 - { 2 } ] - - log/DIP (exit) @ location: 31 - [ 3 - 3 - 7 - { 2 } ] - - DIP (entry) @ location: 32 - [ 3 - 3 - 7 - { 2 } ] - - log/DUP (exit) @ location: 32 - [ 7 - { 2 } ] - - DUP (entry) @ location: 35 - [ 7 - { 2 } ] - - log/[halt] (exit) @ location: 35 - [ 7 - 7 - { 2 } ] - - [halt] (entry) @ location: 35 - [ 7 - 7 - { 2 } ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 7 - 7 - { 2 } ] - - log/PUSH (exit) @ location: 32 - [ 3 - 7 - 7 - { 2 } ] - - PUSH (entry) @ location: 32 - [ 3 - 7 - 7 - { 2 } ] - - log/log/log/DIP (exit) @ location: 32 - [ 3 - 3 - 7 - 7 - { 2 } ] - - log/DIP (exit) @ location: 32 - [ 3 - 3 - 7 - 7 - { 2 } ] - - DIP (entry) @ location: 36 - [ 3 - 3 - 7 - 7 - { 2 } ] - - log/COMPARE (exit) @ location: 36 - [ 3 - 7 - 7 - { 2 } ] - - COMPARE (entry) @ location: 39 - [ 3 - 7 - 7 - { 2 } ] - - log/LT (exit) @ location: 39 - [ -1 - 7 - { 2 } ] - - LT (entry) @ location: 40 - [ -1 - 7 - { 2 } ] - - log/[halt] (exit) @ location: 40 - [ True - 7 - { 2 } ] - - [halt] (entry) @ location: 38 - [ True - 7 - { 2 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 3 - True - 7 - { 2 } ] - - SWAP (entry) @ location: 41 - [ 3 - True - 7 - { 2 } ] - - log/[halt] (exit) @ location: 41 - [ True - 3 - 7 - { 2 } ] - - [halt] (entry) @ location: 30 - [ True - 3 - 7 - { 2 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ { 8 } - True - 3 - 7 - { 2 } ] - - SWAP (entry) @ location: 42 - [ { 8 } - True - 3 - 7 - { 2 } ] - - log/IF (exit) @ location: 42 - [ True - { 8 } - 3 - 7 - { 2 } ] - - IF (entry) @ location: 43 - [ True - { 8 } - 3 - 7 - { 2 } ] - - log/DIP (exit) @ location: 43 - [ { 8 } - 3 - 7 - { 2 } ] - - DIP (entry) @ location: 45 - [ { 8 } - 3 - 7 - { 2 } ] - - log/SWAP (exit) @ location: 45 - [ 3 - 7 - { 2 } ] - - SWAP (entry) @ location: 47 - [ 3 - 7 - { 2 } ] - - log/DIP (exit) @ location: 47 - [ 7 - 3 - { 2 } ] - - DIP (entry) @ location: 48 - [ 7 - 3 - { 2 } ] - - log/CONS (exit) @ location: 48 - [ 3 - { 2 } ] - - CONS (entry) @ location: 50 - [ 3 - { 2 } ] - - log/[halt] (exit) @ location: 50 - [ { 3 ; 2 } ] - - [halt] (entry) @ location: 50 - [ { 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 48 - [ 7 - { 3 ; 2 } ] - - [halt] (entry) @ location: 46 - [ 7 - { 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 45 - [ { 8 } - 7 - { 3 ; 2 } ] - - PUSH (entry) @ location: 51 - [ { 8 } - 7 - { 3 ; 2 } ] - - log/[halt] (exit) @ location: 51 - [ True - { 8 } - 7 - { 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 8 } - 7 - { 3 ; 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ True - { 8 } - 7 - { 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 8 } - 7 - { 3 ; 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ True - { 8 } - 7 - { 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 8 } - 7 - { 3 ; 2 } ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 8 } - 7 - { 3 ; 2 } ] - - IF_CONS (entry) @ location: 26 - [ { 8 } - 7 - { 3 ; 2 } ] - - log/SWAP (exit) @ location: 26 - [ 8 - {} - 7 - { 3 ; 2 } ] - - SWAP (entry) @ location: 28 - [ 8 - {} - 7 - { 3 ; 2 } ] - - log/DIP (exit) @ location: 28 - [ {} - 8 - 7 - { 3 ; 2 } ] - - DIP (entry) @ location: 29 - [ {} - 8 - 7 - { 3 ; 2 } ] - - log/DUP (exit) @ location: 29 - [ 8 - 7 - { 3 ; 2 } ] - - DUP (entry) @ location: 31 - [ 8 - 7 - { 3 ; 2 } ] - - log/DIP (exit) @ location: 31 - [ 8 - 8 - 7 - { 3 ; 2 } ] - - DIP (entry) @ location: 32 - [ 8 - 8 - 7 - { 3 ; 2 } ] - - log/DUP (exit) @ location: 32 - [ 7 - { 3 ; 2 } ] - - DUP (entry) @ location: 35 - [ 7 - { 3 ; 2 } ] - - log/[halt] (exit) @ location: 35 - [ 7 - 7 - { 3 ; 2 } ] - - [halt] (entry) @ location: 35 - [ 7 - 7 - { 3 ; 2 } ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 7 - 7 - { 3 ; 2 } ] - - log/PUSH (exit) @ location: 32 - [ 8 - 7 - 7 - { 3 ; 2 } ] - - PUSH (entry) @ location: 32 - [ 8 - 7 - 7 - { 3 ; 2 } ] - - log/log/log/DIP (exit) @ location: 32 - [ 8 - 8 - 7 - 7 - { 3 ; 2 } ] - - log/DIP (exit) @ location: 32 - [ 8 - 8 - 7 - 7 - { 3 ; 2 } ] - - DIP (entry) @ location: 36 - [ 8 - 8 - 7 - 7 - { 3 ; 2 } ] - - log/COMPARE (exit) @ location: 36 - [ 8 - 7 - 7 - { 3 ; 2 } ] - - COMPARE (entry) @ location: 39 - [ 8 - 7 - 7 - { 3 ; 2 } ] - - log/LT (exit) @ location: 39 - [ 1 - 7 - { 3 ; 2 } ] - - LT (entry) @ location: 40 - [ 1 - 7 - { 3 ; 2 } ] - - log/[halt] (exit) @ location: 40 - [ False - 7 - { 3 ; 2 } ] - - [halt] (entry) @ location: 38 - [ False - 7 - { 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 8 - False - 7 - { 3 ; 2 } ] - - SWAP (entry) @ location: 41 - [ 8 - False - 7 - { 3 ; 2 } ] - - log/[halt] (exit) @ location: 41 - [ False - 8 - 7 - { 3 ; 2 } ] - - [halt] (entry) @ location: 30 - [ False - 8 - 7 - { 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ {} - False - 8 - 7 - { 3 ; 2 } ] - - SWAP (entry) @ location: 42 - [ {} - False - 8 - 7 - { 3 ; 2 } ] - - log/IF (exit) @ location: 42 - [ False - {} - 8 - 7 - { 3 ; 2 } ] - - IF (entry) @ location: 43 - [ False - {} - 8 - 7 - { 3 ; 2 } ] - - log/SWAP (exit) @ location: 43 - [ {} - 8 - 7 - { 3 ; 2 } ] - - SWAP (entry) @ location: 55 - [ {} - 8 - 7 - { 3 ; 2 } ] - - log/CONS (exit) @ location: 55 - [ 8 - {} - 7 - { 3 ; 2 } ] - - CONS (entry) @ location: 56 - [ 8 - {} - 7 - { 3 ; 2 } ] - - log/PUSH (exit) @ location: 56 - [ { 8 } - 7 - { 3 ; 2 } ] - - PUSH (entry) @ location: 57 - [ { 8 } - 7 - { 3 ; 2 } ] - - log/[halt] (exit) @ location: 57 - [ False - { 8 } - 7 - { 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ False - { 8 } - 7 - { 3 ; 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ False - { 8 } - 7 - { 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ False - { 8 } - 7 - { 3 ; 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ False - { 8 } - 7 - { 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ False - { 8 } - 7 - { 3 ; 2 } ] - - control: KLoop_in - - control: KCons - - log/SWAP (exit) @ location: 66 - [ { 8 } - 7 - { 3 ; 2 } ] - - SWAP (entry) @ location: 66 - [ { 8 } - 7 - { 3 ; 2 } ] - - log/CONS (exit) @ location: 66 - [ 7 - { 8 } - { 3 ; 2 } ] - - CONS (entry) @ location: 67 - [ 7 - { 8 } - { 3 ; 2 } ] - - log/SWAP (exit) @ location: 67 - [ { 7 ; 8 } - { 3 ; 2 } ] - - SWAP (entry) @ location: 68 - [ { 7 ; 8 } - { 3 ; 2 } ] - - log/ITER (exit) @ location: 68 - [ { 3 ; 2 } - { 7 ; 8 } ] - - ITER (entry) @ location: 69 - [ { 3 ; 2 } - { 7 ; 8 } ] - - control: KIter - - log/CONS (exit) @ location: 69 - [ 3 - { 7 ; 8 } ] - - CONS (entry) @ location: 71 - [ 3 - { 7 ; 8 } ] - - log/[halt] (exit) @ location: 71 - [ { 3 ; 7 ; 8 } ] - - [halt] (entry) @ location: 69 - [ { 3 ; 7 ; 8 } ] - - control: KIter - - log/CONS (exit) @ location: 69 - [ 2 - { 3 ; 7 ; 8 } ] - - CONS (entry) @ location: 71 - [ 2 - { 3 ; 7 ; 8 } ] - - log/[halt] (exit) @ location: 71 - [ { 2 ; 3 ; 7 ; 8 } ] - - [halt] (entry) @ location: 69 - [ { 2 ; 3 ; 7 ; 8 } ] - - control: KIter - - control: KCons - - log/[halt] (exit) @ location: 69 - [ { 2 ; 3 ; 7 ; 8 } ] - - [halt] (entry) @ location: 13 - [ { 2 ; 3 ; 7 ; 8 } ] - - control: KIter - - log/SWAP (exit) @ location: 13 - [ 6 - { 2 ; 3 ; 7 ; 8 } ] - - SWAP (entry) @ location: 15 - [ 6 - { 2 ; 3 ; 7 ; 8 } ] - - log/DIP (exit) @ location: 15 - [ { 2 ; 3 ; 7 ; 8 } - 6 ] - - DIP (entry) @ location: 16 - [ { 2 ; 3 ; 7 ; 8 } - 6 ] - - log/NIL (exit) @ location: 16 - [ ] - - NIL (entry) @ location: 19 - [ ] - - log/[halt] (exit) @ location: 19 - [ {} ] - - [halt] (entry) @ location: 19 - [ {} ] - - control: KCons - - PUSH (entry) @ location: 16 - [ {} ] - - log/PUSH (exit) @ location: 16 - [ 6 - {} ] - - PUSH (entry) @ location: 16 - [ 6 - {} ] - - log/log/log/PUSH (exit) @ location: 16 - [ { 2 ; 3 ; 7 ; 8 } - 6 - {} ] - - log/PUSH (exit) @ location: 16 - [ { 2 ; 3 ; 7 ; 8 } - 6 - {} ] - - PUSH (entry) @ location: 21 - [ { 2 ; 3 ; 7 ; 8 } - 6 - {} ] - - log/LOOP (exit) @ location: 21 - [ True - { 2 ; 3 ; 7 ; 8 } - 6 - {} ] - - LOOP (entry) @ location: 66 - [ True - { 2 ; 3 ; 7 ; 8 } - 6 - {} ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 2 ; 3 ; 7 ; 8 } - 6 - {} ] - - IF_CONS (entry) @ location: 26 - [ { 2 ; 3 ; 7 ; 8 } - 6 - {} ] - - log/SWAP (exit) @ location: 26 - [ 2 - { 3 ; 7 ; 8 } - 6 - {} ] - - SWAP (entry) @ location: 28 - [ 2 - { 3 ; 7 ; 8 } - 6 - {} ] - - log/DIP (exit) @ location: 28 - [ { 3 ; 7 ; 8 } - 2 - 6 - {} ] - - DIP (entry) @ location: 29 - [ { 3 ; 7 ; 8 } - 2 - 6 - {} ] - - log/DUP (exit) @ location: 29 - [ 2 - 6 - {} ] - - DUP (entry) @ location: 31 - [ 2 - 6 - {} ] - - log/DIP (exit) @ location: 31 - [ 2 - 2 - 6 - {} ] - - DIP (entry) @ location: 32 - [ 2 - 2 - 6 - {} ] - - log/DUP (exit) @ location: 32 - [ 6 - {} ] - - DUP (entry) @ location: 35 - [ 6 - {} ] - - log/[halt] (exit) @ location: 35 - [ 6 - 6 - {} ] - - [halt] (entry) @ location: 35 - [ 6 - 6 - {} ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 6 - 6 - {} ] - - log/PUSH (exit) @ location: 32 - [ 2 - 6 - 6 - {} ] - - PUSH (entry) @ location: 32 - [ 2 - 6 - 6 - {} ] - - log/log/log/DIP (exit) @ location: 32 - [ 2 - 2 - 6 - 6 - {} ] - - log/DIP (exit) @ location: 32 - [ 2 - 2 - 6 - 6 - {} ] - - DIP (entry) @ location: 36 - [ 2 - 2 - 6 - 6 - {} ] - - log/COMPARE (exit) @ location: 36 - [ 2 - 6 - 6 - {} ] - - COMPARE (entry) @ location: 39 - [ 2 - 6 - 6 - {} ] - - log/LT (exit) @ location: 39 - [ -1 - 6 - {} ] - - LT (entry) @ location: 40 - [ -1 - 6 - {} ] - - log/[halt] (exit) @ location: 40 - [ True - 6 - {} ] - - [halt] (entry) @ location: 38 - [ True - 6 - {} ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 2 - True - 6 - {} ] - - SWAP (entry) @ location: 41 - [ 2 - True - 6 - {} ] - - log/[halt] (exit) @ location: 41 - [ True - 2 - 6 - {} ] - - [halt] (entry) @ location: 30 - [ True - 2 - 6 - {} ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ { 3 ; 7 ; 8 } - True - 2 - 6 - {} ] - - SWAP (entry) @ location: 42 - [ { 3 ; 7 ; 8 } - True - 2 - 6 - {} ] - - log/IF (exit) @ location: 42 - [ True - { 3 ; 7 ; 8 } - 2 - 6 - {} ] - - IF (entry) @ location: 43 - [ True - { 3 ; 7 ; 8 } - 2 - 6 - {} ] - - log/DIP (exit) @ location: 43 - [ { 3 ; 7 ; 8 } - 2 - 6 - {} ] - - DIP (entry) @ location: 45 - [ { 3 ; 7 ; 8 } - 2 - 6 - {} ] - - log/SWAP (exit) @ location: 45 - [ 2 - 6 - {} ] - - SWAP (entry) @ location: 47 - [ 2 - 6 - {} ] - - log/DIP (exit) @ location: 47 - [ 6 - 2 - {} ] - - DIP (entry) @ location: 48 - [ 6 - 2 - {} ] - - log/CONS (exit) @ location: 48 - [ 2 - {} ] - - CONS (entry) @ location: 50 - [ 2 - {} ] - - log/[halt] (exit) @ location: 50 - [ { 2 } ] - - [halt] (entry) @ location: 50 - [ { 2 } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 48 - [ 6 - { 2 } ] - - [halt] (entry) @ location: 46 - [ 6 - { 2 } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 45 - [ { 3 ; 7 ; 8 } - 6 - { 2 } ] - - PUSH (entry) @ location: 51 - [ { 3 ; 7 ; 8 } - 6 - { 2 } ] - - log/[halt] (exit) @ location: 51 - [ True - { 3 ; 7 ; 8 } - 6 - { 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 3 ; 7 ; 8 } - 6 - { 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ True - { 3 ; 7 ; 8 } - 6 - { 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 3 ; 7 ; 8 } - 6 - { 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ True - { 3 ; 7 ; 8 } - 6 - { 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 3 ; 7 ; 8 } - 6 - { 2 } ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 3 ; 7 ; 8 } - 6 - { 2 } ] - - IF_CONS (entry) @ location: 26 - [ { 3 ; 7 ; 8 } - 6 - { 2 } ] - - log/SWAP (exit) @ location: 26 - [ 3 - { 7 ; 8 } - 6 - { 2 } ] - - SWAP (entry) @ location: 28 - [ 3 - { 7 ; 8 } - 6 - { 2 } ] - - log/DIP (exit) @ location: 28 - [ { 7 ; 8 } - 3 - 6 - { 2 } ] - - DIP (entry) @ location: 29 - [ { 7 ; 8 } - 3 - 6 - { 2 } ] - - log/DUP (exit) @ location: 29 - [ 3 - 6 - { 2 } ] - - DUP (entry) @ location: 31 - [ 3 - 6 - { 2 } ] - - log/DIP (exit) @ location: 31 - [ 3 - 3 - 6 - { 2 } ] - - DIP (entry) @ location: 32 - [ 3 - 3 - 6 - { 2 } ] - - log/DUP (exit) @ location: 32 - [ 6 - { 2 } ] - - DUP (entry) @ location: 35 - [ 6 - { 2 } ] - - log/[halt] (exit) @ location: 35 - [ 6 - 6 - { 2 } ] - - [halt] (entry) @ location: 35 - [ 6 - 6 - { 2 } ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 6 - 6 - { 2 } ] - - log/PUSH (exit) @ location: 32 - [ 3 - 6 - 6 - { 2 } ] - - PUSH (entry) @ location: 32 - [ 3 - 6 - 6 - { 2 } ] - - log/log/log/DIP (exit) @ location: 32 - [ 3 - 3 - 6 - 6 - { 2 } ] - - log/DIP (exit) @ location: 32 - [ 3 - 3 - 6 - 6 - { 2 } ] - - DIP (entry) @ location: 36 - [ 3 - 3 - 6 - 6 - { 2 } ] - - log/COMPARE (exit) @ location: 36 - [ 3 - 6 - 6 - { 2 } ] - - COMPARE (entry) @ location: 39 - [ 3 - 6 - 6 - { 2 } ] - - log/LT (exit) @ location: 39 - [ -1 - 6 - { 2 } ] - - LT (entry) @ location: 40 - [ -1 - 6 - { 2 } ] - - log/[halt] (exit) @ location: 40 - [ True - 6 - { 2 } ] - - [halt] (entry) @ location: 38 - [ True - 6 - { 2 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 3 - True - 6 - { 2 } ] - - SWAP (entry) @ location: 41 - [ 3 - True - 6 - { 2 } ] - - log/[halt] (exit) @ location: 41 - [ True - 3 - 6 - { 2 } ] - - [halt] (entry) @ location: 30 - [ True - 3 - 6 - { 2 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ { 7 ; 8 } - True - 3 - 6 - { 2 } ] - - SWAP (entry) @ location: 42 - [ { 7 ; 8 } - True - 3 - 6 - { 2 } ] - - log/IF (exit) @ location: 42 - [ True - { 7 ; 8 } - 3 - 6 - { 2 } ] - - IF (entry) @ location: 43 - [ True - { 7 ; 8 } - 3 - 6 - { 2 } ] - - log/DIP (exit) @ location: 43 - [ { 7 ; 8 } - 3 - 6 - { 2 } ] - - DIP (entry) @ location: 45 - [ { 7 ; 8 } - 3 - 6 - { 2 } ] - - log/SWAP (exit) @ location: 45 - [ 3 - 6 - { 2 } ] - - SWAP (entry) @ location: 47 - [ 3 - 6 - { 2 } ] - - log/DIP (exit) @ location: 47 - [ 6 - 3 - { 2 } ] - - DIP (entry) @ location: 48 - [ 6 - 3 - { 2 } ] - - log/CONS (exit) @ location: 48 - [ 3 - { 2 } ] - - CONS (entry) @ location: 50 - [ 3 - { 2 } ] - - log/[halt] (exit) @ location: 50 - [ { 3 ; 2 } ] - - [halt] (entry) @ location: 50 - [ { 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 48 - [ 6 - { 3 ; 2 } ] - - [halt] (entry) @ location: 46 - [ 6 - { 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 45 - [ { 7 ; 8 } - 6 - { 3 ; 2 } ] - - PUSH (entry) @ location: 51 - [ { 7 ; 8 } - 6 - { 3 ; 2 } ] - - log/[halt] (exit) @ location: 51 - [ True - { 7 ; 8 } - 6 - { 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 7 ; 8 } - 6 - { 3 ; 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ True - { 7 ; 8 } - 6 - { 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 7 ; 8 } - 6 - { 3 ; 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ True - { 7 ; 8 } - 6 - { 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 7 ; 8 } - 6 - { 3 ; 2 } ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 7 ; 8 } - 6 - { 3 ; 2 } ] - - IF_CONS (entry) @ location: 26 - [ { 7 ; 8 } - 6 - { 3 ; 2 } ] - - log/SWAP (exit) @ location: 26 - [ 7 - { 8 } - 6 - { 3 ; 2 } ] - - SWAP (entry) @ location: 28 - [ 7 - { 8 } - 6 - { 3 ; 2 } ] - - log/DIP (exit) @ location: 28 - [ { 8 } - 7 - 6 - { 3 ; 2 } ] - - DIP (entry) @ location: 29 - [ { 8 } - 7 - 6 - { 3 ; 2 } ] - - log/DUP (exit) @ location: 29 - [ 7 - 6 - { 3 ; 2 } ] - - DUP (entry) @ location: 31 - [ 7 - 6 - { 3 ; 2 } ] - - log/DIP (exit) @ location: 31 - [ 7 - 7 - 6 - { 3 ; 2 } ] - - DIP (entry) @ location: 32 - [ 7 - 7 - 6 - { 3 ; 2 } ] - - log/DUP (exit) @ location: 32 - [ 6 - { 3 ; 2 } ] - - DUP (entry) @ location: 35 - [ 6 - { 3 ; 2 } ] - - log/[halt] (exit) @ location: 35 - [ 6 - 6 - { 3 ; 2 } ] - - [halt] (entry) @ location: 35 - [ 6 - 6 - { 3 ; 2 } ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 6 - 6 - { 3 ; 2 } ] - - log/PUSH (exit) @ location: 32 - [ 7 - 6 - 6 - { 3 ; 2 } ] - - PUSH (entry) @ location: 32 - [ 7 - 6 - 6 - { 3 ; 2 } ] - - log/log/log/DIP (exit) @ location: 32 - [ 7 - 7 - 6 - 6 - { 3 ; 2 } ] - - log/DIP (exit) @ location: 32 - [ 7 - 7 - 6 - 6 - { 3 ; 2 } ] - - DIP (entry) @ location: 36 - [ 7 - 7 - 6 - 6 - { 3 ; 2 } ] - - log/COMPARE (exit) @ location: 36 - [ 7 - 6 - 6 - { 3 ; 2 } ] - - COMPARE (entry) @ location: 39 - [ 7 - 6 - 6 - { 3 ; 2 } ] - - log/LT (exit) @ location: 39 - [ 1 - 6 - { 3 ; 2 } ] - - LT (entry) @ location: 40 - [ 1 - 6 - { 3 ; 2 } ] - - log/[halt] (exit) @ location: 40 - [ False - 6 - { 3 ; 2 } ] - - [halt] (entry) @ location: 38 - [ False - 6 - { 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 7 - False - 6 - { 3 ; 2 } ] - - SWAP (entry) @ location: 41 - [ 7 - False - 6 - { 3 ; 2 } ] - - log/[halt] (exit) @ location: 41 - [ False - 7 - 6 - { 3 ; 2 } ] - - [halt] (entry) @ location: 30 - [ False - 7 - 6 - { 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ { 8 } - False - 7 - 6 - { 3 ; 2 } ] - - SWAP (entry) @ location: 42 - [ { 8 } - False - 7 - 6 - { 3 ; 2 } ] - - log/IF (exit) @ location: 42 - [ False - { 8 } - 7 - 6 - { 3 ; 2 } ] - - IF (entry) @ location: 43 - [ False - { 8 } - 7 - 6 - { 3 ; 2 } ] - - log/SWAP (exit) @ location: 43 - [ { 8 } - 7 - 6 - { 3 ; 2 } ] - - SWAP (entry) @ location: 55 - [ { 8 } - 7 - 6 - { 3 ; 2 } ] - - log/CONS (exit) @ location: 55 - [ 7 - { 8 } - 6 - { 3 ; 2 } ] - - CONS (entry) @ location: 56 - [ 7 - { 8 } - 6 - { 3 ; 2 } ] - - log/PUSH (exit) @ location: 56 - [ { 7 ; 8 } - 6 - { 3 ; 2 } ] - - PUSH (entry) @ location: 57 - [ { 7 ; 8 } - 6 - { 3 ; 2 } ] - - log/[halt] (exit) @ location: 57 - [ False - { 7 ; 8 } - 6 - { 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ False - { 7 ; 8 } - 6 - { 3 ; 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ False - { 7 ; 8 } - 6 - { 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ False - { 7 ; 8 } - 6 - { 3 ; 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ False - { 7 ; 8 } - 6 - { 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ False - { 7 ; 8 } - 6 - { 3 ; 2 } ] - - control: KLoop_in - - control: KCons - - log/SWAP (exit) @ location: 66 - [ { 7 ; 8 } - 6 - { 3 ; 2 } ] - - SWAP (entry) @ location: 66 - [ { 7 ; 8 } - 6 - { 3 ; 2 } ] - - log/CONS (exit) @ location: 66 - [ 6 - { 7 ; 8 } - { 3 ; 2 } ] - - CONS (entry) @ location: 67 - [ 6 - { 7 ; 8 } - { 3 ; 2 } ] - - log/SWAP (exit) @ location: 67 - [ { 6 ; 7 ; 8 } - { 3 ; 2 } ] - - SWAP (entry) @ location: 68 - [ { 6 ; 7 ; 8 } - { 3 ; 2 } ] - - log/ITER (exit) @ location: 68 - [ { 3 ; 2 } - { 6 ; 7 ; 8 } ] - - ITER (entry) @ location: 69 - [ { 3 ; 2 } - { 6 ; 7 ; 8 } ] - - control: KIter - - log/CONS (exit) @ location: 69 - [ 3 - { 6 ; 7 ; 8 } ] - - CONS (entry) @ location: 71 - [ 3 - { 6 ; 7 ; 8 } ] - - log/[halt] (exit) @ location: 71 - [ { 3 ; 6 ; 7 ; 8 } ] - - [halt] (entry) @ location: 69 - [ { 3 ; 6 ; 7 ; 8 } ] - - control: KIter - - log/CONS (exit) @ location: 69 - [ 2 - { 3 ; 6 ; 7 ; 8 } ] - - CONS (entry) @ location: 71 - [ 2 - { 3 ; 6 ; 7 ; 8 } ] - - log/[halt] (exit) @ location: 71 - [ { 2 ; 3 ; 6 ; 7 ; 8 } ] - - [halt] (entry) @ location: 69 - [ { 2 ; 3 ; 6 ; 7 ; 8 } ] - - control: KIter - - control: KCons - - log/[halt] (exit) @ location: 69 - [ { 2 ; 3 ; 6 ; 7 ; 8 } ] - - [halt] (entry) @ location: 13 - [ { 2 ; 3 ; 6 ; 7 ; 8 } ] - - control: KIter - - log/SWAP (exit) @ location: 13 - [ 9 - { 2 ; 3 ; 6 ; 7 ; 8 } ] - - SWAP (entry) @ location: 15 - [ 9 - { 2 ; 3 ; 6 ; 7 ; 8 } ] - - log/DIP (exit) @ location: 15 - [ { 2 ; 3 ; 6 ; 7 ; 8 } - 9 ] - - DIP (entry) @ location: 16 - [ { 2 ; 3 ; 6 ; 7 ; 8 } - 9 ] - - log/NIL (exit) @ location: 16 - [ ] - - NIL (entry) @ location: 19 - [ ] - - log/[halt] (exit) @ location: 19 - [ {} ] - - [halt] (entry) @ location: 19 - [ {} ] - - control: KCons - - PUSH (entry) @ location: 16 - [ {} ] - - log/PUSH (exit) @ location: 16 - [ 9 - {} ] - - PUSH (entry) @ location: 16 - [ 9 - {} ] - - log/log/log/PUSH (exit) @ location: 16 - [ { 2 ; 3 ; 6 ; 7 ; 8 } - 9 - {} ] - - log/PUSH (exit) @ location: 16 - [ { 2 ; 3 ; 6 ; 7 ; 8 } - 9 - {} ] - - PUSH (entry) @ location: 21 - [ { 2 ; 3 ; 6 ; 7 ; 8 } - 9 - {} ] - - log/LOOP (exit) @ location: 21 - [ True - { 2 ; 3 ; 6 ; 7 ; 8 } - 9 - {} ] - - LOOP (entry) @ location: 66 - [ True - { 2 ; 3 ; 6 ; 7 ; 8 } - 9 - {} ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 2 ; 3 ; 6 ; 7 ; 8 } - 9 - {} ] - - IF_CONS (entry) @ location: 26 - [ { 2 ; 3 ; 6 ; 7 ; 8 } - 9 - {} ] - - log/SWAP (exit) @ location: 26 - [ 2 - { 3 ; 6 ; 7 ; 8 } - 9 - {} ] - - SWAP (entry) @ location: 28 - [ 2 - { 3 ; 6 ; 7 ; 8 } - 9 - {} ] - - log/DIP (exit) @ location: 28 - [ { 3 ; 6 ; 7 ; 8 } - 2 - 9 - {} ] - - DIP (entry) @ location: 29 - [ { 3 ; 6 ; 7 ; 8 } - 2 - 9 - {} ] - - log/DUP (exit) @ location: 29 - [ 2 - 9 - {} ] - - DUP (entry) @ location: 31 - [ 2 - 9 - {} ] - - log/DIP (exit) @ location: 31 - [ 2 - 2 - 9 - {} ] - - DIP (entry) @ location: 32 - [ 2 - 2 - 9 - {} ] - - log/DUP (exit) @ location: 32 - [ 9 - {} ] - - DUP (entry) @ location: 35 - [ 9 - {} ] - - log/[halt] (exit) @ location: 35 - [ 9 - 9 - {} ] - - [halt] (entry) @ location: 35 - [ 9 - 9 - {} ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 9 - 9 - {} ] - - log/PUSH (exit) @ location: 32 - [ 2 - 9 - 9 - {} ] - - PUSH (entry) @ location: 32 - [ 2 - 9 - 9 - {} ] - - log/log/log/DIP (exit) @ location: 32 - [ 2 - 2 - 9 - 9 - {} ] - - log/DIP (exit) @ location: 32 - [ 2 - 2 - 9 - 9 - {} ] - - DIP (entry) @ location: 36 - [ 2 - 2 - 9 - 9 - {} ] - - log/COMPARE (exit) @ location: 36 - [ 2 - 9 - 9 - {} ] - - COMPARE (entry) @ location: 39 - [ 2 - 9 - 9 - {} ] - - log/LT (exit) @ location: 39 - [ -1 - 9 - {} ] - - LT (entry) @ location: 40 - [ -1 - 9 - {} ] - - log/[halt] (exit) @ location: 40 - [ True - 9 - {} ] - - [halt] (entry) @ location: 38 - [ True - 9 - {} ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 2 - True - 9 - {} ] - - SWAP (entry) @ location: 41 - [ 2 - True - 9 - {} ] - - log/[halt] (exit) @ location: 41 - [ True - 2 - 9 - {} ] - - [halt] (entry) @ location: 30 - [ True - 2 - 9 - {} ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ { 3 ; 6 ; 7 ; 8 } - True - 2 - 9 - {} ] - - SWAP (entry) @ location: 42 - [ { 3 ; 6 ; 7 ; 8 } - True - 2 - 9 - {} ] - - log/IF (exit) @ location: 42 - [ True - { 3 ; 6 ; 7 ; 8 } - 2 - 9 - {} ] - - IF (entry) @ location: 43 - [ True - { 3 ; 6 ; 7 ; 8 } - 2 - 9 - {} ] - - log/DIP (exit) @ location: 43 - [ { 3 ; 6 ; 7 ; 8 } - 2 - 9 - {} ] - - DIP (entry) @ location: 45 - [ { 3 ; 6 ; 7 ; 8 } - 2 - 9 - {} ] - - log/SWAP (exit) @ location: 45 - [ 2 - 9 - {} ] - - SWAP (entry) @ location: 47 - [ 2 - 9 - {} ] - - log/DIP (exit) @ location: 47 - [ 9 - 2 - {} ] - - DIP (entry) @ location: 48 - [ 9 - 2 - {} ] - - log/CONS (exit) @ location: 48 - [ 2 - {} ] - - CONS (entry) @ location: 50 - [ 2 - {} ] - - log/[halt] (exit) @ location: 50 - [ { 2 } ] - - [halt] (entry) @ location: 50 - [ { 2 } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 48 - [ 9 - { 2 } ] - - [halt] (entry) @ location: 46 - [ 9 - { 2 } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 45 - [ { 3 ; 6 ; 7 ; 8 } - 9 - { 2 } ] - - PUSH (entry) @ location: 51 - [ { 3 ; 6 ; 7 ; 8 } - 9 - { 2 } ] - - log/[halt] (exit) @ location: 51 - [ True - { 3 ; 6 ; 7 ; 8 } - 9 - { 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 3 ; 6 ; 7 ; 8 } - 9 - { 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ True - { 3 ; 6 ; 7 ; 8 } - 9 - { 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 3 ; 6 ; 7 ; 8 } - 9 - { 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ True - { 3 ; 6 ; 7 ; 8 } - 9 - { 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 3 ; 6 ; 7 ; 8 } - 9 - { 2 } ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 3 ; 6 ; 7 ; 8 } - 9 - { 2 } ] - - IF_CONS (entry) @ location: 26 - [ { 3 ; 6 ; 7 ; 8 } - 9 - { 2 } ] - - log/SWAP (exit) @ location: 26 - [ 3 - { 6 ; 7 ; 8 } - 9 - { 2 } ] - - SWAP (entry) @ location: 28 - [ 3 - { 6 ; 7 ; 8 } - 9 - { 2 } ] - - log/DIP (exit) @ location: 28 - [ { 6 ; 7 ; 8 } - 3 - 9 - { 2 } ] - - DIP (entry) @ location: 29 - [ { 6 ; 7 ; 8 } - 3 - 9 - { 2 } ] - - log/DUP (exit) @ location: 29 - [ 3 - 9 - { 2 } ] - - DUP (entry) @ location: 31 - [ 3 - 9 - { 2 } ] - - log/DIP (exit) @ location: 31 - [ 3 - 3 - 9 - { 2 } ] - - DIP (entry) @ location: 32 - [ 3 - 3 - 9 - { 2 } ] - - log/DUP (exit) @ location: 32 - [ 9 - { 2 } ] - - DUP (entry) @ location: 35 - [ 9 - { 2 } ] - - log/[halt] (exit) @ location: 35 - [ 9 - 9 - { 2 } ] - - [halt] (entry) @ location: 35 - [ 9 - 9 - { 2 } ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 9 - 9 - { 2 } ] - - log/PUSH (exit) @ location: 32 - [ 3 - 9 - 9 - { 2 } ] - - PUSH (entry) @ location: 32 - [ 3 - 9 - 9 - { 2 } ] - - log/log/log/DIP (exit) @ location: 32 - [ 3 - 3 - 9 - 9 - { 2 } ] - - log/DIP (exit) @ location: 32 - [ 3 - 3 - 9 - 9 - { 2 } ] - - DIP (entry) @ location: 36 - [ 3 - 3 - 9 - 9 - { 2 } ] - - log/COMPARE (exit) @ location: 36 - [ 3 - 9 - 9 - { 2 } ] - - COMPARE (entry) @ location: 39 - [ 3 - 9 - 9 - { 2 } ] - - log/LT (exit) @ location: 39 - [ -1 - 9 - { 2 } ] - - LT (entry) @ location: 40 - [ -1 - 9 - { 2 } ] - - log/[halt] (exit) @ location: 40 - [ True - 9 - { 2 } ] - - [halt] (entry) @ location: 38 - [ True - 9 - { 2 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 3 - True - 9 - { 2 } ] - - SWAP (entry) @ location: 41 - [ 3 - True - 9 - { 2 } ] - - log/[halt] (exit) @ location: 41 - [ True - 3 - 9 - { 2 } ] - - [halt] (entry) @ location: 30 - [ True - 3 - 9 - { 2 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ { 6 ; 7 ; 8 } - True - 3 - 9 - { 2 } ] - - SWAP (entry) @ location: 42 - [ { 6 ; 7 ; 8 } - True - 3 - 9 - { 2 } ] - - log/IF (exit) @ location: 42 - [ True - { 6 ; 7 ; 8 } - 3 - 9 - { 2 } ] - - IF (entry) @ location: 43 - [ True - { 6 ; 7 ; 8 } - 3 - 9 - { 2 } ] - - log/DIP (exit) @ location: 43 - [ { 6 ; 7 ; 8 } - 3 - 9 - { 2 } ] - - DIP (entry) @ location: 45 - [ { 6 ; 7 ; 8 } - 3 - 9 - { 2 } ] - - log/SWAP (exit) @ location: 45 - [ 3 - 9 - { 2 } ] - - SWAP (entry) @ location: 47 - [ 3 - 9 - { 2 } ] - - log/DIP (exit) @ location: 47 - [ 9 - 3 - { 2 } ] - - DIP (entry) @ location: 48 - [ 9 - 3 - { 2 } ] - - log/CONS (exit) @ location: 48 - [ 3 - { 2 } ] - - CONS (entry) @ location: 50 - [ 3 - { 2 } ] - - log/[halt] (exit) @ location: 50 - [ { 3 ; 2 } ] - - [halt] (entry) @ location: 50 - [ { 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 48 - [ 9 - { 3 ; 2 } ] - - [halt] (entry) @ location: 46 - [ 9 - { 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 45 - [ { 6 ; 7 ; 8 } - 9 - { 3 ; 2 } ] - - PUSH (entry) @ location: 51 - [ { 6 ; 7 ; 8 } - 9 - { 3 ; 2 } ] - - log/[halt] (exit) @ location: 51 - [ True - { 6 ; 7 ; 8 } - 9 - { 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 6 ; 7 ; 8 } - 9 - { 3 ; 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ True - { 6 ; 7 ; 8 } - 9 - { 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 6 ; 7 ; 8 } - 9 - { 3 ; 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ True - { 6 ; 7 ; 8 } - 9 - { 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 6 ; 7 ; 8 } - 9 - { 3 ; 2 } ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 6 ; 7 ; 8 } - 9 - { 3 ; 2 } ] - - IF_CONS (entry) @ location: 26 - [ { 6 ; 7 ; 8 } - 9 - { 3 ; 2 } ] - - log/SWAP (exit) @ location: 26 - [ 6 - { 7 ; 8 } - 9 - { 3 ; 2 } ] - - SWAP (entry) @ location: 28 - [ 6 - { 7 ; 8 } - 9 - { 3 ; 2 } ] - - log/DIP (exit) @ location: 28 - [ { 7 ; 8 } - 6 - 9 - { 3 ; 2 } ] - - DIP (entry) @ location: 29 - [ { 7 ; 8 } - 6 - 9 - { 3 ; 2 } ] - - log/DUP (exit) @ location: 29 - [ 6 - 9 - { 3 ; 2 } ] - - DUP (entry) @ location: 31 - [ 6 - 9 - { 3 ; 2 } ] - - log/DIP (exit) @ location: 31 - [ 6 - 6 - 9 - { 3 ; 2 } ] - - DIP (entry) @ location: 32 - [ 6 - 6 - 9 - { 3 ; 2 } ] - - log/DUP (exit) @ location: 32 - [ 9 - { 3 ; 2 } ] - - DUP (entry) @ location: 35 - [ 9 - { 3 ; 2 } ] - - log/[halt] (exit) @ location: 35 - [ 9 - 9 - { 3 ; 2 } ] - - [halt] (entry) @ location: 35 - [ 9 - 9 - { 3 ; 2 } ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 9 - 9 - { 3 ; 2 } ] - - log/PUSH (exit) @ location: 32 - [ 6 - 9 - 9 - { 3 ; 2 } ] - - PUSH (entry) @ location: 32 - [ 6 - 9 - 9 - { 3 ; 2 } ] - - log/log/log/DIP (exit) @ location: 32 - [ 6 - 6 - 9 - 9 - { 3 ; 2 } ] - - log/DIP (exit) @ location: 32 - [ 6 - 6 - 9 - 9 - { 3 ; 2 } ] - - DIP (entry) @ location: 36 - [ 6 - 6 - 9 - 9 - { 3 ; 2 } ] - - log/COMPARE (exit) @ location: 36 - [ 6 - 9 - 9 - { 3 ; 2 } ] - - COMPARE (entry) @ location: 39 - [ 6 - 9 - 9 - { 3 ; 2 } ] - - log/LT (exit) @ location: 39 - [ -1 - 9 - { 3 ; 2 } ] - - LT (entry) @ location: 40 - [ -1 - 9 - { 3 ; 2 } ] - - log/[halt] (exit) @ location: 40 - [ True - 9 - { 3 ; 2 } ] - - [halt] (entry) @ location: 38 - [ True - 9 - { 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 6 - True - 9 - { 3 ; 2 } ] - - SWAP (entry) @ location: 41 - [ 6 - True - 9 - { 3 ; 2 } ] - - log/[halt] (exit) @ location: 41 - [ True - 6 - 9 - { 3 ; 2 } ] - - [halt] (entry) @ location: 30 - [ True - 6 - 9 - { 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ { 7 ; 8 } - True - 6 - 9 - { 3 ; 2 } ] - - SWAP (entry) @ location: 42 - [ { 7 ; 8 } - True - 6 - 9 - { 3 ; 2 } ] - - log/IF (exit) @ location: 42 - [ True - { 7 ; 8 } - 6 - 9 - { 3 ; 2 } ] - - IF (entry) @ location: 43 - [ True - { 7 ; 8 } - 6 - 9 - { 3 ; 2 } ] - - log/DIP (exit) @ location: 43 - [ { 7 ; 8 } - 6 - 9 - { 3 ; 2 } ] - - DIP (entry) @ location: 45 - [ { 7 ; 8 } - 6 - 9 - { 3 ; 2 } ] - - log/SWAP (exit) @ location: 45 - [ 6 - 9 - { 3 ; 2 } ] - - SWAP (entry) @ location: 47 - [ 6 - 9 - { 3 ; 2 } ] - - log/DIP (exit) @ location: 47 - [ 9 - 6 - { 3 ; 2 } ] - - DIP (entry) @ location: 48 - [ 9 - 6 - { 3 ; 2 } ] - - log/CONS (exit) @ location: 48 - [ 6 - { 3 ; 2 } ] - - CONS (entry) @ location: 50 - [ 6 - { 3 ; 2 } ] - - log/[halt] (exit) @ location: 50 - [ { 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 50 - [ { 6 ; 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 48 - [ 9 - { 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 46 - [ 9 - { 6 ; 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 45 - [ { 7 ; 8 } - 9 - { 6 ; 3 ; 2 } ] - - PUSH (entry) @ location: 51 - [ { 7 ; 8 } - 9 - { 6 ; 3 ; 2 } ] - - log/[halt] (exit) @ location: 51 - [ True - { 7 ; 8 } - 9 - { 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 7 ; 8 } - 9 - { 6 ; 3 ; 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ True - { 7 ; 8 } - 9 - { 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 7 ; 8 } - 9 - { 6 ; 3 ; 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ True - { 7 ; 8 } - 9 - { 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 7 ; 8 } - 9 - { 6 ; 3 ; 2 } ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 7 ; 8 } - 9 - { 6 ; 3 ; 2 } ] - - IF_CONS (entry) @ location: 26 - [ { 7 ; 8 } - 9 - { 6 ; 3 ; 2 } ] - - log/SWAP (exit) @ location: 26 - [ 7 - { 8 } - 9 - { 6 ; 3 ; 2 } ] - - SWAP (entry) @ location: 28 - [ 7 - { 8 } - 9 - { 6 ; 3 ; 2 } ] - - log/DIP (exit) @ location: 28 - [ { 8 } - 7 - 9 - { 6 ; 3 ; 2 } ] - - DIP (entry) @ location: 29 - [ { 8 } - 7 - 9 - { 6 ; 3 ; 2 } ] - - log/DUP (exit) @ location: 29 - [ 7 - 9 - { 6 ; 3 ; 2 } ] - - DUP (entry) @ location: 31 - [ 7 - 9 - { 6 ; 3 ; 2 } ] - - log/DIP (exit) @ location: 31 - [ 7 - 7 - 9 - { 6 ; 3 ; 2 } ] - - DIP (entry) @ location: 32 - [ 7 - 7 - 9 - { 6 ; 3 ; 2 } ] - - log/DUP (exit) @ location: 32 - [ 9 - { 6 ; 3 ; 2 } ] - - DUP (entry) @ location: 35 - [ 9 - { 6 ; 3 ; 2 } ] - - log/[halt] (exit) @ location: 35 - [ 9 - 9 - { 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 35 - [ 9 - 9 - { 6 ; 3 ; 2 } ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 9 - 9 - { 6 ; 3 ; 2 } ] - - log/PUSH (exit) @ location: 32 - [ 7 - 9 - 9 - { 6 ; 3 ; 2 } ] - - PUSH (entry) @ location: 32 - [ 7 - 9 - 9 - { 6 ; 3 ; 2 } ] - - log/log/log/DIP (exit) @ location: 32 - [ 7 - 7 - 9 - 9 - { 6 ; 3 ; 2 } ] - - log/DIP (exit) @ location: 32 - [ 7 - 7 - 9 - 9 - { 6 ; 3 ; 2 } ] - - DIP (entry) @ location: 36 - [ 7 - 7 - 9 - 9 - { 6 ; 3 ; 2 } ] - - log/COMPARE (exit) @ location: 36 - [ 7 - 9 - 9 - { 6 ; 3 ; 2 } ] - - COMPARE (entry) @ location: 39 - [ 7 - 9 - 9 - { 6 ; 3 ; 2 } ] - - log/LT (exit) @ location: 39 - [ -1 - 9 - { 6 ; 3 ; 2 } ] - - LT (entry) @ location: 40 - [ -1 - 9 - { 6 ; 3 ; 2 } ] - - log/[halt] (exit) @ location: 40 - [ True - 9 - { 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 38 - [ True - 9 - { 6 ; 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 7 - True - 9 - { 6 ; 3 ; 2 } ] - - SWAP (entry) @ location: 41 - [ 7 - True - 9 - { 6 ; 3 ; 2 } ] - - log/[halt] (exit) @ location: 41 - [ True - 7 - 9 - { 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 30 - [ True - 7 - 9 - { 6 ; 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ { 8 } - True - 7 - 9 - { 6 ; 3 ; 2 } ] - - SWAP (entry) @ location: 42 - [ { 8 } - True - 7 - 9 - { 6 ; 3 ; 2 } ] - - log/IF (exit) @ location: 42 - [ True - { 8 } - 7 - 9 - { 6 ; 3 ; 2 } ] - - IF (entry) @ location: 43 - [ True - { 8 } - 7 - 9 - { 6 ; 3 ; 2 } ] - - log/DIP (exit) @ location: 43 - [ { 8 } - 7 - 9 - { 6 ; 3 ; 2 } ] - - DIP (entry) @ location: 45 - [ { 8 } - 7 - 9 - { 6 ; 3 ; 2 } ] - - log/SWAP (exit) @ location: 45 - [ 7 - 9 - { 6 ; 3 ; 2 } ] - - SWAP (entry) @ location: 47 - [ 7 - 9 - { 6 ; 3 ; 2 } ] - - log/DIP (exit) @ location: 47 - [ 9 - 7 - { 6 ; 3 ; 2 } ] - - DIP (entry) @ location: 48 - [ 9 - 7 - { 6 ; 3 ; 2 } ] - - log/CONS (exit) @ location: 48 - [ 7 - { 6 ; 3 ; 2 } ] - - CONS (entry) @ location: 50 - [ 7 - { 6 ; 3 ; 2 } ] - - log/[halt] (exit) @ location: 50 - [ { 7 ; 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 50 - [ { 7 ; 6 ; 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 48 - [ 9 - { 7 ; 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 46 - [ 9 - { 7 ; 6 ; 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 45 - [ { 8 } - 9 - { 7 ; 6 ; 3 ; 2 } ] - - PUSH (entry) @ location: 51 - [ { 8 } - 9 - { 7 ; 6 ; 3 ; 2 } ] - - log/[halt] (exit) @ location: 51 - [ True - { 8 } - 9 - { 7 ; 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 8 } - 9 - { 7 ; 6 ; 3 ; 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ True - { 8 } - 9 - { 7 ; 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 8 } - 9 - { 7 ; 6 ; 3 ; 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ True - { 8 } - 9 - { 7 ; 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 8 } - 9 - { 7 ; 6 ; 3 ; 2 } ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 8 } - 9 - { 7 ; 6 ; 3 ; 2 } ] - - IF_CONS (entry) @ location: 26 - [ { 8 } - 9 - { 7 ; 6 ; 3 ; 2 } ] - - log/SWAP (exit) @ location: 26 - [ 8 - {} - 9 - { 7 ; 6 ; 3 ; 2 } ] - - SWAP (entry) @ location: 28 - [ 8 - {} - 9 - { 7 ; 6 ; 3 ; 2 } ] - - log/DIP (exit) @ location: 28 - [ {} - 8 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - DIP (entry) @ location: 29 - [ {} - 8 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - log/DUP (exit) @ location: 29 - [ 8 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - DUP (entry) @ location: 31 - [ 8 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - log/DIP (exit) @ location: 31 - [ 8 - 8 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - DIP (entry) @ location: 32 - [ 8 - 8 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - log/DUP (exit) @ location: 32 - [ 9 - { 7 ; 6 ; 3 ; 2 } ] - - DUP (entry) @ location: 35 - [ 9 - { 7 ; 6 ; 3 ; 2 } ] - - log/[halt] (exit) @ location: 35 - [ 9 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 35 - [ 9 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 9 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - log/PUSH (exit) @ location: 32 - [ 8 - 9 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - PUSH (entry) @ location: 32 - [ 8 - 9 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - log/log/log/DIP (exit) @ location: 32 - [ 8 - 8 - 9 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - log/DIP (exit) @ location: 32 - [ 8 - 8 - 9 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - DIP (entry) @ location: 36 - [ 8 - 8 - 9 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - log/COMPARE (exit) @ location: 36 - [ 8 - 9 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - COMPARE (entry) @ location: 39 - [ 8 - 9 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - log/LT (exit) @ location: 39 - [ -1 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - LT (entry) @ location: 40 - [ -1 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - log/[halt] (exit) @ location: 40 - [ True - 9 - { 7 ; 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 38 - [ True - 9 - { 7 ; 6 ; 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 8 - True - 9 - { 7 ; 6 ; 3 ; 2 } ] - - SWAP (entry) @ location: 41 - [ 8 - True - 9 - { 7 ; 6 ; 3 ; 2 } ] - - log/[halt] (exit) @ location: 41 - [ True - 8 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 30 - [ True - 8 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ {} - True - 8 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - SWAP (entry) @ location: 42 - [ {} - True - 8 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - log/IF (exit) @ location: 42 - [ True - {} - 8 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - IF (entry) @ location: 43 - [ True - {} - 8 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - log/DIP (exit) @ location: 43 - [ {} - 8 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - DIP (entry) @ location: 45 - [ {} - 8 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - log/SWAP (exit) @ location: 45 - [ 8 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - SWAP (entry) @ location: 47 - [ 8 - 9 - { 7 ; 6 ; 3 ; 2 } ] - - log/DIP (exit) @ location: 47 - [ 9 - 8 - { 7 ; 6 ; 3 ; 2 } ] - - DIP (entry) @ location: 48 - [ 9 - 8 - { 7 ; 6 ; 3 ; 2 } ] - - log/CONS (exit) @ location: 48 - [ 8 - { 7 ; 6 ; 3 ; 2 } ] - - CONS (entry) @ location: 50 - [ 8 - { 7 ; 6 ; 3 ; 2 } ] - - log/[halt] (exit) @ location: 50 - [ { 8 ; 7 ; 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 50 - [ { 8 ; 7 ; 6 ; 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 48 - [ 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 46 - [ 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 45 - [ {} - 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - PUSH (entry) @ location: 51 - [ {} - 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - log/[halt] (exit) @ location: 51 - [ True - {} - 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ True - {} - 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ True - {} - 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ True - {} - 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ True - {} - 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ True - {} - 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ {} - 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - IF_CONS (entry) @ location: 26 - [ {} - 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - log/NIL (exit) @ location: 26 - [ 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - NIL (entry) @ location: 61 - [ 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - log/PUSH (exit) @ location: 61 - [ {} - 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - PUSH (entry) @ location: 63 - [ {} - 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - log/[halt] (exit) @ location: 63 - [ False - {} - 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ False - {} - 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ False - {} - 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ False - {} - 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - control: KLoop_in - - control: KCons - - log/SWAP (exit) @ location: 66 - [ {} - 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - SWAP (entry) @ location: 66 - [ {} - 9 - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - log/CONS (exit) @ location: 66 - [ 9 - {} - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - CONS (entry) @ location: 67 - [ 9 - {} - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - log/SWAP (exit) @ location: 67 - [ { 9 } - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - SWAP (entry) @ location: 68 - [ { 9 } - { 8 ; 7 ; 6 ; 3 ; 2 } ] - - log/ITER (exit) @ location: 68 - [ { 8 ; 7 ; 6 ; 3 ; 2 } - { 9 } ] - - ITER (entry) @ location: 69 - [ { 8 ; 7 ; 6 ; 3 ; 2 } - { 9 } ] - - control: KIter - - log/CONS (exit) @ location: 69 - [ 8 - { 9 } ] - - CONS (entry) @ location: 71 - [ 8 - { 9 } ] - - log/[halt] (exit) @ location: 71 - [ { 8 ; 9 } ] - - [halt] (entry) @ location: 69 - [ { 8 ; 9 } ] - - control: KIter - - log/CONS (exit) @ location: 69 - [ 7 - { 8 ; 9 } ] - - CONS (entry) @ location: 71 - [ 7 - { 8 ; 9 } ] - - log/[halt] (exit) @ location: 71 - [ { 7 ; 8 ; 9 } ] - - [halt] (entry) @ location: 69 - [ { 7 ; 8 ; 9 } ] - - control: KIter - - log/CONS (exit) @ location: 69 - [ 6 - { 7 ; 8 ; 9 } ] - - CONS (entry) @ location: 71 - [ 6 - { 7 ; 8 ; 9 } ] - - log/[halt] (exit) @ location: 71 - [ { 6 ; 7 ; 8 ; 9 } ] - - [halt] (entry) @ location: 69 - [ { 6 ; 7 ; 8 ; 9 } ] - - control: KIter - - log/CONS (exit) @ location: 69 - [ 3 - { 6 ; 7 ; 8 ; 9 } ] - - CONS (entry) @ location: 71 - [ 3 - { 6 ; 7 ; 8 ; 9 } ] - - log/[halt] (exit) @ location: 71 - [ { 3 ; 6 ; 7 ; 8 ; 9 } ] - - [halt] (entry) @ location: 69 - [ { 3 ; 6 ; 7 ; 8 ; 9 } ] - - control: KIter - - log/CONS (exit) @ location: 69 - [ 2 - { 3 ; 6 ; 7 ; 8 ; 9 } ] - - CONS (entry) @ location: 71 - [ 2 - { 3 ; 6 ; 7 ; 8 ; 9 } ] - - log/[halt] (exit) @ location: 71 - [ { 2 ; 3 ; 6 ; 7 ; 8 ; 9 } ] - - [halt] (entry) @ location: 69 - [ { 2 ; 3 ; 6 ; 7 ; 8 ; 9 } ] - - control: KIter - - control: KCons - - log/[halt] (exit) @ location: 69 - [ { 2 ; 3 ; 6 ; 7 ; 8 ; 9 } ] - - [halt] (entry) @ location: 13 - [ { 2 ; 3 ; 6 ; 7 ; 8 ; 9 } ] - - control: KIter - - log/SWAP (exit) @ location: 13 - [ 5 - { 2 ; 3 ; 6 ; 7 ; 8 ; 9 } ] - - SWAP (entry) @ location: 15 - [ 5 - { 2 ; 3 ; 6 ; 7 ; 8 ; 9 } ] - - log/DIP (exit) @ location: 15 - [ { 2 ; 3 ; 6 ; 7 ; 8 ; 9 } - 5 ] - - DIP (entry) @ location: 16 - [ { 2 ; 3 ; 6 ; 7 ; 8 ; 9 } - 5 ] - - log/NIL (exit) @ location: 16 - [ ] - - NIL (entry) @ location: 19 - [ ] - - log/[halt] (exit) @ location: 19 - [ {} ] - - [halt] (entry) @ location: 19 - [ {} ] - - control: KCons - - PUSH (entry) @ location: 16 - [ {} ] - - log/PUSH (exit) @ location: 16 - [ 5 - {} ] - - PUSH (entry) @ location: 16 - [ 5 - {} ] - - log/log/log/PUSH (exit) @ location: 16 - [ { 2 ; 3 ; 6 ; 7 ; 8 ; 9 } - 5 - {} ] - - log/PUSH (exit) @ location: 16 - [ { 2 ; 3 ; 6 ; 7 ; 8 ; 9 } - 5 - {} ] - - PUSH (entry) @ location: 21 - [ { 2 ; 3 ; 6 ; 7 ; 8 ; 9 } - 5 - {} ] - - log/LOOP (exit) @ location: 21 - [ True - { 2 ; 3 ; 6 ; 7 ; 8 ; 9 } - 5 - {} ] - - LOOP (entry) @ location: 66 - [ True - { 2 ; 3 ; 6 ; 7 ; 8 ; 9 } - 5 - {} ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 2 ; 3 ; 6 ; 7 ; 8 ; 9 } - 5 - {} ] - - IF_CONS (entry) @ location: 26 - [ { 2 ; 3 ; 6 ; 7 ; 8 ; 9 } - 5 - {} ] - - log/SWAP (exit) @ location: 26 - [ 2 - { 3 ; 6 ; 7 ; 8 ; 9 } - 5 - {} ] - - SWAP (entry) @ location: 28 - [ 2 - { 3 ; 6 ; 7 ; 8 ; 9 } - 5 - {} ] - - log/DIP (exit) @ location: 28 - [ { 3 ; 6 ; 7 ; 8 ; 9 } - 2 - 5 - {} ] - - DIP (entry) @ location: 29 - [ { 3 ; 6 ; 7 ; 8 ; 9 } - 2 - 5 - {} ] - - log/DUP (exit) @ location: 29 - [ 2 - 5 - {} ] - - DUP (entry) @ location: 31 - [ 2 - 5 - {} ] - - log/DIP (exit) @ location: 31 - [ 2 - 2 - 5 - {} ] - - DIP (entry) @ location: 32 - [ 2 - 2 - 5 - {} ] - - log/DUP (exit) @ location: 32 - [ 5 - {} ] - - DUP (entry) @ location: 35 - [ 5 - {} ] - - log/[halt] (exit) @ location: 35 - [ 5 - 5 - {} ] - - [halt] (entry) @ location: 35 - [ 5 - 5 - {} ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 5 - 5 - {} ] - - log/PUSH (exit) @ location: 32 - [ 2 - 5 - 5 - {} ] - - PUSH (entry) @ location: 32 - [ 2 - 5 - 5 - {} ] - - log/log/log/DIP (exit) @ location: 32 - [ 2 - 2 - 5 - 5 - {} ] - - log/DIP (exit) @ location: 32 - [ 2 - 2 - 5 - 5 - {} ] - - DIP (entry) @ location: 36 - [ 2 - 2 - 5 - 5 - {} ] - - log/COMPARE (exit) @ location: 36 - [ 2 - 5 - 5 - {} ] - - COMPARE (entry) @ location: 39 - [ 2 - 5 - 5 - {} ] - - log/LT (exit) @ location: 39 - [ -1 - 5 - {} ] - - LT (entry) @ location: 40 - [ -1 - 5 - {} ] - - log/[halt] (exit) @ location: 40 - [ True - 5 - {} ] - - [halt] (entry) @ location: 38 - [ True - 5 - {} ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 2 - True - 5 - {} ] - - SWAP (entry) @ location: 41 - [ 2 - True - 5 - {} ] - - log/[halt] (exit) @ location: 41 - [ True - 2 - 5 - {} ] - - [halt] (entry) @ location: 30 - [ True - 2 - 5 - {} ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ { 3 ; 6 ; 7 ; 8 ; 9 } - True - 2 - 5 - {} ] - - SWAP (entry) @ location: 42 - [ { 3 ; 6 ; 7 ; 8 ; 9 } - True - 2 - 5 - {} ] - - log/IF (exit) @ location: 42 - [ True - { 3 ; 6 ; 7 ; 8 ; 9 } - 2 - 5 - {} ] - - IF (entry) @ location: 43 - [ True - { 3 ; 6 ; 7 ; 8 ; 9 } - 2 - 5 - {} ] - - log/DIP (exit) @ location: 43 - [ { 3 ; 6 ; 7 ; 8 ; 9 } - 2 - 5 - {} ] - - DIP (entry) @ location: 45 - [ { 3 ; 6 ; 7 ; 8 ; 9 } - 2 - 5 - {} ] - - log/SWAP (exit) @ location: 45 - [ 2 - 5 - {} ] - - SWAP (entry) @ location: 47 - [ 2 - 5 - {} ] - - log/DIP (exit) @ location: 47 - [ 5 - 2 - {} ] - - DIP (entry) @ location: 48 - [ 5 - 2 - {} ] - - log/CONS (exit) @ location: 48 - [ 2 - {} ] - - CONS (entry) @ location: 50 - [ 2 - {} ] - - log/[halt] (exit) @ location: 50 - [ { 2 } ] - - [halt] (entry) @ location: 50 - [ { 2 } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 48 - [ 5 - { 2 } ] - - [halt] (entry) @ location: 46 - [ 5 - { 2 } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 45 - [ { 3 ; 6 ; 7 ; 8 ; 9 } - 5 - { 2 } ] - - PUSH (entry) @ location: 51 - [ { 3 ; 6 ; 7 ; 8 ; 9 } - 5 - { 2 } ] - - log/[halt] (exit) @ location: 51 - [ True - { 3 ; 6 ; 7 ; 8 ; 9 } - 5 - { 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 3 ; 6 ; 7 ; 8 ; 9 } - 5 - { 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ True - { 3 ; 6 ; 7 ; 8 ; 9 } - 5 - { 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 3 ; 6 ; 7 ; 8 ; 9 } - 5 - { 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ True - { 3 ; 6 ; 7 ; 8 ; 9 } - 5 - { 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 3 ; 6 ; 7 ; 8 ; 9 } - 5 - { 2 } ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 3 ; 6 ; 7 ; 8 ; 9 } - 5 - { 2 } ] - - IF_CONS (entry) @ location: 26 - [ { 3 ; 6 ; 7 ; 8 ; 9 } - 5 - { 2 } ] - - log/SWAP (exit) @ location: 26 - [ 3 - { 6 ; 7 ; 8 ; 9 } - 5 - { 2 } ] - - SWAP (entry) @ location: 28 - [ 3 - { 6 ; 7 ; 8 ; 9 } - 5 - { 2 } ] - - log/DIP (exit) @ location: 28 - [ { 6 ; 7 ; 8 ; 9 } - 3 - 5 - { 2 } ] - - DIP (entry) @ location: 29 - [ { 6 ; 7 ; 8 ; 9 } - 3 - 5 - { 2 } ] - - log/DUP (exit) @ location: 29 - [ 3 - 5 - { 2 } ] - - DUP (entry) @ location: 31 - [ 3 - 5 - { 2 } ] - - log/DIP (exit) @ location: 31 - [ 3 - 3 - 5 - { 2 } ] - - DIP (entry) @ location: 32 - [ 3 - 3 - 5 - { 2 } ] - - log/DUP (exit) @ location: 32 - [ 5 - { 2 } ] - - DUP (entry) @ location: 35 - [ 5 - { 2 } ] - - log/[halt] (exit) @ location: 35 - [ 5 - 5 - { 2 } ] - - [halt] (entry) @ location: 35 - [ 5 - 5 - { 2 } ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 5 - 5 - { 2 } ] - - log/PUSH (exit) @ location: 32 - [ 3 - 5 - 5 - { 2 } ] - - PUSH (entry) @ location: 32 - [ 3 - 5 - 5 - { 2 } ] - - log/log/log/DIP (exit) @ location: 32 - [ 3 - 3 - 5 - 5 - { 2 } ] - - log/DIP (exit) @ location: 32 - [ 3 - 3 - 5 - 5 - { 2 } ] - - DIP (entry) @ location: 36 - [ 3 - 3 - 5 - 5 - { 2 } ] - - log/COMPARE (exit) @ location: 36 - [ 3 - 5 - 5 - { 2 } ] - - COMPARE (entry) @ location: 39 - [ 3 - 5 - 5 - { 2 } ] - - log/LT (exit) @ location: 39 - [ -1 - 5 - { 2 } ] - - LT (entry) @ location: 40 - [ -1 - 5 - { 2 } ] - - log/[halt] (exit) @ location: 40 - [ True - 5 - { 2 } ] - - [halt] (entry) @ location: 38 - [ True - 5 - { 2 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 3 - True - 5 - { 2 } ] - - SWAP (entry) @ location: 41 - [ 3 - True - 5 - { 2 } ] - - log/[halt] (exit) @ location: 41 - [ True - 3 - 5 - { 2 } ] - - [halt] (entry) @ location: 30 - [ True - 3 - 5 - { 2 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ { 6 ; 7 ; 8 ; 9 } - True - 3 - 5 - { 2 } ] - - SWAP (entry) @ location: 42 - [ { 6 ; 7 ; 8 ; 9 } - True - 3 - 5 - { 2 } ] - - log/IF (exit) @ location: 42 - [ True - { 6 ; 7 ; 8 ; 9 } - 3 - 5 - { 2 } ] - - IF (entry) @ location: 43 - [ True - { 6 ; 7 ; 8 ; 9 } - 3 - 5 - { 2 } ] - - log/DIP (exit) @ location: 43 - [ { 6 ; 7 ; 8 ; 9 } - 3 - 5 - { 2 } ] - - DIP (entry) @ location: 45 - [ { 6 ; 7 ; 8 ; 9 } - 3 - 5 - { 2 } ] - - log/SWAP (exit) @ location: 45 - [ 3 - 5 - { 2 } ] - - SWAP (entry) @ location: 47 - [ 3 - 5 - { 2 } ] - - log/DIP (exit) @ location: 47 - [ 5 - 3 - { 2 } ] - - DIP (entry) @ location: 48 - [ 5 - 3 - { 2 } ] - - log/CONS (exit) @ location: 48 - [ 3 - { 2 } ] - - CONS (entry) @ location: 50 - [ 3 - { 2 } ] - - log/[halt] (exit) @ location: 50 - [ { 3 ; 2 } ] - - [halt] (entry) @ location: 50 - [ { 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 48 - [ 5 - { 3 ; 2 } ] - - [halt] (entry) @ location: 46 - [ 5 - { 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 45 - [ { 6 ; 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - PUSH (entry) @ location: 51 - [ { 6 ; 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - log/[halt] (exit) @ location: 51 - [ True - { 6 ; 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 6 ; 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ True - { 6 ; 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 6 ; 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ True - { 6 ; 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ True - { 6 ; 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 6 ; 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - IF_CONS (entry) @ location: 26 - [ { 6 ; 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - log/SWAP (exit) @ location: 26 - [ 6 - { 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - SWAP (entry) @ location: 28 - [ 6 - { 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - log/DIP (exit) @ location: 28 - [ { 7 ; 8 ; 9 } - 6 - 5 - { 3 ; 2 } ] - - DIP (entry) @ location: 29 - [ { 7 ; 8 ; 9 } - 6 - 5 - { 3 ; 2 } ] - - log/DUP (exit) @ location: 29 - [ 6 - 5 - { 3 ; 2 } ] - - DUP (entry) @ location: 31 - [ 6 - 5 - { 3 ; 2 } ] - - log/DIP (exit) @ location: 31 - [ 6 - 6 - 5 - { 3 ; 2 } ] - - DIP (entry) @ location: 32 - [ 6 - 6 - 5 - { 3 ; 2 } ] - - log/DUP (exit) @ location: 32 - [ 5 - { 3 ; 2 } ] - - DUP (entry) @ location: 35 - [ 5 - { 3 ; 2 } ] - - log/[halt] (exit) @ location: 35 - [ 5 - 5 - { 3 ; 2 } ] - - [halt] (entry) @ location: 35 - [ 5 - 5 - { 3 ; 2 } ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 5 - 5 - { 3 ; 2 } ] - - log/PUSH (exit) @ location: 32 - [ 6 - 5 - 5 - { 3 ; 2 } ] - - PUSH (entry) @ location: 32 - [ 6 - 5 - 5 - { 3 ; 2 } ] - - log/log/log/DIP (exit) @ location: 32 - [ 6 - 6 - 5 - 5 - { 3 ; 2 } ] - - log/DIP (exit) @ location: 32 - [ 6 - 6 - 5 - 5 - { 3 ; 2 } ] - - DIP (entry) @ location: 36 - [ 6 - 6 - 5 - 5 - { 3 ; 2 } ] - - log/COMPARE (exit) @ location: 36 - [ 6 - 5 - 5 - { 3 ; 2 } ] - - COMPARE (entry) @ location: 39 - [ 6 - 5 - 5 - { 3 ; 2 } ] - - log/LT (exit) @ location: 39 - [ 1 - 5 - { 3 ; 2 } ] - - LT (entry) @ location: 40 - [ 1 - 5 - { 3 ; 2 } ] - - log/[halt] (exit) @ location: 40 - [ False - 5 - { 3 ; 2 } ] - - [halt] (entry) @ location: 38 - [ False - 5 - { 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 6 - False - 5 - { 3 ; 2 } ] - - SWAP (entry) @ location: 41 - [ 6 - False - 5 - { 3 ; 2 } ] - - log/[halt] (exit) @ location: 41 - [ False - 6 - 5 - { 3 ; 2 } ] - - [halt] (entry) @ location: 30 - [ False - 6 - 5 - { 3 ; 2 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ { 7 ; 8 ; 9 } - False - 6 - 5 - { 3 ; 2 } ] - - SWAP (entry) @ location: 42 - [ { 7 ; 8 ; 9 } - False - 6 - 5 - { 3 ; 2 } ] - - log/IF (exit) @ location: 42 - [ False - { 7 ; 8 ; 9 } - 6 - 5 - { 3 ; 2 } ] - - IF (entry) @ location: 43 - [ False - { 7 ; 8 ; 9 } - 6 - 5 - { 3 ; 2 } ] - - log/SWAP (exit) @ location: 43 - [ { 7 ; 8 ; 9 } - 6 - 5 - { 3 ; 2 } ] - - SWAP (entry) @ location: 55 - [ { 7 ; 8 ; 9 } - 6 - 5 - { 3 ; 2 } ] - - log/CONS (exit) @ location: 55 - [ 6 - { 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - CONS (entry) @ location: 56 - [ 6 - { 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - log/PUSH (exit) @ location: 56 - [ { 6 ; 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - PUSH (entry) @ location: 57 - [ { 6 ; 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - log/[halt] (exit) @ location: 57 - [ False - { 6 ; 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ False - { 6 ; 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ False - { 6 ; 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ False - { 6 ; 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ False - { 6 ; 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - [halt] (entry) @ location: 66 - [ False - { 6 ; 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - control: KLoop_in - - control: KCons - - log/SWAP (exit) @ location: 66 - [ { 6 ; 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - SWAP (entry) @ location: 66 - [ { 6 ; 7 ; 8 ; 9 } - 5 - { 3 ; 2 } ] - - log/CONS (exit) @ location: 66 - [ 5 - { 6 ; 7 ; 8 ; 9 } - { 3 ; 2 } ] - - CONS (entry) @ location: 67 - [ 5 - { 6 ; 7 ; 8 ; 9 } - { 3 ; 2 } ] - - log/SWAP (exit) @ location: 67 - [ { 5 ; 6 ; 7 ; 8 ; 9 } - { 3 ; 2 } ] - - SWAP (entry) @ location: 68 - [ { 5 ; 6 ; 7 ; 8 ; 9 } - { 3 ; 2 } ] - - log/ITER (exit) @ location: 68 - [ { 3 ; 2 } - { 5 ; 6 ; 7 ; 8 ; 9 } ] - - ITER (entry) @ location: 69 - [ { 3 ; 2 } - { 5 ; 6 ; 7 ; 8 ; 9 } ] - - control: KIter - - log/CONS (exit) @ location: 69 - [ 3 - { 5 ; 6 ; 7 ; 8 ; 9 } ] - - CONS (entry) @ location: 71 - [ 3 - { 5 ; 6 ; 7 ; 8 ; 9 } ] - - log/[halt] (exit) @ location: 71 - [ { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - [halt] (entry) @ location: 69 - [ { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - control: KIter - - log/CONS (exit) @ location: 69 - [ 2 - { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - CONS (entry) @ location: 71 - [ 2 - { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - log/[halt] (exit) @ location: 71 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - [halt] (entry) @ location: 69 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - control: KIter - - control: KCons - - log/[halt] (exit) @ location: 69 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - [halt] (entry) @ location: 13 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - control: KIter - - log/SWAP (exit) @ location: 13 - [ 1 - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - SWAP (entry) @ location: 15 - [ 1 - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - log/DIP (exit) @ location: 15 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 ] - - DIP (entry) @ location: 16 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 ] - - log/NIL (exit) @ location: 16 - [ ] - - NIL (entry) @ location: 19 - [ ] - - log/[halt] (exit) @ location: 19 - [ {} ] - - [halt] (entry) @ location: 19 - [ {} ] - - control: KCons - - PUSH (entry) @ location: 16 - [ {} ] - - log/PUSH (exit) @ location: 16 - [ 1 - {} ] - - PUSH (entry) @ location: 16 - [ 1 - {} ] - - log/log/log/PUSH (exit) @ location: 16 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - {} ] - - log/PUSH (exit) @ location: 16 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - {} ] - - PUSH (entry) @ location: 21 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - {} ] - - log/LOOP (exit) @ location: 21 - [ True - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - {} ] - - LOOP (entry) @ location: 66 - [ True - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - {} ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - {} ] - - IF_CONS (entry) @ location: 26 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - {} ] - - log/SWAP (exit) @ location: 26 - [ 2 - { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - {} ] - - SWAP (entry) @ location: 28 - [ 2 - { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - {} ] - - log/DIP (exit) @ location: 28 - [ { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 2 - 1 - {} ] - - DIP (entry) @ location: 29 - [ { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 2 - 1 - {} ] - - log/DUP (exit) @ location: 29 - [ 2 - 1 - {} ] - - DUP (entry) @ location: 31 - [ 2 - 1 - {} ] - - log/DIP (exit) @ location: 31 - [ 2 - 2 - 1 - {} ] - - DIP (entry) @ location: 32 - [ 2 - 2 - 1 - {} ] - - log/DUP (exit) @ location: 32 - [ 1 - {} ] - - DUP (entry) @ location: 35 - [ 1 - {} ] - - log/[halt] (exit) @ location: 35 - [ 1 - 1 - {} ] - - [halt] (entry) @ location: 35 - [ 1 - 1 - {} ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 1 - 1 - {} ] - - log/PUSH (exit) @ location: 32 - [ 2 - 1 - 1 - {} ] - - PUSH (entry) @ location: 32 - [ 2 - 1 - 1 - {} ] - - log/log/log/DIP (exit) @ location: 32 - [ 2 - 2 - 1 - 1 - {} ] - - log/DIP (exit) @ location: 32 - [ 2 - 2 - 1 - 1 - {} ] - - DIP (entry) @ location: 36 - [ 2 - 2 - 1 - 1 - {} ] - - log/COMPARE (exit) @ location: 36 - [ 2 - 1 - 1 - {} ] - - COMPARE (entry) @ location: 39 - [ 2 - 1 - 1 - {} ] - - log/LT (exit) @ location: 39 - [ 1 - 1 - {} ] - - LT (entry) @ location: 40 - [ 1 - 1 - {} ] - - log/[halt] (exit) @ location: 40 - [ False - 1 - {} ] - - [halt] (entry) @ location: 38 - [ False - 1 - {} ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 2 - False - 1 - {} ] - - SWAP (entry) @ location: 41 - [ 2 - False - 1 - {} ] - - log/[halt] (exit) @ location: 41 - [ False - 2 - 1 - {} ] - - [halt] (entry) @ location: 30 - [ False - 2 - 1 - {} ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - False - 2 - 1 - {} ] - - SWAP (entry) @ location: 42 - [ { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - False - 2 - 1 - {} ] - - log/IF (exit) @ location: 42 - [ False - { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 2 - 1 - {} ] - - IF (entry) @ location: 43 - [ False - { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 2 - 1 - {} ] - - log/SWAP (exit) @ location: 43 - [ { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 2 - 1 - {} ] - - SWAP (entry) @ location: 55 - [ { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 2 - 1 - {} ] - - log/CONS (exit) @ location: 55 - [ 2 - { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - {} ] - - CONS (entry) @ location: 56 - [ 2 - { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - {} ] - - log/PUSH (exit) @ location: 56 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - {} ] - - PUSH (entry) @ location: 57 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - {} ] - - log/[halt] (exit) @ location: 57 - [ False - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - {} ] - - [halt] (entry) @ location: 66 - [ False - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - {} ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ False - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - {} ] - - [halt] (entry) @ location: 66 - [ False - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - {} ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ False - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - {} ] - - [halt] (entry) @ location: 66 - [ False - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - {} ] - - control: KLoop_in - - control: KCons - - log/SWAP (exit) @ location: 66 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - {} ] - - SWAP (entry) @ location: 66 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - {} ] - - log/CONS (exit) @ location: 66 - [ 1 - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - {} ] - - CONS (entry) @ location: 67 - [ 1 - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - {} ] - - log/SWAP (exit) @ location: 67 - [ { 1 ; 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - {} ] - - SWAP (entry) @ location: 68 - [ { 1 ; 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - {} ] - - log/ITER (exit) @ location: 68 - [ {} - { 1 ; 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - ITER (entry) @ location: 69 - [ {} - { 1 ; 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - control: KIter - - control: KCons - - log/[halt] (exit) @ location: 69 - [ { 1 ; 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - [halt] (entry) @ location: 13 - [ { 1 ; 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - control: KIter - - log/SWAP (exit) @ location: 13 - [ 4 - { 1 ; 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - SWAP (entry) @ location: 15 - [ 4 - { 1 ; 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - log/DIP (exit) @ location: 15 - [ { 1 ; 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 ] - - DIP (entry) @ location: 16 - [ { 1 ; 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 ] - - log/NIL (exit) @ location: 16 - [ ] - - NIL (entry) @ location: 19 - [ ] - - log/[halt] (exit) @ location: 19 - [ {} ] - - [halt] (entry) @ location: 19 - [ {} ] - - control: KCons - - PUSH (entry) @ location: 16 - [ {} ] - - log/PUSH (exit) @ location: 16 - [ 4 - {} ] - - PUSH (entry) @ location: 16 - [ 4 - {} ] - - log/log/log/PUSH (exit) @ location: 16 - [ { 1 ; 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - {} ] - - log/PUSH (exit) @ location: 16 - [ { 1 ; 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - {} ] - - PUSH (entry) @ location: 21 - [ { 1 ; 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - {} ] - - log/LOOP (exit) @ location: 21 - [ True - { 1 ; 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - {} ] - - LOOP (entry) @ location: 66 - [ True - { 1 ; 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - {} ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 1 ; 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - {} ] - - IF_CONS (entry) @ location: 26 - [ { 1 ; 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - {} ] - - log/SWAP (exit) @ location: 26 - [ 1 - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - {} ] - - SWAP (entry) @ location: 28 - [ 1 - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - {} ] - - log/DIP (exit) @ location: 28 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - 4 - {} ] - - DIP (entry) @ location: 29 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - 4 - {} ] - - log/DUP (exit) @ location: 29 - [ 1 - 4 - {} ] - - DUP (entry) @ location: 31 - [ 1 - 4 - {} ] - - log/DIP (exit) @ location: 31 - [ 1 - 1 - 4 - {} ] - - DIP (entry) @ location: 32 - [ 1 - 1 - 4 - {} ] - - log/DUP (exit) @ location: 32 - [ 4 - {} ] - - DUP (entry) @ location: 35 - [ 4 - {} ] - - log/[halt] (exit) @ location: 35 - [ 4 - 4 - {} ] - - [halt] (entry) @ location: 35 - [ 4 - 4 - {} ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 4 - 4 - {} ] - - log/PUSH (exit) @ location: 32 - [ 1 - 4 - 4 - {} ] - - PUSH (entry) @ location: 32 - [ 1 - 4 - 4 - {} ] - - log/log/log/DIP (exit) @ location: 32 - [ 1 - 1 - 4 - 4 - {} ] - - log/DIP (exit) @ location: 32 - [ 1 - 1 - 4 - 4 - {} ] - - DIP (entry) @ location: 36 - [ 1 - 1 - 4 - 4 - {} ] - - log/COMPARE (exit) @ location: 36 - [ 1 - 4 - 4 - {} ] - - COMPARE (entry) @ location: 39 - [ 1 - 4 - 4 - {} ] - - log/LT (exit) @ location: 39 - [ -1 - 4 - {} ] - - LT (entry) @ location: 40 - [ -1 - 4 - {} ] - - log/[halt] (exit) @ location: 40 - [ True - 4 - {} ] - - [halt] (entry) @ location: 38 - [ True - 4 - {} ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 1 - True - 4 - {} ] - - SWAP (entry) @ location: 41 - [ 1 - True - 4 - {} ] - - log/[halt] (exit) @ location: 41 - [ True - 1 - 4 - {} ] - - [halt] (entry) @ location: 30 - [ True - 1 - 4 - {} ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - True - 1 - 4 - {} ] - - SWAP (entry) @ location: 42 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - True - 1 - 4 - {} ] - - log/IF (exit) @ location: 42 - [ True - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - 4 - {} ] - - IF (entry) @ location: 43 - [ True - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - 4 - {} ] - - log/DIP (exit) @ location: 43 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - 4 - {} ] - - DIP (entry) @ location: 45 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - 4 - {} ] - - log/SWAP (exit) @ location: 45 - [ 1 - 4 - {} ] - - SWAP (entry) @ location: 47 - [ 1 - 4 - {} ] - - log/DIP (exit) @ location: 47 - [ 4 - 1 - {} ] - - DIP (entry) @ location: 48 - [ 4 - 1 - {} ] - - log/CONS (exit) @ location: 48 - [ 1 - {} ] - - CONS (entry) @ location: 50 - [ 1 - {} ] - - log/[halt] (exit) @ location: 50 - [ { 1 } ] - - [halt] (entry) @ location: 50 - [ { 1 } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 48 - [ 4 - { 1 } ] - - [halt] (entry) @ location: 46 - [ 4 - { 1 } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 45 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 1 } ] - - PUSH (entry) @ location: 51 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 1 } ] - - log/[halt] (exit) @ location: 51 - [ True - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 1 } ] - - [halt] (entry) @ location: 66 - [ True - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 1 } ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ True - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 1 } ] - - [halt] (entry) @ location: 66 - [ True - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 1 } ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ True - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 1 } ] - - [halt] (entry) @ location: 66 - [ True - { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 1 } ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 1 } ] - - IF_CONS (entry) @ location: 26 - [ { 2 ; 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 1 } ] - - log/SWAP (exit) @ location: 26 - [ 2 - { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 1 } ] - - SWAP (entry) @ location: 28 - [ 2 - { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 1 } ] - - log/DIP (exit) @ location: 28 - [ { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 2 - 4 - { 1 } ] - - DIP (entry) @ location: 29 - [ { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 2 - 4 - { 1 } ] - - log/DUP (exit) @ location: 29 - [ 2 - 4 - { 1 } ] - - DUP (entry) @ location: 31 - [ 2 - 4 - { 1 } ] - - log/DIP (exit) @ location: 31 - [ 2 - 2 - 4 - { 1 } ] - - DIP (entry) @ location: 32 - [ 2 - 2 - 4 - { 1 } ] - - log/DUP (exit) @ location: 32 - [ 4 - { 1 } ] - - DUP (entry) @ location: 35 - [ 4 - { 1 } ] - - log/[halt] (exit) @ location: 35 - [ 4 - 4 - { 1 } ] - - [halt] (entry) @ location: 35 - [ 4 - 4 - { 1 } ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 4 - 4 - { 1 } ] - - log/PUSH (exit) @ location: 32 - [ 2 - 4 - 4 - { 1 } ] - - PUSH (entry) @ location: 32 - [ 2 - 4 - 4 - { 1 } ] - - log/log/log/DIP (exit) @ location: 32 - [ 2 - 2 - 4 - 4 - { 1 } ] - - log/DIP (exit) @ location: 32 - [ 2 - 2 - 4 - 4 - { 1 } ] - - DIP (entry) @ location: 36 - [ 2 - 2 - 4 - 4 - { 1 } ] - - log/COMPARE (exit) @ location: 36 - [ 2 - 4 - 4 - { 1 } ] - - COMPARE (entry) @ location: 39 - [ 2 - 4 - 4 - { 1 } ] - - log/LT (exit) @ location: 39 - [ -1 - 4 - { 1 } ] - - LT (entry) @ location: 40 - [ -1 - 4 - { 1 } ] - - log/[halt] (exit) @ location: 40 - [ True - 4 - { 1 } ] - - [halt] (entry) @ location: 38 - [ True - 4 - { 1 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 2 - True - 4 - { 1 } ] - - SWAP (entry) @ location: 41 - [ 2 - True - 4 - { 1 } ] - - log/[halt] (exit) @ location: 41 - [ True - 2 - 4 - { 1 } ] - - [halt] (entry) @ location: 30 - [ True - 2 - 4 - { 1 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - True - 2 - 4 - { 1 } ] - - SWAP (entry) @ location: 42 - [ { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - True - 2 - 4 - { 1 } ] - - log/IF (exit) @ location: 42 - [ True - { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 2 - 4 - { 1 } ] - - IF (entry) @ location: 43 - [ True - { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 2 - 4 - { 1 } ] - - log/DIP (exit) @ location: 43 - [ { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 2 - 4 - { 1 } ] - - DIP (entry) @ location: 45 - [ { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 2 - 4 - { 1 } ] - - log/SWAP (exit) @ location: 45 - [ 2 - 4 - { 1 } ] - - SWAP (entry) @ location: 47 - [ 2 - 4 - { 1 } ] - - log/DIP (exit) @ location: 47 - [ 4 - 2 - { 1 } ] - - DIP (entry) @ location: 48 - [ 4 - 2 - { 1 } ] - - log/CONS (exit) @ location: 48 - [ 2 - { 1 } ] - - CONS (entry) @ location: 50 - [ 2 - { 1 } ] - - log/[halt] (exit) @ location: 50 - [ { 2 ; 1 } ] - - [halt] (entry) @ location: 50 - [ { 2 ; 1 } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 48 - [ 4 - { 2 ; 1 } ] - - [halt] (entry) @ location: 46 - [ 4 - { 2 ; 1 } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 45 - [ { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 2 ; 1 } ] - - PUSH (entry) @ location: 51 - [ { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 2 ; 1 } ] - - log/[halt] (exit) @ location: 51 - [ True - { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 2 ; 1 } ] - - [halt] (entry) @ location: 66 - [ True - { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 2 ; 1 } ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ True - { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 2 ; 1 } ] - - [halt] (entry) @ location: 66 - [ True - { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 2 ; 1 } ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ True - { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 2 ; 1 } ] - - [halt] (entry) @ location: 66 - [ True - { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 2 ; 1 } ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 2 ; 1 } ] - - IF_CONS (entry) @ location: 26 - [ { 3 ; 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 2 ; 1 } ] - - log/SWAP (exit) @ location: 26 - [ 3 - { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 2 ; 1 } ] - - SWAP (entry) @ location: 28 - [ 3 - { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 2 ; 1 } ] - - log/DIP (exit) @ location: 28 - [ { 5 ; 6 ; 7 ; 8 ; 9 } - 3 - 4 - { 2 ; 1 } ] - - DIP (entry) @ location: 29 - [ { 5 ; 6 ; 7 ; 8 ; 9 } - 3 - 4 - { 2 ; 1 } ] - - log/DUP (exit) @ location: 29 - [ 3 - 4 - { 2 ; 1 } ] - - DUP (entry) @ location: 31 - [ 3 - 4 - { 2 ; 1 } ] - - log/DIP (exit) @ location: 31 - [ 3 - 3 - 4 - { 2 ; 1 } ] - - DIP (entry) @ location: 32 - [ 3 - 3 - 4 - { 2 ; 1 } ] - - log/DUP (exit) @ location: 32 - [ 4 - { 2 ; 1 } ] - - DUP (entry) @ location: 35 - [ 4 - { 2 ; 1 } ] - - log/[halt] (exit) @ location: 35 - [ 4 - 4 - { 2 ; 1 } ] - - [halt] (entry) @ location: 35 - [ 4 - 4 - { 2 ; 1 } ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 4 - 4 - { 2 ; 1 } ] - - log/PUSH (exit) @ location: 32 - [ 3 - 4 - 4 - { 2 ; 1 } ] - - PUSH (entry) @ location: 32 - [ 3 - 4 - 4 - { 2 ; 1 } ] - - log/log/log/DIP (exit) @ location: 32 - [ 3 - 3 - 4 - 4 - { 2 ; 1 } ] - - log/DIP (exit) @ location: 32 - [ 3 - 3 - 4 - 4 - { 2 ; 1 } ] - - DIP (entry) @ location: 36 - [ 3 - 3 - 4 - 4 - { 2 ; 1 } ] - - log/COMPARE (exit) @ location: 36 - [ 3 - 4 - 4 - { 2 ; 1 } ] - - COMPARE (entry) @ location: 39 - [ 3 - 4 - 4 - { 2 ; 1 } ] - - log/LT (exit) @ location: 39 - [ -1 - 4 - { 2 ; 1 } ] - - LT (entry) @ location: 40 - [ -1 - 4 - { 2 ; 1 } ] - - log/[halt] (exit) @ location: 40 - [ True - 4 - { 2 ; 1 } ] - - [halt] (entry) @ location: 38 - [ True - 4 - { 2 ; 1 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 3 - True - 4 - { 2 ; 1 } ] - - SWAP (entry) @ location: 41 - [ 3 - True - 4 - { 2 ; 1 } ] - - log/[halt] (exit) @ location: 41 - [ True - 3 - 4 - { 2 ; 1 } ] - - [halt] (entry) @ location: 30 - [ True - 3 - 4 - { 2 ; 1 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ { 5 ; 6 ; 7 ; 8 ; 9 } - True - 3 - 4 - { 2 ; 1 } ] - - SWAP (entry) @ location: 42 - [ { 5 ; 6 ; 7 ; 8 ; 9 } - True - 3 - 4 - { 2 ; 1 } ] - - log/IF (exit) @ location: 42 - [ True - { 5 ; 6 ; 7 ; 8 ; 9 } - 3 - 4 - { 2 ; 1 } ] - - IF (entry) @ location: 43 - [ True - { 5 ; 6 ; 7 ; 8 ; 9 } - 3 - 4 - { 2 ; 1 } ] - - log/DIP (exit) @ location: 43 - [ { 5 ; 6 ; 7 ; 8 ; 9 } - 3 - 4 - { 2 ; 1 } ] - - DIP (entry) @ location: 45 - [ { 5 ; 6 ; 7 ; 8 ; 9 } - 3 - 4 - { 2 ; 1 } ] - - log/SWAP (exit) @ location: 45 - [ 3 - 4 - { 2 ; 1 } ] - - SWAP (entry) @ location: 47 - [ 3 - 4 - { 2 ; 1 } ] - - log/DIP (exit) @ location: 47 - [ 4 - 3 - { 2 ; 1 } ] - - DIP (entry) @ location: 48 - [ 4 - 3 - { 2 ; 1 } ] - - log/CONS (exit) @ location: 48 - [ 3 - { 2 ; 1 } ] - - CONS (entry) @ location: 50 - [ 3 - { 2 ; 1 } ] - - log/[halt] (exit) @ location: 50 - [ { 3 ; 2 ; 1 } ] - - [halt] (entry) @ location: 50 - [ { 3 ; 2 ; 1 } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 48 - [ 4 - { 3 ; 2 ; 1 } ] - - [halt] (entry) @ location: 46 - [ 4 - { 3 ; 2 ; 1 } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 45 - [ { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - PUSH (entry) @ location: 51 - [ { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - log/[halt] (exit) @ location: 51 - [ True - { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - [halt] (entry) @ location: 66 - [ True - { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ True - { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - [halt] (entry) @ location: 66 - [ True - { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ True - { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - [halt] (entry) @ location: 66 - [ True - { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - IF_CONS (entry) @ location: 26 - [ { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - log/SWAP (exit) @ location: 26 - [ 5 - { 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - SWAP (entry) @ location: 28 - [ 5 - { 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - log/DIP (exit) @ location: 28 - [ { 6 ; 7 ; 8 ; 9 } - 5 - 4 - { 3 ; 2 ; 1 } ] - - DIP (entry) @ location: 29 - [ { 6 ; 7 ; 8 ; 9 } - 5 - 4 - { 3 ; 2 ; 1 } ] - - log/DUP (exit) @ location: 29 - [ 5 - 4 - { 3 ; 2 ; 1 } ] - - DUP (entry) @ location: 31 - [ 5 - 4 - { 3 ; 2 ; 1 } ] - - log/DIP (exit) @ location: 31 - [ 5 - 5 - 4 - { 3 ; 2 ; 1 } ] - - DIP (entry) @ location: 32 - [ 5 - 5 - 4 - { 3 ; 2 ; 1 } ] - - log/DUP (exit) @ location: 32 - [ 4 - { 3 ; 2 ; 1 } ] - - DUP (entry) @ location: 35 - [ 4 - { 3 ; 2 ; 1 } ] - - log/[halt] (exit) @ location: 35 - [ 4 - 4 - { 3 ; 2 ; 1 } ] - - [halt] (entry) @ location: 35 - [ 4 - 4 - { 3 ; 2 ; 1 } ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 4 - 4 - { 3 ; 2 ; 1 } ] - - log/PUSH (exit) @ location: 32 - [ 5 - 4 - 4 - { 3 ; 2 ; 1 } ] - - PUSH (entry) @ location: 32 - [ 5 - 4 - 4 - { 3 ; 2 ; 1 } ] - - log/log/log/DIP (exit) @ location: 32 - [ 5 - 5 - 4 - 4 - { 3 ; 2 ; 1 } ] - - log/DIP (exit) @ location: 32 - [ 5 - 5 - 4 - 4 - { 3 ; 2 ; 1 } ] - - DIP (entry) @ location: 36 - [ 5 - 5 - 4 - 4 - { 3 ; 2 ; 1 } ] - - log/COMPARE (exit) @ location: 36 - [ 5 - 4 - 4 - { 3 ; 2 ; 1 } ] - - COMPARE (entry) @ location: 39 - [ 5 - 4 - 4 - { 3 ; 2 ; 1 } ] - - log/LT (exit) @ location: 39 - [ 1 - 4 - { 3 ; 2 ; 1 } ] - - LT (entry) @ location: 40 - [ 1 - 4 - { 3 ; 2 ; 1 } ] - - log/[halt] (exit) @ location: 40 - [ False - 4 - { 3 ; 2 ; 1 } ] - - [halt] (entry) @ location: 38 - [ False - 4 - { 3 ; 2 ; 1 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 5 - False - 4 - { 3 ; 2 ; 1 } ] - - SWAP (entry) @ location: 41 - [ 5 - False - 4 - { 3 ; 2 ; 1 } ] - - log/[halt] (exit) @ location: 41 - [ False - 5 - 4 - { 3 ; 2 ; 1 } ] - - [halt] (entry) @ location: 30 - [ False - 5 - 4 - { 3 ; 2 ; 1 } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ { 6 ; 7 ; 8 ; 9 } - False - 5 - 4 - { 3 ; 2 ; 1 } ] - - SWAP (entry) @ location: 42 - [ { 6 ; 7 ; 8 ; 9 } - False - 5 - 4 - { 3 ; 2 ; 1 } ] - - log/IF (exit) @ location: 42 - [ False - { 6 ; 7 ; 8 ; 9 } - 5 - 4 - { 3 ; 2 ; 1 } ] - - IF (entry) @ location: 43 - [ False - { 6 ; 7 ; 8 ; 9 } - 5 - 4 - { 3 ; 2 ; 1 } ] - - log/SWAP (exit) @ location: 43 - [ { 6 ; 7 ; 8 ; 9 } - 5 - 4 - { 3 ; 2 ; 1 } ] - - SWAP (entry) @ location: 55 - [ { 6 ; 7 ; 8 ; 9 } - 5 - 4 - { 3 ; 2 ; 1 } ] - - log/CONS (exit) @ location: 55 - [ 5 - { 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - CONS (entry) @ location: 56 - [ 5 - { 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - log/PUSH (exit) @ location: 56 - [ { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - PUSH (entry) @ location: 57 - [ { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - log/[halt] (exit) @ location: 57 - [ False - { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - [halt] (entry) @ location: 66 - [ False - { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ False - { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - [halt] (entry) @ location: 66 - [ False - { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ False - { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - [halt] (entry) @ location: 66 - [ False - { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - control: KLoop_in - - control: KCons - - log/SWAP (exit) @ location: 66 - [ { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - SWAP (entry) @ location: 66 - [ { 5 ; 6 ; 7 ; 8 ; 9 } - 4 - { 3 ; 2 ; 1 } ] - - log/CONS (exit) @ location: 66 - [ 4 - { 5 ; 6 ; 7 ; 8 ; 9 } - { 3 ; 2 ; 1 } ] - - CONS (entry) @ location: 67 - [ 4 - { 5 ; 6 ; 7 ; 8 ; 9 } - { 3 ; 2 ; 1 } ] - - log/SWAP (exit) @ location: 67 - [ { 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - { 3 ; 2 ; 1 } ] - - SWAP (entry) @ location: 68 - [ { 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - { 3 ; 2 ; 1 } ] - - log/ITER (exit) @ location: 68 - [ { 3 ; 2 ; 1 } - { 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - ITER (entry) @ location: 69 - [ { 3 ; 2 ; 1 } - { 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - control: KIter - - log/CONS (exit) @ location: 69 - [ 3 - { 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - CONS (entry) @ location: 71 - [ 3 - { 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - log/[halt] (exit) @ location: 71 - [ { 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - [halt] (entry) @ location: 69 - [ { 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - control: KIter - - log/CONS (exit) @ location: 69 - [ 2 - { 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - CONS (entry) @ location: 71 - [ 2 - { 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - log/[halt] (exit) @ location: 71 - [ { 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - [halt] (entry) @ location: 69 - [ { 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - control: KIter - - log/CONS (exit) @ location: 69 - [ 1 - { 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - CONS (entry) @ location: 71 - [ 1 - { 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - log/[halt] (exit) @ location: 71 - [ { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - [halt] (entry) @ location: 69 - [ { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - control: KIter - - control: KCons - - log/[halt] (exit) @ location: 69 - [ { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - [halt] (entry) @ location: 13 - [ { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - control: KIter - - log/SWAP (exit) @ location: 13 - [ 0 - { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - SWAP (entry) @ location: 15 - [ 0 - { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - log/DIP (exit) @ location: 15 - [ { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 ] - - DIP (entry) @ location: 16 - [ { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 ] - - log/NIL (exit) @ location: 16 - [ ] - - NIL (entry) @ location: 19 - [ ] - - log/[halt] (exit) @ location: 19 - [ {} ] - - [halt] (entry) @ location: 19 - [ {} ] - - control: KCons - - PUSH (entry) @ location: 16 - [ {} ] - - log/PUSH (exit) @ location: 16 - [ 0 - {} ] - - PUSH (entry) @ location: 16 - [ 0 - {} ] - - log/log/log/PUSH (exit) @ location: 16 - [ { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 - {} ] - - log/PUSH (exit) @ location: 16 - [ { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 - {} ] - - PUSH (entry) @ location: 21 - [ { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 - {} ] - - log/LOOP (exit) @ location: 21 - [ True - { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 - {} ] - - LOOP (entry) @ location: 66 - [ True - { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 - {} ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 66 - [ { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 - {} ] - - IF_CONS (entry) @ location: 26 - [ { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 - {} ] - - log/SWAP (exit) @ location: 26 - [ 1 - { 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 - {} ] - - SWAP (entry) @ location: 28 - [ 1 - { 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 - {} ] - - log/DIP (exit) @ location: 28 - [ { 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - 0 - {} ] - - DIP (entry) @ location: 29 - [ { 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - 0 - {} ] - - log/DUP (exit) @ location: 29 - [ 1 - 0 - {} ] - - DUP (entry) @ location: 31 - [ 1 - 0 - {} ] - - log/DIP (exit) @ location: 31 - [ 1 - 1 - 0 - {} ] - - DIP (entry) @ location: 32 - [ 1 - 1 - 0 - {} ] - - log/DUP (exit) @ location: 32 - [ 0 - {} ] - - DUP (entry) @ location: 35 - [ 0 - {} ] - - log/[halt] (exit) @ location: 35 - [ 0 - 0 - {} ] - - [halt] (entry) @ location: 35 - [ 0 - 0 - {} ] - - control: KCons - - PUSH (entry) @ location: 32 - [ 0 - 0 - {} ] - - log/PUSH (exit) @ location: 32 - [ 1 - 0 - 0 - {} ] - - PUSH (entry) @ location: 32 - [ 1 - 0 - 0 - {} ] - - log/log/log/DIP (exit) @ location: 32 - [ 1 - 1 - 0 - 0 - {} ] - - log/DIP (exit) @ location: 32 - [ 1 - 1 - 0 - 0 - {} ] - - DIP (entry) @ location: 36 - [ 1 - 1 - 0 - 0 - {} ] - - log/COMPARE (exit) @ location: 36 - [ 1 - 0 - 0 - {} ] - - COMPARE (entry) @ location: 39 - [ 1 - 0 - 0 - {} ] - - log/LT (exit) @ location: 39 - [ 1 - 0 - {} ] - - LT (entry) @ location: 40 - [ 1 - 0 - {} ] - - log/[halt] (exit) @ location: 40 - [ False - 0 - {} ] - - [halt] (entry) @ location: 38 - [ False - 0 - {} ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 36 - [ 1 - False - 0 - {} ] - - SWAP (entry) @ location: 41 - [ 1 - False - 0 - {} ] - - log/[halt] (exit) @ location: 41 - [ False - 1 - 0 - {} ] - - [halt] (entry) @ location: 30 - [ False - 1 - 0 - {} ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 29 - [ { 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - False - 1 - 0 - {} ] - - SWAP (entry) @ location: 42 - [ { 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - False - 1 - 0 - {} ] - - log/IF (exit) @ location: 42 - [ False - { 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - 0 - {} ] - - IF (entry) @ location: 43 - [ False - { 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - 0 - {} ] - - log/SWAP (exit) @ location: 43 - [ { 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - 0 - {} ] - - SWAP (entry) @ location: 55 - [ { 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 1 - 0 - {} ] - - log/CONS (exit) @ location: 55 - [ 1 - { 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 - {} ] - - CONS (entry) @ location: 56 - [ 1 - { 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 - {} ] - - log/PUSH (exit) @ location: 56 - [ { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 - {} ] - - PUSH (entry) @ location: 57 - [ { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 - {} ] - - log/[halt] (exit) @ location: 57 - [ False - { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 - {} ] - - [halt] (entry) @ location: 66 - [ False - { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 - {} ] - - control: KCons - - log/[halt] (exit) @ location: 43 - [ False - { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 - {} ] - - [halt] (entry) @ location: 66 - [ False - { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 - {} ] - - control: KCons - - log/[halt] (exit) @ location: 26 - [ False - { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 - {} ] - - [halt] (entry) @ location: 66 - [ False - { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 - {} ] - - control: KLoop_in - - control: KCons - - log/SWAP (exit) @ location: 66 - [ { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 - {} ] - - SWAP (entry) @ location: 66 - [ { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - 0 - {} ] - - log/CONS (exit) @ location: 66 - [ 0 - { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - {} ] - - CONS (entry) @ location: 67 - [ 0 - { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - {} ] - - log/SWAP (exit) @ location: 67 - [ { 0 ; 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - {} ] - - SWAP (entry) @ location: 68 - [ { 0 ; 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } - {} ] - - log/ITER (exit) @ location: 68 - [ {} - { 0 ; 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - ITER (entry) @ location: 69 - [ {} - { 0 ; 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - control: KIter - - control: KCons - - log/[halt] (exit) @ location: 69 - [ { 0 ; 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - [halt] (entry) @ location: 13 - [ { 0 ; 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - control: KIter - - control: KCons - - log/NIL (exit) @ location: 13 - [ { 0 ; 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - NIL (entry) @ location: 72 - [ { 0 ; 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - log/PAIR (exit) @ location: 72 - [ {} - { 0 ; 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - PAIR (entry) @ location: 74 - [ {} - { 0 ; 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 } ] - - log/[halt] (exit) @ location: 74 - [ (Pair {} { 0 ; 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 }) ] - - [halt] (entry) @ location: 8 - [ (Pair {} { 0 ; 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 ; 8 ; 9 }) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/list_map_block.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/list_map_block.out deleted file mode 100644 index 202f29541787ef38dc38cec05643243ff54c1761..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/list_map_block.out +++ /dev/null @@ -1,451 +0,0 @@ - -trace - - CAR (interp) @ location: 9 - [ (Pair { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 } {}) ] - - CAR (entry) @ location: 9 - [ (Pair { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 } {}) ] - - log/PUSH (exit) @ location: 9 - [ { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 } ] - - PUSH (entry) @ location: 10 - [ { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 } ] - - log/SWAP (exit) @ location: 10 - [ 0 - { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 } ] - - SWAP (entry) @ location: 13 - [ 0 - { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 } ] - - log/MAP (exit) @ location: 13 - [ { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 } - 0 ] - - MAP (entry) @ location: 14 - [ { 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7 } - 0 ] - - control: KList_enter_body - - log/DIP (exit) @ location: 14 - [ 1 - 0 ] - - DIP (entry) @ location: 16 - [ 1 - 0 ] - - log/DUP (exit) @ location: 16 - [ 0 ] - - DUP (entry) @ location: 18 - [ 0 ] - - log/[halt] (exit) @ location: 18 - [ 0 - 0 ] - - [halt] (entry) @ location: 18 - [ 0 - 0 ] - - control: KUndip - - control: KCons - - log/ADD (exit) @ location: 16 - [ 1 - 0 - 0 ] - - ADD (entry) @ location: 19 - [ 1 - 0 - 0 ] - - log/DIP (exit) @ location: 19 - [ 1 - 0 ] - - DIP (entry) @ location: 20 - [ 1 - 0 ] - - log/PUSH (exit) @ location: 20 - [ 0 ] - - PUSH (entry) @ location: 22 - [ 0 ] - - log/ADD (exit) @ location: 22 - [ 1 - 0 ] - - ADD (entry) @ location: 25 - [ 1 - 0 ] - - log/[halt] (exit) @ location: 25 - [ 1 ] - - [halt] (entry) @ location: 21 - [ 1 ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 20 - [ 1 - 1 ] - - [halt] (entry) @ location: 14 - [ 1 - 1 ] - - control: KList_exit_body - - control: KList_enter_body - - log/DIP (exit) @ location: 14 - [ 2 - 1 ] - - DIP (entry) @ location: 16 - [ 2 - 1 ] - - log/DUP (exit) @ location: 16 - [ 1 ] - - DUP (entry) @ location: 18 - [ 1 ] - - log/[halt] (exit) @ location: 18 - [ 1 - 1 ] - - [halt] (entry) @ location: 18 - [ 1 - 1 ] - - control: KUndip - - control: KCons - - log/ADD (exit) @ location: 16 - [ 2 - 1 - 1 ] - - ADD (entry) @ location: 19 - [ 2 - 1 - 1 ] - - log/DIP (exit) @ location: 19 - [ 3 - 1 ] - - DIP (entry) @ location: 20 - [ 3 - 1 ] - - log/PUSH (exit) @ location: 20 - [ 1 ] - - PUSH (entry) @ location: 22 - [ 1 ] - - log/ADD (exit) @ location: 22 - [ 1 - 1 ] - - ADD (entry) @ location: 25 - [ 1 - 1 ] - - log/[halt] (exit) @ location: 25 - [ 2 ] - - [halt] (entry) @ location: 21 - [ 2 ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 20 - [ 3 - 2 ] - - [halt] (entry) @ location: 14 - [ 3 - 2 ] - - control: KList_exit_body - - control: KList_enter_body - - log/DIP (exit) @ location: 14 - [ 3 - 2 ] - - DIP (entry) @ location: 16 - [ 3 - 2 ] - - log/DUP (exit) @ location: 16 - [ 2 ] - - DUP (entry) @ location: 18 - [ 2 ] - - log/[halt] (exit) @ location: 18 - [ 2 - 2 ] - - [halt] (entry) @ location: 18 - [ 2 - 2 ] - - control: KUndip - - control: KCons - - log/ADD (exit) @ location: 16 - [ 3 - 2 - 2 ] - - ADD (entry) @ location: 19 - [ 3 - 2 - 2 ] - - log/DIP (exit) @ location: 19 - [ 5 - 2 ] - - DIP (entry) @ location: 20 - [ 5 - 2 ] - - log/PUSH (exit) @ location: 20 - [ 2 ] - - PUSH (entry) @ location: 22 - [ 2 ] - - log/ADD (exit) @ location: 22 - [ 1 - 2 ] - - ADD (entry) @ location: 25 - [ 1 - 2 ] - - log/[halt] (exit) @ location: 25 - [ 3 ] - - [halt] (entry) @ location: 21 - [ 3 ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 20 - [ 5 - 3 ] - - [halt] (entry) @ location: 14 - [ 5 - 3 ] - - control: KList_exit_body - - control: KList_enter_body - - log/DIP (exit) @ location: 14 - [ 4 - 3 ] - - DIP (entry) @ location: 16 - [ 4 - 3 ] - - log/DUP (exit) @ location: 16 - [ 3 ] - - DUP (entry) @ location: 18 - [ 3 ] - - log/[halt] (exit) @ location: 18 - [ 3 - 3 ] - - [halt] (entry) @ location: 18 - [ 3 - 3 ] - - control: KUndip - - control: KCons - - log/ADD (exit) @ location: 16 - [ 4 - 3 - 3 ] - - ADD (entry) @ location: 19 - [ 4 - 3 - 3 ] - - log/DIP (exit) @ location: 19 - [ 7 - 3 ] - - DIP (entry) @ location: 20 - [ 7 - 3 ] - - log/PUSH (exit) @ location: 20 - [ 3 ] - - PUSH (entry) @ location: 22 - [ 3 ] - - log/ADD (exit) @ location: 22 - [ 1 - 3 ] - - ADD (entry) @ location: 25 - [ 1 - 3 ] - - log/[halt] (exit) @ location: 25 - [ 4 ] - - [halt] (entry) @ location: 21 - [ 4 ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 20 - [ 7 - 4 ] - - [halt] (entry) @ location: 14 - [ 7 - 4 ] - - control: KList_exit_body - - control: KList_enter_body - - log/DIP (exit) @ location: 14 - [ 5 - 4 ] - - DIP (entry) @ location: 16 - [ 5 - 4 ] - - log/DUP (exit) @ location: 16 - [ 4 ] - - DUP (entry) @ location: 18 - [ 4 ] - - log/[halt] (exit) @ location: 18 - [ 4 - 4 ] - - [halt] (entry) @ location: 18 - [ 4 - 4 ] - - control: KUndip - - control: KCons - - log/ADD (exit) @ location: 16 - [ 5 - 4 - 4 ] - - ADD (entry) @ location: 19 - [ 5 - 4 - 4 ] - - log/DIP (exit) @ location: 19 - [ 9 - 4 ] - - DIP (entry) @ location: 20 - [ 9 - 4 ] - - log/PUSH (exit) @ location: 20 - [ 4 ] - - PUSH (entry) @ location: 22 - [ 4 ] - - log/ADD (exit) @ location: 22 - [ 1 - 4 ] - - ADD (entry) @ location: 25 - [ 1 - 4 ] - - log/[halt] (exit) @ location: 25 - [ 5 ] - - [halt] (entry) @ location: 21 - [ 5 ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 20 - [ 9 - 5 ] - - [halt] (entry) @ location: 14 - [ 9 - 5 ] - - control: KList_exit_body - - control: KList_enter_body - - log/DIP (exit) @ location: 14 - [ 6 - 5 ] - - DIP (entry) @ location: 16 - [ 6 - 5 ] - - log/DUP (exit) @ location: 16 - [ 5 ] - - DUP (entry) @ location: 18 - [ 5 ] - - log/[halt] (exit) @ location: 18 - [ 5 - 5 ] - - [halt] (entry) @ location: 18 - [ 5 - 5 ] - - control: KUndip - - control: KCons - - log/ADD (exit) @ location: 16 - [ 6 - 5 - 5 ] - - ADD (entry) @ location: 19 - [ 6 - 5 - 5 ] - - log/DIP (exit) @ location: 19 - [ 11 - 5 ] - - DIP (entry) @ location: 20 - [ 11 - 5 ] - - log/PUSH (exit) @ location: 20 - [ 5 ] - - PUSH (entry) @ location: 22 - [ 5 ] - - log/ADD (exit) @ location: 22 - [ 1 - 5 ] - - ADD (entry) @ location: 25 - [ 1 - 5 ] - - log/[halt] (exit) @ location: 25 - [ 6 ] - - [halt] (entry) @ location: 21 - [ 6 ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 20 - [ 11 - 6 ] - - [halt] (entry) @ location: 14 - [ 11 - 6 ] - - control: KList_exit_body - - control: KList_enter_body - - log/DIP (exit) @ location: 14 - [ 7 - 6 ] - - DIP (entry) @ location: 16 - [ 7 - 6 ] - - log/DUP (exit) @ location: 16 - [ 6 ] - - DUP (entry) @ location: 18 - [ 6 ] - - log/[halt] (exit) @ location: 18 - [ 6 - 6 ] - - [halt] (entry) @ location: 18 - [ 6 - 6 ] - - control: KUndip - - control: KCons - - log/ADD (exit) @ location: 16 - [ 7 - 6 - 6 ] - - ADD (entry) @ location: 19 - [ 7 - 6 - 6 ] - - log/DIP (exit) @ location: 19 - [ 13 - 6 ] - - DIP (entry) @ location: 20 - [ 13 - 6 ] - - log/PUSH (exit) @ location: 20 - [ 6 ] - - PUSH (entry) @ location: 22 - [ 6 ] - - log/ADD (exit) @ location: 22 - [ 1 - 6 ] - - ADD (entry) @ location: 25 - [ 1 - 6 ] - - log/[halt] (exit) @ location: 25 - [ 7 ] - - [halt] (entry) @ location: 21 - [ 7 ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 20 - [ 13 - 7 ] - - [halt] (entry) @ location: 14 - [ 13 - 7 ] - - control: KList_exit_body - - control: KList_enter_body - - control: KCons - - log/NIL (exit) @ location: 14 - [ { 1 ; 3 ; 5 ; 7 ; 9 ; 11 ; 13 } - 7 ] - - NIL (entry) @ location: 26 - [ { 1 ; 3 ; 5 ; 7 ; 9 ; 11 ; 13 } - 7 ] - - log/PAIR (exit) @ location: 26 - [ {} - { 1 ; 3 ; 5 ; 7 ; 9 ; 11 ; 13 } - 7 ] - - PAIR (entry) @ location: 28 - [ {} - { 1 ; 3 ; 5 ; 7 ; 9 ; 11 ; 13 } - 7 ] - - log/DIP (exit) @ location: 28 - [ (Pair {} { 1 ; 3 ; 5 ; 7 ; 9 ; 11 ; 13 }) - 7 ] - - DIP (entry) @ location: 29 - [ (Pair {} { 1 ; 3 ; 5 ; 7 ; 9 ; 11 ; 13 }) - 7 ] - - log/DROP (exit) @ location: 29 - [ 7 ] - - DROP (entry) @ location: 31 - [ 7 ] - - log/[halt] (exit) @ location: 31 - [ ] - - [halt] (entry) @ location: 31 - [ ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 29 - [ (Pair {} { 1 ; 3 ; 5 ; 7 ; 9 ; 11 ; 13 }) ] - - [halt] (entry) @ location: 8 - [ (Pair {} { 1 ; 3 ; 5 ; 7 ; 9 ; 11 ; 13 }) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/loop_left.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/loop_left.out deleted file mode 100644 index 896f7396ad68b0df28b34fd54a348c5e2b7493dc..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/loop_left.out +++ /dev/null @@ -1,253 +0,0 @@ - -trace - - CAR (interp) @ location: 9 - [ (Pair { "abc" ; "xyz" } { "zyx" ; "cba" }) ] - - CAR (entry) @ location: 9 - [ (Pair { "abc" ; "xyz" } { "zyx" ; "cba" }) ] - - log/NIL (exit) @ location: 9 - [ { "abc" ; "xyz" } ] - - NIL (entry) @ location: 10 - [ { "abc" ; "xyz" } ] - - log/SWAP (exit) @ location: 10 - [ {} - { "abc" ; "xyz" } ] - - SWAP (entry) @ location: 12 - [ {} - { "abc" ; "xyz" } ] - - log/PAIR (exit) @ location: 12 - [ { "abc" ; "xyz" } - {} ] - - PAIR (entry) @ location: 13 - [ { "abc" ; "xyz" } - {} ] - - log/LEFT (exit) @ location: 13 - [ (Pair { "abc" ; "xyz" } {}) ] - - LEFT (entry) @ location: 14 - [ (Pair { "abc" ; "xyz" } {}) ] - - log/LOOP_LEFT (exit) @ location: 14 - [ (Left (Pair { "abc" ; "xyz" } {})) ] - - LOOP_LEFT (entry) @ location: 41 - [ (Left (Pair { "abc" ; "xyz" } {})) ] - - control: KLoop_in_left - - log/DUP (exit) @ location: 41 - [ (Pair { "abc" ; "xyz" } {}) ] - - DUP (entry) @ location: 19 - [ (Pair { "abc" ; "xyz" } {}) ] - - log/CAR (exit) @ location: 19 - [ (Pair { "abc" ; "xyz" } {}) - (Pair { "abc" ; "xyz" } {}) ] - - CAR (entry) @ location: 20 - [ (Pair { "abc" ; "xyz" } {}) - (Pair { "abc" ; "xyz" } {}) ] - - log/DIP (exit) @ location: 20 - [ { "abc" ; "xyz" } - (Pair { "abc" ; "xyz" } {}) ] - - DIP (entry) @ location: 21 - [ { "abc" ; "xyz" } - (Pair { "abc" ; "xyz" } {}) ] - - log/CDR (exit) @ location: 21 - [ (Pair { "abc" ; "xyz" } {}) ] - - CDR (entry) @ location: 23 - [ (Pair { "abc" ; "xyz" } {}) ] - - log/[halt] (exit) @ location: 23 - [ {} ] - - [halt] (entry) @ location: 23 - [ {} ] - - control: KUndip - - control: KCons - - log/IF_CONS (exit) @ location: 21 - [ { "abc" ; "xyz" } - {} ] - - IF_CONS (entry) @ location: 24 - [ { "abc" ; "xyz" } - {} ] - - log/SWAP (exit) @ location: 24 - [ "abc" - { "xyz" } - {} ] - - SWAP (entry) @ location: 26 - [ "abc" - { "xyz" } - {} ] - - log/DIP (exit) @ location: 26 - [ { "xyz" } - "abc" - {} ] - - DIP (entry) @ location: 27 - [ { "xyz" } - "abc" - {} ] - - log/CONS (exit) @ location: 27 - [ "abc" - {} ] - - CONS (entry) @ location: 29 - [ "abc" - {} ] - - log/[halt] (exit) @ location: 29 - [ { "abc" } ] - - [halt] (entry) @ location: 29 - [ { "abc" } ] - - control: KUndip - - control: KCons - - log/PAIR (exit) @ location: 27 - [ { "xyz" } - { "abc" } ] - - PAIR (entry) @ location: 30 - [ { "xyz" } - { "abc" } ] - - log/LEFT (exit) @ location: 30 - [ (Pair { "xyz" } { "abc" }) ] - - LEFT (entry) @ location: 31 - [ (Pair { "xyz" } { "abc" }) ] - - log/[halt] (exit) @ location: 31 - [ (Left (Pair { "xyz" } { "abc" })) ] - - [halt] (entry) @ location: 41 - [ (Left (Pair { "xyz" } { "abc" })) ] - - control: KCons - - log/[halt] (exit) @ location: 24 - [ (Left (Pair { "xyz" } { "abc" })) ] - - [halt] (entry) @ location: 41 - [ (Left (Pair { "xyz" } { "abc" })) ] - - control: KLoop_in_left - - log/DUP (exit) @ location: 41 - [ (Pair { "xyz" } { "abc" }) ] - - DUP (entry) @ location: 19 - [ (Pair { "xyz" } { "abc" }) ] - - log/CAR (exit) @ location: 19 - [ (Pair { "xyz" } { "abc" }) - (Pair { "xyz" } { "abc" }) ] - - CAR (entry) @ location: 20 - [ (Pair { "xyz" } { "abc" }) - (Pair { "xyz" } { "abc" }) ] - - log/DIP (exit) @ location: 20 - [ { "xyz" } - (Pair { "xyz" } { "abc" }) ] - - DIP (entry) @ location: 21 - [ { "xyz" } - (Pair { "xyz" } { "abc" }) ] - - log/CDR (exit) @ location: 21 - [ (Pair { "xyz" } { "abc" }) ] - - CDR (entry) @ location: 23 - [ (Pair { "xyz" } { "abc" }) ] - - log/[halt] (exit) @ location: 23 - [ { "abc" } ] - - [halt] (entry) @ location: 23 - [ { "abc" } ] - - control: KUndip - - control: KCons - - log/IF_CONS (exit) @ location: 21 - [ { "xyz" } - { "abc" } ] - - IF_CONS (entry) @ location: 24 - [ { "xyz" } - { "abc" } ] - - log/SWAP (exit) @ location: 24 - [ "xyz" - {} - { "abc" } ] - - SWAP (entry) @ location: 26 - [ "xyz" - {} - { "abc" } ] - - log/DIP (exit) @ location: 26 - [ {} - "xyz" - { "abc" } ] - - DIP (entry) @ location: 27 - [ {} - "xyz" - { "abc" } ] - - log/CONS (exit) @ location: 27 - [ "xyz" - { "abc" } ] - - CONS (entry) @ location: 29 - [ "xyz" - { "abc" } ] - - log/[halt] (exit) @ location: 29 - [ { "xyz" ; "abc" } ] - - [halt] (entry) @ location: 29 - [ { "xyz" ; "abc" } ] - - control: KUndip - - control: KCons - - log/PAIR (exit) @ location: 27 - [ {} - { "xyz" ; "abc" } ] - - PAIR (entry) @ location: 30 - [ {} - { "xyz" ; "abc" } ] - - log/LEFT (exit) @ location: 30 - [ (Pair {} { "xyz" ; "abc" }) ] - - LEFT (entry) @ location: 31 - [ (Pair {} { "xyz" ; "abc" }) ] - - log/[halt] (exit) @ location: 31 - [ (Left (Pair {} { "xyz" ; "abc" })) ] - - [halt] (entry) @ location: 41 - [ (Left (Pair {} { "xyz" ; "abc" })) ] - - control: KCons - - log/[halt] (exit) @ location: 24 - [ (Left (Pair {} { "xyz" ; "abc" })) ] - - [halt] (entry) @ location: 41 - [ (Left (Pair {} { "xyz" ; "abc" })) ] - - control: KLoop_in_left - - log/DUP (exit) @ location: 41 - [ (Pair {} { "xyz" ; "abc" }) ] - - DUP (entry) @ location: 19 - [ (Pair {} { "xyz" ; "abc" }) ] - - log/CAR (exit) @ location: 19 - [ (Pair {} { "xyz" ; "abc" }) - (Pair {} { "xyz" ; "abc" }) ] - - CAR (entry) @ location: 20 - [ (Pair {} { "xyz" ; "abc" }) - (Pair {} { "xyz" ; "abc" }) ] - - log/DIP (exit) @ location: 20 - [ {} - (Pair {} { "xyz" ; "abc" }) ] - - DIP (entry) @ location: 21 - [ {} - (Pair {} { "xyz" ; "abc" }) ] - - log/CDR (exit) @ location: 21 - [ (Pair {} { "xyz" ; "abc" }) ] - - CDR (entry) @ location: 23 - [ (Pair {} { "xyz" ; "abc" }) ] - - log/[halt] (exit) @ location: 23 - [ { "xyz" ; "abc" } ] - - [halt] (entry) @ location: 23 - [ { "xyz" ; "abc" } ] - - control: KUndip - - control: KCons - - log/IF_CONS (exit) @ location: 21 - [ {} - { "xyz" ; "abc" } ] - - IF_CONS (entry) @ location: 24 - [ {} - { "xyz" ; "abc" } ] - - log/RIGHT (exit) @ location: 24 - [ { "xyz" ; "abc" } ] - - RIGHT (entry) @ location: 35 - [ { "xyz" ; "abc" } ] - - log/[halt] (exit) @ location: 35 - [ (Right { "xyz" ; "abc" }) ] - - [halt] (entry) @ location: 41 - [ (Right { "xyz" ; "abc" }) ] - - control: KCons - - log/[halt] (exit) @ location: 24 - [ (Right { "xyz" ; "abc" }) ] - - [halt] (entry) @ location: 41 - [ (Right { "xyz" ; "abc" }) ] - - control: KLoop_in_left - - control: KCons - - log/NIL (exit) @ location: 41 - [ { "xyz" ; "abc" } ] - - NIL (entry) @ location: 41 - [ { "xyz" ; "abc" } ] - - log/PAIR (exit) @ location: 41 - [ {} - { "xyz" ; "abc" } ] - - PAIR (entry) @ location: 43 - [ {} - { "xyz" ; "abc" } ] - - log/[halt] (exit) @ location: 43 - [ (Pair {} { "xyz" ; "abc" }) ] - - [halt] (entry) @ location: 8 - [ (Pair {} { "xyz" ; "abc" }) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/opt_map.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/opt_map.out deleted file mode 100644 index e46a51e6dc9bb517508dd97e21593cc92290466a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/opt_map.out +++ /dev/null @@ -1,82 +0,0 @@ - -trace - - UNPAIR (interp) @ location: 8 - [ (Pair 7 (Some 3)) ] - - UNPAIR (entry) @ location: 8 - [ (Pair 7 (Some 3)) ] - - log/SWAP (exit) @ location: 8 - [ 7 - (Some 3) ] - - SWAP (entry) @ location: 9 - [ 7 - (Some 3) ] - - log/MAP (exit) @ location: 9 - [ (Some 3) - 7 ] - - MAP (entry) @ location: 11 - [ (Some 3) - 7 ] - - log/DIP (exit) @ location: 11 - [ 3 - 7 ] - - DIP (entry) @ location: 12 - [ 3 - 7 ] - - log/DUP (exit) @ location: 12 - [ 7 ] - - DUP (entry) @ location: 14 - [ 7 ] - - log/[halt] (exit) @ location: 14 - [ 7 - 7 ] - - [halt] (entry) @ location: 14 - [ 7 - 7 ] - - control: KUndip - - control: KCons - - log/ADD (exit) @ location: 12 - [ 3 - 7 - 7 ] - - ADD (entry) @ location: 15 - [ 3 - 7 - 7 ] - - log/[halt] (exit) @ location: 15 - [ 10 - 7 ] - - [halt] (entry) @ location: 11 - [ 10 - 7 ] - - control: KMap_head - - log/DIP (exit) @ location: 11 - [ (Some 10) - 7 ] - - DIP (entry) @ location: 16 - [ (Some 10) - 7 ] - - log/DROP (exit) @ location: 16 - [ 7 ] - - DROP (entry) @ location: 18 - [ 7 ] - - log/[halt] (exit) @ location: 18 - [ ] - - [halt] (entry) @ location: 18 - [ ] - - control: KUndip - - control: KCons - - log/NIL (exit) @ location: 16 - [ (Some 10) ] - - NIL (entry) @ location: 19 - [ (Some 10) ] - - log/PAIR (exit) @ location: 19 - [ {} - (Some 10) ] - - PAIR (entry) @ location: 21 - [ {} - (Some 10) ] - - log/[halt] (exit) @ location: 21 - [ (Pair {} (Some 10)) ] - - [halt] (entry) @ location: 7 - [ (Pair {} (Some 10)) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/packunpack.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/packunpack.out deleted file mode 100644 index 0246417e2aa9b8731b475b406c01973841be3c06..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/packunpack.out +++ /dev/null @@ -1,103 +0,0 @@ - -trace - - CAR (interp) @ location: 15 - [ (Pair (Pair (Pair (Pair "abc" { 1 ; 2 ; 3 }) { 4 ; 5 ; 6 }) - 0x0507070707010000000361626302000000060001000200030200000006000400050006) - Unit) ] - - CAR (entry) @ location: 15 - [ (Pair (Pair (Pair (Pair "abc" { 1 ; 2 ; 3 }) { 4 ; 5 ; 6 }) - 0x0507070707010000000361626302000000060001000200030200000006000400050006) - Unit) ] - - log/UNPAIR (exit) @ location: 15 - [ (Pair (Pair (Pair "abc" { 1 ; 2 ; 3 }) { 4 ; 5 ; 6 }) - 0x0507070707010000000361626302000000060001000200030200000006000400050006) ] - - UNPAIR (entry) @ location: 16 - [ (Pair (Pair (Pair "abc" { 1 ; 2 ; 3 }) { 4 ; 5 ; 6 }) - 0x0507070707010000000361626302000000060001000200030200000006000400050006) ] - - log/DIP (exit) @ location: 16 - [ (Pair (Pair "abc" { 1 ; 2 ; 3 }) { 4 ; 5 ; 6 }) - 0x0507070707010000000361626302000000060001000200030200000006000400050006 ] - - DIP (entry) @ location: 17 - [ (Pair (Pair "abc" { 1 ; 2 ; 3 }) { 4 ; 5 ; 6 }) - 0x0507070707010000000361626302000000060001000200030200000006000400050006 ] - - log/DUP (exit) @ location: 17 - [ 0x0507070707010000000361626302000000060001000200030200000006000400050006 ] - - DUP (entry) @ location: 19 - [ 0x0507070707010000000361626302000000060001000200030200000006000400050006 ] - - log/[halt] (exit) @ location: 19 - [ 0x0507070707010000000361626302000000060001000200030200000006000400050006 - 0x0507070707010000000361626302000000060001000200030200000006000400050006 ] - - [halt] (entry) @ location: 19 - [ 0x0507070707010000000361626302000000060001000200030200000006000400050006 - 0x0507070707010000000361626302000000060001000200030200000006000400050006 ] - - control: KUndip - - control: KCons - - log/PACK (exit) @ location: 17 - [ (Pair (Pair "abc" { 1 ; 2 ; 3 }) { 4 ; 5 ; 6 }) - 0x0507070707010000000361626302000000060001000200030200000006000400050006 - 0x0507070707010000000361626302000000060001000200030200000006000400050006 ] - - PACK (entry) @ location: 20 - [ (Pair (Pair "abc" { 1 ; 2 ; 3 }) { 4 ; 5 ; 6 }) - 0x0507070707010000000361626302000000060001000200030200000006000400050006 - 0x0507070707010000000361626302000000060001000200030200000006000400050006 ] - - log/COMPARE (exit) @ location: 20 - [ 0x0507070707010000000361626302000000060001000200030200000006000400050006 - 0x0507070707010000000361626302000000060001000200030200000006000400050006 - 0x0507070707010000000361626302000000060001000200030200000006000400050006 ] - - COMPARE (entry) @ location: 23 - [ 0x0507070707010000000361626302000000060001000200030200000006000400050006 - 0x0507070707010000000361626302000000060001000200030200000006000400050006 - 0x0507070707010000000361626302000000060001000200030200000006000400050006 ] - - log/EQ (exit) @ location: 23 - [ 0 - 0x0507070707010000000361626302000000060001000200030200000006000400050006 ] - - EQ (entry) @ location: 24 - [ 0 - 0x0507070707010000000361626302000000060001000200030200000006000400050006 ] - - log/IF (exit) @ location: 24 - [ True - 0x0507070707010000000361626302000000060001000200030200000006000400050006 ] - - IF (entry) @ location: 25 - [ True - 0x0507070707010000000361626302000000060001000200030200000006000400050006 ] - - log/[halt] (exit) @ location: 25 - [ 0x0507070707010000000361626302000000060001000200030200000006000400050006 ] - - [halt] (entry) @ location: 31 - [ 0x0507070707010000000361626302000000060001000200030200000006000400050006 ] - - control: KCons - - log/UNPACK (exit) @ location: 25 - [ 0x0507070707010000000361626302000000060001000200030200000006000400050006 ] - - UNPACK (entry) @ location: 31 - [ 0x0507070707010000000361626302000000060001000200030200000006000400050006 ] - - log/IF_NONE (exit) @ location: 31 - [ (Some (Pair (Pair "abc" { 1 ; 2 ; 3 }) { 4 ; 5 ; 6 })) ] - - IF_NONE (entry) @ location: 40 - [ (Some (Pair (Pair "abc" { 1 ; 2 ; 3 }) { 4 ; 5 ; 6 })) ] - - log/[halt] (exit) @ location: 40 - [ (Pair (Pair "abc" { 1 ; 2 ; 3 }) { 4 ; 5 ; 6 }) ] - - [halt] (entry) @ location: 46 - [ (Pair (Pair "abc" { 1 ; 2 ; 3 }) { 4 ; 5 ; 6 }) ] - - control: KCons - - log/DROP (exit) @ location: 40 - [ (Pair (Pair "abc" { 1 ; 2 ; 3 }) { 4 ; 5 ; 6 }) ] - - DROP (entry) @ location: 46 - [ (Pair (Pair "abc" { 1 ; 2 ; 3 }) { 4 ; 5 ; 6 }) ] - - log/PUSH (exit) @ location: 46 - [ ] - - PUSH (entry) @ location: 47 - [ ] - - log/NIL (exit) @ location: 47 - [ Unit ] - - NIL (entry) @ location: 48 - [ Unit ] - - log/PAIR (exit) @ location: 48 - [ {} - Unit ] - - PAIR (entry) @ location: 50 - [ {} - Unit ] - - log/[halt] (exit) @ location: 50 - [ (Pair {} Unit) ] - - [halt] (entry) @ location: 14 - [ (Pair {} Unit) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/pexec.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/pexec.out deleted file mode 100644 index 067af7c55351a54b04e6288d07efdaad83cdbde4..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/pexec.out +++ /dev/null @@ -1,83 +0,0 @@ - -trace - - LAMBDA (interp) @ location: 7 - [ (Pair 7 77) ] - - LAMBDA (entry) @ location: 7 - [ (Pair 7 77) ] - - log/SWAP (exit) @ location: 7 - [ { UNPAIR ; ADD } - (Pair 7 77) ] - - SWAP (entry) @ location: 15 - [ { UNPAIR ; ADD } - (Pair 7 77) ] - - log/UNPAIR (exit) @ location: 15 - [ (Pair 7 77) - { UNPAIR ; ADD } ] - - UNPAIR (entry) @ location: 16 - [ (Pair 7 77) - { UNPAIR ; ADD } ] - - log/DIP (exit) @ location: 16 - [ 7 - 77 - { UNPAIR ; ADD } ] - - DIP (entry) @ location: 17 - [ 7 - 77 - { UNPAIR ; ADD } ] - - log/APPLY (exit) @ location: 17 - [ 77 - { UNPAIR ; ADD } ] - - APPLY (entry) @ location: 19 - [ 77 - { UNPAIR ; ADD } ] - - log/[halt] (exit) @ location: 19 - [ { PUSH nat 77 ; PAIR ; { UNPAIR ; ADD } } ] - - [halt] (entry) @ location: 19 - [ { PUSH nat 77 ; PAIR ; { UNPAIR ; ADD } } ] - - control: KUndip - - control: KCons - - log/EXEC (exit) @ location: 17 - [ 7 - { PUSH nat 77 ; PAIR ; { UNPAIR ; ADD } } ] - - EXEC (entry) @ location: 20 - [ 7 - { PUSH nat 77 ; PAIR ; { UNPAIR ; ADD } } ] - - PUSH (entry) @ location: 12 - [ 7 ] - - log/PAIR (exit) @ location: 12 - [ 77 - 7 ] - - PAIR (entry) @ location: 12 - [ 77 - 7 ] - - log/UNPAIR (exit) @ location: 12 - [ (Pair 77 7) ] - - UNPAIR (entry) @ location: 13 - [ (Pair 77 7) ] - - log/ADD (exit) @ location: 13 - [ 77 - 7 ] - - ADD (entry) @ location: 14 - [ 77 - 7 ] - - log/[halt] (exit) @ location: 14 - [ 84 ] - - [halt] (entry) @ location: 12 - [ 84 ] - - control: KReturn - - control: KCons - - log/NIL (exit) @ location: 20 - [ 84 ] - - NIL (entry) @ location: 21 - [ 84 ] - - log/PAIR (exit) @ location: 21 - [ {} - 84 ] - - PAIR (entry) @ location: 23 - [ {} - 84 ] - - log/[halt] (exit) @ location: 23 - [ (Pair {} 84) ] - - [halt] (entry) @ location: 6 - [ (Pair {} 84) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/rec_id_unit.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/rec_id_unit.out deleted file mode 100644 index 8ac716e1d0587b3814f50cd68f9db794c6c452a1..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/rec_id_unit.out +++ /dev/null @@ -1,56 +0,0 @@ - -trace - - CAR (interp) @ location: 7 - [ (Pair Unit Unit) ] - - CAR (entry) @ location: 7 - [ (Pair Unit Unit) ] - - log/LAMBDA_REC (exit) @ location: 7 - [ Unit ] - - LAMBDA_REC (entry) @ location: 8 - [ Unit ] - - log/SWAP (exit) @ location: 8 - [ (Lambda_rec { DIP { DROP } }) - Unit ] - - SWAP (entry) @ location: 15 - [ (Lambda_rec { DIP { DROP } }) - Unit ] - - log/EXEC (exit) @ location: 15 - [ Unit - (Lambda_rec { DIP { DROP } }) ] - - EXEC (entry) @ location: 16 - [ Unit - (Lambda_rec { DIP { DROP } }) ] - - DIP (entry) @ location: 12 - [ Unit - (Lambda_rec { DIP { DROP } }) ] - - log/DROP (exit) @ location: 12 - [ (Lambda_rec { DIP { DROP } }) ] - - DROP (entry) @ location: 14 - [ (Lambda_rec { DIP { DROP } }) ] - - log/[halt] (exit) @ location: 14 - [ ] - - [halt] (entry) @ location: 14 - [ ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 12 - [ Unit ] - - [halt] (entry) @ location: 12 - [ Unit ] - - control: KReturn - - control: KCons - - log/NIL (exit) @ location: 16 - [ Unit ] - - NIL (entry) @ location: 17 - [ Unit ] - - log/PAIR (exit) @ location: 17 - [ {} - Unit ] - - PAIR (entry) @ location: 19 - [ {} - Unit ] - - log/[halt] (exit) @ location: 19 - [ (Pair {} Unit) ] - - [halt] (entry) @ location: 6 - [ (Pair {} Unit) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/reverse_loop.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/reverse_loop.out deleted file mode 100644 index 76ea2381bed376df5f7d6dae17bda8daad08fe6c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/reverse_loop.out +++ /dev/null @@ -1,261 +0,0 @@ - -trace - - CAR (interp) @ location: 9 - [ (Pair { "abc" ; "def" ; "ghi" } {}) ] - - CAR (entry) @ location: 9 - [ (Pair { "abc" ; "def" ; "ghi" } {}) ] - - log/NIL (exit) @ location: 9 - [ { "abc" ; "def" ; "ghi" } ] - - NIL (entry) @ location: 10 - [ { "abc" ; "def" ; "ghi" } ] - - log/SWAP (exit) @ location: 10 - [ {} - { "abc" ; "def" ; "ghi" } ] - - SWAP (entry) @ location: 12 - [ {} - { "abc" ; "def" ; "ghi" } ] - - log/PUSH (exit) @ location: 12 - [ { "abc" ; "def" ; "ghi" } - {} ] - - PUSH (entry) @ location: 13 - [ { "abc" ; "def" ; "ghi" } - {} ] - - log/LOOP (exit) @ location: 13 - [ True - { "abc" ; "def" ; "ghi" } - {} ] - - LOOP (entry) @ location: 33 - [ True - { "abc" ; "def" ; "ghi" } - {} ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 33 - [ { "abc" ; "def" ; "ghi" } - {} ] - - IF_CONS (entry) @ location: 18 - [ { "abc" ; "def" ; "ghi" } - {} ] - - log/SWAP (exit) @ location: 18 - [ "abc" - { "def" ; "ghi" } - {} ] - - SWAP (entry) @ location: 20 - [ "abc" - { "def" ; "ghi" } - {} ] - - log/DIP (exit) @ location: 20 - [ { "def" ; "ghi" } - "abc" - {} ] - - DIP (entry) @ location: 21 - [ { "def" ; "ghi" } - "abc" - {} ] - - log/CONS (exit) @ location: 21 - [ "abc" - {} ] - - CONS (entry) @ location: 23 - [ "abc" - {} ] - - log/[halt] (exit) @ location: 23 - [ { "abc" } ] - - [halt] (entry) @ location: 23 - [ { "abc" } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 21 - [ { "def" ; "ghi" } - { "abc" } ] - - PUSH (entry) @ location: 24 - [ { "def" ; "ghi" } - { "abc" } ] - - log/[halt] (exit) @ location: 24 - [ True - { "def" ; "ghi" } - { "abc" } ] - - [halt] (entry) @ location: 33 - [ True - { "def" ; "ghi" } - { "abc" } ] - - control: KCons - - log/[halt] (exit) @ location: 18 - [ True - { "def" ; "ghi" } - { "abc" } ] - - [halt] (entry) @ location: 33 - [ True - { "def" ; "ghi" } - { "abc" } ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 33 - [ { "def" ; "ghi" } - { "abc" } ] - - IF_CONS (entry) @ location: 18 - [ { "def" ; "ghi" } - { "abc" } ] - - log/SWAP (exit) @ location: 18 - [ "def" - { "ghi" } - { "abc" } ] - - SWAP (entry) @ location: 20 - [ "def" - { "ghi" } - { "abc" } ] - - log/DIP (exit) @ location: 20 - [ { "ghi" } - "def" - { "abc" } ] - - DIP (entry) @ location: 21 - [ { "ghi" } - "def" - { "abc" } ] - - log/CONS (exit) @ location: 21 - [ "def" - { "abc" } ] - - CONS (entry) @ location: 23 - [ "def" - { "abc" } ] - - log/[halt] (exit) @ location: 23 - [ { "def" ; "abc" } ] - - [halt] (entry) @ location: 23 - [ { "def" ; "abc" } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 21 - [ { "ghi" } - { "def" ; "abc" } ] - - PUSH (entry) @ location: 24 - [ { "ghi" } - { "def" ; "abc" } ] - - log/[halt] (exit) @ location: 24 - [ True - { "ghi" } - { "def" ; "abc" } ] - - [halt] (entry) @ location: 33 - [ True - { "ghi" } - { "def" ; "abc" } ] - - control: KCons - - log/[halt] (exit) @ location: 18 - [ True - { "ghi" } - { "def" ; "abc" } ] - - [halt] (entry) @ location: 33 - [ True - { "ghi" } - { "def" ; "abc" } ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 33 - [ { "ghi" } - { "def" ; "abc" } ] - - IF_CONS (entry) @ location: 18 - [ { "ghi" } - { "def" ; "abc" } ] - - log/SWAP (exit) @ location: 18 - [ "ghi" - {} - { "def" ; "abc" } ] - - SWAP (entry) @ location: 20 - [ "ghi" - {} - { "def" ; "abc" } ] - - log/DIP (exit) @ location: 20 - [ {} - "ghi" - { "def" ; "abc" } ] - - DIP (entry) @ location: 21 - [ {} - "ghi" - { "def" ; "abc" } ] - - log/CONS (exit) @ location: 21 - [ "ghi" - { "def" ; "abc" } ] - - CONS (entry) @ location: 23 - [ "ghi" - { "def" ; "abc" } ] - - log/[halt] (exit) @ location: 23 - [ { "ghi" ; "def" ; "abc" } ] - - [halt] (entry) @ location: 23 - [ { "ghi" ; "def" ; "abc" } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 21 - [ {} - { "ghi" ; "def" ; "abc" } ] - - PUSH (entry) @ location: 24 - [ {} - { "ghi" ; "def" ; "abc" } ] - - log/[halt] (exit) @ location: 24 - [ True - {} - { "ghi" ; "def" ; "abc" } ] - - [halt] (entry) @ location: 33 - [ True - {} - { "ghi" ; "def" ; "abc" } ] - - control: KCons - - log/[halt] (exit) @ location: 18 - [ True - {} - { "ghi" ; "def" ; "abc" } ] - - [halt] (entry) @ location: 33 - [ True - {} - { "ghi" ; "def" ; "abc" } ] - - control: KLoop_in - - log/IF_CONS (exit) @ location: 33 - [ {} - { "ghi" ; "def" ; "abc" } ] - - IF_CONS (entry) @ location: 18 - [ {} - { "ghi" ; "def" ; "abc" } ] - - log/NIL (exit) @ location: 18 - [ { "ghi" ; "def" ; "abc" } ] - - NIL (entry) @ location: 28 - [ { "ghi" ; "def" ; "abc" } ] - - log/PUSH (exit) @ location: 28 - [ {} - { "ghi" ; "def" ; "abc" } ] - - PUSH (entry) @ location: 30 - [ {} - { "ghi" ; "def" ; "abc" } ] - - log/[halt] (exit) @ location: 30 - [ False - {} - { "ghi" ; "def" ; "abc" } ] - - [halt] (entry) @ location: 33 - [ False - {} - { "ghi" ; "def" ; "abc" } ] - - control: KCons - - log/[halt] (exit) @ location: 18 - [ False - {} - { "ghi" ; "def" ; "abc" } ] - - [halt] (entry) @ location: 33 - [ False - {} - { "ghi" ; "def" ; "abc" } ] - - control: KLoop_in - - control: KCons - - log/DROP (exit) @ location: 33 - [ {} - { "ghi" ; "def" ; "abc" } ] - - DROP (entry) @ location: 33 - [ {} - { "ghi" ; "def" ; "abc" } ] - - log/NIL (exit) @ location: 33 - [ { "ghi" ; "def" ; "abc" } ] - - NIL (entry) @ location: 34 - [ { "ghi" ; "def" ; "abc" } ] - - log/PAIR (exit) @ location: 34 - [ {} - { "ghi" ; "def" ; "abc" } ] - - PAIR (entry) @ location: 36 - [ {} - { "ghi" ; "def" ; "abc" } ] - - log/[halt] (exit) @ location: 36 - [ (Pair {} { "ghi" ; "def" ; "abc" }) ] - - [halt] (entry) @ location: 8 - [ (Pair {} { "ghi" ; "def" ; "abc" }) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/set_delegate.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/set_delegate.out deleted file mode 100644 index 89bf0cc887b96b2b1ca5a5f11b5b5b9d91c86817..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/set_delegate.out +++ /dev/null @@ -1,51 +0,0 @@ - -trace - - UNPAIR (interp) @ location: 8 - [ (Pair (Some "[PUBLIC_KEY_HASH]") Unit) ] - - UNPAIR (entry) @ location: 8 - [ (Pair (Some "[PUBLIC_KEY_HASH]") Unit) ] - - log/SET_DELEGATE (exit) @ location: 8 - [ (Some "[PUBLIC_KEY_HASH]") - Unit ] - - SET_DELEGATE (entry) @ location: 9 - [ (Some "[PUBLIC_KEY_HASH]") - Unit ] - - log/DIP (exit) @ location: 9 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000003ff00e7670f32038107a59a2b9cfefae36ea21f5aa63c - Unit ] - - DIP (entry) @ location: 10 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000003ff00e7670f32038107a59a2b9cfefae36ea21f5aa63c - Unit ] - - log/NIL (exit) @ location: 10 - [ Unit ] - - NIL (entry) @ location: 12 - [ Unit ] - - log/[halt] (exit) @ location: 12 - [ {} - Unit ] - - [halt] (entry) @ location: 12 - [ {} - Unit ] - - control: KUndip - - control: KCons - - log/CONS (exit) @ location: 10 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000003ff00e7670f32038107a59a2b9cfefae36ea21f5aa63c - {} - Unit ] - - CONS (entry) @ location: 14 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000003ff00e7670f32038107a59a2b9cfefae36ea21f5aa63c - {} - Unit ] - - log/PAIR (exit) @ location: 14 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000003ff00e7670f32038107a59a2b9cfefae36ea21f5aa63c } - Unit ] - - PAIR (entry) @ location: 15 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000003ff00e7670f32038107a59a2b9cfefae36ea21f5aa63c } - Unit ] - - log/[halt] (exit) @ location: 15 - [ (Pair { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000003ff00e7670f32038107a59a2b9cfefae36ea21f5aa63c } - Unit) ] - - [halt] (entry) @ location: 7 - [ (Pair { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000003ff00e7670f32038107a59a2b9cfefae36ea21f5aa63c } - Unit) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/shifts.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/shifts.out deleted file mode 100644 index 73e5b8e2405809b31eb9f18c00e8c9a4c0aa7dcc..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/shifts.out +++ /dev/null @@ -1,44 +0,0 @@ - -trace - - CAR (interp) @ location: 14 - [ (Pair (Right (Pair 3 2)) None) ] - - CAR (entry) @ location: 14 - [ (Pair (Right (Pair 3 2)) None) ] - - log/IF_LEFT (exit) @ location: 14 - [ (Right (Pair 3 2)) ] - - IF_LEFT (entry) @ location: 15 - [ (Right (Pair 3 2)) ] - - log/UNPAIR (exit) @ location: 15 - [ (Pair 3 2) ] - - UNPAIR (entry) @ location: 20 - [ (Pair 3 2) ] - - log/LSR (exit) @ location: 20 - [ 3 - 2 ] - - LSR (entry) @ location: 21 - [ 3 - 2 ] - - log/[halt] (exit) @ location: 21 - [ 0 ] - - [halt] (entry) @ location: 22 - [ 0 ] - - control: KCons - - log/SOME (exit) @ location: 15 - [ 0 ] - - SOME (entry) @ location: 22 - [ 0 ] - - log/NIL (exit) @ location: 22 - [ (Some 0) ] - - NIL (entry) @ location: 23 - [ (Some 0) ] - - log/PAIR (exit) @ location: 23 - [ {} - (Some 0) ] - - PAIR (entry) @ location: 25 - [ {} - (Some 0) ] - - log/[halt] (exit) @ location: 25 - [ (Pair {} (Some 0)) ] - - [halt] (entry) @ location: 13 - [ (Pair {} (Some 0)) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/spawn_identities.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/spawn_identities.out deleted file mode 100644 index 9f1a07749f236c2cc30144fa575cebb4c6e9370a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/spawn_identities.out +++ /dev/null @@ -1,4341 +0,0 @@ - -trace - - DUP (interp) @ location: 8 - [ (Pair 7 {}) ] - - DUP (entry) @ location: 8 - [ (Pair 7 {}) ] - - log/CAR (exit) @ location: 8 - [ (Pair 7 {}) - (Pair 7 {}) ] - - CAR (entry) @ location: 9 - [ (Pair 7 {}) - (Pair 7 {}) ] - - log/DIP (exit) @ location: 9 - [ 7 - (Pair 7 {}) ] - - DIP (entry) @ location: 10 - [ 7 - (Pair 7 {}) ] - - log/CDR (exit) @ location: 10 - [ (Pair 7 {}) ] - - CDR (entry) @ location: 12 - [ (Pair 7 {}) ] - - log/NIL (exit) @ location: 12 - [ {} ] - - NIL (entry) @ location: 13 - [ {} ] - - log/[halt] (exit) @ location: 13 - [ {} - {} ] - - [halt] (entry) @ location: 11 - [ {} - {} ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 10 - [ 7 - {} - {} ] - - PUSH (entry) @ location: 15 - [ 7 - {} - {} ] - - log/LOOP (exit) @ location: 15 - [ True - 7 - {} - {} ] - - LOOP (entry) @ location: 76 - [ True - 7 - {} - {} ] - - control: KLoop_in - - log/DUP (exit) @ location: 76 - [ 7 - {} - {} ] - - DUP (entry) @ location: 20 - [ 7 - {} - {} ] - - log/PUSH (exit) @ location: 20 - [ 7 - 7 - {} - {} ] - - PUSH (entry) @ location: 21 - [ 7 - 7 - {} - {} ] - - log/COMPARE (exit) @ location: 21 - [ 0 - 7 - 7 - {} - {} ] - - COMPARE (entry) @ location: 25 - [ 0 - 7 - 7 - {} - {} ] - - log/EQ (exit) @ location: 25 - [ -1 - 7 - {} - {} ] - - EQ (entry) @ location: 26 - [ -1 - 7 - {} - {} ] - - log/IF (exit) @ location: 26 - [ False - 7 - {} - {} ] - - IF (entry) @ location: 27 - [ False - 7 - {} - {} ] - - log/PUSH (exit) @ location: 27 - [ 7 - {} - {} ] - - PUSH (entry) @ location: 33 - [ 7 - {} - {} ] - - log/SWAP (exit) @ location: 33 - [ 1 - 7 - {} - {} ] - - SWAP (entry) @ location: 36 - [ 1 - 7 - {} - {} ] - - log/SUB (exit) @ location: 36 - [ 7 - 1 - {} - {} ] - - SUB (entry) @ location: 37 - [ 7 - 1 - {} - {} ] - - log/ABS (exit) @ location: 37 - [ 6 - {} - {} ] - - ABS (entry) @ location: 38 - [ 6 - {} - {} ] - - log/PUSH (exit) @ location: 38 - [ 6 - {} - {} ] - - PUSH (entry) @ location: 39 - [ 6 - {} - {} ] - - log/PUSH (exit) @ location: 39 - [ "init" - 6 - {} - {} ] - - PUSH (entry) @ location: 42 - [ "init" - 6 - {} - {} ] - - log/NONE (exit) @ location: 42 - [ 5000000 - "init" - 6 - {} - {} ] - - NONE (entry) @ location: 45 - [ 5000000 - "init" - 6 - {} - {} ] - - log/CREATE_CONTRACT (exit) @ location: 45 - [ None - 5000000 - "init" - 6 - {} - {} ] - - CREATE_CONTRACT (entry) @ location: 47 - [ None - 5000000 - "init" - 6 - {} - {} ] - - log/SWAP (exit) @ location: 47 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - "[CONTRACT_HASH]" - 6 - {} - {} ] - - SWAP (entry) @ location: 59 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - "[CONTRACT_HASH]" - 6 - {} - {} ] - - log/DIP (exit) @ location: 59 - [ "[CONTRACT_HASH]" - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 6 - {} - {} ] - - DIP (entry) @ location: 60 - [ "[CONTRACT_HASH]" - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 6 - {} - {} ] - - log/SWAP (exit) @ location: 60 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 6 - {} - {} ] - - SWAP (entry) @ location: 62 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 6 - {} - {} ] - - log/DIP (exit) @ location: 62 - [ 6 - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - {} - {} ] - - DIP (entry) @ location: 63 - [ 6 - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - {} - {} ] - - log/CONS (exit) @ location: 63 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - {} - {} ] - - CONS (entry) @ location: 65 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - {} - {} ] - - log/[halt] (exit) @ location: 65 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - {} ] - - [halt] (entry) @ location: 65 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - {} ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 63 - [ 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - {} ] - - [halt] (entry) @ location: 61 - [ 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - {} ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 60 - [ "[CONTRACT_HASH]" - 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - {} ] - - SWAP (entry) @ location: 66 - [ "[CONTRACT_HASH]" - 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - {} ] - - log/DIP (exit) @ location: 66 - [ 6 - "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - {} ] - - DIP (entry) @ location: 67 - [ 6 - "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - {} ] - - log/SWAP (exit) @ location: 67 - [ "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - {} ] - - SWAP (entry) @ location: 69 - [ "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - {} ] - - log/DIP (exit) @ location: 69 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - "[CONTRACT_HASH]" - {} ] - - DIP (entry) @ location: 70 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - "[CONTRACT_HASH]" - {} ] - - log/CONS (exit) @ location: 70 - [ "[CONTRACT_HASH]" - {} ] - - CONS (entry) @ location: 72 - [ "[CONTRACT_HASH]" - {} ] - - log/[halt] (exit) @ location: 72 - [ { "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 72 - [ { "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 70 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 68 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 67 - [ 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 73 - [ 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/[halt] (exit) @ location: 73 - [ True - 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 76 - [ True - 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - control: KCons - - log/[halt] (exit) @ location: 27 - [ True - 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 76 - [ True - 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - control: KLoop_in - - log/DUP (exit) @ location: 76 - [ 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - DUP (entry) @ location: 20 - [ 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 20 - [ 6 - 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 21 - [ 6 - 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/COMPARE (exit) @ location: 21 - [ 0 - 6 - 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - COMPARE (entry) @ location: 25 - [ 0 - 6 - 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/EQ (exit) @ location: 25 - [ -1 - 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - EQ (entry) @ location: 26 - [ -1 - 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/IF (exit) @ location: 26 - [ False - 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - IF (entry) @ location: 27 - [ False - 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 27 - [ 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 33 - [ 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 33 - [ 1 - 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 36 - [ 1 - 6 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/SUB (exit) @ location: 36 - [ 6 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - SUB (entry) @ location: 37 - [ 6 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/ABS (exit) @ location: 37 - [ 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - ABS (entry) @ location: 38 - [ 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 38 - [ 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 39 - [ 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 39 - [ "init" - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 42 - [ "init" - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/NONE (exit) @ location: 42 - [ 5000000 - "init" - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - NONE (entry) @ location: 45 - [ 5000000 - "init" - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/CREATE_CONTRACT (exit) @ location: 45 - [ None - 5000000 - "init" - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - CREATE_CONTRACT (entry) @ location: 47 - [ None - 5000000 - "init" - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 47 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - "[CONTRACT_HASH]" - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 59 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - "[CONTRACT_HASH]" - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 59 - [ "[CONTRACT_HASH]" - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 60 - [ "[CONTRACT_HASH]" - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 60 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 62 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 62 - [ 5 - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 63 - [ 5 - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/CONS (exit) @ location: 63 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - CONS (entry) @ location: 65 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/[halt] (exit) @ location: 65 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 65 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 63 - [ 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 61 - [ 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 60 - [ "[CONTRACT_HASH]" - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 66 - [ "[CONTRACT_HASH]" - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 66 - [ 5 - "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 67 - [ 5 - "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 67 - [ "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 69 - [ "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 69 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 70 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" } ] - - log/CONS (exit) @ location: 70 - [ "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" } ] - - CONS (entry) @ location: 72 - [ "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" } ] - - log/[halt] (exit) @ location: 72 - [ { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 72 - [ { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 70 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 68 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 67 - [ 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 73 - [ 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/[halt] (exit) @ location: 73 - [ True - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 76 - [ True - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KCons - - log/[halt] (exit) @ location: 27 - [ True - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 76 - [ True - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KLoop_in - - log/DUP (exit) @ location: 76 - [ 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DUP (entry) @ location: 20 - [ 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 20 - [ 5 - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 21 - [ 5 - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/COMPARE (exit) @ location: 21 - [ 0 - 5 - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - COMPARE (entry) @ location: 25 - [ 0 - 5 - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/EQ (exit) @ location: 25 - [ -1 - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - EQ (entry) @ location: 26 - [ -1 - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/IF (exit) @ location: 26 - [ False - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - IF (entry) @ location: 27 - [ False - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 27 - [ 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 33 - [ 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 33 - [ 1 - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 36 - [ 1 - 5 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SUB (exit) @ location: 36 - [ 5 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SUB (entry) @ location: 37 - [ 5 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/ABS (exit) @ location: 37 - [ 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - ABS (entry) @ location: 38 - [ 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 38 - [ 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 39 - [ 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 39 - [ "init" - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 42 - [ "init" - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/NONE (exit) @ location: 42 - [ 5000000 - "init" - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - NONE (entry) @ location: 45 - [ 5000000 - "init" - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/CREATE_CONTRACT (exit) @ location: 45 - [ None - 5000000 - "init" - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - CREATE_CONTRACT (entry) @ location: 47 - [ None - 5000000 - "init" - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 47 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - "[CONTRACT_HASH]" - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 59 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - "[CONTRACT_HASH]" - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 59 - [ "[CONTRACT_HASH]" - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 60 - [ "[CONTRACT_HASH]" - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 60 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 62 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 62 - [ 4 - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 63 - [ 4 - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/CONS (exit) @ location: 63 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - CONS (entry) @ location: 65 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/[halt] (exit) @ location: 65 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 65 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 63 - [ 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 61 - [ 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 60 - [ "[CONTRACT_HASH]" - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 66 - [ "[CONTRACT_HASH]" - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 66 - [ 4 - "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 67 - [ 4 - "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 67 - [ "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 69 - [ "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 69 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 70 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/CONS (exit) @ location: 70 - [ "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - CONS (entry) @ location: 72 - [ "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/[halt] (exit) @ location: 72 - [ { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 72 - [ { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 70 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 68 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 67 - [ 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 73 - [ 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/[halt] (exit) @ location: 73 - [ True - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 76 - [ True - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KCons - - log/[halt] (exit) @ location: 27 - [ True - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 76 - [ True - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KLoop_in - - log/DUP (exit) @ location: 76 - [ 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DUP (entry) @ location: 20 - [ 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 20 - [ 4 - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 21 - [ 4 - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/COMPARE (exit) @ location: 21 - [ 0 - 4 - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - COMPARE (entry) @ location: 25 - [ 0 - 4 - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/EQ (exit) @ location: 25 - [ -1 - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - EQ (entry) @ location: 26 - [ -1 - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/IF (exit) @ location: 26 - [ False - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - IF (entry) @ location: 27 - [ False - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 27 - [ 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 33 - [ 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 33 - [ 1 - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 36 - [ 1 - 4 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SUB (exit) @ location: 36 - [ 4 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SUB (entry) @ location: 37 - [ 4 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/ABS (exit) @ location: 37 - [ 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - ABS (entry) @ location: 38 - [ 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 38 - [ 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 39 - [ 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 39 - [ "init" - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 42 - [ "init" - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/NONE (exit) @ location: 42 - [ 5000000 - "init" - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - NONE (entry) @ location: 45 - [ 5000000 - "init" - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/CREATE_CONTRACT (exit) @ location: 45 - [ None - 5000000 - "init" - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - CREATE_CONTRACT (entry) @ location: 47 - [ None - 5000000 - "init" - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 47 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - "[CONTRACT_HASH]" - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 59 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - "[CONTRACT_HASH]" - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 59 - [ "[CONTRACT_HASH]" - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 60 - [ "[CONTRACT_HASH]" - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 60 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 62 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 62 - [ 3 - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 63 - [ 3 - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/CONS (exit) @ location: 63 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - CONS (entry) @ location: 65 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/[halt] (exit) @ location: 65 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 65 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 63 - [ 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 61 - [ 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 60 - [ "[CONTRACT_HASH]" - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 66 - [ "[CONTRACT_HASH]" - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 66 - [ 3 - "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 67 - [ 3 - "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 67 - [ "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 69 - [ "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 69 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 70 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/CONS (exit) @ location: 70 - [ "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - CONS (entry) @ location: 72 - [ "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/[halt] (exit) @ location: 72 - [ { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 72 - [ { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 70 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 68 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 67 - [ 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 73 - [ 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/[halt] (exit) @ location: 73 - [ True - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 76 - [ True - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KCons - - log/[halt] (exit) @ location: 27 - [ True - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 76 - [ True - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KLoop_in - - log/DUP (exit) @ location: 76 - [ 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DUP (entry) @ location: 20 - [ 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 20 - [ 3 - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 21 - [ 3 - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/COMPARE (exit) @ location: 21 - [ 0 - 3 - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - COMPARE (entry) @ location: 25 - [ 0 - 3 - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/EQ (exit) @ location: 25 - [ -1 - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - EQ (entry) @ location: 26 - [ -1 - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/IF (exit) @ location: 26 - [ False - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - IF (entry) @ location: 27 - [ False - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 27 - [ 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 33 - [ 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 33 - [ 1 - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 36 - [ 1 - 3 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SUB (exit) @ location: 36 - [ 3 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SUB (entry) @ location: 37 - [ 3 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/ABS (exit) @ location: 37 - [ 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - ABS (entry) @ location: 38 - [ 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 38 - [ 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 39 - [ 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 39 - [ "init" - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 42 - [ "init" - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/NONE (exit) @ location: 42 - [ 5000000 - "init" - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - NONE (entry) @ location: 45 - [ 5000000 - "init" - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/CREATE_CONTRACT (exit) @ location: 45 - [ None - 5000000 - "init" - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - CREATE_CONTRACT (entry) @ location: 47 - [ None - 5000000 - "init" - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 47 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - "[CONTRACT_HASH]" - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 59 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - "[CONTRACT_HASH]" - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 59 - [ "[CONTRACT_HASH]" - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 60 - [ "[CONTRACT_HASH]" - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 60 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 62 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 62 - [ 2 - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 63 - [ 2 - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/CONS (exit) @ location: 63 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - CONS (entry) @ location: 65 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/[halt] (exit) @ location: 65 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 65 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 63 - [ 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 61 - [ 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 60 - [ "[CONTRACT_HASH]" - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 66 - [ "[CONTRACT_HASH]" - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 66 - [ 2 - "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 67 - [ 2 - "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 67 - [ "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 69 - [ "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 69 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 70 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/CONS (exit) @ location: 70 - [ "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - CONS (entry) @ location: 72 - [ "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/[halt] (exit) @ location: 72 - [ { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 72 - [ { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 70 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 68 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 67 - [ 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 73 - [ 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/[halt] (exit) @ location: 73 - [ True - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 76 - [ True - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KCons - - log/[halt] (exit) @ location: 27 - [ True - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 76 - [ True - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KLoop_in - - log/DUP (exit) @ location: 76 - [ 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DUP (entry) @ location: 20 - [ 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 20 - [ 2 - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 21 - [ 2 - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/COMPARE (exit) @ location: 21 - [ 0 - 2 - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - COMPARE (entry) @ location: 25 - [ 0 - 2 - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/EQ (exit) @ location: 25 - [ -1 - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - EQ (entry) @ location: 26 - [ -1 - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/IF (exit) @ location: 26 - [ False - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - IF (entry) @ location: 27 - [ False - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 27 - [ 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 33 - [ 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 33 - [ 1 - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 36 - [ 1 - 2 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SUB (exit) @ location: 36 - [ 2 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SUB (entry) @ location: 37 - [ 2 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/ABS (exit) @ location: 37 - [ 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - ABS (entry) @ location: 38 - [ 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 38 - [ 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 39 - [ 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 39 - [ "init" - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 42 - [ "init" - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/NONE (exit) @ location: 42 - [ 5000000 - "init" - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - NONE (entry) @ location: 45 - [ 5000000 - "init" - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/CREATE_CONTRACT (exit) @ location: 45 - [ None - 5000000 - "init" - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - CREATE_CONTRACT (entry) @ location: 47 - [ None - 5000000 - "init" - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 47 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - "[CONTRACT_HASH]" - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 59 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - "[CONTRACT_HASH]" - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 59 - [ "[CONTRACT_HASH]" - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 60 - [ "[CONTRACT_HASH]" - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 60 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 62 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 62 - [ 1 - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 63 - [ 1 - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/CONS (exit) @ location: 63 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - CONS (entry) @ location: 65 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/[halt] (exit) @ location: 65 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 65 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 63 - [ 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 61 - [ 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 60 - [ "[CONTRACT_HASH]" - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 66 - [ "[CONTRACT_HASH]" - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 66 - [ 1 - "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 67 - [ 1 - "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 67 - [ "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 69 - [ "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 69 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 70 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/CONS (exit) @ location: 70 - [ "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - CONS (entry) @ location: 72 - [ "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/[halt] (exit) @ location: 72 - [ { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 72 - [ { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 70 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 68 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 67 - [ 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 73 - [ 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/[halt] (exit) @ location: 73 - [ True - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 76 - [ True - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KCons - - log/[halt] (exit) @ location: 27 - [ True - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 76 - [ True - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KLoop_in - - log/DUP (exit) @ location: 76 - [ 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DUP (entry) @ location: 20 - [ 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 20 - [ 1 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 21 - [ 1 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/COMPARE (exit) @ location: 21 - [ 0 - 1 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - COMPARE (entry) @ location: 25 - [ 0 - 1 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/EQ (exit) @ location: 25 - [ -1 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - EQ (entry) @ location: 26 - [ -1 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/IF (exit) @ location: 26 - [ False - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - IF (entry) @ location: 27 - [ False - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 27 - [ 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 33 - [ 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 33 - [ 1 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 36 - [ 1 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SUB (exit) @ location: 36 - [ 1 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SUB (entry) @ location: 37 - [ 1 - 1 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/ABS (exit) @ location: 37 - [ 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - ABS (entry) @ location: 38 - [ 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 38 - [ 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 39 - [ 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 39 - [ "init" - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 42 - [ "init" - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/NONE (exit) @ location: 42 - [ 5000000 - "init" - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - NONE (entry) @ location: 45 - [ 5000000 - "init" - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/CREATE_CONTRACT (exit) @ location: 45 - [ None - 5000000 - "init" - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - CREATE_CONTRACT (entry) @ location: 47 - [ None - 5000000 - "init" - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 47 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - "[CONTRACT_HASH]" - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 59 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - "[CONTRACT_HASH]" - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 59 - [ "[CONTRACT_HASH]" - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 60 - [ "[CONTRACT_HASH]" - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 60 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 62 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 62 - [ 0 - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 63 - [ 0 - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/CONS (exit) @ location: 63 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - CONS (entry) @ location: 65 - [ 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/[halt] (exit) @ location: 65 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 65 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 63 - [ 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 61 - [ 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/SWAP (exit) @ location: 60 - [ "[CONTRACT_HASH]" - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 66 - [ "[CONTRACT_HASH]" - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 66 - [ 0 - "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 67 - [ 0 - "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/SWAP (exit) @ location: 67 - [ "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - SWAP (entry) @ location: 69 - [ "[CONTRACT_HASH]" - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/DIP (exit) @ location: 69 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DIP (entry) @ location: 70 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/CONS (exit) @ location: 70 - [ "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - CONS (entry) @ location: 72 - [ "[CONTRACT_HASH]" - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/[halt] (exit) @ location: 72 - [ { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 72 - [ { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/[halt] (exit) @ location: 70 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 68 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KUndip - - control: KCons - - log/PUSH (exit) @ location: 67 - [ 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 73 - [ 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/[halt] (exit) @ location: 73 - [ True - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 76 - [ True - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KCons - - log/[halt] (exit) @ location: 27 - [ True - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 76 - [ True - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KLoop_in - - log/DUP (exit) @ location: 76 - [ 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DUP (entry) @ location: 20 - [ 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 20 - [ 0 - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 21 - [ 0 - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/COMPARE (exit) @ location: 21 - [ 0 - 0 - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - COMPARE (entry) @ location: 25 - [ 0 - 0 - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/EQ (exit) @ location: 25 - [ 0 - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - EQ (entry) @ location: 26 - [ 0 - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/IF (exit) @ location: 26 - [ True - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - IF (entry) @ location: 27 - [ True - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PUSH (exit) @ location: 27 - [ 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PUSH (entry) @ location: 29 - [ 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/[halt] (exit) @ location: 29 - [ False - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 76 - [ False - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KCons - - log/[halt] (exit) @ location: 27 - [ False - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - [halt] (entry) @ location: 76 - [ False - 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - control: KLoop_in - - control: KCons - - log/DROP (exit) @ location: 76 - [ 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - DROP (entry) @ location: 76 - [ 0 - { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/PAIR (exit) @ location: 76 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - PAIR (entry) @ location: 77 - [ { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" } ] - - log/[halt] (exit) @ location: 77 - [ (Pair { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" }) ] - - [halt] (entry) @ location: 7 - [ (Pair { 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000602c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000502c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000402c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000302c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000202c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000102c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 ; - 0x014828e9aa0b3e6e970da0515b5c5d8ccf5028758900000002c096b102000000001c02000000170500036805010368050202000000080316053d036d0342000000090100000004696e6974 } - { "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" ; - "[CONTRACT_HASH]" }) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/ticket_join.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/ticket_join.out deleted file mode 100644 index 9b2173a0c4f327ff0d387fc082863437f378cccd..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/ticket_join.out +++ /dev/null @@ -1,42 +0,0 @@ - -trace - - UNPAIR (interp) @ location: 10 - [ (Pair (Pair "[CONTRACT_HASH]" 17 3) None) ] - - UNPAIR (entry) @ location: 10 - [ (Pair (Pair "[CONTRACT_HASH]" 17 3) None) ] - - log/SWAP (exit) @ location: 10 - [ (Pair "[CONTRACT_HASH]" 17 3) - None ] - - SWAP (entry) @ location: 11 - [ (Pair "[CONTRACT_HASH]" 17 3) - None ] - - log/IF_NONE (exit) @ location: 11 - [ None - (Pair "[CONTRACT_HASH]" 17 3) ] - - IF_NONE (entry) @ location: 12 - [ None - (Pair "[CONTRACT_HASH]" 17 3) ] - - log/[halt] (exit) @ location: 12 - [ (Pair "[CONTRACT_HASH]" 17 3) ] - - [halt] (entry) @ location: 24 - [ (Pair "[CONTRACT_HASH]" 17 3) ] - - control: KCons - - log/SOME (exit) @ location: 12 - [ (Pair "[CONTRACT_HASH]" 17 3) ] - - SOME (entry) @ location: 24 - [ (Pair "[CONTRACT_HASH]" 17 3) ] - - log/NIL (exit) @ location: 24 - [ (Some (Pair "[CONTRACT_HASH]" 17 3)) ] - - NIL (entry) @ location: 25 - [ (Some (Pair "[CONTRACT_HASH]" 17 3)) ] - - log/PAIR (exit) @ location: 25 - [ {} - (Some (Pair "[CONTRACT_HASH]" 17 3)) ] - - PAIR (entry) @ location: 27 - [ {} - (Some (Pair "[CONTRACT_HASH]" 17 3)) ] - - log/[halt] (exit) @ location: 27 - [ (Pair {} (Some (Pair "[CONTRACT_HASH]" 17 3))) ] - - [halt] (entry) @ location: 9 - [ (Pair {} (Some (Pair "[CONTRACT_HASH]" 17 3))) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/ticket_split.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/ticket_split.out deleted file mode 100644 index 52f6e5de51a3540f8dea27dc6807c4106b692c0f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/ticket_split.out +++ /dev/null @@ -1,180 +0,0 @@ - -trace - - CAR (interp) @ location: 8 - [ (Pair (Pair "[CONTRACT_HASH]" 17 3) Unit) ] - - CAR (entry) @ location: 8 - [ (Pair (Pair "[CONTRACT_HASH]" 17 3) Unit) ] - - log/PUSH (exit) @ location: 8 - [ (Pair "[CONTRACT_HASH]" 17 3) ] - - PUSH (entry) @ location: 9 - [ (Pair "[CONTRACT_HASH]" 17 3) ] - - log/SWAP (exit) @ location: 9 - [ (Pair 1 2) - (Pair "[CONTRACT_HASH]" 17 3) ] - - SWAP (entry) @ location: 16 - [ (Pair 1 2) - (Pair "[CONTRACT_HASH]" 17 3) ] - - log/SPLIT_TICKET (exit) @ location: 16 - [ (Pair "[CONTRACT_HASH]" 17 3) - (Pair 1 2) ] - - SPLIT_TICKET (entry) @ location: 17 - [ (Pair "[CONTRACT_HASH]" 17 3) - (Pair 1 2) ] - - log/IF_NONE (exit) @ location: 17 - [ (Some (Pair (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2))) ] - - IF_NONE (entry) @ location: 19 - [ (Some (Pair (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2))) ] - - log/[halt] (exit) @ location: 19 - [ (Pair (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2)) ] - - [halt] (entry) @ location: 25 - [ (Pair (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2)) ] - - control: KCons - - log/UNPAIR (exit) @ location: 19 - [ (Pair (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2)) ] - - UNPAIR (entry) @ location: 25 - [ (Pair (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2)) ] - - log/READ_TICKET (exit) @ location: 25 - [ (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2) ] - - READ_TICKET (entry) @ location: 26 - [ (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2) ] - - log/CDR (exit) @ location: 26 - [ (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2) ] - - CDR (entry) @ location: 28 - [ (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2) ] - - log/CDR (exit) @ location: 28 - [ (Pair 17 1) - (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2) ] - - CDR (entry) @ location: 29 - [ (Pair 17 1) - (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2) ] - - log/PUSH (exit) @ location: 29 - [ 1 - (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2) ] - - PUSH (entry) @ location: 30 - [ 1 - (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2) ] - - log/COMPARE (exit) @ location: 30 - [ 1 - 1 - (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2) ] - - COMPARE (entry) @ location: 35 - [ 1 - 1 - (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2) ] - - log/EQ (exit) @ location: 35 - [ 0 - (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2) ] - - EQ (entry) @ location: 36 - [ 0 - (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2) ] - - log/IF (exit) @ location: 36 - [ True - (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2) ] - - IF (entry) @ location: 37 - [ True - (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2) ] - - log/[halt] (exit) @ location: 37 - [ (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2) ] - - [halt] (entry) @ location: 43 - [ (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2) ] - - control: KCons - - log/DROP (exit) @ location: 37 - [ (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2) ] - - DROP (entry) @ location: 43 - [ (Pair "[CONTRACT_HASH]" 17 1) - (Pair "[CONTRACT_HASH]" 17 2) ] - - log/READ_TICKET (exit) @ location: 43 - [ (Pair "[CONTRACT_HASH]" 17 2) ] - - READ_TICKET (entry) @ location: 44 - [ (Pair "[CONTRACT_HASH]" 17 2) ] - - log/CDR (exit) @ location: 44 - [ (Pair "[CONTRACT_HASH]" 17 2) - (Pair "[CONTRACT_HASH]" 17 2) ] - - CDR (entry) @ location: 46 - [ (Pair "[CONTRACT_HASH]" 17 2) - (Pair "[CONTRACT_HASH]" 17 2) ] - - log/CDR (exit) @ location: 46 - [ (Pair 17 2) - (Pair "[CONTRACT_HASH]" 17 2) ] - - CDR (entry) @ location: 47 - [ (Pair 17 2) - (Pair "[CONTRACT_HASH]" 17 2) ] - - log/PUSH (exit) @ location: 47 - [ 2 - (Pair "[CONTRACT_HASH]" 17 2) ] - - PUSH (entry) @ location: 48 - [ 2 - (Pair "[CONTRACT_HASH]" 17 2) ] - - log/COMPARE (exit) @ location: 48 - [ 2 - 2 - (Pair "[CONTRACT_HASH]" 17 2) ] - - COMPARE (entry) @ location: 53 - [ 2 - 2 - (Pair "[CONTRACT_HASH]" 17 2) ] - - log/EQ (exit) @ location: 53 - [ 0 - (Pair "[CONTRACT_HASH]" 17 2) ] - - EQ (entry) @ location: 54 - [ 0 - (Pair "[CONTRACT_HASH]" 17 2) ] - - log/IF (exit) @ location: 54 - [ True - (Pair "[CONTRACT_HASH]" 17 2) ] - - IF (entry) @ location: 55 - [ True - (Pair "[CONTRACT_HASH]" 17 2) ] - - log/[halt] (exit) @ location: 55 - [ (Pair "[CONTRACT_HASH]" 17 2) ] - - [halt] (entry) @ location: 61 - [ (Pair "[CONTRACT_HASH]" 17 2) ] - - control: KCons - - log/DROP (exit) @ location: 55 - [ (Pair "[CONTRACT_HASH]" 17 2) ] - - DROP (entry) @ location: 61 - [ (Pair "[CONTRACT_HASH]" 17 2) ] - - log/PUSH (exit) @ location: 61 - [ ] - - PUSH (entry) @ location: 62 - [ ] - - log/NIL (exit) @ location: 62 - [ Unit ] - - NIL (entry) @ location: 63 - [ Unit ] - - log/PAIR (exit) @ location: 63 - [ {} - Unit ] - - PAIR (entry) @ location: 65 - [ {} - Unit ] - - log/[halt] (exit) @ location: 65 - [ (Pair {} Unit) ] - - [halt] (entry) @ location: 7 - [ (Pair {} Unit) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/view_fib.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/view_fib.out deleted file mode 100644 index 374caebbb37841d31f1819d69d3f0e86f384ffbe..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/view_fib.out +++ /dev/null @@ -1,41 +0,0 @@ - -trace - - CAR (interp) @ location: 9 - [ (Pair (Pair 8 "[CONTRACT_HASH]") 0) ] - - CAR (entry) @ location: 9 - [ (Pair (Pair 8 "[CONTRACT_HASH]") 0) ] - - log/UNPAIR (exit) @ location: 9 - [ (Pair 8 "[CONTRACT_HASH]") ] - - UNPAIR (entry) @ location: 10 - [ (Pair 8 "[CONTRACT_HASH]") ] - - log/VIEW (exit) @ location: 10 - [ 8 - "[CONTRACT_HASH]" ] - - VIEW (entry) @ location: 11 - [ 8 - "[CONTRACT_HASH]" ] - - control: KView_exit - - log/IF_NONE (exit) @ location: 11 - [ (Some 21) ] - - IF_NONE (entry) @ location: 15 - [ (Some 21) ] - - log/NIL (exit) @ location: 15 - [ 21 ] - - NIL (entry) @ location: 21 - [ 21 ] - - log/PAIR (exit) @ location: 21 - [ {} - 21 ] - - PAIR (entry) @ location: 23 - [ {} - 21 ] - - log/[halt] (exit) @ location: 23 - [ (Pair {} 21) ] - - [halt] (entry) @ location: 8 - [ (Pair {} 21) ] - - control: KCons - - log/[halt] (exit) @ location: 15 - [ (Pair {} 21) ] - - [halt] (entry) @ location: 8 - [ (Pair {} 21) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/view_toplevel_lib.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/view_toplevel_lib.out deleted file mode 100644 index 8791bd97f511034fcb1e3b6ab5261de2c48fd747..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/view_toplevel_lib.out +++ /dev/null @@ -1,21 +0,0 @@ - -trace - - CAR (interp) @ location: 7 - [ (Pair 5 3) ] - - CAR (entry) @ location: 7 - [ (Pair 5 3) ] - - log/NIL (exit) @ location: 7 - [ 5 ] - - NIL (entry) @ location: 8 - [ 5 ] - - log/PAIR (exit) @ location: 8 - [ {} - 5 ] - - PAIR (entry) @ location: 10 - [ {} - 5 ] - - log/[halt] (exit) @ location: 10 - [ (Pair {} 5) ] - - [halt] (entry) @ location: 6 - [ (Pair {} 5) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/xor.out b/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/xor.out deleted file mode 100644 index 5eb5063226ee2d8ba8a2ab8432660c92eb760188..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/expected/test_logging.ml/xor.out +++ /dev/null @@ -1,48 +0,0 @@ - -trace - - CAR (interp) @ location: 16 - [ (Pair (Left (Pair True False)) None) ] - - CAR (entry) @ location: 16 - [ (Pair (Left (Pair True False)) None) ] - - log/IF_LEFT (exit) @ location: 16 - [ (Left (Pair True False)) ] - - IF_LEFT (entry) @ location: 17 - [ (Left (Pair True False)) ] - - log/UNPAIR (exit) @ location: 17 - [ (Pair True False) ] - - UNPAIR (entry) @ location: 19 - [ (Pair True False) ] - - log/XOR (exit) @ location: 19 - [ True - False ] - - XOR (entry) @ location: 20 - [ True - False ] - - log/LEFT (exit) @ location: 20 - [ True ] - - LEFT (entry) @ location: 21 - [ True ] - - log/[halt] (exit) @ location: 21 - [ (Left True) ] - - [halt] (entry) @ location: 28 - [ (Left True) ] - - control: KCons - - log/SOME (exit) @ location: 17 - [ (Left True) ] - - SOME (entry) @ location: 28 - [ (Left True) ] - - log/NIL (exit) @ location: 28 - [ (Some (Left True)) ] - - NIL (entry) @ location: 29 - [ (Some (Left True)) ] - - log/PAIR (exit) @ location: 29 - [ {} - (Some (Left True)) ] - - PAIR (entry) @ location: 31 - [ {} - (Some (Left True)) ] - - log/[halt] (exit) @ location: 31 - [ (Pair {} (Some (Left True))) ] - - [halt] (entry) @ location: 15 - [ (Pair {} (Some (Left True))) ] - - control: KNil diff --git a/src/proto_017_PtNairob/lib_protocol/test/regression/test_logging.ml b/src/proto_017_PtNairob/lib_protocol/test/regression/test_logging.ml deleted file mode 100644 index 16c5c07d8a40d5f07bfb4a345f00fc21a09c493a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/regression/test_logging.ml +++ /dev/null @@ -1,401 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (type-checking) - Invocation: cd src/proto_alpha/lib_protocol/test/regression && \ - dune exec ./main.exe - Subject: Type-checking - *) - -open Protocol -open Alpha_context -open Tezt - -module Traced_interpreter = Plugin.RPC.Scripts.Traced_interpreter (struct - let unparsing_mode = Script_ir_unparser.Readable -end) - -type contract = {filename : string; storage : string} - -type transaction = - | Simple of {dst : contract; amount : Tez.t; parameter : string} - | With_lib of { - dst : contract; - lib : contract; - amount : Tez.t; - parameter : Contract_hash.t -> string; - } - -type element_kind = Interp | Entry | Exit - -type log_element = - | With_stack : - context - * ('a, 'b, 'c, 'd) Script_typed_ir.kinstr - * Script.location - * ('e * 'f) - * ('e, 'f) Script_typed_ir.stack_ty - * element_kind - -> log_element - | Ctrl : ('a, 'b, 'c, 'd) Script_typed_ir.continuation -> log_element - -type trace_element = - | TInstr : - Script.location - * Gas.t - * ('a, 'b, 'c, 'd) Script_typed_ir.kinstr - * Script.expr list - * element_kind - -> trace_element - | TCtrl : ('a, 'b, 'c, 'd) Script_typed_ir.continuation -> trace_element - -let transaction ?(amount = Tez.zero) ~parameter ~storage filename = - Simple {amount; parameter; dst = {filename; storage}} - -let with_lib ?(amount = Tez.zero) ~parameter ~storage ~lib ~lib_storage filename - = - With_lib - { - amount; - parameter; - dst = {storage; filename}; - lib = {filename = lib; storage = lib_storage}; - } - -let filename = function - | Simple {dst = {filename; _}; _} | With_lib {dst = {filename; _}; _} -> - filename - -let amount = function Simple {amount; _} | With_lib {amount; _} -> amount - -let storage = function - | Simple {dst = {storage; _}; _} | With_lib {dst = {storage; _}; _} -> storage - -let with_indentation fmt = function - | Interp -> - Format.fprintf - fmt - "- @[%a (interp) @@ location: %d@,[ @[%a ]@]@]" - | Exit -> - Format.fprintf - fmt - "- @[%a (exit) @@ location: %d@,[ @[%a ]@]@]@]" - | Entry -> - Format.fprintf - fmt - "@[- @[%a (entry) @@ location: %d@,[ @[%a ]@]@]" - -let pp_trace fmt = function - | TInstr (loc, _gas, instr, stack, element_kind) -> - with_indentation - fmt - element_kind - Plugin.RPC.Scripts.pp_instr_name - instr - loc - (Format.pp_print_list (fun ppf e -> - Format.fprintf ppf "@[%a@]" Michelson_v1_printer.print_expr e)) - stack - | TCtrl continuation -> ( - Format.fprintf fmt "- @[control: %s@]" - @@ - match continuation with - | KNil -> "KNil" - | KCons _ -> "KCons" - | KReturn _ -> "KReturn" - | KView_exit _ -> "KView_exit" - | KMap_head _ -> "KMap_head" - | KUndip _ -> "KUndip" - | KLoop_in _ -> "KLoop_in" - | KLoop_in_left _ -> "KLoop_in_left" - | KIter _ -> "KIter" - | KList_enter_body _ -> "KList_enter_body" - | KList_exit_body _ -> "KList_exit_body" - | KMap_enter_body _ -> "KMap_enter_body" - | KMap_exit_body _ -> "KMap_exit_body" - | KLog _ -> "KLog") - -let logger () : - (unit -> trace_element list tzresult Lwt.t) * Script_typed_ir.logger = - let open Lwt_result_syntax in - let open Script_typed_ir in - let log : log_element list ref = ref [] in - let logger = - Script_interpreter_logging.make - (module struct - let log_interp : type a s b f c u. (a, s, b, f, c, u) logging_function = - fun instr ctxt loc sty stack -> - log := With_stack (ctxt, instr, loc, stack, sty, Interp) :: !log - - let log_entry instr ctxt loc sty stack = - log := With_stack (ctxt, instr, loc, stack, sty, Entry) :: !log - - let log_exit instr ctxt loc sty stack = - log := With_stack (ctxt, instr, loc, stack, sty, Exit) :: !log - - let log_control cont = log := Ctrl cont :: !log - - let get_log () = return_none - end) - in - let assemble_log () = - let open Environment.Error_monad in - let+ l = - List.map_es - (function - | With_stack (ctxt, instr, loc, stack, stack_ty, indent) -> - let+ stack = - Lwt.map Environment.wrap_tzresult - @@ Traced_interpreter.unparse_stack ctxt (stack, stack_ty) - in - TInstr (loc, Gas.level ctxt, instr, stack, indent) - | Ctrl cont -> return @@ TCtrl cont) - !log - in - List.rev l - in - (assemble_log, logger) - -(* [with_logger ~mask f] creates a fresh logger and passes it to [f]. - After [f] finishes, logs are gathered and each occurrence of each - string in [mask] list is being replaced with asterisks. Thus processed - log is captured as regression output. *) -let with_logger f = - let open Lwt_result_syntax in - let get_log, logger = logger () in - let* () = f logger in - let* log = get_log () in - let capture s = Tezos_regression.replace_variables s |> Regression.capture in - Format.kasprintf - capture - "@,@[trace@,%a@]" - (Format.pp_print_list pp_trace) - log ; - return_unit - -let read_code filename = - let filename = - project_root // Filename.dirname __FILE__ // "contracts" - // (filename ^ ".tz") - in - Contract_helpers.read_file filename - -let run_script transaction () = - let open Lwt_result_syntax in - let script = read_code @@ filename transaction in - let* parameter, ctxt = - match transaction with - | With_lib {lib = {filename; storage}; parameter; _} -> - let* block, baker, _contract, _src2 = Contract_helpers.init () in - let sender = Contract.Implicit baker in - let* src_addr, _script, block = - Contract_helpers.originate_contract_from_string_hash - ~baker - ~source_contract:sender - ~script:(read_code filename) - ~storage - block - in - let* incr = Incremental.begin_construction block in - return (parameter src_addr, Incremental.alpha_ctxt incr) - | Simple {parameter; _} -> - let* b, _contract = Context.init1 ~consensus_threshold:0 () in - let* inc = Incremental.begin_construction b in - let ctxt = Incremental.alpha_ctxt inc in - let ctxt = - Alpha_context.Origination_nonce.init ctxt Operation_hash.zero - in - return (parameter, ctxt) - in - with_logger @@ fun logger -> - let step_constants = - Contract_helpers. - { - default_step_constants with - amount = amount transaction; - now = Script_timestamp.of_int64 1649939559L; - } - in - let* _res, _ctxt = - Contract_helpers.run_script - ctxt - script - ~logger - ~storage:(storage transaction) - ~parameter - ~step_constants - ~internal:true (* Allow for forged values (e.g. tickets). *) - () - in - return_unit - -let fail_on_error f () = - let open Lwt_syntax in - let* result = f () in - match result with - | Ok () -> return () - | Error e -> Test.fail "%a" Error_monad.pp_print_trace e - -(* Make sure that after a snapshot the snapshotted version of the test - has a different [~title], because all tests are linked in [tezt/tests/main.exe]. *) -let protocol = - match __FILE__ =~* rex "^src/proto_([0-9a-zA-Z_]*)/" with - | None -> - Stdlib.failwith ("failed to extract protocol name from path: " ^ __FILE__) - | Some name -> name - -let register_script transaction = - (* [~title] must be unique across the codebase, so we prefix it with the protocol name. - [~file] however is better kept the same across protocols to simplify snapshotting. *) - let file = filename transaction in - Regression.register - ~__FILE__ - ~title:(protocol ^ ": " ^ file) - ~tags:["protocol"; "regression"; "logging"] - ~file - (fail_on_error @@ run_script transaction) - -(* These tests should always cover: - - every instruction type, which means an example of each group of instructions - which are similar to each other with respect to logging; no need to cover every - instruction whatsoever, but just every distinct kind ; - - every continuation and control structure in Michelson, because those impact - what is being logged and what is not. - We are not concerned with gas, because that's kept track of by regular regression - tests. Actually, gas is unaccounted for in all the tests in this module. *) -let () = - Array.iter - register_script - [| - transaction - ~storage:"{}" - ~parameter:"Left \"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx\"" - "accounts"; - transaction - ~storage:"{1; 2; 3}" - ~parameter:"Pair {7; 8; 9} {4; 5; 6}" - "append"; - transaction - ~amount:(Tez.of_mutez_exn 100_000_000L) - ~parameter:"\"tz1b7tUupMgCNw2cCLpKTkSD1NZzB5TkP2sv\"" - ~storage: - "Pair \"2099-12-31T23:59:59Z\" (Pair 50000000 \ - \"tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU\")" - "auction"; - transaction - ~parameter:"{Pair \"string\" 12; Pair \"abc\" 99; Pair \"def\" 3}" - ~storage:"Pair { Elt \"123\" 123 } Unit" - "big_map_union"; - transaction - ~parameter:"\"edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav\"" - ~storage: - "Pair \ - \"edsigu6Ue4mQgPC5aCFqqjitU9pCs5VErXrfPTAZffyJepccGzDEEBExtuPjGuMc2ZRSTBUDR7tJMLVTeJzZn7p9jN9inh4ooV1\" \ - \"TEZOS\"" - "check_signature"; - transaction ~parameter:"Pair 1 4 2 Unit" ~storage:"Unit" "comb-get"; - transaction ~parameter:"Unit" ~storage:"Pair 1 4 2 Unit" "comb-set"; - transaction ~parameter:"\"abcd\"" ~storage:"\"efgh\"" "concat"; - transaction ~parameter:"Right (Some 23)" ~storage:"\"\"" "conditionals"; - transaction ~parameter:"2" ~storage:"60" "cps_fact"; - transaction - ~parameter:"Pair (Pair (Pair (Pair 0 1) 2) 3) 4" - ~storage:"7" - "dign"; - transaction - ~parameter:"Pair (Pair (Pair (Pair 0 1) 2) 3) 4" - ~storage:"7" - "dipn"; - transaction - ~parameter:"Pair (Pair (Pair (Pair 0 1) 2) 3) 4" - ~storage:"7" - "dugn"; - transaction - ~parameter:"Pair 127 11" - ~storage:"Pair None None None None" - "ediv"; - transaction - ~parameter:"\"tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU\"" - ~storage:"\"2020-01-01T00:00:00Z\"" - "faucet"; - transaction - ~parameter:"\"abc\"" - ~storage:"Pair (Some 321) {Elt \"def\" 123}" - "get_and_update_map"; - transaction ~parameter:"True" ~storage:"None" "if"; - transaction - ~parameter:"{8; 3; 2; 7; 6; 9; 5; 1; 4; 0}" - ~storage:"{}" - "insertion_sort"; - transaction - ~parameter:"{1; 2; 3; 4; 5; 6; 7}" - ~storage:"{}" - "list_map_block"; - transaction - ~parameter:"{\"abc\"; \"xyz\"}" - ~storage:"{\"zyx\"; \"cba\"}" - "loop_left"; - transaction - ~parameter: - "Pair (Pair (Pair \"abc\" {1; 2; 3}) {4; 5; 6}) \ - 0x0507070707010000000361626302000000060001000200030200000006000400050006" - ~storage:"Unit" - "packunpack"; - transaction ~parameter:"7" ~storage:"77" "pexec"; - transaction - ~parameter:"{\"abc\"; \"def\" ; \"ghi\"}" - ~storage:"{}" - "reverse_loop"; - transaction - ~parameter:"Some \"tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN\"" - ~storage:"Unit" - "set_delegate"; - transaction ~parameter:"Right (Pair 3 2)" ~storage:"None" "shifts"; - transaction - ~amount:(Tez.of_mutez_exn 1_200_00L) - ~parameter:"7" - ~storage:"{}" - "spawn_identities"; - transaction - ~parameter:"Pair \"KT1Ln1MPvHDJ1phLL8dNL4jrKF6Q1yQCBG1v\" 17 3" - ~storage:"None" - "ticket_join"; - transaction - ~parameter:"Pair \"KT1Ln1MPvHDJ1phLL8dNL4jrKF6Q1yQCBG1v\" 17 3" - ~storage:"Unit" - "ticket_split"; - transaction ~parameter:"5" ~storage:"3" "view_toplevel_lib"; - transaction ~parameter:"Left (Pair True False)" ~storage:"None" "xor"; - transaction ~parameter:"7" ~storage:"Some 3" "opt_map"; - with_lib - ~parameter:(Format.asprintf "Pair 8 \"%a\"" Contract_hash.pp) - ~storage:"0" - ~lib:"view_toplevel_lib" - ~lib_storage:"0" - "view_fib"; - transaction ~parameter:"Unit" ~storage:"Unit" "rec_id_unit"; - |] diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/dune b/src/proto_017_PtNairob/lib_protocol/test/unit/dune deleted file mode 100644 index cf24ec93d1eb9c72cdfce2d57c0429a6576edb40..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/dune +++ /dev/null @@ -1,95 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name src_proto_017_PtNairob_lib_protocol_test_unit_tezt_lib) - (instrumentation (backend bisect_ppx)) - (libraries - tezt.core - octez-libs.base - octez-libs.base-test-helpers - octez-libs.micheline - octez-protocol-017-PtNairob-libs.client - octez-shell-libs.client-base - tezos-protocol-017-PtNairob.parameters - octez-proto-libs.protocol-environment - octez-libs.stdlib-unix - tezos-protocol-017-PtNairob.protocol - octez-libs.test-helpers - octez-protocol-017-PtNairob-libs.test-helpers - octez-alcotezt - octez-l2-libs.scoru-wasm-helpers - octez-libs.stdlib - octez-libs.crypto-dal - octez-l2-libs.scoru-wasm - octez-l2-libs.webassembly-interpreter-extra) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezt_core - -open Tezt_core.Base - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_base_test_helpers - -open Tezos_micheline - -open Tezos_client_017_PtNairob - -open Tezos_protocol_017_PtNairob_parameters - -open Tezos_protocol_017_PtNairob - -open Tezos_test_helpers - -open Tezos_017_PtNairob_test_helpers - -open Octez_alcotezt - -open Tezos_scoru_wasm_helpers - -open Tezos_stdlib - -open Tezos_crypto_dal - -open Tezos_webassembly_interpreter_extra) - (modules - test_bond_id_repr - test_consensus_key - test_contract_repr - test_destination_repr - test_fitness - test_fixed_point - test_gas_monad - test_global_constants_storage - test_level_module - test_liquidity_baking_repr - test_merkle_list - test_operation_repr - test_qty - test_receipt - test_round_repr - test_saturation - test_sc_rollup_arith - test_sc_rollup_game - test_sc_rollup_inbox - test_sc_rollup_management_protocol - test_sc_rollup_storage - test_skip_list_repr - test_tez_repr - test_time_repr - test_zk_rollup_storage - test_sc_rollup_inbox_legacy - test_sc_rollup_wasm - test_local_contexts - test_dal_slot_proof)) - -(executable - (name main) - (instrumentation (backend bisect_ppx --bisect-sigterm)) - (libraries - src_proto_017_PtNairob_lib_protocol_test_unit_tezt_lib - tezt) - (link_flags - (:standard) - (:include %{workspace_root}/macos-link-flags.sexp)) - (modules main)) - -(rule - (alias runtest) - (package tezos-protocol-017-PtNairob-tests) - (enabled_if (<> false %{env:RUNTEZTALIAS=true})) - (action (run %{dep:./main.exe}))) - -(rule - (targets main.ml) - (action (with-stdout-to %{targets} (echo "let () = Tezt.Test.run ()")))) diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_alpha_context.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_alpha_context.ml deleted file mode 100644 index 16e5f15b5432e9e55d3e6d0f1decb844d09ad81c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_alpha_context.ml +++ /dev/null @@ -1,291 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Marigold *) -(* *) -(* 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 -open Alpha_context - -(** Testing - ------- - Component: Alpha_context - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_alpha_context.ml - Dependencies: helpers/block.ml - Subject: To test the modules (including the top-level) - in alpha_context.ml as individual units, particularly - failure cases. Superficial goal: increase coverage percentage. -*) - -(** Creates an Alpha_context without creating a full-fledged block *) -let create () = - let account = Account.new_account () in - let bootstrap_account = Account.make_bootstrap_account account in - Block.alpha_context [bootstrap_account] - -let assert_equal_key_values ~loc kvs1 kvs2 = - let sort_by_key_hash = - List.sort (fun (k1, _) (k2, _) -> Script_expr_hash.compare k1 k2) - in - Assert.assert_equal_list - ~loc - (fun (k1, v1) (k2, v2) -> - Script_expr_hash.equal k1 k2 - && String.equal (Expr.to_string v1) (Expr.to_string v2)) - "Compare key-value list" - (fun fmt (k, v) -> - Format.fprintf fmt "(%a, %s)" Script_expr_hash.pp k (Expr.to_string v)) - (sort_by_key_hash kvs1) - (sort_by_key_hash kvs2) - -module Test_Script = struct - (** Force serialise of lazy [Big_map.t] in a given [alpha_context] *) - let test_force_bytes_in_context () = - create () >>=? fun alpha_context -> - let mbytes_pp ppf t = - Format.pp_print_string ppf (Environment.Bytes.to_string t) - in - let open Alpha_context.Script in - Environment.wrap_tzresult - @@ force_bytes_in_context alpha_context - @@ lazy_expr @@ Micheline.strip_locations - @@ Prim (0, D_Unit, [], []) - >>?= fun (bytes, _) -> - Assert.equal - ~loc:__LOC__ - Environment.Bytes.equal - "script serialised incorrectly" - mbytes_pp - bytes - (`Hex "030b" |> Hex.to_bytes_exn) -end - -module Test_Big_map = struct - (** Test failure path: look for a non-existent key in a [Big_map] *) - let test_mem () = - ( create () >>=? fun alpha_context -> - Big_map.fresh ~temporary:true alpha_context >|= Environment.wrap_tzresult - >>=? fun (alpha_context, big_map_id) -> - Big_map.mem - alpha_context - big_map_id - (Script_expr_hash.hash_string ["0"; "0"]) - >|= Environment.wrap_tzresult ) - >>=? fun (_alpha_context, is_member) -> - Assert.equal_bool ~loc:__LOC__ is_member false - - (** Test failure code path of [get_opt] by looking for missing key in a [Big_map.t] *) - let test_get_opt () = - ( create () >>=? fun alpha_context -> - Big_map.fresh ~temporary:true alpha_context >|= Environment.wrap_tzresult - >>=? fun (alpha_context, big_map_id) -> - Big_map.get_opt - alpha_context - big_map_id - (Script_expr_hash.hash_string ["0"; "0"]) - >|= Environment.wrap_tzresult ) - >>=? fun (_alpha_context, value) -> - match value with - | Some _ -> - failwith "get_opt should have failed looking for a non-existent key" - | None -> return_unit - - (** Test existence of a non-existent [Big_map] in an [Alpha_context.t] *) - let test_exists () = - ( create () >>=? fun alpha_context -> - Big_map.fresh ~temporary:true alpha_context >|= Environment.wrap_tzresult - >>=? fun (alpha_context, big_map_id) -> - Big_map.exists alpha_context big_map_id >|= Environment.wrap_tzresult ) - >>=? fun (_alpha_context, value) -> - match value with - | Some _ -> - failwith "exists should have failed looking for a non-existent big_map" - | None -> return_unit - - (** Test that [Big_map.list_key_values] retrieves hashed keys and values. *) - let test_list_key_values () = - let open Lwt_result_syntax in - let* block, source = Context.init1 () in - let key_values = - [ - ("1", {|"A"|}); - ("2", {|"B"|}); - ("3", {|"C"|}); - ("4", {|"D"|}); - ("5", {|"E"|}); - ] - |> List.map (fun (k, v) -> (Expr.from_string k, Expr.from_string v)) - in - let* big_map_id, ctxt = - Big_map_helpers.make_big_map - block - ~source - ~key_type:"int" - ~value_type:"string" - key_values - in - let* _ctxt, retrieved_key_values = - Big_map.list_key_values ctxt big_map_id >|= Environment.wrap_tzresult - in - let expected_key_hash_values = - List.map - (fun (key, value) -> - let bytes = - Data_encoding.Binary.to_bytes_exn Script_repr.expr_encoding key - in - let key_hash = Script_expr_hash.hash_bytes [bytes] in - (key_hash, value)) - key_values - in - assert_equal_key_values - ~loc:__LOC__ - expected_key_hash_values - retrieved_key_values - - (** Test [Big_map.list_key_values] with [length] and [offset] arguments. *) - let test_list_key_values_parameters () = - let open Lwt_result_syntax in - let* block, source = Context.init1 () in - let hash_key key = - let bytes = - Data_encoding.Binary.to_bytes_exn Script_repr.expr_encoding key - in - Script_expr_hash.hash_bytes [bytes] - in - let check_key_values ~loc ~num_elements ?offset ?length () = - let key_values = - WithExceptions.List.init ~loc:__LOC__ num_elements (fun n -> - (string_of_int n, Printf.sprintf {|"Value %d"|} n)) - |> List.map (fun (k, v) -> (Expr.from_string k, Expr.from_string v)) - in - let sorted_key_values = - List.sort - (fun (k1, _) (k2, _) -> - Script_expr_hash.compare (hash_key k1) (hash_key k2)) - key_values - in - let* big_map_id, ctxt = - Big_map_helpers.make_big_map - block - ~source - ~key_type:"int" - ~value_type:"string" - key_values - in - let* _ctxt, retrieved_key_values = - Big_map.list_key_values ?offset ?length ctxt big_map_id - >|= Environment.wrap_tzresult - in - let expected_key_hash_values = - (* A negative length is interpreted as 0 *) - let length = - match length with - | Some l -> max l 0 - | None -> List.length sorted_key_values - in - let offset = match offset with Some o -> max o 0 | None -> 0 in - let expected = - List.take_n length @@ List.drop_n offset sorted_key_values - in - List.map - (fun (key, value) -> - let bytes = - Data_encoding.Binary.to_bytes_exn Script_repr.expr_encoding key - in - let key_hash = Script_expr_hash.hash_bytes [bytes] in - (key_hash, value)) - expected - in - let* () = - assert_equal_key_values - ~loc - retrieved_key_values - expected_key_hash_values - in - return retrieved_key_values - in - (* The following combinations should yield the same key-values. *) - let* kvs1 = check_key_values ~loc:__LOC__ ~num_elements:10 () in - let* kvs2 = check_key_values ~loc:__LOC__ ~num_elements:10 ~offset:0 () in - let* kvs3 = check_key_values ~loc:__LOC__ ~num_elements:10 ~length:10 () in - let* kvs4 = - check_key_values ~loc:__LOC__ ~num_elements:10 ~offset:0 ~length:10 () - in - let* () = assert_equal_key_values ~loc:__LOC__ kvs1 kvs2 in - let* () = assert_equal_key_values ~loc:__LOC__ kvs2 kvs3 in - let* () = assert_equal_key_values ~loc:__LOC__ kvs3 kvs4 in - (* Attempt to consume more elements then the length. *) - let* kvs1 = check_key_values ~loc:__LOC__ ~num_elements:20 () in - let* kvs2 = check_key_values ~loc:__LOC__ ~num_elements:20 ~length:100 () in - let* () = assert_equal_key_values ~loc:__LOC__ kvs1 kvs2 in - let* (_ : _ list) = - check_key_values ~loc:__LOC__ ~num_elements:100 ~offset:100 ~length:1 () - in - (* Offset greater than the length. *) - let* kvs = check_key_values ~loc:__LOC__ ~num_elements:10 ~offset:100 () in - let* () = assert_equal_key_values ~loc:__LOC__ kvs [] in - (* Negative length is treated as zero. *) - let* kvs = check_key_values ~loc:__LOC__ ~num_elements:10 ~length:(-1) () in - let* () = assert_equal_key_values ~loc:__LOC__ kvs [] in - (* Negative offset is treated as zero. *) - let* kvs1 = - check_key_values ~loc:__LOC__ ~num_elements:10 ~offset:(-5) () - in - let* kvs2 = check_key_values ~loc:__LOC__ ~num_elements:10 () in - let* () = assert_equal_key_values ~loc:__LOC__ kvs1 kvs2 in - return_unit -end - -let tests = - [ - Tztest.tztest - "Script.force_bytes_in_context: checks if it serialises a simple \ - michelson expression" - `Quick - Test_Script.test_force_bytes_in_context; - Tztest.tztest - "Big_map.mem: failure case - must return false when starting with an \ - empty map" - `Quick - Test_Big_map.test_mem; - Tztest.tztest - "Big_map.get_opt: failure case - looking up key that doesn't exist" - `Quick - Test_Big_map.test_get_opt; - Tztest.tztest - "Big_map.exists: failure case - looking up big_map that doesn't exist" - `Quick - Test_Big_map.test_exists; - Tztest.tztest - "Big_map.list_key_values basic tests" - `Quick - Test_Big_map.test_list_key_values; - Tztest.tztest - "Big_map.list_key_values: combinations of parameters" - `Quick - Test_Big_map.test_list_key_values_parameters; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("alpha context", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_bond_id_repr.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_bond_id_repr.ml deleted file mode 100644 index cf0d549c71b5e466bffc0e7d38b89fe83df18109..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_bond_id_repr.ml +++ /dev/null @@ -1,118 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Trilitech *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Bond_id_repr - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_bond_id_repr.ml - Dependencies: -- - Subject: Test bond id representations for RPC definitions. -*) - -open Protocol - -let assert_bond_id_result_equal ~loc = - Assert.equal_result - ~loc - ~pp_ok:Bond_id_repr.pp - ~pp_error:Format.pp_print_string - Bond_id_repr.( = ) - ( = ) - -let test_destruct_sc_bond_id_repr () = - let open Lwt_result_syntax in - let sc_rollup_address1 = "sr1JPVatbbPoGp4vb6VfQ1jzEPMrYFcKq6VG" in - let sc_rollup_address2 = "sr1JtMTWShgi1jLrqeHohMwLYiGizpsyWzXJ" in - let invalid_sc_rollup_address = "sr1RWAV26caoU7oVMvetUPMt8CqvGmKtA8BO" in - let destruct = Bond_id_repr.Internal_for_test.destruct in - let sc_bond id = - match Sc_rollup_repr.Address.of_b58check_opt id with - | Some id -> Ok (Bond_id_repr.Sc_rollup_bond_id id) - | None -> Error "Not an sc address" - in - let* () = - assert_bond_id_result_equal - ~loc:__LOC__ - (destruct sc_rollup_address1) - (sc_bond sc_rollup_address1) - in - let* () = - assert_bond_id_result_equal - ~loc:__LOC__ - (destruct sc_rollup_address2) - (sc_bond sc_rollup_address2) - in - Assert.is_error - ~loc:__LOC__ - ~pp:Bond_id_repr.pp - (destruct invalid_sc_rollup_address) - -let test_destruct_invalid_bond_id_repr () = - let open Lwt_result_syntax in - let invalid_address = "asdfasdfasdf" in - let empty_address = "" in - let destruct = Bond_id_repr.Internal_for_test.destruct in - let* () = - Assert.is_error ~loc:__LOC__ ~pp:Bond_id_repr.pp (destruct invalid_address) - in - Assert.is_error ~loc:__LOC__ ~pp:Bond_id_repr.pp (destruct empty_address) - -let test_roundtrip () = - let open Lwt_result_syntax in - let destruct_for_rountrip v = - let r = - match Bond_id_repr.Internal_for_test.destruct v with - | Ok r -> return r - | _ -> failwith "Destruct failed for %s" v - in - r - in - let rountrip_test loc s = - let* r = destruct_for_rountrip s in - let s2 = Bond_id_repr.Internal_for_test.construct r in - Assert.equal_string ~loc s s2 - in - let sc_rollup_address1 = "sr1JPVatbbPoGp4vb6VfQ1jzEPMrYFcKq6VG" in - let sc_rollup_address2 = "sr1JtMTWShgi1jLrqeHohMwLYiGizpsyWzXJ" in - let* () = rountrip_test __LOC__ sc_rollup_address1 in - rountrip_test __LOC__ sc_rollup_address2 - -let tests = - [ - Tztest.tztest - "Deserializing sc bond ids succeeds only when id is valid" - `Quick - test_destruct_sc_bond_id_repr; - Tztest.tztest - "Deserializing invalid bond ids fails" - `Quick - test_destruct_invalid_bond_id_repr; - Tztest.tztest "Deserialize/serialize roundtrip" `Quick test_roundtrip; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("Bond_id_repr.ml", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_consensus_key.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_consensus_key.ml deleted file mode 100644 index e5035303e5433ef5bba900b7688391b81a9d5f21..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_consensus_key.ml +++ /dev/null @@ -1,244 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 G.B. Fefe, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (delegate_consensus_key) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_consensus_key.ml - Subject: Functions from the module `Delegate_consensus_key` -*) - -open Protocol - -let create () = - let open Lwt_result_syntax in - let*? accounts = Account.generate_accounts 2 in - let a1, a2 = match accounts with [a1; a2] -> (a1, a2) | _ -> assert false in - let* ctxt = Block.alpha_context (Account.make_bootstrap_accounts accounts) in - return (Alpha_context.Internal_for_tests.to_raw ctxt, a1, a2) - -module Consensus_key = struct - let active_key ctxt pkh = - Delegate_consensus_key.active_key ctxt pkh >|= Environment.wrap_tzresult - - let active_pubkey ctxt pkh = - Delegate_consensus_key.active_pubkey ctxt pkh >|= Environment.wrap_tzresult - - let active_pubkey_for_cycle ctxt pkh cycle = - Delegate_consensus_key.active_pubkey_for_cycle - ctxt - pkh - (Cycle_repr.of_int32_exn (Int32.of_int cycle)) - >|= Environment.wrap_tzresult - - let pending_updates ctxt pkh = - Delegate_consensus_key.pending_updates ctxt pkh - >|= Environment.wrap_tzresult - - let register_update ctxt pkh pk = - Delegate_consensus_key.register_update ctxt pkh pk - >|= Environment.wrap_tzresult - - let activate ctxt ~new_cycle = - Delegate_consensus_key.activate ctxt ~new_cycle - >|= Environment.wrap_tzresult -end - -module Assert = struct - include Assert - - let equal_pkh ~__LOC__ a b = - Assert.equal - ~loc:__LOC__ - Signature.Public_key_hash.equal - "pkh" - Signature.Public_key_hash.pp - a - b - - let equal_pk ~__LOC__ a b = - Assert.equal - ~loc:__LOC__ - Signature.Public_key.equal - "pk" - Signature.Public_key.pp - a - b - - let active_keys ~__LOC__ ctxt delegate l = - List.iter_es - (fun (c, pk) -> - let open Lwt_result_syntax in - let* active_pk = - Consensus_key.active_pubkey_for_cycle ctxt delegate c - in - equal_pk ~__LOC__ active_pk.consensus_pk pk) - l -end - -let rec add_cycles ctxt n = - if n <= 0 then return ctxt - else - let open Lwt_result_syntax in - let current_level = Raw_context.current_level ctxt in - let new_cycle = Cycle_repr.succ current_level.cycle in - let* ctxt = Consensus_key.activate ctxt ~new_cycle in - let ctxt = Raw_context.Internal_for_tests.add_cycles ctxt 1 in - add_cycles ctxt (n - 1) - -let test_consensus_key_storage () = - let open Lwt_result_syntax in - let* ctxt, del1, del2 = create () in - let a1 = Account.new_account () in - let a2 = Account.new_account () in - let preserved_cycles = Constants_storage.preserved_cycles ctxt in - let* () = Assert.equal_int ~loc:__LOC__ preserved_cycles 3 in - let* () = - let* active_pkh = Consensus_key.active_key ctxt del1.pkh in - Assert.equal_pkh ~__LOC__ active_pkh.consensus_pkh del1.pkh - in - let* () = - let* active_pk = Consensus_key.active_pubkey ctxt del1.pkh in - Assert.equal_pk ~__LOC__ active_pk.consensus_pk del1.pk - in - let* () = - let* active_pk = Consensus_key.active_pubkey_for_cycle ctxt del1.pkh 3 in - Assert.equal_pk ~__LOC__ active_pk.consensus_pk del1.pk - in - let* () = - let*! err = Consensus_key.register_update ctxt del1.pkh del2.pk in - Assert.proto_error ~loc:__LOC__ err (function - | Delegate_consensus_key.Invalid_consensus_key_update_active -> true - | _ -> false) - in - let* ctxt = Consensus_key.register_update ctxt del1.pkh a1.pk in - let* () = - let*! err = Consensus_key.register_update ctxt del1.pkh a1.pk in - Assert.proto_error ~loc:__LOC__ err (function - | Delegate_consensus_key.Invalid_consensus_key_update_noop c -> - c = Cycle_repr.of_int32_exn 4l - | _ -> false) - in - let* () = - let*! err = Consensus_key.register_update ctxt del2.pkh a1.pk in - Assert.proto_error ~loc:__LOC__ err (function - | Delegate_consensus_key.Invalid_consensus_key_update_active -> true - | _ -> false) - in - let* ctxt = Consensus_key.register_update ctxt del2.pkh del1.pk in - let* () = - Assert.active_keys - ~__LOC__ - ctxt - del1.pkh - [ - (0, del1.pk); - (1, del1.pk); - (2, del1.pk); - (2, del1.pk); - (3, del1.pk); - (4, a1.pk); - (5, a1.pk); - ] - in - let* ctxt = add_cycles ctxt 1 in - let* () = - let* active_pkh = Consensus_key.active_key ctxt del1.pkh in - Assert.equal_pkh ~__LOC__ active_pkh.consensus_pkh del1.pkh - in - let* () = - let*! err = Consensus_key.register_update ctxt del1.pkh a1.pk in - Assert.proto_error ~loc:__LOC__ err (function - | Delegate_consensus_key.Invalid_consensus_key_update_noop c -> - c = Cycle_repr.of_int32_exn 4l - | _ -> false) - in - let* ctxt = Consensus_key.register_update ctxt del1.pkh a2.pk in - let* ctxt = Consensus_key.register_update ctxt del2.pkh a1.pk in - let* ctxt = Consensus_key.register_update ctxt del2.pkh del2.pk in - let* () = - Assert.active_keys - ~__LOC__ - ctxt - del1.pkh - [ - (1, del1.pk); - (2, del1.pk); - (2, del1.pk); - (3, del1.pk); - (4, a1.pk); - (5, a2.pk); - (6, a2.pk); - ] - in - let* ctxt = add_cycles ctxt 2 in - let* () = - let* active_pkh = Consensus_key.active_key ctxt del1.pkh in - Assert.equal_pkh ~__LOC__ active_pkh.consensus_pkh del1.pkh - in - let* () = - let*! err = Consensus_key.register_update ctxt del1.pkh a2.pk in - Assert.proto_error ~loc:__LOC__ err (function - | Delegate_consensus_key.Invalid_consensus_key_update_noop c -> - c = Cycle_repr.of_int32_exn 5l - | _ -> false) - in - let* ctxt = Consensus_key.register_update ctxt del1.pkh a1.pk in - let* () = - Assert.active_keys - ~__LOC__ - ctxt - del1.pkh - [(3, del1.pk); (4, a1.pk); (5, a2.pk); (6, a2.pk); (7, a1.pk); (8, a1.pk)] - in - let* ctxt = add_cycles ctxt 1 in - let* () = - let* active_pkh = Consensus_key.active_key ctxt del1.pkh in - Assert.equal_pkh ~__LOC__ active_pkh.consensus_pkh a1.pkh - in - let* ctxt = add_cycles ctxt 1 in - let* () = - let* active_pkh = Consensus_key.active_key ctxt del1.pkh in - Assert.equal_pkh ~__LOC__ active_pkh.consensus_pkh a2.pkh - in - let* ctxt = add_cycles ctxt 1 in - let* () = - let* active_pkh = Consensus_key.active_key ctxt del1.pkh in - Assert.equal_pkh ~__LOC__ active_pkh.consensus_pkh a2.pkh - in - let* ctxt = add_cycles ctxt 1 in - let* () = - let* active_pkh = Consensus_key.active_key ctxt del1.pkh in - Assert.equal_pkh ~__LOC__ active_pkh.consensus_pkh a1.pkh - in - return () - -let tests = - [Tztest.tztest "consensus_key_storage" `Quick test_consensus_key_storage] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("Delegate consensus key", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_contract_repr.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_contract_repr.ml deleted file mode 100644 index accd616ea54d2ffa3e23a477bf132f5f01360d7c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_contract_repr.ml +++ /dev/null @@ -1,124 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Marigold *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Contract_repr - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_contract_repr.ml - Dependencies: contract_hash.ml - Subject: To test the modules (including the top-level) - in contract_repr.ml as individual units, particularly - failure cases. Superficial goal: increase coverage percentage. -*) -open Protocol - -open Tztest - -(* - - TODO: Remove dependence on contract_hash.ml and mock it - - *) - -module Test_contract_repr = struct - (** Assert if [is_implicit] correctly returns the implicit contract *) - open Contract_repr - - let dummy_operation_hash = - Operation_hash.of_bytes_exn - (Bytes.of_string "test-operation-hash-of-length-32") - - let dummy_origination_nonce = Origination_nonce.initial dummy_operation_hash - - let dummy_contract_hash = - (* WARNING: Uses Contract_repr itself, which is yet to be tested. This happened because Contract_hash wasn't mocked *) - let data = - Data_encoding.Binary.to_bytes_exn - Origination_nonce.encoding - dummy_origination_nonce - in - Contract_hash.hash_bytes [data] - - let dummy_implicit_contract = Implicit Signature.Public_key_hash.zero - - let dummy_originated_contract = originated_contract @@ dummy_origination_nonce - - let test_to_b58check_implicit () = - Assert.equal - ~loc:__LOC__ - String.equal - "%s should have been equal to %" - Format.pp_print_string - (to_b58check dummy_implicit_contract) - Signature.Public_key_hash.(to_b58check zero) - - let test_to_b58check_originated () = - Assert.equal - ~loc:__LOC__ - String.equal - "%s should have been equal to %" - Format.pp_print_string - (to_b58check dummy_originated_contract) - Contract_hash.(to_b58check @@ dummy_contract_hash) - - let create_dummy_contracts n = - let since = dummy_origination_nonce in - let rec incr_n_times nonce = function - | 0 -> nonce - | n -> incr_n_times (Origination_nonce.incr nonce) (n - 1) - in - let until = incr_n_times since n in - let contracts = originated_contracts ~since ~until in - contracts - - let test_originated_contracts_basic () = - let n = 5 in - let contracts = create_dummy_contracts n in - Assert.equal_int ~loc:__LOC__ (List.length contracts) n -end - -let tests = - [ - tztest - "Contract_repr.to_b58check: must correctly stringify, b58check encoded, \ - an implicit contract" - `Quick - Test_contract_repr.test_to_b58check_implicit; - tztest - "Contract_repr.originated_contract: must correctly create an originated \ - contract" - `Quick - Test_contract_repr.test_originated_contracts_basic; - tztest - "Contract_repr.to_b58check: must correctly stringify, b58check encoded, \ - an originated contract" - `Quick - Test_contract_repr.test_to_b58check_originated; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("Contract_repr.ml", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_dal_slot_proof.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_dal_slot_proof.ml deleted file mode 100644 index 0a600135144aeed2d73b9d1bbc35693875b81be6..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_dal_slot_proof.ml +++ /dev/null @@ -1,445 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (dal slot proof) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_dal_slot_proof.ml - Subject: These unit tests check proof-related functions of Dal slots. -*) - -open Protocol -module S = Dal_slot_repr -module H = S.Header -module P = S.Page -module Hist = S.History - -module Make (Parameters : sig - val name : string - - val dal_parameters : Alpha_context.Constants.Parametric.dal -end) = -struct - open Dal_helpers.Make (struct - include Parameters - - let cryptobox = - Lazy.from_fun @@ fun () -> - WithExceptions.Result.get_ok ~loc:__LOC__ - @@ Dal_helpers.mk_cryptobox Parameters.dal_parameters.cryptobox_parameters - end) - - (* Tests to check insertion of slots in a dal skip list. *) - - (** Check insertion of a new slot in the given skip list. *) - let skip_list_ordering skip_list ~mk_level ~mk_slot_index ~check_result = - let open Lwt_result_syntax in - let {S.Header.id; _} = Hist.Internal_for_tests.content skip_list in - let level = mk_level id in - let index = mk_slot_index id in - let*? _data, _poly, slot = mk_slot ~level ~index () in - Hist.add_confirmed_slot_headers_no_cache skip_list [slot] - |> Environment.wrap_tzresult |> check_result - - (** This test attempts to add a slot on top of genesis cell zero which would - break the ordering. In fact, confirmed slots' skip list is ordered by slots - ID: the slots' level should increase or the level is equal in which case the - slots' index should increase. In the test below, we attempt to insert a slot - where (published_level, slot_index) doesn't increase (is the same as the - genesis cell). *) - let insertion_breaks_skip_list_ordering () = - skip_list_ordering - genesis_history - ~mk_level:(fun id -> id.H.published_level) - ~mk_slot_index:(fun id -> id.H.index) - ~check_result:(fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Hist.Add_element_in_slots_skip_list_violates_ordering -> true - | _ -> false)) - - (** This test attempts to add a slot on top of genesis cell zero which satisfies - the ordering. *) - let correct_insertion_in_skip_list_ordering_1 () = - let open Lwt_result_syntax in - skip_list_ordering - genesis_history - ~mk_level:(fun id -> Raw_level_repr.succ id.H.published_level) - ~mk_slot_index:(fun id -> id.H.index) - ~check_result:(fun res -> - let* (_skip_list : Hist.t) = Assert.get_ok ~__LOC__ res in - return_unit) - - (** This test attempts to add a slot on top of genesis cell zero which satisfies - the ordering. *) - let correct_insertion_in_skip_list_ordering_2 () = - let open Lwt_result_syntax in - skip_list_ordering - genesis_history - ~mk_level:(fun id -> id.H.published_level) - ~mk_slot_index:(fun id -> succ_slot_index id.H.index) - ~check_result:(fun res -> - let* (_skip_list : Hist.t) = Assert.get_ok ~__LOC__ res in - return_unit) - - (** This test attempts to add two slots on top of genesis cell zero which satisfies - the ordering. *) - let correct_insertion_in_skip_list_ordering_3 () = - let open Lwt_result_syntax in - skip_list_ordering - genesis_history - ~mk_level:(fun id -> id.H.published_level) - ~mk_slot_index:(fun id -> succ_slot_index id.H.index) - ~check_result:(fun res -> - let* skip_list = Assert.get_ok ~__LOC__ res in - skip_list_ordering - skip_list - ~mk_level:(fun id -> - Raw_level_repr.(succ (succ id.H.published_level))) - ~mk_slot_index:(fun id -> id.H.index) - ~check_result:(fun res -> - let* (_skip_list : Hist.t) = Assert.get_ok ~__LOC__ res in - return_unit)) - - (* Tests of construct/verify proofs that confirm/unconfirm pages on top of - genesis skip list (whose unique cell is slot zero). *) - - (** This test attempts to construct a proof to confirm a slot page from the - genesis skip list. Proof production is expected to fail. *) - let confirmed_page_on_genesis () = - let {H.id = {published_level; index}; _} = - Hist.Internal_for_tests.content genesis_history - in - let page_id = mk_page_id published_level index P.Index.zero in - produce_and_verify_proof - genesis_history - ~get_history:(get_history genesis_history_cache) - (* values of level and slot index are equal to slot zero. We would get a - page confirmation proof. But, no proof that confirms the existence of a page - in slot [zero] is possible. *) - ~page_info:None - ~page_id - ~check_produce:(slot_confirmed_but_page_data_not_provided ~__LOC__) - - (** This test attempts to construct a proof to unconfirm a slot page from the - genesis skip list. Proof production is expected to succeed. *) - let unconfirmed_page_on_genesis incr_level = - let {H.id = {published_level; index}; _} = - Hist.Internal_for_tests.content genesis_history - in - let level, sindex = - if incr_level then (Raw_level_repr.succ published_level, index) - else (published_level, succ_slot_index index) - in - let page_id = mk_page_id level sindex P.Index.zero in - produce_and_verify_proof - genesis_history - ~get_history:(get_history genesis_history_cache) - ~page_info:None - ~page_id - ~check_produce:(successful_check_produce_result ~__LOC__ `Unconfirmed) - ~check_verify:(successful_check_verify_result ~__LOC__ `Unconfirmed) - - (* Tests of construct/verify proofs that attempt to confirm pages on top of a - (confirmed) slot added in genesis_history skip list. *) - - (** Helper function that adds a slot a top of the genesis skip list. *) - let helper_confirmed_slot_on_genesis ~level ~mk_page_info ~check_produce - ?check_verify () = - let open Lwt_result_syntax in - let*? _slot_data, polynomial, slot = mk_slot ~level () in - let*? skip_list, cache = - Hist.add_confirmed_slot_headers - genesis_history - genesis_history_cache - [slot] - |> Environment.wrap_tzresult - in - let*? page_info, page_id = mk_page_info slot polynomial in - produce_and_verify_proof - skip_list - ~get_history:(get_history cache) - ~page_info - ~page_id - ?check_verify - ~check_produce - - (** Test where a slot is confirmed, requesting a proof for a confirmed page, - where the correct data and page proof are provided. *) - let confirmed_slot_on_genesis_confirmed_page_good_data = - helper_confirmed_slot_on_genesis - ~level:(Raw_level_repr.succ level_ten) - ~mk_page_info - ~check_produce:(successful_check_produce_result ~__LOC__ `Confirmed) - ~check_verify:(successful_check_verify_result ~__LOC__ `Confirmed) - - (** Test where a slot is confirmed, requesting a proof for a confirmed page, - where the page data and proof are not given. *) - let confirmed_slot_on_genesis_confirmed_page_no_data = - helper_confirmed_slot_on_genesis - ~level:(Raw_level_repr.succ level_ten) - ~mk_page_info:(mk_page_info ~custom_data:no_data) - ~check_produce:(slot_confirmed_but_page_data_not_provided ~__LOC__) - - (** Test where a slot is confirmed, requesting a proof for a confirmed page, - where correct data are provided, but the given page proof is wrong. *) - let confirmed_slot_on_genesis_confirmed_page_bad_page_proof = - let open Result_syntax in - helper_confirmed_slot_on_genesis - ~level:(Raw_level_repr.succ level_ten) - ~mk_page_info:(fun slot poly -> - let* page_info1, _page_id1 = mk_page_info ~page_index:1 slot poly in - let* page_info2, page_id2 = mk_page_info ~page_index:2 slot poly in - assert ( - match (page_info1, page_info2) with - | Some (_d1, p1), Some (_d2, p2) -> not (eq_page_proof p1 p2) - | _ -> false) ; - return (page_info1, page_id2)) - ~check_produce: - (failing_check_produce_result - ~__LOC__ - ~expected_error: - (Hist.Dal_proof_error - "Wrong page content for the given page index and slot \ - commitment (page id=(published_level: 11, slot_index: 0, \ - page_index: 2)).")) - - (** Test where a slot is confirmed, requesting a proof for a confirmed page, - where correct page proof is provided, but given page data is altered. *) - let confirmed_slot_on_genesis_confirmed_page_bad_data_right_length = - helper_confirmed_slot_on_genesis - ~level:(Raw_level_repr.succ level_ten) - ~mk_page_info: - (mk_page_info - ~custom_data: - (Some - (fun ~default_char page_size -> - Some - (Bytes.init page_size (fun i -> - if i = 0 then next_char default_char else default_char))))) - ~check_produce: - (failing_check_produce_result - ~__LOC__ - ~expected_error: - (Hist.Dal_proof_error - "Wrong page content for the given page index and slot \ - commitment (page id=(published_level: 11, slot_index: 0, \ - page_index: 0)).")) - - (** Same as {!confirmed_slot_on_genesis_confirmed_page_bad_data_right_length} - but the data is too short. *) - let confirmed_slot_on_genesis_confirmed_page_bad_data_short = - let page_size = Parameters.dal_parameters.cryptobox_parameters.page_size in - helper_confirmed_slot_on_genesis - ~level:(Raw_level_repr.succ level_ten) - ~mk_page_info: - (mk_page_info - ~custom_data: - (Some - (fun ~default_char page_size -> - Some (Bytes.make (page_size - 1) default_char)))) - ~check_produce: - (failing_check_produce_result - ~__LOC__ - ~expected_error: - (Hist.Unexpected_page_size - {expected_size = page_size; page_size = page_size - 1})) - - (** Same as {!confirmed_slot_on_genesis_confirmed_page_bad_data_right_length} - but the data is too long. *) - let confirmed_slot_on_genesis_confirmed_page_bad_data_long = - let page_size = Parameters.dal_parameters.cryptobox_parameters.page_size in - helper_confirmed_slot_on_genesis - ~level:(Raw_level_repr.succ level_ten) - ~mk_page_info: - (mk_page_info - ~custom_data: - (Some - (fun ~default_char page_size -> - Some (Bytes.make (page_size + 1) default_char)))) - ~check_produce: - (failing_check_produce_result - ~__LOC__ - ~expected_error: - (Hist.Unexpected_page_size - {expected_size = page_size; page_size = page_size + 1})) - - (* Variants of the tests above: Construct/verify proofs that attempt to - unconfirm pages on top of a (confirmed) slot added in genesis_history skip - list. - - All the tests are somehow equivalent when building "Unconfirmed page" proof, - because the page's data & page's proof are ignored in this case. - *) - - (** Specialisation of helper {!helper_confirmed_slot_on_genesis}, where some - parameters are fixed. *) - let helper_confirmed_slot_on_genesis_unconfirmed_page ~check_produce - ?check_verify ~page_level ~mk_page_info = - helper_confirmed_slot_on_genesis - ~level:(Raw_level_repr.succ page_level) - ~mk_page_info - ~check_produce - ?check_verify - - (** Unconfirmation proof for a page with good data. *) - let confirmed_slot_on_genesis_unconfirmed_page_good_data = - helper_confirmed_slot_on_genesis_unconfirmed_page - ~page_level:level_ten - ~mk_page_info:(mk_page_info ~level:level_ten) - ~check_produce:(slot_not_confirmed_but_page_data_provided ~__LOC__) - - (** Unconfirmation proof for a page with no data. *) - let confirmed_slot_on_genesis_unconfirmed_page_no_data = - helper_confirmed_slot_on_genesis_unconfirmed_page - ~page_level:level_ten - ~mk_page_info:(mk_page_info ~custom_data:no_data ~level:level_ten) - ~check_produce:(successful_check_produce_result ~__LOC__ `Unconfirmed) - - (** Unconfirmation proof for a page with bad page proof. *) - let confirmed_slot_on_genesis_unconfirmed_page_bad_proof = - let open Result_syntax in - let level = level_ten in - helper_confirmed_slot_on_genesis_unconfirmed_page - ~page_level:level - ~mk_page_info:(fun slot poly -> - let* page_info1, _page_id1 = - mk_page_info ~level:level_ten ~page_index:1 slot poly - in - let* _page_info2, page_id2 = - mk_page_info ~level:level_ten ~page_index:2 slot poly - in - assert ( - match (page_info1, _page_info2) with - | Some (_d1, p1), Some (_d2, p2) -> not (eq_page_proof p1 p2) - | _ -> false) ; - return (page_info1, page_id2)) - ~check_produce:(slot_not_confirmed_but_page_data_provided ~__LOC__) - - (** Unconfirmation proof for a page with bad data. *) - let confirmed_slot_on_genesis_unconfirmed_page_bad_data = - let level = level_ten in - helper_confirmed_slot_on_genesis_unconfirmed_page - ~page_level:level - ~mk_page_info: - (mk_page_info - ~level:level_ten - ~custom_data: - (Some - (fun ~default_char page_size -> - Some - (Bytes.init page_size (fun i -> - if i = 0 then next_char default_char else default_char))))) - ~check_produce:(slot_not_confirmed_but_page_data_provided ~__LOC__) - - (* The list of tests. *) - let tests = - let mk_title = Format.sprintf "[%s] %s" Parameters.name in - let tztest title test_function = - Tztest.tztest (mk_title title) `Quick test_function - in - let qcheck2 title gen test = - Tztest.tztest_qcheck2 ~name:(mk_title title) ~count:2 gen test - in - let bool = QCheck2.Gen.bool in - let ordering_tests = - [ - tztest - "add a slot on top of genesis that breaks ordering" - insertion_breaks_skip_list_ordering; - tztest - "add a slot on top of genesis that satisfies ordering (1/2)" - correct_insertion_in_skip_list_ordering_1; - tztest - "add a slot on top of genesis that satisfies ordering (2/2)" - correct_insertion_in_skip_list_ordering_2; - tztest - "add two slots on top of genesis that satisfy ordering" - correct_insertion_in_skip_list_ordering_3; - ] - in - let proofs_tests_on_genesis = - [ - tztest "Confirmed page on genesis" confirmed_page_on_genesis; - qcheck2 "Unconfirmed page on genesis" bool unconfirmed_page_on_genesis; - ] - in - - let confirmed_slot_on_genesis_confirmed_page_tests = - [ - tztest - "Confirmed slot on top of genesis: confirmed page with good data" - confirmed_slot_on_genesis_confirmed_page_good_data; - tztest - "Confirmed slot on top of genesis: confirmed page with no data" - confirmed_slot_on_genesis_confirmed_page_no_data; - tztest - "Confirmed slot on top of genesis: confirmed page with bad proof" - confirmed_slot_on_genesis_confirmed_page_bad_page_proof; - tztest - "Confirmed slot on top of genesis: confirmed page with bad data" - confirmed_slot_on_genesis_confirmed_page_bad_data_right_length; - tztest - "Confirmed slot on top of genesis: confirmed page with too short data" - confirmed_slot_on_genesis_confirmed_page_bad_data_short; - tztest - "Confirmed slot on top of genesis: confirmed page with too long data" - confirmed_slot_on_genesis_confirmed_page_bad_data_long; - ] - in - let confirmed_slot_on_genesis_unconfirmed_page_tests = - [ - tztest - "Confirmed slot on top of genesis: unconfirmed page with good data" - confirmed_slot_on_genesis_unconfirmed_page_good_data; - tztest - "Confirmed slot on top of genesis: unconfirmed page with no data" - confirmed_slot_on_genesis_unconfirmed_page_no_data; - tztest - "Confirmed slot on top of genesis: unconfirmed page with bad proof" - confirmed_slot_on_genesis_unconfirmed_page_bad_proof; - tztest - "Confirmed slot on top of genesis: unconfirmed page with bad data \ - (altered)" - confirmed_slot_on_genesis_unconfirmed_page_bad_data; - ] - in - ordering_tests @ proofs_tests_on_genesis - @ confirmed_slot_on_genesis_confirmed_page_tests - @ confirmed_slot_on_genesis_unconfirmed_page_tests -end - -let tests = - let open Tezos_protocol_017_PtNairob_parameters.Default_parameters in - let module Test = Make (struct - let name = "test" - - let dal_parameters = constants_test.dal - end) in - Test.tests - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("dal slot proof", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_destination_repr.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_destination_repr.ml deleted file mode 100644 index 121d47df24956fc543c475f13ebd39219bd162c3..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_destination_repr.ml +++ /dev/null @@ -1,229 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs. *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Destination_repr - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_destination_repr.ml - Subject: To test the encoding of [Destination_repr] and assert it is - compatible with [Contract_repr.encoding]. -*) - -open Protocol -open Tztest - -let dummy_operation_hash = - Operation_hash.of_bytes_exn - (Bytes.of_string "test-operation-hash-of-length-32") - -let dummy_origination_nonce = Origination_nonce.initial dummy_operation_hash - -let contracts = - let since = dummy_origination_nonce in - let rec incr_n_times nonce = function - | 0 -> nonce - | n -> incr_n_times (Origination_nonce.incr nonce) (n - 1) - in - let until = incr_n_times since 5 in - Contract_repr.originated_contracts ~since ~until - |> List.map (fun c -> Contract_repr.Originated c) - -let dest x = Destination_repr.Contract x - -let construct = Data_encoding.Json.construct - -let destruct = Data_encoding.Json.destruct - -let to_bytes_exn = Data_encoding.Binary.to_bytes_exn - -let of_bytes_exn = Data_encoding.Binary.of_bytes_exn - -let ( !! ) = function Ok x -> x | Error _ -> raise (Invalid_argument "( !! )") - -(* The following addresses have been extracted from TzKT. *) - -let null_address = "tz1Ke2h7sDdakHJQh8WX4Z372du1KChsksyU" - -let liquidity_baking_dex = "KT1TxqZ8QtKvLu3V3JH7Gx58n7Co8pgtpQU5" - -(* The following address has been extracted from - [tezt/_regressions/tx_rollup_simple_use_case.out]. *) - -let tx_rollup_address = "txr1YNMEtkj5Vkqsbdmt7xaxBTMRZjzS96UAi" - -(* The following address has been extracted like this: - - [dune exec tezt/tests/main.exe -- -verbose --file sc_rollup.ml - sc_rollup list] -*) -let sc_rollup_address = "sr1BAwv191dVYeZg44ZxVy8dFwfRQKW6bSqc" - -(* TODO: https://gitlab.com/tezos/tezos/-/issues/3731 - Explain how this address was computed *) -let zk_rollup_address = "epx18RJJqrYuJQqhB636BWvukU3XBNQGbtm8C" - -let assert_compat contract destination = - match destination with - | Destination_repr.Contract contract' - when Contract_repr.equal contract contract' -> - () - | _ -> raise (Invalid_argument "assert_compat") - -(** [test_decoding_json_compat str] decodes [str] as both a [Destination_repr.t] - and [Contract_repr.t], and checks the two are equal. *) -let test_decoding_json_compat str () = - let json = - !!(Data_encoding.Json.from_string @@ Format.sprintf {|"%s"|} str) - in - let contract = destruct Contract_repr.encoding json in - let destination = destruct Destination_repr.encoding json in - - assert_compat contract destination ; - - return_unit - -(** [test_encode_contract_decode_destination str] interprets [str] as - a [Contract_repr.t], encodes it in a bytes array, then decodes it - as a [Destination_repr.t]. The resulting destination should be - equal to the initial contract. *) -let test_encode_contract_decode_destination str () = - let contract = !!(Contract_repr.of_b58check str) in - let bytes = to_bytes_exn Contract_repr.encoding contract in - let destination = of_bytes_exn Destination_repr.encoding bytes in - - assert_compat contract destination ; - - return_unit - -(** [test_encode_destination_decode_contract str] interprets [str] as - a [Destination_repr.t], encodes it in a bytes array, then decodes - it as a [Contract_repr.t]. The resulting contract should be equal - to the initial destination. *) -let test_encode_destination_decode_contract str () = - let destination = !!(Destination_repr.of_b58check str) in - let bytes = to_bytes_exn Destination_repr.encoding destination in - let contract = of_bytes_exn Contract_repr.encoding bytes in - - assert_compat contract destination ; - - return_unit - -let encoding_compat ~encode_contract ~decode_contract ~encode_destination - ~decode_destination contract = - let destination = dest contract in - - let encoded_contract = encode_contract contract in - let encoded_destination = encode_destination destination in - - let destination_of_contract = decode_destination encoded_contract in - let contract_of_destination = decode_contract encoded_destination in - - assert_compat contract_of_destination destination ; - assert_compat contract destination_of_contract ; - - return_unit - -(** [encoding_json_compat contract] creates a {!Destination_repr.t} using - a dummy contract and ensures that their JSON encodings are compatible with - each other. -*) -let encoding_json_compat contract = - encoding_compat - ~encode_contract:(construct Contract_repr.encoding) - ~decode_contract:(destruct Contract_repr.encoding) - ~encode_destination:(construct Destination_repr.encoding) - ~decode_destination:(destruct Destination_repr.encoding) - contract - -(** [encoding_json_compat contract] creates a {!Destination_repr.t} using - a dummy contract and ensures that their binary encodings are compatible with - each other. -*) -let encoding_binary_compat contract = - encoding_compat - ~encode_contract:(to_bytes_exn Contract_repr.encoding) - ~decode_contract:(of_bytes_exn Contract_repr.encoding) - ~encode_destination:(to_bytes_exn Destination_repr.encoding) - ~decode_destination:(of_bytes_exn Destination_repr.encoding) - contract - -let test_contracts f () = - List.iter (fun contract -> ignore (f contract)) contracts ; - - return_unit - -let test_encoding_binary_compat = test_contracts encoding_binary_compat - -let test_encoding_json_compat = test_contracts encoding_json_compat - -let test_compare_destination () = - let tz1 = !!(Destination_repr.of_b58check null_address) in - let kt1 = !!(Destination_repr.of_b58check liquidity_baking_dex) in - let txr1 = !!(Destination_repr.of_b58check tx_rollup_address) in - let scr1 = !!(Destination_repr.of_b58check sc_rollup_address) in - let epx1 = !!(Destination_repr.of_b58check zk_rollup_address) in - - assert (Destination_repr.(tz1 < kt1)) ; - assert (Destination_repr.(kt1 < txr1)) ; - assert (Destination_repr.(tz1 < txr1)) ; - assert (Destination_repr.(txr1 < scr1)) ; - assert (Destination_repr.(scr1 < epx1)) ; - - return_unit - -let tests = - [ - tztest "Json decoding compat implicit contract (null address)" `Quick - @@ test_decoding_json_compat null_address; - tztest "Json decoding compat smart contract (liquidity baking dex)" `Quick - @@ test_decoding_json_compat liquidity_baking_dex; - tztest "Binary Contract_repr to Destination_repr (null address)" `Quick - @@ test_encode_contract_decode_destination null_address; - tztest - "Binary Contract_repr to Destination_repr (liquidity baking dex)" - `Quick - @@ test_encode_contract_decode_destination liquidity_baking_dex; - tztest "Binary Destination_repr to Contract_repr (null address)" `Quick - @@ test_encode_destination_decode_contract null_address; - tztest - "Binary Destination_repr to Contract_repr (liquidity baking dex)" - `Quick - @@ test_encode_destination_decode_contract liquidity_baking_dex; - tztest - "Json encoding compatibility Contract_repr to Destination_repr with \ - dummy contracts" - `Quick - @@ test_encoding_json_compat; - tztest - "Binary encoding compatibility Contract_repr to Destination_repr with \ - dummy contracts" - `Quick - @@ test_encoding_json_compat; - tztest "Comparison of destinations" `Quick test_compare_destination; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("Destination_repr.ml", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_fitness.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_fitness.ml deleted file mode 100644 index 7254762a8aadfeb984167d01d2f52ccea1b1b7ef..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_fitness.ml +++ /dev/null @@ -1,161 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (committee selection) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_fitness.ml - Subject: test the fitness module -*) - -open Protocol - -let level_zero = Raw_level_repr.of_int32_exn 0l - -let round_of_int32_exn i = - match Round_repr.of_int32 i with - | Ok i -> i - | Error _ -> Stdlib.failwith "Invalid round representation" - -let make_tuple (level, r_opt, r0, r1) = - let r_opt = Option.map round_of_int32_exn r_opt in - let r0 = round_of_int32_exn r0 in - let r1 = round_of_int32_exn r1 in - (level, r_opt, r0, r1) - -let test_cases = - List.map - make_tuple - [ - (3l, Some 1l, 1l, 12l); - (10l, Some 1l, 1l, 12l); - (10l, Some 4l, 2l, 6l); - (10l, Some 4l, 1l, 12l); - (9l, Some 2l, 0l, 3l); - (7l, None, 0l, 3l); - (7l, None, 1l, 3l); - (0l, None, 0l, 0l); - (12l, Some 2l, 8l, 7l); - (10l, Some 0l, 1l, 1l); - (8l, None, 1l, 0l); - (12l, Some 1l, 8l, 7l); - (8l, None, 6l, 0l); - ] - -let rec product l1 l2 = - match l1 with - | [] -> [] - | h :: tl -> List.map (fun x -> (h, x)) l2 @ product tl l2 - -let test_product_cases = product test_cases test_cases - -let tuple_to_fitness (level, locked_round, predecessor_round, round) = - Fitness_repr.create - ~level:(Raw_level_repr.of_int32_exn level) - ~locked_round - ~predecessor_round - ~round - -let tuple_to_fitness_exn tuple = - tuple_to_fitness tuple |> function - | Ok f -> f - | Error err -> - Format.kasprintf - Stdlib.failwith - "cannot create fitness from tuple: %a" - pp_print_trace - (Environment.wrap_tztrace err) - -let test_from_to_raw_fitness tuple = - let fitness = tuple_to_fitness_exn tuple in - Fitness_repr.from_raw (Fitness_repr.to_raw fitness) |> function - | Ok new_fitness -> assert (fitness = new_fitness) - | Error _x -> assert false - -let test_from_to_raw_fitness_all () = - List.iter test_from_to_raw_fitness test_cases ; - return_unit - -let test_locked_round () = - let test_bad_cases = - List.map - make_tuple - [ - (8l, Some 7l, 1l, 1l); - (9l, Some 8l, 0l, 3l); - (10l, Some 7l, 2l, 6l); - (11l, Some 5l, 5l, 1l); - (8l, Some 2l, 1l, 1l); - (9l, Some 3l, 0l, 3l); - (11l, Some 5l, 5l, 1l); - (13l, Some 2l, 1l, 1l); - (10l, Some 4l, 1l, 1l); - (8l, Some 7l, 1l, 1l); - (10l, Some 8l, 2l, 6l); - (11l, Some 9l, 5l, 1l); - (12l, Some 10l, 8l, 7l); - (13l, Some 14l, 1l, 1l); - ] - in - List.iter_es - (fun tuple -> - Environment.wrap_tzresult @@ tuple_to_fitness tuple |> function - | Error - [ - Environment.Ecoproto_error - (Fitness_repr.Locked_round_not_less_than_round _); - ] -> - return_unit - | Error err -> failwith "unexpected failure: %a" pp_print_trace err - | Ok f -> failwith "unexpected success: %a" Fitness_repr.pp f) - test_bad_cases - -let test_compare (tuple1, tuple2) = - let fitness1 = tuple_to_fitness_exn tuple1 in - let fitness2 = tuple_to_fitness_exn tuple2 in - let raw_fitness1 = Fitness_repr.to_raw fitness1 in - let raw_fitness2 = Fitness_repr.to_raw fitness2 in - let cmp_fitness = Fitness_repr.Internal_for_tests.compare fitness1 fitness2 in - let cmp_raw_fitness = Fitness.compare raw_fitness1 raw_fitness2 in - Assert.equal_int ~loc:__LOC__ cmp_fitness cmp_raw_fitness - -let test_compare_all () = List.iter_es test_compare test_product_cases - -let tests = - [ - Tztest.tztest - "from/to raw fitness is identity" - `Quick - test_from_to_raw_fitness_all; - Tztest.tztest "locked round is smaller than round" `Quick test_locked_round; - Tztest.tztest - "compare fitness = compare raw_fitness" - `Quick - test_compare_all; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("fitness", tests)] |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_fixed_point.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_fixed_point.ml deleted file mode 100644 index 2389060e3b97a6bd0237c8de37d57d7baf895c35..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_fixed_point.ml +++ /dev/null @@ -1,179 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (fixed-point decimals) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_fixed_point.ml - Subject: On fixed-point decimal numbers. -*) - -open Protocol - -exception Fixed_point_test_error of string - -let err x = Exn (Fixed_point_test_error x) - -module type Arith = sig - type t - - val zero : t - - val equal : t -> t -> bool - - val random : unit -> t - - val add : t -> t -> t - - val sub : t -> t -> t -end - -let n = Z.of_int 42 - -let n' = Z.of_int 43 - -let basic_arith name (module A : Arith) = - let err msg = err (Format.asprintf "%s test: %s" name msg) in - let x = A.random () in - fail_unless A.(add zero x = x) (err "zero is neutral for +") >>=? fun () -> - let x = A.random () in - let y = A.random () in - fail_unless A.(add x y = add y x) (err "addition is commutative") - >>=? fun () -> - let x = A.random () in - fail_unless - A.(sub (add zero x) x = zero) - (err "addition and subtraction cancel") - >>=? fun () -> - let x = A.random () in - let y = A.random () in - let z = A.random () in - fail_unless - A.(add x (add y z) = add (add x y) z) - (err "addition is associative") - -let arith_from_integral : (module Fixed_point_repr.Full) -> (module Arith) = - fun (module FP) -> - let module Arith = struct - type t = FP.integral - - let zero = FP.zero - - let equal = FP.equal - - let random () = FP.integral_of_int_exn (Random.int 898987) - - let add = FP.add - - let sub = FP.sub - end in - (module Arith) - -let arith_from_fp : (module Fixed_point_repr.Full) -> (module Arith) = - fun (module FP) -> - let module Arith = struct - type t = FP.fp - - let zero = FP.zero - - let equal = FP.equal - - let random () = FP.unsafe_fp (Z.of_int (Random.int 898987)) - - let add = FP.add - - let sub = FP.sub - end in - (module Arith) - -let integral_tests () = - let module FP = Gas_limit_repr.Arith in - (* test roundtrips *) - fail_unless (FP.(integral_to_z (integral_exn n)) = n) (err "roundtrip > 0") - >>=? fun () -> - fail_unless - (FP.(integral_to_z (integral_exn Z.zero)) = Z.zero) - (err "roundtrip = 0") - >>=? fun () -> - (* test ceil/floor on integral *) - fail_unless - FP.(ceil (fp (integral_exn n)) = integral_exn n) - (err "integral;fp;ceil = integral") - >>=? fun () -> - fail_unless - FP.(floor (fp (integral_exn n)) = integral_exn n) - (err "integral;fp;floor = integral") - >>=? fun () -> - fail_unless - (Format.asprintf "%a" FP.pp FP.(fp (integral_exn n)) - = Format.asprintf "%a" FP.pp_integral (FP.integral_exn n)) - (err "pp_integral(integral) = pp(fp(integral))") - >>=? fun () -> basic_arith "integral arith" (arith_from_integral (module FP)) - -let fp_nonzero () = - let decimals = 3 in - let module FP = Gas_limit_repr.Arith in - let prefix msg = Format.asprintf "(%d decimals) %s" decimals msg in - let err msg = err (prefix msg) in - basic_arith (prefix "integral arith") (arith_from_integral (module FP)) - >>=? fun () -> - basic_arith (prefix "fp arith") (arith_from_fp (module FP)) >>=? fun () -> - let epsilon = FP.unsafe_fp Z.one in - fail_unless FP.(ceil epsilon = integral_exn Z.one) (err "ceil eps = 1") - >>=? fun () -> - fail_unless FP.(floor epsilon = integral_exn Z.zero) (err "floor eps = 1") - >>=? fun () -> - let x = Z.of_int (Random.int 980812) in - fail_unless - FP.( - ceil (add (fp (integral_exn x)) (unsafe_fp Z.one)) - = integral_exn (Z.succ x)) - (err "ceil (x + eps) = x + 1") - -let fp_pp () = - let module FP = Gas_limit_repr.Arith in - let prefix msg = Format.asprintf "(%d decimals) %s" 3 msg in - let err msg = err (prefix msg) in - let epsilon = FP.unsafe_fp Z.one in - let ( =:= ) x expected = Format.asprintf "%a" FP.pp x = expected in - fail_unless (epsilon =:= "0.001") (err "eps = 0.001") >>=? fun () -> - fail_unless (FP.unsafe_fp (Z.of_int 1000) =:= "1") (err "1.000 = 1") - >>=? fun () -> - fail_unless (FP.unsafe_fp (Z.of_int 1001) =:= "1.001") (err "1.001") - >>=? fun () -> - fail_unless (FP.unsafe_fp (Z.of_int 10001) =:= "10.001") (err "10.001") - >>=? fun () -> fail_unless (FP.zero =:= "0") (err "0") - -let tests = - [ - Tztest.tztest "Integral tests (3 decimals)" `Quick integral_tests; - Tztest.tztest "FP tests (3 decimals)" `Quick fp_nonzero; - Tztest.tztest "FP pp tests (3 decimals)" `Quick fp_pp; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("fixed point computation", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_gas_monad.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_gas_monad.ml deleted file mode 100644 index 6e4b8a287469f748f46cb27593823ed57008f3fc..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_gas_monad.ml +++ /dev/null @@ -1,219 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol Gas_monad - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_gas_monad.ml - Subject: Tests for the gas monad module -*) - -open Protocol -open Alpha_context -module GM = Gas_monad - -let ten_milligas = Gas.fp_of_milligas_int 10 - -let new_context ~limit = - Context.init1 () >>=? fun (b, _contract) -> - Incremental.begin_construction b >|=? fun inc -> - Gas.set_limit (Incremental.alpha_ctxt inc) limit - -let assert_gas_exhaustion ~loc ctxt gas_monad = - match GM.run ctxt gas_monad with - | Error _ -> return () - | _ -> failwith "%s: expected gas-exhaustion error" loc - -let assert_equal_gas ~loc g1 g2 = - Assert.equal ~loc Gas.Arith.equal "Compare gas" Gas.Arith.pp g1 g2 - -let assert_inner_errors ~loc ctxt gas_monad ~errors ~remaining_gas = - match GM.run ctxt gas_monad with - | Ok (Error e, ctxt) -> - let open Lwt_result_syntax in - let* () = - Assert.assert_equal_list - ~loc - ( = ) - "Inner error" - Format.pp_print_string - e - errors - in - assert_equal_gas - ~loc - (Gas.remaining_operation_gas ctxt) - (Gas.fp_of_milligas_int remaining_gas) - | _ -> failwith "%s: expected inner error" loc - -let assert_success ~loc ctxt gas_monad ~result ~remaining_gas = - match GM.run ctxt gas_monad with - | Ok (Ok x, ctxt) -> - let open Lwt_result_syntax in - let* () = Assert.equal_int ~loc x result in - assert_equal_gas - ~loc - (Gas.remaining_operation_gas ctxt) - (Gas.fp_of_milligas_int remaining_gas) - | _ -> failwith "%s: expected successful result `%d' but got error" loc result - -let with_context f ~limit = new_context ~limit >>=? f - -(** Test that consuming more gas than remaining results in a gas-exhaustion - error. *) -let test_gas_exhaustion () = - with_context ~limit:ten_milligas @@ fun ctxt -> - let gas_monad = - let open Gas_monad.Syntax in - let* () = GM.consume_gas (Saturation_repr.safe_int 5) in - let* x = GM.return 1 in - let* () = GM.consume_gas (Saturation_repr.safe_int 10) in - let* y = GM.return 2 in - GM.return (x + y) - in - assert_gas_exhaustion ~loc:__LOC__ ctxt gas_monad - -(** Test that consuming more gas than remaining results in a gas-exhaustion - error before an inner error is produced. *) -let test_gas_exhaustion_before_error () = - with_context ~limit:ten_milligas @@ fun ctxt -> - let gas_monad = - let open Gas_monad.Syntax in - let* () = GM.consume_gas (Saturation_repr.safe_int 5) in - let* x = GM.return 1 in - let* () = GM.consume_gas (Saturation_repr.safe_int 10) in - let* () = GM.of_result (error "Oh no") in - let* y = GM.return 2 in - GM.return (x + y) - in - assert_gas_exhaustion ~loc:__LOC__ ctxt gas_monad - -(** Test that consuming all remaining gas is feasible. *) -let test_successful_with_remaining_gas () = - with_context ~limit:ten_milligas @@ fun ctxt -> - let gas_monad = - let open Gas_monad.Syntax in - let* x = GM.return 1 in - let* () = GM.consume_gas (Saturation_repr.safe_int 5) in - let* y = GM.return 2 in - let* () = GM.consume_gas (Saturation_repr.safe_int 5) in - GM.return (x + y) - in - assert_success ~loc:__LOC__ ctxt gas_monad ~result:3 ~remaining_gas:0 - -(** Test that the context has the expected amount of spare gas after the - computation. *) -let test_successful_with_spare_gas () = - with_context ~limit:ten_milligas @@ fun ctxt -> - let gas_monad = - let open Gas_monad.Syntax in - let* x = GM.return 1 in - let* () = GM.consume_gas (Saturation_repr.safe_int 5) in - let* y = GM.return 2 in - let* () = GM.consume_gas (Saturation_repr.safe_int 3) in - GM.return (x + y) - in - assert_success ~loc:__LOC__ ctxt gas_monad ~result:3 ~remaining_gas:2 - -(** Test that an inner error is produced rather than a gas-exhaustion error. *) -let test_inner_error () = - with_context ~limit:ten_milligas @@ fun ctxt -> - let gas_monad = - let open Gas_monad.Syntax in - let* x = GM.return 1 in - let* () = GM.consume_gas (Saturation_repr.safe_int 5) in - let* () = GM.of_result (error "Oh no") in - let* y = GM.return 2 in - let* () = GM.consume_gas (Saturation_repr.safe_int 10) in - GM.return (x + y) - in - assert_inner_errors - ~loc:__LOC__ - ctxt - gas_monad - ~errors:["Oh no"] - ~remaining_gas:5 - -(* Test that no gas-exhaustion error is produced and that no gas is consumed - when run in unlimited mode. -*) -let test_unlimited () = - with_context ~limit:ten_milligas @@ fun ctxt -> - let gas_monad = - let open Gas_monad.Syntax in - let* x = GM.return 1 in - let* () = GM.consume_gas (Saturation_repr.safe_int 5) in - let* y = GM.return 2 in - let* () = GM.consume_gas (Saturation_repr.safe_int 100) in - let* () = GM.consume_gas (Saturation_repr.safe_int 3) in - GM.return (x + y) - in - assert_success - ~loc:__LOC__ - (Gas.set_unlimited ctxt) - gas_monad - ~result:3 - ~remaining_gas:10 - -let test_syntax_module () = - with_context ~limit:ten_milligas @@ fun ctxt -> - let gas_monad = - let open Gas_monad.Syntax in - let* none = return_none in - let* nil = return_nil in - let* t = return_true in - let* f = return_false in - let*? one = Ok 1 in - let+ two = return 2 in - (none, nil, t, f, one, two) - in - match GM.run ctxt gas_monad with - | Ok (Ok (None, [], true, false, 1, 2), _ctxt) -> return () - | _ -> failwith "Expected `Ok (None, [], true, false, 1, 2)`" - -let tests = - [ - Tztest.tztest "exhaustion" `Quick test_gas_exhaustion; - Tztest.tztest - "exhaustion before error" - `Quick - test_gas_exhaustion_before_error; - Tztest.tztest - "successful result with remaining gas" - `Quick - test_successful_with_remaining_gas; - Tztest.tztest - "successful result with spare gas" - `Quick - test_successful_with_spare_gas; - Tztest.tztest "inner error" `Quick test_inner_error; - Tztest.tztest "unlimited" `Quick test_unlimited; - Tztest.tztest "syntax module" `Quick test_syntax_module; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("gas monad", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_global_constants_storage.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_global_constants_storage.ml deleted file mode 100644 index df77573030cb880c0108c1696ff9070ed57bf0ff..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_global_constants_storage.ml +++ /dev/null @@ -1,420 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Marigold *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Global table of constants - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_global_constants_storage.ml - Dependencies: contract_hash.ml - Subject: Test the global table of constants -*) - -open Protocol -open Alpha_context -open Tztest -open Micheline -open QCheck2 -open Qcheck2_helpers -open Michelson_v1_primitives -open Michelson_v1_printer -open Test_global_constants - -(** [get] on a nonexistent global constant - returns an error. *) -let test_get_on_nonexistent_fails = - tztest_qcheck2 - ~name:"get on a nonexistent global constants fails" - (Gen.pair - (Generators.context_gen ()) - (Generators.canonical_without_constant_gen ())) - (fun (context, expr) -> - expr_to_hash expr |> Environment.wrap_tzresult >>?= fun hash -> - Global_constants_storage.get context hash - >|= Environment.wrap_tzresult - >>= assert_proto_error_id __LOC__ "Nonexistent_global") - -(** If registering an expression yields a hash [h] and context [c], - then [get c h] should yield the original expression. *) -let test_get_always_returns_registered_expr = - tztest_qcheck2 - ~name:"get always returned the registered constant" - (Gen.pair - (Generators.context_gen ()) - (Generators.canonical_without_constant_gen ())) - (fun (context, expr) -> - Global_constants_storage.register context expr - >|= Environment.wrap_tzresult - >>=? fun (context, hash, _cost) -> - Global_constants_storage.get context hash >|= Environment.wrap_tzresult - >|=? fun (_context, actual_expr) -> - qcheck_eq ~pp:print_expr actual_expr expr) - -(* Attempts to register an expression that contains references - to expressions not already registered should fail. *) -let test_register_fails_with_unregistered_references = - tztest "register: fails with unregistered references" `Quick (fun () -> - let prim_with_constant = - Expr.from_string - {| Pair 1 - (constant "exprubuoE4JFvkSpxsZJXAvhTdozCNZpgfCnyg6WsiAYX79q4z3bXu")|} - in - create_context () >>=? fun context -> - Global_constants_storage.register context prim_with_constant - >|= Environment.wrap_tzresult - >>= assert_proto_error_id __LOC__ "Nonexistent_global") - -(** Same test as [test_register_fails_with_unregistered_references] - but with random values. *) -let test_register_fails_with_unregistered_references_pbt = - tztest_qcheck2 - ~name:"register: fails with unregistered references pbt" - (Gen.pair - (Generators.context_gen ()) - (Generators.canonical_with_constant_gen ())) - (fun (context, (_, expr, _)) -> - assume_expr_not_too_large expr ; - Global_constants_storage.register context expr - >|= Environment.wrap_tzresult - >>= assert_proto_error_id __LOC__ "Nonexistent_global") - -let rec grow n node = - match n with n when n <= 0 -> node | n -> grow (n - 1) (Seq ((), [node])) - -(* Any expression with a depth that exceeds - [Global_constants_storage.max_allowed_global_constant_depth] - should be rejected. *) -let test_register_fails_if_too_deep = - tztest "register: fails if expression too deep" `Quick (fun () -> - let vdeep_expr = - grow - (Constants_repr.max_allowed_global_constant_depth + 1) - (Int ((), Z.of_int 1)) - |> Micheline.strip_locations - in - create_context () >>=? fun context -> - Global_constants_storage.register context vdeep_expr - >|= Environment.wrap_tzresult - >>= assert_proto_error_id __LOC__ "Expression_too_deep") - -(** [expand] on an expression containing a nonexistent global - constant returns an error. *) -let test_expand_nonexistent_fails = - tztest_qcheck2 - ~name: - "expand on an expression containing a nonexistent global constant fails" - (Gen.pair - (Generators.context_gen ()) - (Generators.canonical_with_constant_gen ())) - @@ fun (context, (_, expr, _)) -> - assume_expr_not_too_large expr ; - Global_constants_storage.expand context expr - >|= Environment.wrap_tzresult - >>= assert_proto_error_id __LOC__ "Nonexistent_global" - -(** Expanding an expression without constants should yield the same expression. *) -let test_expand_no_constants = - tztest "expand: no constants case" `Quick (fun () -> - create_context () >>=? fun context -> - let expected = Expr.from_string "Pair 1 (Pair 2 3)" in - Global_constants_storage.expand context expected - >|= Environment.wrap_tzresult - >>=? fun (_, result_expr) -> - assert_expr_equal __LOC__ expected result_expr) - -(** Similar to [test_expand_no_constants], but random. *) -let test_register_and_expand_orthogonal = - tztest_qcheck2 - ~name:"register and expand are orthogonal" - (Gen.triple - (Generators.context_gen ()) - (Generators.canonical_without_constant_gen ()) - (Generators.canonical_without_constant_gen ())) - (fun (context, expr1, expr2) -> - assume_expr_not_too_large expr1 ; - assume_expr_not_too_large expr2 ; - let open Michelson_v1_printer in - Global_constants_storage.register context expr1 - >|= Environment.wrap_tzresult - >>=? fun (context, _hash, _cost) -> - Global_constants_storage.expand context expr2 - >|= Environment.wrap_tzresult - >|=? fun (_, expr2_result) -> qcheck_eq ~pp:print_expr expr2 expr2_result) - -(** Expanding should expand constants in the given - expression, then expand any new constants, etc. - recursively until no constants remain. *) -let test_expand_deep_constants = - tztest "expand: deep constants" `Quick (fun () -> - (* Should hold for any n, but this test is very slow, - hence we don't do QCheck2. *) - let n = 1000 in - let expr1 = Expr.from_string "{}" in - create_context () >>=? fun context -> - let rec n_constants_deep context node n = - Global_constants_storage.register context (strip_locations node) - >|= Environment.wrap_tzresult - >>=? fun (context, hash, _) -> - if n <= 1 then return (context, node, hash) - else - let new_node = - Seq - ( -1, - [ - Prim - ( -1, - H_constant, - [String (-1, Script_expr_hash.to_b58check hash)], - [] ); - ] ) - in - n_constants_deep context new_node (n - 1) - in - n_constants_deep context (root expr1) n >>=? fun (context, _, hash) -> - let deep_expr = - Expr.from_string - @@ Format.sprintf - "{constant \"%s\"; CDR; NIL operation; PAIR}" - (Script_expr_hash.to_b58check hash) - in - Global_constants_storage.expand context deep_expr - >|= Environment.wrap_tzresult - >>=? fun (_, result) -> - let seq_n_deep n = - let rec advance n acc = - match n with 0 -> acc | _ -> advance (n - 1) (Seq (-1, [acc])) - in - advance (n - 1) (Seq (-1, [])) - in - let seq_str = Expr.to_string @@ strip_locations @@ seq_n_deep n in - let expected = - Expr.from_string - @@ Format.sprintf "{ %s; CDR; NIL operation; PAIR; }" - @@ seq_str - in - assert_expr_equal __LOC__ expected result) - -(** The [constant] prim is permitted only to have a - single string argument, representing a valid - Script_repr.expr hash, with no annotations *) -let test_expand_reject_ill_formed = - tztest "expand: ill formed constants are rejected" `Quick (fun () -> - (* first, create a context, register a constant and check - that its expansion works well. *) - create_context () >>=? fun context -> - let some_expr = Expr.from_string "0" in - Global_constants_storage.register context some_expr - >|= Environment.wrap_tzresult - >>=? fun (context, hash, _) -> - let hash = Script_expr_hash.to_b58check hash in - (* check that expansion of the registered constant works *) - Global_constants_storage.expand - context - (Expr.from_string @@ Format.sprintf "constant \"%s\"" hash) - >|= Environment.wrap_tzresult - >>=? fun (context, result) -> - assert_expr_equal __LOC__ some_expr result >>=? fun () -> - let test expr = - let expected = Expr.from_string expr in - Global_constants_storage.expand context expected - >|= Environment.wrap_tzresult - >>= assert_proto_error_id __LOC__ "Badly_formed_constant_expression" - in - (* constant with an argument other than String fails *) - test "constant 9" >>=? fun () -> - (* same as above but nested *) - test "Pair 1 (constant (Pair 2 3))" >>=? fun () -> - (* constant with bad hash fails *) - test "constant \"foobar\"" >>=? fun () -> - (* constant with type annot *) - test @@ Format.sprintf "(constant :a \"%s\")" hash >>=? fun () -> - (* constant with var annot *) - test @@ Format.sprintf "(constant @a \"%s\")" hash >>=? fun () -> - (* constant with field annot *) - test @@ Format.sprintf "(constant %%a \"%s\")" hash) - -(** The [constant] prim is not permitted to have a - [constant] child argument. - - The idea is to have expansion like this: - - constant (constant ) -> constant hash -> value - - But we want to forbid this as a badly formed constant. - Asserting that every constant must be a *static* string - makes it easier to see which constants are used where, because - you can just traverse the AST (no expansion necessary). *) -let test_reject_use_of_inner_constant = - tztest - "expand: use of 'constant (constant ...)' is rejected" - `Quick - (fun () -> - (* First, create a context, register a constant and check - that its expansion works well. *) - create_context () >>=? fun context -> - let some_expr = Expr.from_string "0" in - Global_constants_storage.register context some_expr - >|= Environment.wrap_tzresult - >>=? fun (context, hash, _) -> - let hash = Script_expr_hash.to_b58check hash in - (* Next, register the hash itself as a constant. *) - Global_constants_storage.register - context - (strip_locations (Micheline.String (-1, hash))) - >|= Environment.wrap_tzresult - >>=? fun (context, hash, _) -> - let hash = Script_expr_hash.to_b58check hash in - Global_constants_storage.expand - context - (Expr.from_string - @@ Format.sprintf "{ constant (constant \"%s\") } " hash) - >|= Environment.wrap_tzresult - >>= assert_proto_error_id __LOC__ "Badly_formed_constant_expression") - -(** [test_expand] accepts an expression [stored] to be - registered in the store, an expression [expr] that includes a template slot for - the hash of [stored], and an [expected] expression, and generates a test that - asserts the value of [expr] after expansion matches [expected]. *) -let make_expand_test ~stored ~expr ~expected () = - create_context () >>=? fun context -> - let stored_expr = Expr.from_string stored in - Global_constants_storage.register context stored_expr - >|= Environment.wrap_tzresult - >>=? fun (context, hash, _) -> - let expected = Expr.from_string expected in - let expr_with_constant = - Format.sprintf expr (Script_expr_hash.to_b58check hash) |> Expr.from_string - in - Global_constants_storage.expand context expr_with_constant - >|= Environment.wrap_tzresult - >>=? fun (_, result_expr) -> assert_expr_equal __LOC__ expected result_expr - -let test_expand_data_example = - tztest - "expand: data" - `Quick - (make_expand_test - ~stored:"3" - ~expr:"Pair 1 (Pair 2 (constant \"%s\"))" - ~expected:"Pair 1 (Pair 2 3)") - -let test_expand_types_example = - tztest - "expand: types" - `Quick - (make_expand_test - ~stored:"big_map string string" - ~expr:"PUSH (constant \"%s\") {}" - ~expected:"PUSH (big_map string string) {}") - -let test_expand_instr_example = - tztest - "expand: instr" - `Quick - (make_expand_test - ~stored:"PUSH int 3" - ~expr:"{ DROP; constant \"%s\"; DROP }" - ~expected:"{ DROP; PUSH int 3 ; DROP }") - -(** For any expression [e], when replacing any subexpression - [e'] with a constant hash and registering [e'], calling - [expand] on the new expression yields the - original expression [e]*) -let test_expand_pbt = - let open Michelson_v1_printer in - tztest_qcheck2 - ~name:"expand: random" - (Gen.pair - (Generators.context_gen ()) - (Generators.canonical_with_constant_gen ())) - (fun (context, (full_expr, expr_with_constant, sub_expr)) -> - assume_expr_not_too_large full_expr ; - assume_expr_not_too_large expr_with_constant ; - assume_expr_not_too_large sub_expr ; - Global_constants_storage.register context sub_expr - >|= Environment.wrap_tzresult - >>=? fun (context, _, _) -> - Global_constants_storage.expand context expr_with_constant - >|= Environment.wrap_tzresult - >|=? fun (_, result_expr) -> - qcheck_eq ~pp:print_expr full_expr result_expr) - -let test_expand_is_idempotent = - tztest_qcheck2 - ~name:"expand is idempotent" - (Gen.pair - (Generators.context_gen ()) - (Generators.canonical_with_constant_gen ())) - (fun (context, (full_expr, expr_with_constant, sub_expr)) -> - assume_expr_not_too_large full_expr ; - Global_constants_storage.register context sub_expr - >|= Environment.wrap_tzresult - >>=? fun (context, _, _) -> - Global_constants_storage.expand context expr_with_constant - >|= Environment.wrap_tzresult - >>=? fun (context, result1) -> - Global_constants_storage.expand context full_expr - >|= Environment.wrap_tzresult - >|=? fun (_, result2) -> qcheck_eq ~pp:print_expr result1 result2) - -(** [bottom_up_fold_cps] does not stack overflow even when - given large values. *) -let test_fold_does_not_stack_overflow = - tztest "bottom_up_fold_cps: does not stack overflow" `Quick (fun () -> - let node = grow 1_000_000 @@ Int ((), Z.zero) in - return @@ ignore - @@ Global_constants_storage.Internal_for_tests.bottom_up_fold_cps - () - node - (fun _ _ -> ()) - (fun _ node k -> k () node)) - -let tests = - [ - test_get_on_nonexistent_fails; - test_get_always_returns_registered_expr; - test_register_fails_with_unregistered_references; - test_register_fails_with_unregistered_references_pbt; - test_register_fails_if_too_deep; - test_expand_nonexistent_fails; - test_expand_no_constants; - test_register_and_expand_orthogonal; - test_expand_deep_constants; - test_expand_reject_ill_formed; - test_reject_use_of_inner_constant; - test_expand_data_example; - test_expand_types_example; - test_expand_instr_example; - test_expand_pbt; - test_expand_is_idempotent; - test_fold_does_not_stack_overflow; - ] - -let () = - Alcotest_lwt.run - ~__FILE__ - Protocol.name - [("Global_constants_storage.ml", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_level_module.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_level_module.ml deleted file mode 100644 index 656e3e5eac8c288c14ab028c2bea148626c8c5c5..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_level_module.ml +++ /dev/null @@ -1,283 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (baking) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_level_module.ml - Subject: some functions in the Level module -*) - -open Protocol - -let test_create_cycle_eras () = - let empty_cycle_eras = - Level_repr.create_cycle_eras [] |> Environment.wrap_tzresult - in - Assert.proto_error_with_info - ~loc:__LOC__ - empty_cycle_eras - "Invalid cycle eras" - >>=? fun () -> - let increasing_first_levels = - [ - Level_repr. - { - first_level = Raw_level_repr.of_int32_exn 1l; - first_cycle = Cycle_repr.succ Cycle_repr.root; - blocks_per_cycle = 8l; - blocks_per_commitment = 2l; - }; - { - first_level = Raw_level_repr.of_int32_exn 9l; - first_cycle = Cycle_repr.root; - blocks_per_cycle = 8l; - blocks_per_commitment = 2l; - }; - ] - |> Level_repr.create_cycle_eras |> Environment.wrap_tzresult - in - Assert.proto_error_with_info - ~loc:__LOC__ - increasing_first_levels - "Invalid cycle eras" - >>=? fun () -> - let increasing_first_cycles = - [ - Level_repr. - { - first_level = Raw_level_repr.of_int32_exn 9l; - first_cycle = Cycle_repr.root; - blocks_per_cycle = 8l; - blocks_per_commitment = 2l; - }; - { - first_level = Raw_level_repr.of_int32_exn 1l; - first_cycle = Cycle_repr.succ Cycle_repr.root; - blocks_per_cycle = 8l; - blocks_per_commitment = 2l; - }; - ] - |> Level_repr.create_cycle_eras |> Environment.wrap_tzresult - in - Assert.proto_error_with_info - ~loc:__LOC__ - increasing_first_cycles - "Invalid cycle eras" - -let test_case_1 = - ( [ - Level_repr. - { - first_level = Raw_level_repr.of_int32_exn 1l; - first_cycle = Cycle_repr.root; - blocks_per_cycle = 8l; - blocks_per_commitment = 2l; - }; - ], - [ - (1, (1, 0, 0, 0, false)); - (2, (2, 1, 0, 1, true)); - (3, (3, 2, 0, 2, false)); - (8, (8, 7, 0, 7, true)); - (9, (9, 8, 1, 0, false)); - (16, (16, 15, 1, 7, true)); - (17, (17, 16, 2, 0, false)); - (64, (64, 63, 7, 7, true)); - (65, (65, 64, 8, 0, false)); - ] ) - -let test_case_2 = - ( List.rev - [ - Level_repr. - { - first_level = Raw_level_repr.of_int32_exn 1l; - first_cycle = Cycle_repr.root; - blocks_per_cycle = 8l; - blocks_per_commitment = 2l; - }; - { - first_level = Raw_level_repr.of_int32_exn 17l; - first_cycle = Cycle_repr.of_int32_exn 2l; - blocks_per_cycle = 16l; - blocks_per_commitment = 4l; - }; - ], - [ - (1, (1, 0, 0, 0, false)); - (2, (2, 1, 0, 1, true)); - (3, (3, 2, 0, 2, false)); - (8, (8, 7, 0, 7, true)); - (9, (9, 8, 1, 0, false)); - (16, (16, 15, 1, 7, true)); - (17, (17, 16, 2, 0, false)); - (32, (32, 31, 2, 15, true)); - (33, (33, 32, 3, 0, false)); - (64, (64, 63, 4, 15, true)); - (65, (65, 64, 5, 0, false)); - ] ) - -let test_case_3 = - ( List.rev - [ - Level_repr. - { - first_level = Raw_level_repr.of_int32_exn 1l; - first_cycle = Cycle_repr.root; - blocks_per_cycle = 8l; - blocks_per_commitment = 2l; - }; - { - first_level = Raw_level_repr.of_int32_exn 17l; - first_cycle = Cycle_repr.of_int32_exn 2l; - blocks_per_cycle = 16l; - blocks_per_commitment = 4l; - }; - { - first_level = Raw_level_repr.of_int32_exn 49l; - first_cycle = Cycle_repr.of_int32_exn 4l; - blocks_per_cycle = 6l; - blocks_per_commitment = 3l; - }; - ], - [ - (1, (1, 0, 0, 0, false)); - (2, (2, 1, 0, 1, true)); - (3, (3, 2, 0, 2, false)); - (8, (8, 7, 0, 7, true)); - (9, (9, 8, 1, 0, false)); - (16, (16, 15, 1, 7, true)); - (17, (17, 16, 2, 0, false)); - (32, (32, 31, 2, 15, true)); - (33, (33, 32, 3, 0, false)); - (48, (48, 47, 3, 15, true)); - (49, (49, 48, 4, 0, false)); - (64, (64, 63, 6, 3, false)); - (65, (65, 64, 6, 4, false)); - (66, (66, 65, 6, 5, true)); - (67, (67, 66, 7, 0, false)); - ] ) - -let test_level_from_raw () = - List.iter_es - (fun (cycle_eras, test_cases) -> - List.iter_es - (fun ( input_level, - ( level, - level_position, - cycle, - cycle_position, - expected_commitment ) ) -> - let raw_level = - Raw_level_repr.of_int32_exn (Int32.of_int input_level) - in - Level_repr.create_cycle_eras cycle_eras |> Environment.wrap_tzresult - >>?= fun cycle_eras -> - let level_from_raw = - Protocol.Level_repr.level_from_raw ~cycle_eras raw_level - in - Assert.equal_int - ~loc:__LOC__ - (Int32.to_int (Raw_level_repr.to_int32 level_from_raw.level)) - level - >>=? fun () -> - Assert.equal_int - ~loc:__LOC__ - (Int32.to_int level_from_raw.level_position) - level_position - >>=? fun () -> - Assert.equal_int - ~loc:__LOC__ - (Int32.to_int (Cycle_repr.to_int32 level_from_raw.cycle)) - cycle - >>=? fun () -> - Assert.equal_int - ~loc:__LOC__ - (Int32.to_int level_from_raw.cycle_position) - cycle_position - >>=? fun () -> - Assert.equal_bool - ~loc:__LOC__ - level_from_raw.expected_commitment - expected_commitment - >>=? fun () -> - let offset = - Int32.neg (Int32.add Int32.one (Int32.of_int input_level)) - in - let res = - Level_repr.level_from_raw_with_offset ~cycle_eras ~offset raw_level - in - Assert.proto_error - ~loc:__LOC__ - (Environment.wrap_tzresult res) - (fun err -> - let error_info = - Error_monad.find_info_of_error (Environment.wrap_tzerror err) - in - error_info.title = "Negative sum of level and offset")) - test_cases) - [test_case_1; test_case_2; test_case_3] - -let test_first_level_in_cycle () = - let cycle_eras = fst test_case_3 in - let test_cases = - (* cycle, level *) - [ - (0l, 1); - (1l, 9); - (2l, 17); - (3l, 33); - (4l, 49); - (5l, 55); - (6l, 61); - (7l, 67); - ] - in - let f (input_cycle, level) = - Level_repr.create_cycle_eras cycle_eras |> Environment.wrap_tzresult - >>?= fun cycle_eras -> - let input_cycle = Cycle_repr.of_int32_exn input_cycle in - let level_res = - Level_repr.first_level_in_cycle_from_eras ~cycle_eras input_cycle - in - Assert.equal_int - ~loc:__LOC__ - (Int32.to_int (Raw_level_repr.to_int32 level_res.level)) - level - in - List.iter_es f test_cases - -let tests = - [ - Tztest.tztest "create_cycle_eras" `Quick test_create_cycle_eras; - Tztest.tztest "level_from_raw" `Quick test_level_from_raw; - Tztest.tztest "first_level_in_cycle" `Quick test_first_level_in_cycle; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("level module", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_liquidity_baking_repr.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_liquidity_baking_repr.ml deleted file mode 100644 index 28d300e90ba2a70411935a4511d6f7ef5598e8d2..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_liquidity_baking_repr.ml +++ /dev/null @@ -1,255 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol Liquidity_baking_repr module - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_liquidity_baking_repr.ml - Subject: Tests for the Liquidity_baking_repr module -*) - -open Protocol - -let ema_of_int32 ema = - Liquidity_baking_repr.Toggle_EMA.of_int32 ema >|= Environment.wrap_tzresult - -let ema_to_int32 = Liquidity_baking_repr.Toggle_EMA.to_int32 - -let compute_new_ema ~toggle_vote ema = - Liquidity_baking_repr.compute_new_ema ~toggle_vote ema |> ema_to_int32 - -(* Folds compute_new_ema on a list of votes *) -let compute_new_ema_n toggle_votes initial_ema = - List.fold_left - (fun ema toggle_vote -> - Liquidity_baking_repr.compute_new_ema ~toggle_vote ema) - initial_ema - toggle_votes - |> ema_to_int32 - -let ema_range = - [ - 0l; - 1l; - 10l; - 100l; - 1000l; - 10_000l; - 100_000l; - 1_000_000l; - 10_000_000l; - 100_000_000l; - 200_000_000l; - 300_000_000l; - 400_000_000l; - 500_000_000l; - 600_000_000l; - 760_000_000l; - 800_000_000l; - 900_000_000l; - 1_000_000_000l; - 1_100_000_000l; - 1_200_000_000l; - 1_300_000_000l; - 1_400_000_000l; - 1_500_000_000l; - 1_600_000_000l; - 1_700_000_000l; - 1_800_000_000l; - 1_900_000_000l; - 1_990_000_000l; - 1_999_000_000l; - 1_999_900_000l; - 1_999_990_000l; - 1_999_999_000l; - 1_999_999_900l; - 1_999_999_990l; - 1_999_999_999l; - 2_000_000_000l; - ] - -(* Test that new_ema = old_ema when voting Pass. *) -let test_ema_pass () = - List.iter_es - (fun old_ema -> - ema_of_int32 old_ema >>=? fun ema -> - Assert.equal_int32 - ~loc:__LOC__ - (compute_new_ema ~toggle_vote:LB_pass ema) - old_ema) - ema_range - -(* Test that new_ema is still between 0 and 2,000,000,000 after an Off vote. *) -let test_ema_in_bound_off () = - List.iter_es - (fun old_ema -> - ema_of_int32 old_ema >>=? fun ema -> - let new_ema = compute_new_ema ~toggle_vote:LB_off ema in - Assert.leq_int32 ~loc:__LOC__ 0l new_ema >>=? fun () -> - Assert.leq_int32 ~loc:__LOC__ new_ema 2_000_000_000l) - ema_range - -(* Test that new_ema > old_ema when voting Off, except if old_ema is - already very close to the upper bound. *) -let test_ema_increases_off () = - List.iter_es - (fun old_ema -> - ema_of_int32 old_ema >>=? fun ema -> - Assert.lt_int32 - ~loc:__LOC__ - old_ema - (compute_new_ema ~toggle_vote:LB_off ema)) - (List.filter (fun ema -> Compare.Int32.(ema < 1_999_999_000l)) ema_range) - -(* Test that the increase in EMA caused by an Off vote is bounded by 1,000,000 *) -let test_ema_increases_off_bound () = - List.iter_es - (fun old_ema -> - ema_of_int32 old_ema >>=? fun ema -> - Assert.leq_int32 - ~loc:__LOC__ - (Int32.sub (compute_new_ema ~toggle_vote:LB_off ema) old_ema) - 1_000_000l) - ema_range - -(* Test that new_ema is still between 0 and 2,000,000,000 after an Off vote. *) -let test_ema_in_bound_on () = - List.iter_es - (fun old_ema -> - ema_of_int32 old_ema >>=? fun ema -> - let new_ema = compute_new_ema ~toggle_vote:LB_on ema in - Assert.leq_int32 ~loc:__LOC__ 0l new_ema >>=? fun () -> - Assert.leq_int32 ~loc:__LOC__ new_ema 2_000_000_000l) - ema_range - -(* Test that new_ema < old_ema when voting On, except if old_ema is - already very close to the lower bound. *) -let test_ema_decreases_on () = - List.iter_es - (fun old_ema -> - ema_of_int32 old_ema >>=? fun ema -> - Assert.lt_int32 - ~loc:__LOC__ - (compute_new_ema ~toggle_vote:LB_on ema) - old_ema) - (List.filter (fun ema -> Compare.Int32.(ema > 1000l)) ema_range) - -(* Test that the decrease in EMA caused by an On vote is bounded by 1,000,000 *) -let test_ema_decreases_on_bound () = - List.iter_es - (fun old_ema -> - ema_of_int32 old_ema >>=? fun ema -> - Assert.leq_int32 - ~loc:__LOC__ - (Int32.sub (compute_new_ema ~toggle_vote:LB_on ema) old_ema) - 1_000_000l) - ema_range - -(* Test that 1385 Off votes are needed to reach the threshold from 0. *) -let test_ema_many_off () = - let open Liquidity_baking_repr in - ema_of_int32 0l >>=? fun initial_ema -> - Assert.leq_int32 - ~loc:__LOC__ - (compute_new_ema_n (Stdlib.List.init 1385 (fun _ -> LB_off)) initial_ema) - 1_000_000_000l - >>=? fun () -> - Assert.leq_int32 - ~loc:__LOC__ - 1_000_000_000l - (compute_new_ema_n (Stdlib.List.init 1386 (fun _ -> LB_off)) initial_ema) - -(* Test that 1385 On votes are needed to reach the threshold from the max value of the EMA (2,000,000,000). *) -let test_ema_many_on () = - let open Liquidity_baking_repr in - ema_of_int32 2_000_000_000l >>=? fun initial_ema -> - Assert.leq_int32 - ~loc:__LOC__ - 1_000_000_000l - (compute_new_ema_n (Stdlib.List.init 1385 (fun _ -> LB_on)) initial_ema) - >>=? fun () -> - Assert.leq_int32 - ~loc:__LOC__ - (compute_new_ema_n (Stdlib.List.init 1386 (fun _ -> LB_on)) initial_ema) - 1_000_000_000l - -(* Test that the EMA update function is symmetric: - from two dual values of the EMA (that is, two values x and y such that - x + y = 2,000,000,000), voting On on the first one decreases it by as - much than voting Off on the second one increases it. -*) -let test_ema_symmetry () = - List.iter_es - (fun ema -> - let opposite_ema = Int32.(sub 2_000_000_000l ema) in - ema_of_int32 ema >>=? fun ema -> - ema_of_int32 opposite_ema >>=? fun opposite_ema -> - let new_ema = compute_new_ema ~toggle_vote:LB_on ema in - let new_opposite_ema = compute_new_ema ~toggle_vote:LB_off opposite_ema in - Assert.equal_int32 - ~loc:__LOC__ - Int32.(add new_ema new_opposite_ema) - 2_000_000_000l) - ema_range - -let tests = - [ - Tztest.tztest "EMA does not change when vote is Pass" `Quick test_ema_pass; - Tztest.tztest - "EMA remains in bounds when vote is Off" - `Quick - test_ema_in_bound_off; - Tztest.tztest "EMA increases when vote is Off" `Quick test_ema_increases_off; - Tztest.tztest - "EMA does not increase too much when vote is Off" - `Quick - test_ema_increases_off_bound; - Tztest.tztest - "EMA remains in bounds when vote is On" - `Quick - test_ema_in_bound_on; - Tztest.tztest "EMA decreases when vote is On" `Quick test_ema_decreases_on; - Tztest.tztest - "EMA does not decrease too much when vote is On" - `Quick - test_ema_decreases_on_bound; - Tztest.tztest - "EMA goes from 0 to one billion in 1386 Off votes" - `Quick - test_ema_many_off; - Tztest.tztest - "EMA goes from two billions to one billion in 1386 On votes" - `Quick - test_ema_many_on; - Tztest.tztest - "voting On and Off have symmetric effects on the EMA" - `Quick - test_ema_symmetry; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("liquidity baking", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_local_contexts.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_local_contexts.ml deleted file mode 100644 index 031ac22d61f0bc99c21713be233b58d953208470..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_local_contexts.ml +++ /dev/null @@ -1,139 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 proof ninja, Inc >=? fun alpha_ctxt -> - return @@ A.Internal_for_tests.to_raw alpha_ctxt - -(* /a/b/c *) -let dir1 = ["a"; "b"; "c"] - -module Sub = - Make_subcontext (Registered) (Raw_context) - (struct - let name = dir1 - end) - -module Index : INDEX with type t = string = struct - type t = string - - let path_length = 1 - - let to_path x l = x :: l - - let of_path = function [x] -> Some x | _ -> None - - type 'a ipath = 'a * t - - let args = - Storage_description.One - { - rpc_arg = Environment.RPC_arg.string; - encoding = Data_encoding.string; - compare; - } -end - -module Indexed_context = Make_indexed_subcontext (Sub) (Index) - -module Value : Storage_sigs.VALUE with type t = bytes = struct - type t = bytes - - let encoding = Data_encoding.bytes -end - -module C = - Indexed_context.Make_map - (Registered) - (struct - let name = ["name"] - end) - (Value) - -let eq_context ctxt1 ctxt2 = - let hash ctxt = - Raw_context.get_tree ctxt [] >|= Environment.wrap_tzresult >|=? fun root -> - Raw_context.Tree.hash root - in - hash ctxt1 >>=? fun x -> - hash ctxt2 >>=? fun y -> - Assert.equal - ~loc:__LOC__ - Context_hash.equal - "check context" - Context_hash.pp - x - y - -let write_with_local ctxt local_dir f = - Indexed_context.with_local_context ctxt local_dir (fun local -> - f local >|=? fun local -> (local, ())) - >|=? fun (ctxt, ()) -> ctxt - -let test_local_remove_existing () = - create () >>=? fun ctxt -> - let subdir = "foo" in - let value = Bytes.of_string "ABCDE" in - (* init *) - write_with_local ctxt subdir (fun local -> C.Local.init local value) - >|= Environment.wrap_tzresult - >>=? fun ctxt1 -> - C.init ctxt subdir value >|= Environment.wrap_tzresult >>=? fun ctxt2 -> - eq_context ctxt1 ctxt2 >>=? fun () -> - let ctxt = ctxt2 in - (* remove_existing *) - write_with_local ctxt subdir C.Local.remove_existing - >|= Environment.wrap_tzresult - >>=? fun ctxt1 -> - C.remove_existing ctxt subdir >|= Environment.wrap_tzresult >>=? fun ctxt2 -> - eq_context ctxt1 ctxt2 - -let tests = - [ - Tztest.tztest - "Local.remove_existing: check whether local access has the same behavior" - `Quick - test_local_remove_existing; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("local contexts", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_merkle_list.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_merkle_list.ml deleted file mode 100644 index 9045b5fb941945437e3ddf7dda3e09e8ffff6347..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_merkle_list.ml +++ /dev/null @@ -1,261 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (Merkle list) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_merkle_list.ml - Subject: test the ad-hoc merkle tree structure implemented to encode lists -*) - -open Merkle_list_helper - -let assert_invalid_pos : 'a Environment.Error_monad.tzresult -> _ = function - | Error err -> - let expected_error_msg msg = "Error:\n " ^ msg ^ "\n" in - let actual_error_msg : string = - Format.asprintf "%a" Environment.Error_monad.pp_trace err - in - Log.debug "%s\n" actual_error_msg ; - assert ( - expected_error_msg "Merkle_list_invalid_position" = actual_error_msg) - | _ -> assert false - -(* Check that the result of [compute] is the expected hash *) -let test_compute () = - let open Error_monad.Result_syntax in - let elements = - Stdlib.List.init 5 (fun i -> Bytes.of_string (Int.to_string i)) - in - let element_hashes = List.map (fun e -> Hash.hash_bytes [e]) elements in - let el_hashes_a = Array.of_list element_hashes in - let h01 = hash2 el_hashes_a.(0) el_hashes_a.(1) in - let h23 = hash2 el_hashes_a.(2) el_hashes_a.(3) in - let h4e = hash2 el_hashes_a.(4) empty in - let h03 = hash2 h01 h23 in - let h4ee = hash2 h4e empty in - let expected_root = hash2 h03 h4ee in - assert (Hash.equal (compute elements) expected_root) ; - return_unit - -(* Compare the root of a tree constructed by snoc'ing to the value - given by compute and the values of the leaves *) -let test_snoc () = - let open Error_monad.Result_syntax in - let n = 20 in - let elements = - Stdlib.List.init n (fun i -> Bytes.of_string (Int.to_string i)) - in - - let t = List.fold_left snoc_tr nil elements in - let element_hashes = List.map (fun e -> Hash.hash_bytes [e]) elements in - - assert (Hash.equal (compute elements) (root t)) ; - assert (element_hashes = Internal_for_tests.to_list t) ; - return_unit - -(* Compare the result of the two versions of snoc *) -let test_snoc_non_tr () = - let open Error_monad.Result_syntax in - let n = 20 in - let elements = - Stdlib.List.init n (fun i -> Bytes.of_string (Int.to_string i)) - in - let t1 = List.fold_left snoc_tr nil elements in - let t2 = List.fold_left snoc nil elements in - assert (Internal_for_tests.equal t1 t2) ; - return_unit - -(* Check that the path computed is the expected one *) -let test_compute_path () = - let open Error_monad.Result_syntax in - let elements = - Stdlib.List.init 5 (fun i -> Bytes.of_string (Int.to_string i)) - in - let t = List.fold_left snoc_tr nil elements in - - let element_hashes = List.map (fun e -> Hash.hash_bytes [e]) elements in - let el_hashes_a = Array.of_list element_hashes in - let h23 = hash2 el_hashes_a.(2) el_hashes_a.(3) in - let h4e = hash2 el_hashes_a.(4) empty in - let h4ee = hash2 h4e empty in - let expected_path_for_1 = [el_hashes_a.(0); h23; h4ee] in - let* path = compute_path t 1 in - assert (Internal_for_tests.path_to_list path = expected_path_for_1) ; - return_unit - -(* Negative test: pos < 0 *) -let test_compute_path_negative_pos () = - let open Error_monad.Result_syntax in - let n = 10 in - let elements = - Stdlib.List.init n (fun i -> Bytes.of_string (Int.to_string i)) - in - let t = List.fold_left snoc_tr nil elements in - assert_invalid_pos @@ compute_path t (-1) ; - return_unit - -(* Negative test: pos >= size tree *) -let test_compute_path_out_of_bounds () = - let open Error_monad.Result_syntax in - let n = 20 in - let elements = - Stdlib.List.init n (fun i -> Bytes.of_string (Int.to_string i)) - in - let t = List.fold_left snoc_tr nil elements in - assert_invalid_pos @@ compute_path t n ; - return_unit - -(* Negative test: pos = size tree, when tree is full *) -let test_compute_path_out_of_bounds_full () = - let open Error_monad.Result_syntax in - let n = 4 in - let elements = - Stdlib.List.init n (fun i -> Bytes.of_string (Int.to_string i)) - in - let t = List.fold_left snoc_tr nil elements in - assert_invalid_pos @@ compute_path t n ; - return_unit - -(* Check that a computed root (from [check_path]) is the actual root *) -let test_check_path () = - let open Error_monad.Result_syntax in - let n = 20 in - let elements = - Stdlib.List.init n (fun i -> Bytes.of_string (Int.to_string i)) - in - let elements_array = Array.of_list elements in - let t = List.fold_left snoc_tr nil elements in - Stdlib.List.init n (fun pos -> - let* path = compute_path t pos in - let* b = check_path path pos elements_array.(pos) (ML.root t) in - assert b ; - return_unit) - |> Environment.Error_monad.Result_syntax.tzjoin - -(* Check that a path is only valid for the position for which it - was computed *) -let test_check_path_wrong_pos () = - let open Error_monad.Result_syntax in - let n = 20 in - let elements = - Stdlib.List.init n (fun i -> Bytes.of_string (Int.to_string i)) - in - let elements_array = Array.of_list elements in - let t = List.fold_left snoc_tr ML.nil elements in - let* path = compute_path t (n - 1) in - Stdlib.List.init (n - 2) (fun pos -> - let* b = check_path path pos elements_array.(pos) (ML.root t) in - assert (not b) ; - return_unit) - |> Environment.Error_monad.Result_syntax.tzjoin - -(* Check that a computed path is invalidated by a tree update *) -let test_check_invalidated_path () = - let open Error_monad.Result_syntax in - let n = 20 in - let elements = - Stdlib.List.init n (fun i -> Bytes.of_string (Int.to_string i)) - in - let new_el = Bytes.of_string (Int.to_string n) in - let t = List.fold_left snoc_tr ML.nil elements in - let* path = compute_path t 0 in - let t = snoc_tr t new_el in - let* b = check_path path 0 (Stdlib.List.hd elements) (ML.root t) in - assert (not b) ; - return_unit - -(* Negative test: pos < 0 in [check_path] *) -let test_check_path_negative_pos () = - let open Error_monad.Result_syntax in - let n = 20 in - let elements = - Stdlib.List.init n (fun i -> Bytes.of_string (Int.to_string i)) - in - let elements_array = Array.of_list elements in - let t = List.fold_left snoc_tr nil elements in - let pos = Random.int n in - let* path = compute_path t pos in - assert_invalid_pos @@ check_path path (-1) elements_array.(pos) (ML.root t) ; - return_unit - -(* Negative test: pos >= 2^depth in [check_path] *) -let test_check_path_out_of_bounds () = - let open Error_monad.Result_syntax in - let n = 20 in - let elements = - Stdlib.List.init n (fun i -> Bytes.of_string (Int.to_string i)) - in - let elements_array = Array.of_list elements in - let t = List.fold_left snoc_tr nil elements in - let pos = Random.int n in - let* path = compute_path t pos in - (* NB: for this to be actually invalid, it is not enough to pass - a position larger than [n]. We need pos >= 2^depth. *) - assert_invalid_pos @@ check_path path 32 elements_array.(pos) (ML.root t) ; - return_unit - -(* Encoding roundtrip *) -let test_path_encoding () = - let open Error_monad.Result_syntax in - let n = 20 in - let elements = - Stdlib.List.init n (fun i -> Bytes.of_string (Int.to_string i)) - in - let t = List.fold_left snoc_tr nil elements in - let pos = n / 2 in - let* path = compute_path t pos in - let b = Data_encoding.Binary.to_bytes_exn path_encoding path in - let path' = Data_encoding.Binary.of_bytes_exn path_encoding b in - assert (path' = path) ; - return_unit - -let valid_tests = - [ - ("compute", test_compute); - ("snoc", test_snoc); - ("snoc_non_tr", test_snoc_non_tr); - ("compute_path", test_compute_path); - ("check_path", test_check_path); - ("path_encoding", test_path_encoding); - ("compute_path_negative_pos", test_compute_path_negative_pos); - ("compute_path_out_of_bounds", test_compute_path_out_of_bounds); - ("check_path_negative_pos", test_check_path_negative_pos); - ("check_path_out_of_bounds", test_check_path_out_of_bounds); - ("compute_path_out_of_bounds_full", test_compute_path_out_of_bounds_full); - ("check_path_wrong_pos", test_check_path_wrong_pos); - ("check_invalidated_path", test_check_invalidated_path); - ] - -let wrap (n, f) = - Alcotest_lwt.test_case n `Quick (fun _ () -> - Lwt.return (f ()) >|= function Ok () -> () | Error _ -> assert false) - -let tests = List.map wrap valid_tests - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("merkle list", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_operation_repr.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_operation_repr.ml deleted file mode 100644 index e3dd0f23227ec336e0e899825d209d1533f762e0..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_operation_repr.ml +++ /dev/null @@ -1,189 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Marigold *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Operation_repr - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_operation_repr.ml - Dependencies: -- - Subject: To test the modules (including the top-level) - in operation_repr.ml as individual units, particularly - failure cases. Superficial goal: increase coverage percentage. -*) -open Protocol - -open Tztest - -module Test_operation_repr = struct - open Operation_repr - - let test_of_list_single_case () = - let op = - Manager_operation - { - fee = Obj.magic 0; - operation = Obj.magic 0; - gas_limit = Obj.magic 0; - storage_limit = Obj.magic 0; - counter = Obj.magic 0; - source = Obj.magic 0; - } - in - Environment.wrap_tzresult @@ of_list [Contents op] >>?= fun contents_list -> - match contents_list with - | Contents_list (Single op') when op == Obj.magic op' -> return_unit - | _ -> failwith "Unexpected value" - - let test_of_list_multiple_case () = - let op1 = - Manager_operation - { - fee = Obj.magic 0; - operation = Obj.magic 0; - gas_limit = Obj.magic 0; - storage_limit = Obj.magic 0; - counter = Obj.magic 0; - source = Obj.magic 0; - } - in - let op2 = - Manager_operation - { - fee = Obj.magic 1; - operation = Obj.magic 0; - gas_limit = Obj.magic 0; - storage_limit = Obj.magic 0; - counter = Obj.magic 0; - source = Obj.magic 0; - } - in - Environment.wrap_tzresult @@ of_list [Contents op1; Contents op2] - >>?= fun contents_list -> - match contents_list with - | Contents_list (Cons (op1', Single op2')) - when op1 == Obj.magic op1' && op2 == Obj.magic op2' -> - return_unit - | _ -> failwith "Unexpected value" - - let test_of_list_empty_case () = - match of_list [] with - | Ok _ -> failwith "of_list of an empty list was expected to fail" - | Error _ -> return_unit - - let zero_bls = - match Signature.(split_signature (Bls Signature.Bls.zero)) with - | {prefix = None; _} -> assert false - | {prefix = Some prefix; suffix} -> - let prefix = - Data_encoding.Binary.to_bytes_exn Signature.prefix_encoding prefix - in - (Bytes.cat (Bytes.of_string "\255") prefix, suffix) - - let test_split_signatures error assemble = - let op_bytes = - Data_encoding.Binary.to_bytes_exn - Operation_repr.contents_encoding - (Contents (Failing_noop "")) - in - let prefix, suffix = zero_bls in - let protocol_data_bytes = - Bytes.(concat empty) (assemble op_bytes prefix suffix) - in - match - Data_encoding.Binary.of_bytes - Operation_repr.protocol_data_encoding - protocol_data_bytes - with - | Ok _ -> failwith "Should have failed with %s" error - | Error (User_invariant_guard e) when e = error -> return_unit - | Error e -> - failwith - "Unexpected error: %a instead of %s" - Data_encoding.Binary.pp_read_error - e - error - - let test_only_signature_prefix () = - test_split_signatures "Operation lists should not be empty." - @@ fun _op_bytes prefix suffix -> [prefix; suffix] - - let test_decoding_empty_list () = - test_split_signatures "Operation lists should not be empty." - @@ fun _op_bytes _prefix suffix -> [suffix] - - let test_multiple_signature_prefix () = - test_split_signatures "Signature prefix must appear last" - @@ fun op_bytes prefix suffix -> [op_bytes; prefix; prefix; suffix] - - let test_signature_prefix_not_final () = - test_split_signatures "Signature prefix must appear last" - @@ fun op_bytes prefix suffix -> [prefix; op_bytes; suffix] - - let test_multiple_non_manager () = - test_split_signatures - "Operation list of length > 1 should only contain manager operations." - @@ fun op_bytes prefix suffix -> [op_bytes; op_bytes; prefix; suffix] -end - -let tests = - [ - tztest - "of_list: single element input list" - `Quick - Test_operation_repr.test_of_list_single_case; - tztest - "of_list: multiple element input list" - `Quick - Test_operation_repr.test_of_list_multiple_case; - tztest - "of_list: empty input list" - `Quick - Test_operation_repr.test_of_list_empty_case; - tztest - "protocol_data_encoding: only signature prefix" - `Quick - Test_operation_repr.test_only_signature_prefix; - tztest - "protocol_data_encoding: empty list" - `Quick - Test_operation_repr.test_decoding_empty_list; - tztest - "protocol_data_encoding: multiple signature prefix" - `Quick - Test_operation_repr.test_multiple_signature_prefix; - tztest - "protocol_data_encoding: signature prefix not final" - `Quick - Test_operation_repr.test_signature_prefix_not_final; - tztest - "protocol_data_encoding: multiple non manager" - `Quick - Test_operation_repr.test_multiple_non_manager; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("Operation_repr.ml", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_qty.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_qty.ml deleted file mode 100644 index 03381b187f85bcee22a5f7184e8bdf454add5295..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_qty.ml +++ /dev/null @@ -1,163 +0,0 @@ -(*****************************************************************************) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (quantities) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_qty.ml - Subject: On tez quantities. -*) - -open Protocol - -let known_ok_tez_literals = - [ - (0L, "0"); - (10L, "0.00001"); - (100L, "0.0001"); - (1_000L, "0.001"); - (10_000L, "0.01"); - (100_000L, "0.1"); - (1_000_000L, "1"); - (10_000_000L, "10"); - (100_000_000L, "100"); - (1_000_000_000L, "1000"); - (10_000_000_000L, "10000"); - (100_000_000_000L, "100000"); - (1_000_000_000_000L, "1000000"); - (1_000_000_000_001L, "1000000.000001"); - (1_000_000_000_010L, "1000000.00001"); - (1_000_000_000_100L, "1000000.0001"); - (1_000_000_001_000L, "1000000.001"); - (1_000_000_010_000L, "1000000.01"); - (1_000_000_100_000L, "1000000.1"); - (123_123_123_123_123_123L, "123123123123.123123"); - (999_999_999_999_999_999L, "999999999999.999999"); - ] - -let known_bad_tez_literals = - [ - "10000."; - "100,."; - "100,"; - "1,0000"; - "0.0000,1"; - "0.00,1"; - "0,1"; - "HAHA"; - "0.000,000,1"; - "0.0000000"; - "9,999,999,999,999.999,999"; - ] - -let fail expected given msg = - Format.kasprintf - Stdlib.failwith - "@[%s@ expected: %s@ got: %s@]" - msg - expected - given - -let fail_msg fmt = Format.kasprintf (fail "" "") fmt - -let default_printer _ = "" - -(** Literals which are supposed to be parsed correctly. *) -let test_known_tez_literals () = - List.iter - (fun (v, s) -> - let vv = Tez_repr.of_mutez v in - let vs = Tez_repr.of_string s in - let vs' = - Tez_repr.of_string (String.concat "" (String.split_on_char ',' s)) - in - let vv = - match vv with None -> fail_msg "could not unopt %Ld" v | Some vv -> vv - in - let vs = - match vs with None -> fail_msg "could not unopt %s" s | Some vs -> vs - in - let vs' = - match vs' with - | None -> fail_msg "could not unopt %s" s - | Some vs' -> vs' - in - assert (vv = vs) ; - assert (vv = vs') ; - assert (Tez_repr.to_string vv = s)) - known_ok_tez_literals ; - List.iter - (fun s -> - let vs = Tez_repr.of_string s in - assert (vs = None)) - known_bad_tez_literals ; - return_unit - -(** Randomly generated tez value which is printed into a string then - parsed again for their equality. *) -let test_random_tez_literals () = - for _ = 0 to 100_000 do - let v = Random.int64 12L in - let vv = Tez_repr.of_mutez v in - let vv = - match vv with None -> fail_msg "could not unopt %Ld" v | Some vv -> vv - in - let s = Tez_repr.to_string vv in - let vs = Tez_repr.of_string s in - let s' = String.concat "" (String.split_on_char ',' s) in - let vs' = Tez_repr.of_string s' in - assert (vs <> None) ; - assert (vs' <> None) ; - (match vs with - | None -> assert false - | Some vs -> - let rev = Tez_repr.to_mutez vs in - assert (v = rev)) ; - match vs' with - | None -> assert false - | Some vs' -> - let rev = Tez_repr.to_mutez vs' in - assert (v = rev) - done ; - return_unit - -let tests = - [ - ("tez-literals", fun _ -> test_known_tez_literals ()); - ("rnd-tez-literals", fun _ -> test_random_tez_literals ()); - ] - -let wrap (n, f) = - Alcotest_lwt.test_case n `Quick (fun _ () -> - f () >|= function - | Ok () -> () - | Error error -> - Format.kasprintf Stdlib.failwith "%a" pp_print_trace error) - -let tests = List.map wrap tests - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("qty", tests)] |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_raw_level_repr.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_raw_level_repr.ml deleted file mode 100644 index 881e45628f70f3a79114fdad2e1d45f2f49abf6f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_raw_level_repr.ml +++ /dev/null @@ -1,180 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Marigold *) -(* *) -(* 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 -open Tztest - -(** Testing - ------- - Component: Raw_level_repr - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_raw_level_repr.ml - Dependencies: -- - Subject: To test the modules (including the top-level) - in raw_level_repr.ml as individual units, particularly - failure cases. Superficial goal: increase coverage percentage. -*) - -module Test_raw_level_repr = struct - (* NOTE: Avoid assertions against too many functions from Raw_level_repr. For instance, - Raw_level_repr contains a [compare] function, but while [Assert]'ing, convert them to - int32 (or any convenient OCaml value) and compare instead of using [Raw_level_repr]'s compare *) - - (** Testing [encoding], int32 underneath, by applying it with Data_encoding *) - let test_encoding () = - let encoding = Raw_level_repr.encoding in - let bytes = Bytes.make 4 '0' in - Bytes.set_int32_ne bytes 0 0l ; - (Data_encoding.Binary.of_bytes encoding bytes |> function - | Ok x -> Lwt.return (Ok x) - | Error e -> - failwith - "Data_encoding.Binary.read shouldn't have failed with \ - Raw_level_repr.encoding: %a" - Data_encoding.Binary.pp_read_error - e) - >>=? fun v -> - Assert.equal_int ~loc:__LOC__ (Int32.to_int (Raw_level_repr.to_int32 v)) 0 - >>=? fun () -> - Bytes.set_int32_ne bytes 0 (-1l) ; - Data_encoding.Binary.of_bytes encoding bytes |> function - | Error _ -> return_unit - | Ok x -> - failwith - "Data_encoding.Binary.read shouldn't have succeeded with %a" - Raw_level_repr.pp - x - - (* TODO rpc_arg. RPC_arg needs to be unit tested separately. Preferably, with a functor *) - (* let rpc_arg () = () *) - - (** int32 interop tests *) - let test_int32_interop () = - let int32v = 100l in - Lwt.return (Raw_level_repr.of_int32 int32v) >|= Environment.wrap_tzresult - >>=? fun raw_level -> - Assert.equal_int32 ~loc:__LOC__ (Raw_level_repr.to_int32 raw_level) int32v - >>=? fun () -> - let int32v = -1l in - (Lwt.return (Raw_level_repr.of_int32 int32v) >|= Environment.wrap_tzresult - >>= function - | Ok _ -> failwith "Negative int32s should not be coerced into raw_level" - | Error _ -> return_unit) - >>=? fun () -> - try - let (_ : Raw_level_repr.t) = Raw_level_repr.of_int32_exn int32v in - failwith "Negative int32s should not be coerced into raw_level" - with Invalid_argument _ -> return_unit - - (** Asserting [root]'s runtime value. Expected to be [0l] *) - let test_root () = - let root = Raw_level_repr.root in - Assert.equal_int32 ~loc:__LOC__ (root |> Raw_level_repr.to_int32) 0l - - (** Asserting [succ] which is expected to return successor levels *) - let test_succ () = - let next_raw_level = Raw_level_repr.succ Raw_level_repr.root in - Assert.equal_int32 - ~loc:__LOC__ - (next_raw_level |> Raw_level_repr.to_int32) - 1l - >>=? fun () -> - let arbitrary_next_raw_level = - Raw_level_repr.succ (Raw_level_repr.of_int32_exn 99l) - in - Assert.equal_int32 - ~loc:__LOC__ - (arbitrary_next_raw_level |> Raw_level_repr.to_int32) - 100l - - (** Asserting [pred] which is expected to return predecessor levels *) - let test_pred () = - (match Raw_level_repr.pred (Raw_level_repr.of_int32_exn 1l) with - | Some previous_raw_level -> - Assert.equal_int32 - ~loc:__LOC__ - (previous_raw_level |> Raw_level_repr.to_int32) - 0l - | None -> - failwith - "Raw_level_repr.pred should have successfully returned 0l as the \ - predecessor of 1l") - >>=? fun () -> - Raw_level_repr.pred Raw_level_repr.root |> function - | Some _ -> - failwith - "Raw_level_repr.pred should have returned None when asked for \ - predecessor of [root]" - | None -> return_unit - - let test_skip_succ () = - let int32_limit = 0x7FFFFFFFl in - let overflown_next_raw_level = - Raw_level_repr.succ (Raw_level_repr.of_int32_exn int32_limit) - in - if Int32.compare (Raw_level_repr.to_int32 overflown_next_raw_level) 0l >= 0 - then return_unit - else - failwith - "succ of 0x7FFFFFFFl %a was expected to be non-negative" - Assert.Int32.pp - (overflown_next_raw_level |> Raw_level_repr.to_int32) -end - -let tests = - [ - tztest - "Raw_level_repr.encoding: checks if encoding is int32 as expected" - `Quick - Test_raw_level_repr.test_encoding; - tztest - "Raw_level_repr.root: check if value is 0l" - `Quick - Test_raw_level_repr.test_root; - tztest - "Raw_level_repr.succ: basic assertions" - `Quick - Test_raw_level_repr.test_succ; - tztest - "Raw_level_repr.pred: basic assertions" - `Quick - Test_raw_level_repr.test_pred; - tztest - "Raw_level_repr: int32 interop" - `Quick - Test_raw_level_repr.test_int32_interop; - ] - -let skipped_tests = - [ - tztest - "Raw_level_repr.succ: overflow" - `Quick - Test_raw_level_repr.test_skip_succ; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("raw level repr", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_receipt.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_receipt.ml deleted file mode 100644 index 92ee499eac9386bf9bfbaeb8e104e85ab0fd4b0d..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_receipt.ml +++ /dev/null @@ -1,97 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020-2021 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (token) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_receipt.ml - Subject: Test receipt endocings. -*) - -open Protocol -open Alpha_context -open Data_encoding - -let random_amount () = - match Tez.of_mutez (Int64.add 1L (Random.int64 100L)) with - | None -> assert false - | Some x -> x - -(** Test that [decode (encode balance_updates) = balance_updates]. *) -let test_encodings balance = - Random.init 0 ; - let am = random_amount () in - let r1 = Receipt.(balance, Debited am, Protocol_migration) in - let r2 = Receipt.(balance, Credited am, Protocol_migration) in - let r3 = Receipt.(balance, Debited am, Subsidy) in - let r4 = Receipt.(balance, Credited am, Subsidy) in - let r5 = Receipt.(balance, Debited am, Simulation) in - let r6 = Receipt.(balance, Credited am, Simulation) in - let r7 = Receipt.(balance, Debited am, Block_application) in - let r8 = Receipt.(balance, Credited am, Block_application) in - let coded = - Json.construct - Receipt.balance_updates_encoding - [r1; r2; r3; r4; r5; r6; r7; r8] - in - let decoded = Json.destruct Receipt.balance_updates_encoding coded in - match decoded with - | [r1'; r2'; r3'; r4'; r5'; r6'; r7'; r8'] -> - assert ( - r1' = r1 && r2' = r2 && r3' = r3 && r4' = r4 && r5 = r5' && r6 = r6' - && r7 = r7' && r8 = r8') ; - return_unit - | _ -> assert false - -let test_encodings () = - let open Receipt in - let pkh = Signature.Public_key_hash.zero in - test_encodings (Contract (Contract.Implicit pkh)) >>=? fun () -> - test_encodings Block_fees >>=? fun () -> - test_encodings (Deposits pkh) >>=? fun () -> - test_encodings Nonce_revelation_rewards >>=? fun () -> - test_encodings Double_signing_evidence_rewards >>=? fun () -> - test_encodings Endorsing_rewards >>=? fun () -> - test_encodings Baking_rewards >>=? fun () -> - test_encodings Baking_bonuses >>=? fun () -> - test_encodings Storage_fees >>=? fun () -> - test_encodings Double_signing_punishments >>=? fun () -> - test_encodings (Lost_endorsing_rewards (pkh, Random.bool (), Random.bool ())) - >>=? fun () -> - test_encodings Liquidity_baking_subsidies >>=? fun () -> - test_encodings Burned >>=? fun () -> - test_encodings (Commitments Blinded_public_key_hash.zero) >>=? fun () -> - test_encodings Bootstrap >>=? fun () -> - test_encodings Invoice >>=? fun () -> - test_encodings Initial_commitments >>=? fun () -> - test_encodings Minted >>=? fun () -> - test_encodings Sc_rollup_refutation_punishments >>=? fun () -> - test_encodings Sc_rollup_refutation_rewards - -let tests = Tztest.[tztest "receipt - encoding" `Quick test_encodings] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("receipt", tests)] |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_round_repr.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_round_repr.ml deleted file mode 100644 index 8e51b909422ed1b983e603fdbb5b1cb305d2fb96..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_round_repr.ml +++ /dev/null @@ -1,638 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: protocol - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_round_repr.ml - Subject: test the Round_repr module -*) - -open Protocol -open Alpha_context - -let ( >>>=? ) v f = v >|= Environment.wrap_tzresult >>=? f - -let ( >>>?= ) v f = v |> Environment.wrap_tzresult >>?= f - -let ( >>>? ) v f = v |> Environment.wrap_tzresult >>? f - -type round_test = { - (* input: round; output: round duration *) - round_duration : (int * int) list; - (* input: level offset; output: round, round offset *) - round_and_offset : (int * (int * int)) list; - (* input: pred_ts, pred_round, round; output: ts *) - timestamp_of_round : ((int * int * int) * int) list; - (* input: pred_ts, pred_round, ts; output: round *) - round_of_timestamp : ((int * int * int) * int) list; -} - -(* an association list of the input, output values *) -let case_3_4 = - { - round_duration = [(0, 3); (1, 4); (2, 5); (3, 6)]; - round_and_offset = - [ - (0, (0, 0)); - (1, (0, 1)); - (2, (0, 2)); - (3, (1, 0)); - (4, (1, 1)); - (5, (1, 2)); - (6, (1, 3)); - (7, (2, 0)); - (8, (2, 1)); - ]; - timestamp_of_round = [((100, 0, 6), 136); ((100, 1, 6), 137)]; - round_of_timestamp = - [ - ((100, 0, 121), 4); - ((100, 0, 122), 4); - ((100, 0, 123), 4); - ((100, 0, 124), 4); - ((100, 0, 125), 4); - ((100, 0, 126), 4); - ((100, 1, 121), 3); - ((100, 1, 122), 4); - ((100, 1, 123), 4); - ((100, 1, 124), 4); - ((100, 1, 125), 4); - ((100, 1, 126), 4); - ]; - } - -let case_3_6 = - { - round_duration = - [ - (0, 3); - (1, 6); - (2, 9); - (3, 12); - (4, 15); - (5, 18); - (6, 21); - (7, 24); - (8, 27); - ]; - round_and_offset = - [ - (0, (0, 0)); - (1, (0, 1)); - (2, (0, 2)); - (3, (1, 0)); - (4, (1, 1)); - (5, (1, 2)); - (6, (1, 3)); - (7, (1, 4)); - (8, (1, 5)); - (9, (2, 0)); - (10, (2, 1)); - (11, (2, 2)); - (97, (7, 13)); - ]; - timestamp_of_round = - [ - ((100, 0, 0), 103); - ((100, 1, 0), 106); - ((100, 0, 6), 166); - ((100, 1, 6), 169); - ]; - round_of_timestamp = - [ - ((100, 0, 103), 0); - ((100, 0, 104), 0); - ((100, 0, 105), 0); - ((100, 0, 106), 1); - ((100, 0, 111), 1); - ((100, 0, 112), 2); - ((100, 0, 120), 2); - ((100, 0, 121), 3); - ((100, 0, 132), 3); - ((100, 0, 133), 4); - ((100, 1, 106), 0); - ((100, 1, 107), 0); - ((100, 1, 108), 0); - ((100, 1, 109), 1); - ((100, 1, 114), 1); - ((100, 1, 115), 2); - ]; - } - -let test_cases = - [ - (* (first_round_duration, delay_increment_per_round), test_case_expectations *) - ((3, 1), case_3_4, "case_3_4"); - ((3, 3), case_3_6, "case_3_6"); - ] - -let round_of_int i = Round_repr.of_int i |> Environment.wrap_tzresult - -let mk_round_durations first_round_duration delay_increment_per_round = - let first_round_duration = - Period_repr.of_seconds_exn @@ Int64.of_int first_round_duration - in - let delay_increment_per_round = - Period_repr.of_seconds_exn @@ Int64.of_int delay_increment_per_round - in - (* We assume test specifications do respect round_durations - invariants and cannot fail *) - Stdlib.Option.get - @@ Round_repr.Durations.create_opt - ~first_round_duration - ~delay_increment_per_round - -let process_test_case (round_durations, ios, _) = - let open Round_repr in - List.iter_es - (fun (i, o) -> - round_of_int i >>?= fun round -> - let dur = Durations.round_duration round_durations round in - Assert.equal_int64 - ~loc:__LOC__ - (Int64.of_int o) - (Period_repr.to_seconds dur)) - ios.round_duration - >>=? fun () -> - let open Internals_for_test in - (* test [round_and_offset] *) - List.iter_es - (fun (level_offset, (round, ro)) -> - let level_offset = - Period_repr.of_seconds_exn (Int64.of_int level_offset) - in - Environment.wrap_tzresult (round_and_offset round_durations ~level_offset) - >>?= fun round_and_offset -> - Assert.equal_int32 - ~loc:__LOC__ - (Int32.of_int round) - (Round_repr.to_int32 round_and_offset.round) - >>=? fun () -> - Assert.equal_int64 - ~loc:__LOC__ - (Int64.of_int ro) - (Period_repr.to_seconds round_and_offset.offset)) - ios.round_and_offset - >>=? fun () -> - (* test [timestamp_of_round] *) - List.iter_es - (fun ((pred_ts, pred_round, round), o) -> - let predecessor_timestamp = Time_repr.of_seconds (Int64.of_int pred_ts) in - Lwt.return - ( Round_repr.of_int pred_round >>? fun predecessor_round -> - Round_repr.of_int round >>? fun round -> - timestamp_of_round - round_durations - ~predecessor_timestamp - ~predecessor_round - ~round ) - >>>=? fun ts -> - Assert.equal_int64 ~loc:__LOC__ (Int64.of_int o) (Time_repr.to_seconds ts)) - ios.timestamp_of_round - >>=? fun () -> - (* test [round_of_timestamp] *) - List.iter_es - (fun ((pred_ts, pred_round, ts), o) -> - let predecessor_timestamp = Time_repr.of_seconds (Int64.of_int pred_ts) in - Lwt.return - ( Round_repr.of_int pred_round >>? fun predecessor_round -> - round_of_timestamp - round_durations - ~predecessor_timestamp - ~predecessor_round - ~timestamp:(Time_repr.of_seconds (Int64.of_int ts)) ) - >>>=? fun round -> - Assert.equal_int32 - ~loc:__LOC__ - (Int32.of_int o) - (Round_repr.to_int32 round)) - ios.round_of_timestamp - -let test_round () = - let final_test_cases = - List.map - (fun ((first_round_duration, delay_increment_per_round), ios, name) -> - ( mk_round_durations first_round_duration delay_increment_per_round, - ios, - name )) - test_cases - in - (* TODO this could be run in the error monad instead of lwt *) - List.iter_es process_test_case final_test_cases - -let ts_add ts period = - match Timestamp.(ts +? period) with - | Ok ts' -> ts' - | Error _ -> Environment.Pervasives.failwith "timestamp add" - -let test_round_of_timestamp () = - let duration0 = Period.of_seconds_exn 1L in - Environment.wrap_tzresult - @@ Round.Durations.create - ~first_round_duration:duration0 - ~delay_increment_per_round:Period.one_second - >>?= fun round_durations -> - let predecessor_timestamp = Time.Protocol.epoch in - let level_start = ts_add predecessor_timestamp duration0 in - let rec loop ~expected_round ~elapsed_time = - if elapsed_time < 1000 then - let timestamp = - ts_add level_start (Period.of_seconds_exn (Int64.of_int elapsed_time)) - in - match - Round.round_of_timestamp - round_durations - ~predecessor_timestamp - ~timestamp - ~predecessor_round:Round.zero - with - | Ok round -> - Assert.equal_int32 - ~loc:__LOC__ - (Round.to_int32 round) - (Int32.of_int expected_round) - >>=? fun () -> - let elapsed_time = elapsed_time + (expected_round + 1) - and expected_round = 1 + expected_round in - loop ~expected_round ~elapsed_time - | Error _ -> failwith "error " - else return_unit - in - loop ~elapsed_time:0 ~expected_round:0 - -let round_of_timestamp_perf (duration0_int64, dipr) = - let duration0 = Period.of_seconds_exn duration0_int64 in - let delay_increment_per_round = Period.of_seconds_exn dipr in - let round_durations = - Stdlib.Option.get - @@ Round.Durations.create_opt - ~first_round_duration:duration0 - ~delay_increment_per_round - in - let predecessor_timestamp = Time.Protocol.epoch in - let level_start = ts_add predecessor_timestamp duration0 in - let max_ts = Int64.(sub (of_int32 Int32.max_int) duration0_int64) in - let rec loop i = - if i >= 0L then ( - let repeats = 100 in - let rec loop_inner sum j = - if j > 0 then - let timestamp = - ts_add level_start (Period.of_seconds_exn (Int64.sub max_ts i)) - in - let t0 = Unix.gettimeofday () in - Round.round_of_timestamp - round_durations - ~predecessor_timestamp - ~timestamp - ~predecessor_round:Round.zero - >>? fun (_round : Round.t) -> - let t1 = Unix.gettimeofday () in - let time = t1 -. t0 in - loop_inner (sum +. time) (j - 1) - else ok sum - in - loop_inner 0.0 repeats >>? fun sum -> - let time = sum /. float_of_int repeats in - assert (time < 0.01) ; - loop (Int64.pred i)) - else ok () - in - Environment.wrap_tzresult (loop 1000L) >>?= fun () -> return_unit - -let default_round_durations_list = - [(1L, 1L); (1L, 2L); (1L, 3L); (2L, 3L); (2L, 4L)] - -let test_round_of_timestamp_perf () = - List.iter_es round_of_timestamp_perf default_round_durations_list - -let timestamp_of_round_perf (duration0_int64, dipr) = - let duration0 = Period.of_seconds_exn duration0_int64 in - let delay_increment_per_round = Period.of_seconds_exn dipr in - let round_durations = - Stdlib.Option.get - @@ Round.Durations.create_opt - ~first_round_duration:duration0 - ~delay_increment_per_round - in - let predecessor_timestamp = Time.Protocol.epoch in - let rec loop i = - if i >= 0l then ( - Round.of_int32 Int32.(sub max_int i) >>? fun round -> - let t0 = Unix.gettimeofday () in - Round.timestamp_of_round - round_durations - ~predecessor_timestamp - ~predecessor_round:Round.zero - ~round - >>? fun (_ts : Timestamp.time) -> - let t1 = Unix.gettimeofday () in - let time = t1 -. t0 in - assert (time < 0.01) ; - loop (Int32.pred i)) - else ok () - in - Environment.wrap_tzresult (loop 1000l) >>?= fun () -> return_unit - -let test_timestamp_of_round_perf () = - List.iter_es timestamp_of_round_perf default_round_durations_list - -let test_error_is_triggered_for_too_high_timestamp () = - let round_durations = - Stdlib.Option.get - @@ Round.Durations.create_opt - ~first_round_duration:Period.one_second - ~delay_increment_per_round:Period.one_second - in - - let predecessor_timestamp = Time.Protocol.epoch in - let res = - Round.round_of_timestamp - round_durations - ~predecessor_timestamp - ~predecessor_round:Round.zero - ~timestamp:(Time_repr.of_seconds Int64.max_int) - in - let res = Environment.wrap_tzresult res in - match res with - | Error _ -> - Assert.proto_error_with_info ~loc:__LOC__ res "level offset too high" - | Ok _ -> Assert.error ~loc:__LOC__ res (fun _ -> false) - -let rec ( --> ) i j = - (* [i; i+1; ...; j] *) - if Compare.Int.(i > j) then [] else i :: (succ i --> j) - -let ts_of_round_inverse (duration0_int64, dipr) round_int = - let first_round_duration = Period.of_seconds_exn duration0_int64 in - let delay_increment_per_round = Period.of_seconds_exn dipr in - let round_durations = - Stdlib.Option.get - @@ Round.Durations.create_opt - ~first_round_duration - ~delay_increment_per_round - in - let predecessor_timestamp = Time.Protocol.epoch in - let predecessor_round = Round.zero in - Round.of_int round_int >>>?= fun round -> - Round.timestamp_of_round - round_durations - ~predecessor_timestamp - ~predecessor_round - ~round - >>>?= fun timestamp -> - Round.round_of_timestamp - round_durations - ~predecessor_timestamp - ~predecessor_round - ~timestamp - >>>?= fun round' -> - Round.to_int round' >>>?= fun round' -> - Assert.equal_int ~loc:__LOC__ round_int round' - -(* We restrict to round 134,217,727 as rounds above can lead to - integer overflow in [Round_repr.round_and_offset] and are already prevented - by returning an error. *) -let test_ts_of_round_inverse () = - List.iter_es - (fun durations -> - List.iter_es - (ts_of_round_inverse durations) - ((0 --> 20) @ (60000 --> 60010))) - default_round_durations_list - >>=? fun () -> - List.iter_es - (ts_of_round_inverse (1L, 1L)) - (List.map (fun i -> Int32.to_int 134_217_727l - i) (1 --> 20)) - -let round_of_ts_inverse ~first_round_duration ~delay_increment_per_round ts = - Format.printf "ts = %Ld@." ts ; - let first_round_duration = Period.of_seconds_exn first_round_duration in - let delay_increment_per_round = - Period.of_seconds_exn delay_increment_per_round - in - Round.Durations.create ~first_round_duration ~delay_increment_per_round - >>>?= fun round_durations -> - let predecessor_timestamp = Time.Protocol.epoch in - let predecessor_round = Round.zero in - Timestamp.( +? ) predecessor_timestamp first_round_duration - >>>?= fun level_start -> - let start_of_round timestamp = - Round.round_of_timestamp - round_durations - ~predecessor_timestamp - ~predecessor_round - ~timestamp - >>>? fun round -> - Round.timestamp_of_round - round_durations - ~predecessor_timestamp - ~predecessor_round - ~round - >>>? fun t -> ok (round, t) - in - Period.of_seconds_exn ts |> Timestamp.( +? ) level_start - >>>?= fun timestamp -> - start_of_round timestamp >>?= fun (round, ts_start_of_round) -> - Assert.leq_int64 - ~loc:__LOC__ - (Timestamp.to_seconds ts_start_of_round) - (Timestamp.to_seconds timestamp) - >>=? fun () -> - let pred ts = Period.one_second |> Timestamp.( - ) ts in - let rec iter ts = - start_of_round ts >>?= fun (round', ts_start_of_round') -> - Assert.equal_int64 - ~loc:__LOC__ - (Timestamp.to_seconds ts_start_of_round) - (Timestamp.to_seconds ts_start_of_round') - >>=? fun () -> - Assert.equal_int32 - ~loc:__LOC__ - (Round.to_int32 round) - (Round.to_int32 round') - >>=? fun () -> - if Timestamp.(ts > ts_start_of_round') then iter (pred ts) else return_unit - in - if Timestamp.(timestamp > ts_start_of_round) then iter (pred timestamp) - else return_unit - -let test_round_of_ts_inverse () = - List.iter_es - (fun (first_round_duration, delay_increment_per_round) -> - List.iter_es - (fun ts -> - round_of_ts_inverse - ~first_round_duration - ~delay_increment_per_round - (Int64.of_int ts)) - ((0 --> 20) @ (60000 --> 60010))) - default_round_durations_list - >>=? fun () -> - List.iter_es - (fun ts -> - Format.printf "%Ld@." ts ; - round_of_ts_inverse - ~first_round_duration:1L - ~delay_increment_per_round:2L - ts) - (List.map - (fun i -> Int64.of_int (Int32.to_int Int32.max_int - i)) - (0 --> 20)) - -let test_level_offset_of_round () = - let rd1 = - let first_round_duration = 3 in - let delay_increment_per_round = 1 in - mk_round_durations first_round_duration delay_increment_per_round - in - List.iter_es - (fun (round_durations, tests) -> - List.iter_es - (fun (round, expected_offset) -> - Lwt.return @@ Environment.wrap_tzresult @@ Round_repr.of_int round - >>=? fun round -> - Lwt.return @@ Environment.wrap_tzresult - @@ Round_repr.level_offset_of_round round_durations ~round - >>=? fun computed_offset -> - Assert.equal_int64 - ~loc:__LOC__ - (Period_repr.to_seconds computed_offset) - (Int64.of_int expected_offset)) - tests) - [ - (rd1, [(0, 0); (1, 3); (2, 7)]); - (mk_round_durations 3 3, [(0, 0); (1, 3); (2, 9); (3, 18)]); - ] - -(* This is the previous implementation, serving as an oracle *) -let round_and_offset_oracle (round_durations : Round_repr.Durations.t) - ~level_offset = - let level_offset_in_seconds = Period_repr.to_seconds level_offset in - (* We have the invariant [round <= level_offset] so there is no need to search - beyond [level_offset]. We set [right_bound] to [level_offset + 1] to avoid - triggering the error level_offset too high when the round equals - [level_offset]. *) - let right_bound = - if Compare.Int64.(level_offset_in_seconds < Int64.of_int32 Int32.max_int) - then Int32.of_int (Int64.to_int level_offset_in_seconds + 1) - else Int32.max_int - in - let rec bin_search min_r max_r = - if Compare.Int32.(min_r >= right_bound) then invalid_arg "foo" - else - (Round_repr.of_int32 @@ Int32.(add min_r (div (sub max_r min_r) 2l))) - >>? fun round -> - let next_round = Round_repr.succ round in - Round_repr.level_offset_of_round round_durations ~round:next_round - >>? fun next_level_offset -> - if Period_repr.(level_offset >= next_level_offset) then - bin_search (Round_repr.to_int32 next_round) max_r - else - Round_repr.level_offset_of_round round_durations ~round - >>? fun current_level_offset -> - if Period_repr.(level_offset < current_level_offset) then - bin_search min_r (Round_repr.to_int32 round) - else - ok - Round_repr.Internals_for_test. - { - round; - offset = - Period_repr.of_seconds_exn - (Int64.sub - (Period_repr.to_seconds level_offset) - (Period_repr.to_seconds current_level_offset)); - } - in - Environment.wrap_tzresult @@ bin_search 0l right_bound - -(* Test whether the new version is equivalent to the old one *) -let test_round_and_offset_correction = - Tztest.tztest_qcheck2 - ~name:"round_and_offset is correct" - QCheck2.( - Gen.pair - Qcheck2_helpers.(Gen.pair uint16 uint16) - (Qcheck2_helpers.int64_range_gen 0L 100000L)) - (fun ((first_round_duration, delay_increment_per_round), level_offset) -> - QCheck2.assume (first_round_duration > 0) ; - QCheck2.assume (delay_increment_per_round > 0) ; - let first_round_duration = - Period_repr.of_seconds_exn (Int64.of_int first_round_duration) - and delay_increment_per_round = - Period_repr.of_seconds_exn (Int64.of_int delay_increment_per_round) - and level_offset = Period_repr.of_seconds_exn level_offset in - let round_duration = - Stdlib.Option.get - (Round_repr.Durations.create_opt - ~first_round_duration - ~delay_increment_per_round) - in - let expected = round_and_offset_oracle round_duration ~level_offset in - let computed = - Round_repr.Internals_for_test.round_and_offset - round_duration - ~level_offset - in - match (computed, expected) with - | Error _, Error _ -> return_unit - | Ok {round; offset}, Ok {round = round'; offset = offset'} -> - Assert.equal_int32 - ~loc:__LOC__ - (Round_repr.to_int32 round) - (Round_repr.to_int32 round') - >>=? fun () -> - Assert.equal_int64 - ~loc:__LOC__ - (Period_repr.to_seconds offset) - (Period_repr.to_seconds offset') - | Ok _, Error _ -> failwith "expected error is ok" - | Error _, Ok _ -> failwith "expected ok is error") - -let tests = - Tztest. - [ - tztest "level_offset_of_round" `Quick test_level_offset_of_round; - tztest "Round_duration" `Quick test_round; - tztest "round_of_timestamp" `Quick test_round_of_timestamp; - tztest "round_of_timestamp_perf" `Quick test_round_of_timestamp_perf; - tztest "timestamp_of_round_perf" `Quick test_timestamp_of_round_perf; - tztest - "level offset too high error is triggered" - `Quick - test_error_is_triggered_for_too_high_timestamp; - tztest "round_of_ts (ts_of_round r) = r" `Quick test_ts_of_round_inverse; - tztest - "ts_of_round (round_of_ts ts) <= ts" - `Quick - test_round_of_ts_inverse; - test_round_and_offset_correction; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("round", tests)] |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_saturation.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_saturation.ml deleted file mode 100644 index 485ae471ff2efdf41542617bbeb5a125e26c6170..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_saturation.ml +++ /dev/null @@ -1,240 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2020 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (saturated arithmetic) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_saturation.ml - Subject: The gas is represented using saturated arithmetic. - These unit tests check that saturated arithmetic operations - are correctly implemented. -*) - -open Protocol - -let valid (z : _ Saturation_repr.t) = - let x = z |> Saturation_repr.to_int in - x >= 0 && x < max_int - -exception Saturating_test_error of string - -let err x = Exn (Saturating_test_error x) - -let small_enough (z : _ Saturation_repr.t) = - Saturation_repr.(Compare.Int.((z |> to_int) land 0x7fffffff80000000 = 0)) - -let ok_int x = - match Saturation_repr.of_int_opt x with None -> assert false | Some x -> x - -let n = ok_int 123123 - -let m = ok_int 377337 - -let add () = - Saturation_repr.( - fail_unless - (add saturated (ok_int 1) = saturated) - (err "saturated + 1 <> saturated") - >>=? fun () -> - fail_unless (add zero n = n) (err "zero + n <> n") >>=? fun () -> - fail_unless (add n zero = n) (err "n + zero <> n") >>=? fun () -> - let r = add n m in - fail_unless - (valid r && r = ok_int ((n |> to_int) + (m |> to_int))) - (err "add does not behave like + on small numbers.")) - -let sub () = - Saturation_repr.( - fail_unless (sub zero n = zero) (err "zero - n <> zero") >>=? fun () -> - let n = max n m and m = min n m in - let r = sub n m in - fail_unless - (valid r && r = ok_int ((n |> to_int) - (m |> to_int))) - (err "sub does not behave like - on small numbers.")) - -let mul_safe_of_int x = - Saturation_repr.( - match mul_safe (ok_int x) with Some x -> x | None -> assert false) - -let n' = mul_safe_of_int 1000 - -let m' = mul_safe_of_int 10000 - -let mul_fast () = - Saturation_repr.( - fail_unless (mul_fast zero n' = zero) (err "mul_fast zero x <> zero") - >>=? fun () -> - fail_unless (mul_fast n' zero = zero) (err "mul_fast x zero <> zero") - >>=? fun () -> - let r = mul_fast n' m' in - fail_unless - (valid r && r = ok_int ((n' |> to_int) * (m' |> to_int))) - (err "mul_fast does not behave like * on small numbers.")) - -let scale_fast () = - Saturation_repr.( - fail_unless (scale_fast zero n = zero) (err "scale_fast zero x <> zero") - >>=? fun () -> - fail_unless (scale_fast n' zero = zero) (err "scale_fast x zero <> zero") - >>=? fun () -> - fail_unless - (scale_fast n' saturated = saturated) - (err "scale_fast x saturated <> saturated") - >>=? fun () -> - let r = scale_fast n' m in - fail_unless - (valid r && r = ok_int ((n' |> to_int) * (m |> to_int))) - (err "mul_fast does not behave like * on small numbers.")) - -let mul () = - Saturation_repr.( - fail_unless - (mul saturated saturated = saturated) - (err "saturated * saturated <> saturated") - >>=? fun () -> - fail_unless (mul zero saturated = zero) (err "zero * saturated <> zero") - >>=? fun () -> - fail_unless (mul saturated zero = zero) (err "saturated * zero <> zero") - >>=? fun () -> - let max_squared = ok_int (1 lsl 31) in - let r = mul max_squared max_squared in - fail_unless (r = saturated) (err "2 ^ 31 * 2 ^ 31 should be saturated") - >>=? fun () -> - let safe_squared = ok_int ((1 lsl 31) - 1) in - let r = mul safe_squared safe_squared in - fail_unless - (valid r && r <> saturated) - (err "(2 ^ 31 - 1) * (2 ^ 31 - 1) should not be saturated") - >>=? fun () -> - let r = mul n m in - fail_unless - (valid r && r = ok_int ((n |> to_int) * (m |> to_int))) - (err "mul does not behave like * on small numbers.")) - -let shift_left () = - Saturation_repr.( - let must_saturate flag (k, v) = - fail_unless - (Bool.equal flag (shift_left k v = saturated)) - (err - (Printf.sprintf - "shift_left %d %d %s saturated" - (k |> to_int) - v - (if flag then "<>" else "="))) - in - List.iter_es - (must_saturate true) - [(saturated, 1); (shift_right saturated 1, 2); (ok_int 1, 62)] - >>=? fun () -> - List.iter_es - (must_saturate false) - [ - (ok_int 1, 0); - (ok_int 1, 31); - (ok_int 1, 61); - (ok_int 0, 99); - (ok_int ((1 lsl 62) - 2), 0); - ]) - -let sqrt () = - Saturation_repr.( - fail_unless (sqrt saturated = saturated) (err "sqrt saturated <> saturated") - >>=? fun () -> - fail_unless (sqrt zero = zero) (err "sqrt zero <> zero") >>=? fun () -> - fail_unless (sqrt one = one) (err "sqrt one <> one") >>=? fun () -> - fail_unless (sqrt (ok_int 4) = ok_int 2) (err "sqrt 4 <> 2") >>=? fun () -> - fail_unless - (sqrt (ok_int 5) = ok_int 2) - (err "sqrt 5 <> 2 (sqrt should round down)") - >>=? fun () -> - let safe_squared = ok_int ((1 lsl 31) - 1) in - let r = mul safe_squared safe_squared in - fail_unless - (sqrt r = safe_squared) - (err "sqrt (2 ^ 31 - 1) * (2 ^ 31 - 1) <> (2 ^ 31 - 1)")) - -let of_z_opt () = - fail_unless - (Saturation_repr.(of_z_opt (Z.succ (Z.of_int max_int))) = None) - (err - "of_z_opt should saturate when given a z integer greater than max_int.") - >>=? fun () -> - fail_unless - (Saturation_repr.(of_z_opt (Z.pred Z.zero)) = None) - (err "of_z_opt should fail on a z negative integer.") - >>=? fun () -> - fail_unless - (Saturation_repr.(of_z_opt (Z.of_int min_int)) = None) - (err "of_z_opt should fail on a z negative integer.") - -let encoding encoder () = - let check_encode_decode x = - Data_encoding.Binary.( - match to_bytes encoder (ok_int x) with - | Error _ -> - fail (err (Printf.sprintf "Problem during binary encoding of %d" x)) - | Ok bytes -> ( - match of_bytes encoder bytes with - | Error _ -> - fail - (err (Printf.sprintf "Problem during binary decoding of %d" x)) - | Ok x' -> - fail_unless - (ok_int x = x') - (err - (Printf.sprintf - "decode (encode %d) = %d <> %d" - x - (x' :> int) - x)))) - in - Error_monad.Lwt_result_syntax.tzjoin - (List.map check_encode_decode [0; 7373737373; max_int - 1]) - -let tests = - [ - Tztest.tztest "Addition" `Quick add; - Tztest.tztest "Subtraction" `Quick sub; - Tztest.tztest "Multiplication" `Quick mul; - Tztest.tztest "Multiplication (fast version)" `Quick mul_fast; - Tztest.tztest "Shift left" `Quick shift_left; - Tztest.tztest "Scale fast" `Quick scale_fast; - Tztest.tztest "Square root" `Quick sqrt; - Tztest.tztest "Conversion from Z" `Quick of_z_opt; - Tztest.tztest - "Encoding through z" - `Quick - (encoding Saturation_repr.z_encoding); - Tztest.tztest - "Encoding through n" - `Quick - (encoding Saturation_repr.n_encoding); - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("saturation arithmetic", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_arith.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_arith.ml deleted file mode 100644 index c127044ed5b7074ebdf8c9829c463421757bd3f0..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_arith.ml +++ /dev/null @@ -1,552 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (saturated arithmetic) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_sc_rollup_arith.ml - Subject: Basic testing of the arithmetic rollup example -*) - -open Protocol -module Context_binary = Tezos_context_memory.Context_binary - -(* We first instantiate an arithmetic PVM capable of generating proofs. *) -module Tree : - Environment.Context.TREE - with type t = Context_binary.t - and type tree = Context_binary.tree - and type key = string list - and type value = bytes = struct - type t = Context_binary.t - - type tree = Context_binary.tree - - type key = Context_binary.key - - type value = Context_binary.value - - include Context_binary.Tree -end - -module Arith_Context = struct - module Tree = Tree - - type tree = Tree.tree - - let hash_tree tree = - Sc_rollup_repr.State_hash.context_hash_to_state_hash (Tree.hash tree) - - type proof = Context_binary.Proof.tree Context_binary.Proof.t - - let proof_encoding = - Tezos_context_merkle_proof_encoding.Merkle_proof_encoding.V2.Tree2 - .tree_proof_encoding - - let kinded_hash_to_state_hash = function - | `Value hash | `Node hash -> - Sc_rollup_repr.State_hash.context_hash_to_state_hash hash - - let proof_before proof = - kinded_hash_to_state_hash proof.Context_binary.Proof.before - - let proof_after proof = - kinded_hash_to_state_hash proof.Context_binary.Proof.after - - let produce_proof context tree step = - let open Lwt_syntax in - (* FIXME: With on-disk context, we cannot commit the empty - context. Is it also true in our case? *) - let* context = Context_binary.add_tree context [] tree in - let* (_hash : Context_hash.t) = - Context_binary.commit ~time:Time.Protocol.epoch context - in - let index = Context_binary.index context in - match Context_binary.Tree.kinded_key tree with - | Some k -> - let* p = Context_binary.produce_tree_proof index k step in - return (Some p) - | None -> return None - - let verify_proof proof step = - let open Lwt_syntax in - let* result = Context_binary.verify_tree_proof proof step in - match result with - | Ok v -> return (Some v) - | Error _ -> - (* We skip the error analysis here since proof verification is not a - job for the rollup node. *) - return None -end - -module FullArithPVM = Sc_rollup_arith.Make (Arith_Context) -open FullArithPVM - -let setup boot_sector f = - let open Lwt_syntax in - let* index = Context_binary.init "/tmp" in - let ctxt = Context_binary.empty index in - let empty = Context_binary.Tree.empty ctxt in - let* state = initial_state ~empty in - let* state = install_boot_sector state boot_sector in - f ctxt state - -let pre_boot boot_sector f = - parse_boot_sector boot_sector |> function - | None -> failwith "Invalid boot sector" - | Some boot_sector -> setup boot_sector @@ f - -let test_preboot () = - [""; "1"; "1 2 +"] - |> List.iter_es (fun boot_sector -> - pre_boot boot_sector @@ fun _ctxt _state -> return ()) - -let boot boot_sector f = - pre_boot boot_sector @@ fun ctxt state -> eval state >>= f ctxt - -let test_boot () = - let open Sc_rollup_PVM_sig in - boot "" @@ fun _ctxt state -> - is_input_state state >>= function - | Needs_reveal Reveal_metadata -> return () - | Initial | Needs_reveal _ | First_after _ -> - failwith "After booting, the machine should be waiting for the metadata." - | No_input_required -> - failwith "After booting, the machine must be waiting for input." - -let test_metadata () = - let open Sc_rollup_PVM_sig in - let open Lwt_result_syntax in - boot "" @@ fun _ctxt state -> - let metadata = - Sc_rollup_metadata_repr. - { - address = Sc_rollup_repr.Address.zero; - origination_level = Raw_level_repr.root; - } - in - let input = Reveal (Metadata metadata) in - let*! state = set_input input state in - let*! input_request = is_input_state state in - match input_request with - | Initial -> return () - | Needs_reveal _ | First_after _ | No_input_required -> - failwith - "After evaluating the metadata, the machine must be in the [Initial] \ - state." - -let test_input_message () = - let open Sc_rollup_PVM_sig in - boot "" @@ fun _ctxt state -> - let input = Sc_rollup_helpers.make_external_input_repr "MESSAGE" in - set_input input state >>= fun state -> - eval state >>= fun state -> - is_input_state state >>= function - | Initial | Needs_reveal _ | First_after _ -> - failwith - "After receiving a message, the rollup must not be waiting for input." - | No_input_required -> return () - -let go ~max_steps target_status state = - let rec aux i state = - pp state >>= fun pp -> - Format.eprintf "%a" pp () ; - if i > max_steps then - failwith "Maximum number of steps reached before target status." - else - get_status state >>= fun current_status -> - if target_status = current_status then return state - else eval state >>= aux (i + 1) - in - aux 0 state - -let test_parsing_message ~valid (source, expected_code) = - boot "" @@ fun _ctxt state -> - let input = Sc_rollup_helpers.make_external_input_repr source in - set_input input state >>= fun state -> - eval state >>= fun state -> - go ~max_steps:10000 Evaluating state >>=? fun state -> - get_parsing_result state >>= fun result -> - Assert.equal - ~loc:__LOC__ - (Option.equal Bool.equal) - "Unexpected parsing result" - (fun fmt r -> - Format.fprintf - fmt - (match r with - | None -> "No parsing running" - | Some true -> "Syntax correct" - | Some false -> "Syntax error")) - (Some valid) - result - >>=? fun () -> - if valid then - get_code state >>= fun code -> - Assert.equal - ~loc:__LOC__ - (List.equal equal_instruction) - "The parsed code is not what we expected: " - (Format.pp_print_list pp_instruction) - expected_code - code - else return () - -let syntactically_valid_messages = - List.map - (fun nums -> - ( String.concat " " (List.map string_of_int nums), - List.map (fun x -> IPush x) nums )) - [[0]; [42]; [373]; [0; 1]; [0; 123; 42; 73; 34; 13; 31]] - @ [ - ("1 2 +", [IPush 1; IPush 2; IAdd]); - ( "1 2 3 + + 3 +", - [IPush 1; IPush 2; IPush 3; IAdd; IAdd; IPush 3; IAdd] ); - ("1 2+", [IPush 1; IPush 2; IAdd]); - ("1 2 3++3+", [IPush 1; IPush 2; IPush 3; IAdd; IAdd; IPush 3; IAdd]); - ("", []); - ("1 a", [IPush 1; IStore "a"]); - ] - -let syntactically_invalid_messages = - List.map - (fun s -> (s, [])) - ["@"; " @"; " @ "; "---"; "12 +++ --"; "1a"; "a$"] - -let test_parsing_messages () = - List.iter_es (test_parsing_message ~valid:true) syntactically_valid_messages - >>=? fun () -> - List.iter_es - (test_parsing_message ~valid:false) - syntactically_invalid_messages - -let test_evaluation_message ~valid - (boot_sector, source, expected_stack, expected_vars) = - boot boot_sector @@ fun _ctxt state -> - let input = Sc_rollup_helpers.make_external_input_repr source in - set_input input state >>= fun state -> - eval state >>= fun state -> - go ~max_steps:10000 Waiting_for_input_message state >>=? fun state -> - if valid then - get_stack state >>= fun stack -> - Assert.equal - ~loc:__LOC__ - (List.equal Compare.Int.equal) - "The stack is not what we expected: " - Format.(pp_print_list (fun fmt -> fprintf fmt "%d;@;")) - expected_stack - stack - >>=? fun () -> - List.iter_es - (fun (x, v) -> - get_var state x >>= function - | None -> failwith "The variable %s cannot be found." x - | Some v' -> - Assert.equal - ~loc:__LOC__ - Compare.Int.equal - (Printf.sprintf "The variable %s has not the right value: " x) - (fun fmt x -> Format.fprintf fmt "%d" x) - v - v') - expected_vars - else - get_evaluation_result state >>= function - | Some true -> failwith "This code should lead to an evaluation error." - | None -> failwith "We should have reached the evaluation end." - | Some false -> return () - -let valid_messages = - [ - ("", "0", [0], []); - ("", "1 2", [2; 1], []); - ("", "1 2 +", [3], []); - ("", "1 2 + 3 +", [6], []); - ("", "1 2 + 3 + 1 1 + +", [8], []); - ("0 ", "", [0], []); - ("1 ", "2", [2; 1], []); - ("1 2 ", "+", [3], []); - ("1 2 + ", "3 +", [6], []); - ("1 2 + ", "3 + 1 1 + +", [8], []); - ("", "1 a", [1], [("a", 1)]); - ("", "1 a 2 + b 3 +", [6], [("a", 1); ("b", 3)]); - ("", "1 a 2 + b 3 + result", [6], [("a", 1); ("b", 3); ("result", 6)]); - ("1 a ", "2 b", [2; 1], [("a", 1); ("b", 2)]); - ("1 a ", "2 a", [2; 1], [("a", 2)]); - ("", "1 a 2 a + a", [3], [("a", 3)]); - ("", "1 a b", [1], [("a", 1); ("b", 1)]); - ("1 a", "", [1], [("a", 1)]); - ] - -let invalid_messages = - List.map - (fun s -> ("", s, [], [])) - ["+"; "1 +"; "1 1 + +"; "1 1 + 1 1 + + +"; "a"] - -let test_evaluation_messages () = - List.iter_es (test_evaluation_message ~valid:true) valid_messages - >>=? fun () -> - List.iter_es (test_evaluation_message ~valid:false) invalid_messages - -let test_output_messages_proofs ~valid ~inbox_level (source, expected_outputs) = - let open Lwt_result_syntax in - boot "" @@ fun ctxt state -> - let input = - Sc_rollup_helpers.make_external_input_repr - ~inbox_level:(Raw_level_repr.of_int32_exn (Int32.of_int inbox_level)) - source - in - let*! state = set_input input state in - let*! state = eval state in - let* state = go ~max_steps:10000 Waiting_for_input_message state in - let check_output output = - let*! result = produce_output_proof ctxt state output in - if valid then - match result with - | Ok proof -> - let*! valid = verify_output_proof proof in - fail_unless valid (Exn (Failure "An output proof is not valid.")) - | Error _ -> failwith "Error during proof generation" - else - match result with - | Ok proof -> - let*! proof_is_valid = verify_output_proof proof in - fail_when - proof_is_valid - (Exn - (Failure - (Format.asprintf - "A wrong output proof is valid: %s -> %a" - source - Sc_rollup_PVM_sig.pp_output - output))) - | Error _ -> return () - in - List.iter_es check_output expected_outputs - -let make_output ~outbox_level ~message_index n = - let open Sc_rollup_outbox_message_repr in - let unparsed_parameters = - Micheline.(Int (dummy_location, Z.of_int n) |> strip_locations) - in - let destination = Contract_hash.zero in - let entrypoint = Entrypoint_repr.default in - let transaction = {unparsed_parameters; destination; entrypoint} in - let transactions = [transaction] in - let message_index = Z.of_int message_index in - let outbox_level = Raw_level_repr.of_int32_exn (Int32.of_int outbox_level) in - let message = Atomic_transaction_batch {transactions} in - Sc_rollup_PVM_sig.{outbox_level; message_index; message} - -let test_valid_output_messages () = - let test inbox_level = - let outbox_level = inbox_level in - [ - ("1", []); - ("1 out", [make_output ~outbox_level ~message_index:0 1]); - ( "1 out 2 out", - [ - make_output ~outbox_level ~message_index:0 1; - make_output ~outbox_level ~message_index:1 2; - ] ); - ( "1 out 1 1 + out", - [ - make_output ~outbox_level ~message_index:0 1; - make_output ~outbox_level ~message_index:1 2; - ] ); - ( "1 out 1 1 + out out", - [ - make_output ~outbox_level ~message_index:0 1; - make_output ~outbox_level ~message_index:1 2; - make_output ~outbox_level ~message_index:2 2; - ] ); - ] - |> List.iter_es (test_output_messages_proofs ~valid:true ~inbox_level) - in - (* Test for different inbox/outbox levels. *) - List.iter_es test [0; 1; 2345] - -let test_invalid_output_messages () = - let inbox_level = 0 in - let outbox_level = inbox_level in - [ - ("1", [make_output ~outbox_level ~message_index:0 1]); - ("1 out", [make_output ~outbox_level ~message_index:1 1]); - ( "1 out 1 1 + out", - [ - make_output ~outbox_level ~message_index:0 0; - make_output ~outbox_level ~message_index:3 2; - ] ); - ( "1 out 1 1 + out out", - [ - make_output ~outbox_level ~message_index:0 42; - make_output ~outbox_level ~message_index:1 32; - make_output ~outbox_level ~message_index:2 13; - ] ); - ] - |> List.iter_es (test_output_messages_proofs ~valid:false ~inbox_level) - -let test_invalid_outbox_level () = - let inbox_level = 42 in - let outbox_level = inbox_level - 1 in - [ - ("1", []); - ("1 out", [make_output ~outbox_level ~message_index:0 1]); - ( "1 out 2 out", - [ - make_output ~outbox_level ~message_index:0 1; - make_output ~outbox_level ~message_index:1 2; - ] ); - ] - |> List.iter_es (test_output_messages_proofs ~valid:false ~inbox_level) - -let test_initial_state_hash_arith_pvm () = - let open Alpha_context in - let open Lwt_result_syntax in - let empty = Sc_rollup_helpers.make_empty_tree () in - let*! state = Sc_rollup_helpers.Arith_pvm.initial_state ~empty in - let*! hash = Sc_rollup_helpers.Arith_pvm.state_hash state in - let expected = Sc_rollup.ArithPVM.reference_initial_state_hash in - if Sc_rollup.State_hash.(hash = expected) then return_unit - else - failwith - "incorrect hash, expected %a, got %a" - Sc_rollup.State_hash.pp - expected - Sc_rollup.State_hash.pp - hash - -let dummy_internal_transfer address = - let open Lwt_result_syntax in - let* ctxt = - let* block, _baker, _contract, _src2 = Contract_helpers.init () in - let+ incr = Incremental.begin_construction block in - Incremental.alpha_ctxt incr - in - let sender = - Contract_hash.of_b58check_exn "KT1BuEZtb68c1Q4yjtckcNjGELqWt56Xyesc" - in - let source = - WithExceptions.Result.get_ok - ~loc:__LOC__ - (Signature.Public_key_hash.of_b58check - "tz1RjtZUVeLhADFHDL8UwDZA6vjWWhojpu5w") - in - let payload = Bytes.of_string "foo" in - let* payload, _ctxt = - Script_ir_translator.unparse_data - ctxt - Script_ir_unparser.Optimized - Bytes_t - payload - >|= Environment.wrap_tzresult - in - let transfer = - Sc_rollup_inbox_message_repr.Internal - (Transfer {payload; sender; source; destination = address}) - in - let*? serialized_transfer = - Environment.wrap_tzresult (Sc_rollup_inbox_message_repr.serialize transfer) - in - return serialized_transfer - -let test_filter_internal_message () = - let open Sc_rollup_PVM_sig in - let open Lwt_result_syntax in - boot "" @@ fun _ctxt state -> - let address = Sc_rollup_repr.Address.zero in - let metadata = - Sc_rollup_metadata_repr.{address; origination_level = Raw_level_repr.root} - in - let input = Reveal (Metadata metadata) in - let*! state = set_input input state in - - (* We will set an input where the destination is the same as the one given - in the static metadata. The pvm should process the input. *) - let* () = - let* internal_transfer = dummy_internal_transfer address in - let input = - Inbox_message - { - inbox_level = Raw_level_repr.root; - message_counter = Z.zero; - payload = internal_transfer; - } - in - let*! state = set_input input state in - let*! input_state = is_input_state state in - match input_state with - | No_input_required -> return () - | _ -> failwith "The arith pvm should be processing the internal transfer" - in - - (* We will set an input where the destination is *not* the same as the - one given in the static metadata. The pvm should ignore the input. *) - let* () = - let dummy_address = - Sc_rollup_repr.Address.of_b58check_exn - "sr1Fq8fPi2NjhWUXtcXBggbL6zFjZctGkmso" - in - let* internal_transfer = dummy_internal_transfer dummy_address in - let input = - Inbox_message - { - inbox_level = Raw_level_repr.root; - message_counter = Z.zero; - payload = internal_transfer; - } - in - let*! state = set_input input state in - let*! input_state = is_input_state state in - match input_state with - | No_input_required -> - failwith "The arith pvm should avoid ignored the internal transfer" - | _ -> return () - in - - return () - -let tests = - [ - Tztest.tztest "PreBoot" `Quick test_preboot; - Tztest.tztest "Boot" `Quick test_boot; - Tztest.tztest "Metadata" `Quick test_metadata; - Tztest.tztest "Input message" `Quick test_input_message; - Tztest.tztest "Parsing message" `Quick test_parsing_messages; - Tztest.tztest "Evaluating message" `Quick test_evaluation_messages; - Tztest.tztest "Valid output messages" `Quick test_valid_output_messages; - Tztest.tztest "Invalid output messages" `Quick test_invalid_output_messages; - Tztest.tztest "Invalid outbox level" `Quick test_invalid_outbox_level; - Tztest.tztest - "Initial state hash for Arith" - `Quick - test_initial_state_hash_arith_pvm; - Tztest.tztest "Filter internal message" `Quick test_filter_internal_message; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("sc rollup arith", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_game.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_game.ml deleted file mode 100644 index 3ea7bfca50bb19bb400142ced391327a6e7fb3bb..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_game.ml +++ /dev/null @@ -1,482 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Trili Tech, *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol Sc_rollup_refutation_storage - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_sc_rollup_game.ml - Subject: Tests for the SCORU refutation game -*) - -open Protocol -module Commitment_repr = Sc_rollup_commitment_repr -module T = Test_sc_rollup_storage -module R = Sc_rollup_refutation_storage -module D = Sc_rollup_dissection_chunk_repr -module G = Sc_rollup_game_repr -module Tick = Sc_rollup_tick_repr - -(** Assert that the computation fails with the given error. *) -let assert_fails_with ~__LOC__ k expected_err = - let open Lwt_result_syntax in - let*! res = k in - Assert.proto_error ~loc:__LOC__ res (( = ) expected_err) - -let assert_fails_with_f ~__LOC__ k f = - let open Lwt_result_syntax in - let*! res = k in - Assert.proto_error ~loc:__LOC__ res f - -let tick_of_int_exn n = - match Tick.of_int n with None -> assert false | Some t -> t - -let context_hash_of_string s = Context_hash.hash_string [s] - -let hash_string s = - Sc_rollup_repr.State_hash.context_hash_to_state_hash - @@ context_hash_of_string s - -let hash_int n = hash_string (Format.sprintf "%d" n) - -let mk_dissection_chunk (state_hash, tick) = D.{state_hash; tick} - -let init_dissection ~size ?init_tick start_hash = - let default_init_tick i = - let hash = - if i = size - 1 then None - else Some (if i = 0 then start_hash else hash_int i) - in - mk_dissection_chunk (hash, tick_of_int_exn i) - in - let init_tick = - Option.fold - ~none:default_init_tick - ~some:(fun init_tick -> init_tick size) - init_tick - in - Stdlib.List.init (size + 1) init_tick - -let init_refutation ~size ?init_tick start_hash = - let choice = Sc_rollup_tick_repr.initial in - let step = G.Dissection (init_dissection ~size ?init_tick start_hash) in - (choice, step) - -let two_stakers_in_conflict () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, refuter, defender, staker3 = - T.originate_rollup_and_deposit_with_three_stakers () - in - let hash1 = hash_string "foo" in - let hash2 = hash_string "bar" in - let hash3 = hash_string "xyz" in - let parent_commit = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = T.valid_inbox_level ctxt 1l; - number_of_ticks = T.number_of_ticks_exn 152231L; - compressed_state = hash1; - } - in - let level l = T.valid_inbox_level ctxt l in - let*@ parent, _, ctxt = - T.advance_level_n_refine_stake ctxt rollup defender parent_commit - in - let child1 = - Commitment_repr. - { - predecessor = parent; - inbox_level = level 2l; - number_of_ticks = T.number_of_ticks_exn 10000L; - compressed_state = hash2; - } - in - let child2 = - Commitment_repr. - { - predecessor = parent; - inbox_level = level 2l; - number_of_ticks = T.number_of_ticks_exn 10000L; - compressed_state = hash3; - } - in - let ctxt = T.advance_level_for_commitment ctxt child1 in - let*@ _, _, ctxt, _ = - Sc_rollup_stake_storage.publish_commitment ctxt rollup defender child1 - in - let*@ _, _, ctxt, _ = - Sc_rollup_stake_storage.publish_commitment ctxt rollup refuter child2 - in - let defender_commitment_hash = - Sc_rollup_commitment_repr.hash_uncarbonated child1 - in - let refuter_commitment_hash = - Sc_rollup_commitment_repr.hash_uncarbonated child2 - in - return - ( ctxt, - rollup, - refuter, - defender, - staker3, - refuter_commitment_hash, - defender_commitment_hash ) - -(** A dissection is 'poorly distributed' if its tick counts are not -very evenly spread through the total tick-duration. Formally, the -maximum tick-distance between two consecutive states in a dissection -may not be more than half of the total tick-duration. *) -let test_poorly_distributed_dissection () = - let open Lwt_result_wrap_syntax in - let* ( ctxt, - rollup, - refuter, - defender, - _staker3, - refuter_commitment_hash, - defender_commitment_hash ) = - two_stakers_in_conflict () - in - let start_hash = hash_string "foo" in - let init_tick size i = - mk_dissection_chunk - @@ - if i = size then (None, tick_of_int_exn 10000) - else (Some (if i = 0 then start_hash else hash_int i), tick_of_int_exn i) - in - let player = refuter and opponent = defender in - let player_commitment_hash = refuter_commitment_hash - and opponent_commitment_hash = defender_commitment_hash in - let*@ ctxt = - R.start_game - ctxt - rollup - ~player:(player, player_commitment_hash) - ~opponent:(opponent, opponent_commitment_hash) - in - let size = - Constants_storage.sc_rollup_number_of_sections_in_dissection ctxt - in - let choice, step = init_refutation ~size ~init_tick start_hash in - assert_fails_with_f - ~__LOC__ - (wrap - @@ R.game_move ctxt rollup ~player:refuter ~opponent:defender ~step ~choice - ) - (function D.Dissection_invalid_distribution _ -> true | _ -> false) - -let test_single_valid_game_move () = - let open Lwt_result_wrap_syntax in - let* ( ctxt, - rollup, - refuter, - defender, - _staker3, - refuter_commitment_hash, - defender_commitment_hash ) = - two_stakers_in_conflict () - in - let start_hash = hash_string "foo" in - let size = - Constants_storage.sc_rollup_number_of_sections_in_dissection ctxt - in - let tick_per_state = 10_000 / size in - let dissection = - Stdlib.List.init (size + 1) (fun i -> - mk_dissection_chunk - @@ - if i = 0 then (Some start_hash, tick_of_int_exn 0) - else if i = size then (None, tick_of_int_exn 10000) - else (Some (hash_int i), tick_of_int_exn (i * tick_per_state))) - in - let player = refuter and opponent = defender in - let player_commitment_hash = refuter_commitment_hash - and opponent_commitment_hash = defender_commitment_hash in - - let*@ ctxt = - R.start_game - ctxt - rollup - ~player:(player, player_commitment_hash) - ~opponent:(opponent, opponent_commitment_hash) - in - let choice, step = (Sc_rollup_tick_repr.initial, G.Dissection dissection) in - let*@ game_result, _ctxt = - R.game_move ctxt rollup ~player:refuter ~opponent:defender ~choice ~step - in - Assert.is_none ~loc:__LOC__ ~pp:Sc_rollup_game_repr.pp_game_result game_result - -module Arith_pvm = Sc_rollup_helpers.Arith_pvm - -(** Test that sending a invalid serialized inbox proof to - {Sc_rollup_proof_repr.valid} is rejected. *) -let test_invalid_serialized_inbox_proof () = - let open Lwt_result_wrap_syntax in - let open Alpha_context in - let rollup = Sc_rollup.Address.zero in - let level = Raw_level.(succ root) in - let inbox = Sc_rollup_helpers.dumb_init level in - let snapshot = Sc_rollup.Inbox.take_snapshot inbox in - let dal_snapshot = Dal.Slots_history.genesis in - let dal_parameters = Default_parameters.constants_mainnet.dal in - let ctxt = Sc_rollup_helpers.make_empty_context () in - let empty = Tezos_context_memory.Context_binary.Tree.empty ctxt in - let*! state = Arith_pvm.initial_state ~empty in - (* We evaluate the boot sector, so the [input_requested] is a - [First_after]. *) - let*! state = Arith_pvm.eval state in - let*! pvm_step = Arith_pvm.produce_proof ctxt None state in - let pvm_step = WithExceptions.Result.get_ok ~loc:__LOC__ pvm_step in - - (* We create an obviously invalid inbox *) - let inbox_proof = - Sc_rollup.Inbox.Internal_for_tests.serialized_proof_of_string - "I am the big bad wolf" - in - let inbox_proof = - Sc_rollup.Proof.Inbox_proof - {level = Raw_level.root; message_counter = Z.zero; proof = inbox_proof} - in - let proof = Sc_rollup.Proof.{pvm_step; input_proof = Some inbox_proof} in - - let metadata = - Sc_rollup.Metadata.{address = rollup; origination_level = level} - in - let*! res = - wrap - @@ Sc_rollup.Proof.valid - ~pvm:(module Arith_pvm) - ~metadata - snapshot - Raw_level.root - dal_snapshot - dal_parameters.cryptobox_parameters - ~dal_attestation_lag:dal_parameters.attestation_lag - proof - in - Assert.proto_error - ~loc:__LOC__ - res - (( = ) Sc_rollup_proof_repr.Sc_rollup_invalid_serialized_inbox_proof) - -let test_first_move_with_swapped_commitment () = - let open Lwt_result_wrap_syntax in - let* ( ctxt, - rollup, - refuter, - defender, - _staker3, - refuter_commitment_hash, - defender_commitment_hash ) = - two_stakers_in_conflict () - in - let player = refuter - and opponent = defender - and player_commitment_hash = refuter_commitment_hash - and opponent_commitment_hash = defender_commitment_hash in - let*! res = - wrap - @@ R.start_game - ctxt - rollup - ~player:(player, opponent_commitment_hash) - ~opponent:(opponent, player_commitment_hash) - in - Assert.proto_error - ~loc:__LOC__ - res - (( = ) - (Sc_rollup_errors.Sc_rollup_wrong_staker_for_conflict_commitment - (player, opponent_commitment_hash))) - -let test_first_move_from_invalid_player () = - let open Lwt_result_wrap_syntax in - let* ( ctxt, - rollup, - _refuter, - defender, - staker3, - refuter_commitment_hash, - defender_commitment_hash ) = - two_stakers_in_conflict () - in - let opponent = defender - and player_commitment_hash = refuter_commitment_hash - and opponent_commitment_hash = defender_commitment_hash in - let*! res = - wrap - @@ R.start_game - ctxt - rollup - ~player:(staker3, player_commitment_hash) - ~opponent:(opponent, opponent_commitment_hash) - in - Assert.proto_error - ~loc:__LOC__ - res - (( = ) - (Sc_rollup_errors.Sc_rollup_wrong_staker_for_conflict_commitment - (staker3, player_commitment_hash))) - -let test_first_move_with_invalid_opponent () = - let open Lwt_result_wrap_syntax in - let* ( ctxt, - rollup, - refuter, - _defender, - staker3, - refuter_commitment_hash, - defender_commitment_hash ) = - two_stakers_in_conflict () - in - let player = refuter - and player_commitment_hash = refuter_commitment_hash - and opponent_commitment_hash = defender_commitment_hash in - let*! res = - wrap - @@ R.start_game - ctxt - rollup - ~player:(player, player_commitment_hash) - ~opponent:(staker3, opponent_commitment_hash) - in - Assert.proto_error - ~loc:__LOC__ - res - (( = ) - (Sc_rollup_errors.Sc_rollup_wrong_staker_for_conflict_commitment - (staker3, opponent_commitment_hash))) - -let test_first_move_with_invalid_ancestor () = - let open Lwt_result_wrap_syntax in - let* ( ctxt, - rollup, - refuter, - defender, - _staker3, - refuter_commitment_hash, - defender_commitment_hash ) = - two_stakers_in_conflict () - in - let*@ inbox_level = T.proper_valid_inbox_level (ctxt, rollup) 3 in - let refuter_commitment = - let context_hash11 = hash_string "child11" in - Commitment_repr. - { - predecessor = refuter_commitment_hash; - inbox_level; - number_of_ticks = T.number_of_ticks_exn 10000L; - compressed_state = context_hash11; - } - in - let defender_commitment = - let context_hash21 = hash_string "child21" in - Commitment_repr. - { - predecessor = defender_commitment_hash; - inbox_level; - number_of_ticks = T.number_of_ticks_exn 10000L; - compressed_state = context_hash21; - } - in - let ctxt = T.advance_level_for_commitment ctxt refuter_commitment in - let* _, _, ctxt, _ = - wrap - @@ Sc_rollup_stake_storage.publish_commitment - ctxt - rollup - refuter - refuter_commitment - in - let* _, _, ctxt, _ = - wrap - @@ Sc_rollup_stake_storage.publish_commitment - ctxt - rollup - defender - defender_commitment - in - let refuter_commitment_hash = - Sc_rollup_commitment_repr.hash_uncarbonated refuter_commitment - in - let defender_commitment_hash = - Sc_rollup_commitment_repr.hash_uncarbonated defender_commitment - in - let player = refuter - and opponent = defender - and player_commitment_hash = refuter_commitment_hash - and opponent_commitment_hash = defender_commitment_hash in - let*! res = - wrap - @@ R.start_game - ctxt - rollup - ~player:(player, player_commitment_hash) - ~opponent:(opponent, opponent_commitment_hash) - in - Assert.proto_error - ~loc:__LOC__ - res - (( = ) - (Sc_rollup_errors.Sc_rollup_not_valid_commitments_conflict - (player_commitment_hash, player, opponent_commitment_hash, opponent))) - -let tests = - [ - Tztest.tztest - "A badly distributed dissection is an invalid move." - `Quick - test_poorly_distributed_dissection; - Tztest.tztest - "A single game move with a valid dissection" - `Quick - test_single_valid_game_move; - Tztest.tztest - "Invalid serialized inbox proof is rejected." - `Quick - test_invalid_serialized_inbox_proof; - Tztest.tztest - "start a game with invalid commitment hash (swap commitment)." - `Quick - test_first_move_with_swapped_commitment; - Tztest.tztest - "start a game with invalid commitment hash (op from outsider)." - `Quick - test_first_move_from_invalid_player; - Tztest.tztest - "start a game with invalid commitment hash (opponent is not in game)." - `Quick - test_first_move_with_invalid_opponent; - Tztest.tztest - "start a game with commitment hash that are not the first conflict." - `Quick - test_first_move_with_invalid_ancestor; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("sc rollup game", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_inbox.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_inbox.ml deleted file mode 100644 index 67f76b89e6337bce855abc956398745527a9729a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_inbox.ml +++ /dev/null @@ -1,947 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (smart contract rollup inbox) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_sc_rollup_inbox.ml - Subject: These unit tests check the off-line inbox implementation for - smart contract rollups -*) - -open Protocol - -let opt_get ~__LOC__ = WithExceptions.Option.get ~loc:__LOC__ - -open Sc_rollup_helpers - -module Merkelized_payload_hashes = - Alpha_context.Sc_rollup.Inbox_merkelized_payload_hashes - -module Message = Alpha_context.Sc_rollup.Inbox_message -module Inbox = Alpha_context.Sc_rollup.Inbox -open Alpha_context - -let assert_equal_payload ~__LOC__ found (expected : Message.serialized) = - Assert.equal_string - ~loc:__LOC__ - (Message.unsafe_to_string expected) - (Message.unsafe_to_string found) - -let assert_equal_payload_option ~__LOC__ found expected = - Assert.equal - ~loc:__LOC__ - (Option.equal (fun v1 v2 -> - String.equal - (Message.unsafe_to_string v1) - (Message.unsafe_to_string v2))) - "Input returned by the production is not the expected one" - (Format.pp_print_option - ~none:(fun fmt () -> Format.pp_print_string fmt "None") - (fun fmt v -> - Format.fprintf fmt "Some \"%S\"" (Message.unsafe_to_string v))) - found - expected - -let assert_inbox_message ~__LOC__ found expected = - Assert.equal - ~loc:__LOC__ - (Option.equal Sc_rollup.inbox_message_equal) - "Input returns by the production is not the expected one" - (Format.pp_print_option Sc_rollup.pp_inbox_message) - found - expected - -let assert_equal_payload_hash ~__LOC__ found expected = - Assert.equal - ~loc:__LOC__ - Message.Hash.equal - "Protocol hashes aren't equal" - Message.Hash.pp - expected - found - -let assert_merkelized_payload ~__LOC__ ~payload_hash ~index found = - let open Lwt_result_syntax in - let found_payload_hash = Merkelized_payload_hashes.get_payload_hash found in - let found_index = Merkelized_payload_hashes.get_index found in - let* () = - assert_equal_payload_hash ~__LOC__ found_payload_hash payload_hash - in - Assert.equal_z ~loc:__LOC__ found_index index - -let assert_equal_merkelized_payload ~__LOC__ ~found ~expected = - let payload_hash = Merkelized_payload_hashes.get_payload_hash expected in - let index = Merkelized_payload_hashes.get_index expected in - assert_merkelized_payload ~__LOC__ ~payload_hash ~index found - -let assert_merkelized_payload_proof_error ~__LOC__ expected_msg result = - Assert.error ~loc:__LOC__ (Environment.wrap_tzresult result) (function - | Environment.Ecoproto_error - (Sc_rollup_inbox_merkelized_payload_hashes_repr - .Merkelized_payload_hashes_proof_error msg) -> - expected_msg = msg - | _ -> false) - -let verify_merkelized_payload_proof_fails ~__LOC__ expected_msg proof = - assert_merkelized_payload_proof_error ~__LOC__ expected_msg - @@ Merkelized_payload_hashes.verify_proof proof - -let assert_equal_history_proof ~__LOC__ found expected = - Assert.equal - ~loc:__LOC__ - Inbox.equal_history_proof - "history_proof are not equal" - Inbox.pp_history_proof - expected - found - -let assert_inbox_proof_error ~__LOC__ expected_msg result = - Assert.error ~loc:__LOC__ (Environment.wrap_tzresult result) (function - | Environment.Ecoproto_error (Sc_rollup_inbox_repr.Inbox_proof_error msg) - -> - expected_msg = msg - | _ -> false) - -let verify_payloads_proof_fails ~__LOC__ expected_msg proof head_cell_hash - message_counter = - assert_inbox_proof_error ~__LOC__ expected_msg - @@ Inbox.Internal_for_tests.verify_payloads_proof - proof - head_cell_hash - message_counter - -let verify_inclusion_proof_fails ~__LOC__ expected_msg proof snapshot = - assert_inbox_proof_error ~__LOC__ expected_msg - @@ Inbox.Internal_for_tests.verify_inclusion_proof proof snapshot - -let gen_payload_size = QCheck2.Gen.(1 -- 10) - -let gen_payload_string = - let open QCheck2.Gen in - string_size gen_payload_size - -let gen_payload = - let open QCheck2.Gen in - let+ payload = gen_payload_string in - Message.unsafe_of_string payload - -let gen_payloads ?(min_size = 2) ?(max_size = 50) () = - let open QCheck2.Gen in - list_size (min_size -- max_size) gen_payload - -let gen_index_of_payloads ?(max_index_offset = 0) payloads = - let open QCheck2.Gen in - let max_index = List.length payloads - 1 - max_index_offset in - let+ index = 0 -- max_index in - Z.of_int index - -let gen_payloads_and_index ?min_size ?max_size ?max_index_offset () = - let open QCheck2.Gen in - let* payloads = gen_payloads ?min_size ?max_size () in - let* index = gen_index_of_payloads ?max_index_offset payloads in - return (payloads, index) - -let gen_payloads_for_level ?(inbox_level = Raw_level.(succ root)) () = - gen_messages inbox_level gen_payload_string - -let gen_level ?(inbox_creation_level = 0) ~max_level () = - let open QCheck2.Gen in - let+ int_level = inbox_creation_level -- max_level in - Raw_level.of_int32_exn (Int32.of_int int_level) - -let gen_payloads_and_level ?inbox_creation_level ?(max_level = 100_000) () = - let open QCheck2.Gen in - let* inbox_level = gen_level ?inbox_creation_level ~max_level () in - gen_payloads_for_level ~inbox_level () - -let gen_payloads_and_level_and_index ?inbox_creation_level ?max_level () = - let open QCheck2.Gen in - let* payloads_for_level = - gen_payloads_and_level ?inbox_creation_level ?max_level () - in - let* index = gen_index_of_payloads payloads_for_level.messages in - return (payloads_for_level, index) - -let gen_payloads_for_levels ?(inbox_creation_level = 0) ?(max_level = 15) () = - gen_payloads_for_levels - ~start_level:(inbox_creation_level + 1) - ~max_level - gen_payload_string - -let gen_payloads_for_levels_and_level ?inbox_creation_level ?max_level - ?(level_offset = 1) () = - let open QCheck2.Gen in - let* payloads_for_levels = - gen_payloads_for_levels ?inbox_creation_level ?max_level () - in - let* payloads_index = - 0 -- (List.length payloads_for_levels - 1 - level_offset) - in - let payloads = - opt_get ~__LOC__ @@ List.nth payloads_for_levels payloads_index - in - return (payloads_for_levels, payloads.level) - -let gen_level_and_index payloads_for_levels = - let open QCheck2.Gen in - let* payloads_index = 0 -- (List.length payloads_for_levels - 1) in - let payloads = - opt_get ~__LOC__ @@ List.nth payloads_for_levels payloads_index - in - let* index = gen_index_of_payloads payloads.Sc_rollup_helpers.inputs in - return (payloads.level, index) - -let gen_payloads_for_levels_and_level_and_index ?inbox_creation_level ?max_level - () = - let open QCheck2.Gen in - let* payloads_for_levels = - gen_payloads_for_levels ?inbox_creation_level ?max_level () - in - let* level, index = gen_level_and_index payloads_for_levels in - return (payloads_for_levels, level, index) - -let gen_payloads_for_levels_and_two_levels_and_two_indexes ?inbox_creation_level - ?max_level () = - let open QCheck2.Gen in - let* payloads_for_levels = - gen_payloads_for_levels ?inbox_creation_level ?max_level () - in - let* level, index = gen_level_and_index payloads_for_levels in - let* level', index' = gen_level_and_index payloads_for_levels in - return (payloads_for_levels, level, index, level', index') - -let fill_merkelized_payload history payloads = - let open Lwt_result_syntax in - let* first, payloads = - match payloads with - | x :: xs -> return (x, xs) - | [] -> failwith "empty payloads" - in - let*? history, merkelized_payload = - Environment.wrap_tzresult @@ Merkelized_payload_hashes.genesis history first - in - - Lwt.return @@ Environment.wrap_tzresult - @@ List.fold_left_e - (fun (history, payloads) payload -> - Merkelized_payload_hashes.add_payload history payloads payload) - (history, merkelized_payload) - payloads - -let construct_merkelized_payload_hashes payloads = - let history = Merkelized_payload_hashes.History.empty ~capacity:1000L in - fill_merkelized_payload history payloads - -(** The merkelized payload hashes history is correctly filled with all - values. *) -let test_merkelized_payload_hashes_history payloads = - let open Lwt_result_syntax in - let nb_payloads = List.length payloads in - let* history, merkelized_payloads = - construct_merkelized_payload_hashes payloads - in - let* () = - Assert.equal_z - ~loc:__LOC__ - (Z.of_int nb_payloads) - (Z.succ (Merkelized_payload_hashes.get_index merkelized_payloads)) - in - List.iteri_es - (fun index (expected_payload : Message.serialized) -> - let expected_payload_hash = - Message.hash_serialized_message expected_payload - in - let found_merkelized_payload = - opt_get ~__LOC__ - @@ Merkelized_payload_hashes.Internal_for_tests.find_predecessor_payload - history - ~index:(Z.of_int index) - merkelized_payloads - in - let found_payload_hash = - Merkelized_payload_hashes.get_payload_hash found_merkelized_payload - in - assert_equal_payload_hash - ~__LOC__ - found_payload_hash - expected_payload_hash) - payloads - -(** Produce a merkelized payload hashes proof and verify it's valid. *) -let test_merkelized_payload_hashes_proof (payloads, index) = - let open Lwt_result_syntax in - let* history, merkelized_payload = - construct_merkelized_payload_hashes payloads - in - let ( Merkelized_payload_hashes. - {merkelized = target_merkelized_payload; payload = proof_payload}, - proof ) = - opt_get ~__LOC__ - @@ Merkelized_payload_hashes.produce_proof history ~index merkelized_payload - in - let payload : Message.serialized = - opt_get ~__LOC__ @@ List.nth payloads (Z.to_int index) - in - let payload_hash = Message.hash_serialized_message payload in - let* () = assert_equal_payload ~__LOC__ proof_payload payload in - let* () = - assert_merkelized_payload - ~__LOC__ - ~index - ~payload_hash - target_merkelized_payload - in - let*? proof_ancestor_merkelized, proof_current_merkelized = - Environment.wrap_tzresult @@ Merkelized_payload_hashes.verify_proof proof - in - let* () = - assert_equal_merkelized_payload - ~__LOC__ - ~found:proof_ancestor_merkelized - ~expected:target_merkelized_payload - in - let* () = - assert_equal_merkelized_payload - ~__LOC__ - ~found:proof_current_merkelized - ~expected:merkelized_payload - in - return_unit - -(** Verifying an empty merkelized payload hashes proof fails *) -let test_empty_merkelized_payload_hashes_proof_fails () = - verify_merkelized_payload_proof_fails ~__LOC__ "proof is empty" - @@ Merkelized_payload_hashes.Internal_for_tests.make_proof [] - -(* Test multiple cases of invalid proof. This test is more about testing the - skip list than testing merkelized payload. But it was easier to test with a - skip-list with hashes as pointer. *) -let test_invalid_merkelized_payload_hashes_proof_fails (payloads, index) = - let open Lwt_result_wrap_syntax in - let make_proof = Merkelized_payload_hashes.Internal_for_tests.make_proof in - let hd ~__LOC__ l = List.hd l |> opt_get ~__LOC__ in - let tl ~__LOC__ l = List.tl l |> opt_get ~__LOC__ in - let nth ~__LOC__ idx l = List.nth idx l |> opt_get ~__LOC__ in - let* history, merkelized_payload_hash = - construct_merkelized_payload_hashes payloads - in - let Merkelized_payload_hashes.{merkelized = _target; _}, proof = - opt_get ~__LOC__ - @@ Merkelized_payload_hashes.produce_proof - history - ~index - merkelized_payload_hash - in - let proof :> Merkelized_payload_hashes.t list = proof in - (* We need a proof of more than 3 elements otherwise some tests does not make - sense after. *) - QCheck2.assume Compare.List_length_with.(proof > 3) ; - let proof_len = List.length proof in - let payload = Message.unsafe_of_string "I'm a disruptive payload" in - let payloads' = payload :: payloads in - let* history', merkelized_payload' = - construct_merkelized_payload_hashes payloads' - in - let Merkelized_payload_hashes.{merkelized = target'; payload = _}, proof' = - opt_get ~__LOC__ - @@ Merkelized_payload_hashes.produce_proof - history' - ~index - merkelized_payload' - in - let proof' :> Merkelized_payload_hashes.t list = proof' in - let proof_with_invalid_target = - (* change the target cell. *) - let rest = List.rev proof |> tl ~__LOC__ in - make_proof @@ List.rev (target' :: rest) - in - let proof_with_invalid_cell = - (* change the latest cell. *) - let cell = proof' |> hd ~__LOC__ in - let rest = proof |> tl ~__LOC__ in - make_proof @@ (cell :: rest) - in - let proof_with_only_cell_and_target = - let cell = proof |> hd ~__LOC__ in - let target = List.rev proof |> hd ~__LOC__ in - make_proof @@ [cell; target] - in - let proof_with_invalid_cell_in_path = - let idx = proof_len / 2 in - let rev_prefix, suffix = List.rev_split_n idx proof in - let new_cell = nth ~__LOC__ proof' idx in - let prefix = new_cell :: tl ~__LOC__ rev_prefix |> List.rev in - make_proof @@ prefix @ suffix - in - let proof_with_missing_cell = - let idx = proof_len / 2 in - let rev_prefix, suffix = List.rev_split_n idx proof in - let prefix = tl ~__LOC__ rev_prefix |> List.rev in - make_proof @@ prefix @ suffix - in - let proof_with_extra_step = - let idx = proof_len / 2 in - let rev_prefix, suffix = List.rev_split_n idx proof in - let new_cell = nth ~__LOC__ proof' idx in - let prefix = - match rev_prefix with - | cell :: rest -> List.rev (new_cell :: cell :: rest) - | _ -> assert false - in - make_proof @@ prefix @ suffix - in - let assert_fails ~__LOC__ proof = - verify_merkelized_payload_proof_fails ~__LOC__ "invalid proof" proof - in - let* () = assert_fails ~__LOC__ proof_with_missing_cell in - let* () = assert_fails ~__LOC__ proof_with_invalid_cell_in_path in - let* () = assert_fails ~__LOC__ proof_with_invalid_target in - let* () = assert_fails ~__LOC__ proof_with_invalid_cell in - let* () = assert_fails ~__LOC__ proof_with_only_cell_and_target in - let* () = assert_fails ~__LOC__ proof_with_extra_step in - return_unit - -(** A node produces an inbox inclusion proof and the protocol verify it. *) -let test_inclusion_proof_production (payloads_for_levels, level) = - let open Lwt_result_wrap_syntax in - let*? node_inbox, proto_inbox = - construct_node_and_protocol_inbox - ~inbox_creation_level:Raw_level.root - payloads_for_levels - in - let node_inbox_snapshot = Inbox.old_levels_messages node_inbox.inbox in - let* proof, node_old_level_messages = - Node_inbox.produce_inclusion_proof node_inbox node_inbox_snapshot level - in - let proto_inbox_snapshot = Inbox.take_snapshot proto_inbox in - let*? verified_old_levels_messages = - Environment.wrap_tzresult - @@ Inbox.Internal_for_tests.verify_inclusion_proof - proof - proto_inbox_snapshot - in - assert_equal_history_proof - ~__LOC__ - verified_old_levels_messages - node_old_level_messages - -(** A node produces an inclusion proof and the protocol fails to verify it - against the snapshot of the next (empty) level. *) -let test_inclusion_proof_verification (payloads_for_levels, level) = - let open Lwt_result_wrap_syntax in - let inbox_creation_level = Raw_level.root in - let*? node_inbox, proto_inbox = - construct_node_and_protocol_inbox ~inbox_creation_level payloads_for_levels - in - let node_inbox_snapshot = Inbox.old_levels_messages node_inbox.inbox in - let* proof, _node_old_level_messages = - Node_inbox.produce_inclusion_proof node_inbox node_inbox_snapshot level - in - let*? proto_inbox = - Protocol_inbox.add_new_level ~inbox_creation_level proto_inbox [] - in - (* This snapshot is not the same one as node_inbox_snapshot because we - added an empty level. *) - let proto_inbox_snapshot = Inbox.take_snapshot proto_inbox in - verify_inclusion_proof_fails - ~__LOC__ - "invalid inclusion proof" - proof - proto_inbox_snapshot - -(** The protocol fails to verify an empty inclusion proof. *) -let test_empty_inclusion_proof_fails payloads = - let open Lwt_result_syntax in - let*? proto_inbox = - Protocol_inbox.construct_inbox - ~inbox_creation_level:Raw_level.root - [payloads] - in - let proto_inbox_snapshot = Inbox.take_snapshot proto_inbox in - verify_inclusion_proof_fails - ~__LOC__ - "inclusion proof is empty" - [] - proto_inbox_snapshot - -(** A node produces an inbox payloads proof and the protocol verify it. *) -let test_payloads_proof_production - ((payloads : payloads_per_level), message_counter) = - let open Lwt_result_syntax in - let payloads_for_levels = [payloads] in - let exp_message = - first_after payloads_for_levels payloads.level message_counter |> function - | Some {payload; _} -> Some payload - | None -> None - in - let*? node_inbox, proto_inbox = - construct_node_and_protocol_inbox - ~inbox_creation_level:Raw_level.root - payloads_for_levels - in - let node_head_cell_hash = latest_level_proof_hash node_inbox.inbox in - (* Produce a payloads proof using the {!Node_inbox}. *) - let* ({payload = proof_input; _} as proof) = - Node_inbox.produce_payloads_proof - node_inbox - node_head_cell_hash - message_counter - in - (* Verify the produced proof using the {!Protocol_inbox}. *) - let proto_head_cell_hash = latest_level_proof_hash proto_inbox in - let*? verified_input = - Environment.wrap_tzresult - @@ Inbox.Internal_for_tests.verify_payloads_proof - proof - proto_head_cell_hash - message_counter - in - let* () = assert_equal_payload_option ~__LOC__ proof_input verified_input in - assert_equal_payload_option ~__LOC__ exp_message verified_input - -(** A node produces a payloads proof and the protocol fails to verify it - against the snapshot of the next (empty) level. *) -let test_payloads_proof_invalid_inbox_snapshot (payloads, message_counter) = - let open Lwt_result_syntax in - let inbox_creation_level = Raw_level.root in - let*? node_inbox, proto_inbox = - construct_node_and_protocol_inbox ~inbox_creation_level [payloads] - in - let* proof = - let node_head_cell_hash = latest_level_proof_hash node_inbox.inbox in - Node_inbox.produce_payloads_proof - node_inbox - node_head_cell_hash - message_counter - in - let*? proto_inbox = - Protocol_inbox.add_new_level ~inbox_creation_level proto_inbox [] - in - (* As we added one level in the [proto_inbox], it is one level further than - the [node_inbox]. The proof will not match the history. *) - let head_cell_hash = latest_level_proof_hash proto_inbox in - verify_payloads_proof_fails - ~__LOC__ - "message_proof does not match history" - proof - head_cell_hash - message_counter - -(** Fail to verify a payloads proof with an input when none is expected. *) -let test_payloads_proof_no_payload_expected (payloads : payloads_per_level) = - let open Lwt_result_syntax in - let message_counter = Z.of_int (List.length payloads.inputs) in - let*? node_inbox, proto_inbox = - construct_node_and_protocol_inbox - ~inbox_creation_level:Raw_level.root - [payloads] - in - let* proof = - let node_head_cell_hash = latest_level_proof_hash node_inbox.inbox in - Node_inbox.produce_payloads_proof - node_inbox - node_head_cell_hash - message_counter - in - let invalid_proof = - let payload = Some (make_internal_inbox_message Start_of_level) in - Inbox.Internal_for_tests.{proof with payload} - in - let head_cell_hash = latest_level_proof_hash proto_inbox in - verify_payloads_proof_fails - ~__LOC__ - "Payload provided but none expected" - invalid_proof - head_cell_hash - message_counter - -(** Fail to verify a payloads proof with no input when one is expected. *) -let test_payloads_proof_payload_expected payloads = - let open Lwt_result_syntax in - let message_counter = Z.zero in - let*? node_inbox, proto_inbox = - construct_node_and_protocol_inbox - ~inbox_creation_level:Raw_level.root - [payloads] - in - let* proof = - let node_head_cell_hash = latest_level_proof_hash node_inbox.inbox in - Sc_rollup_helpers.Node_inbox.produce_payloads_proof - node_inbox - node_head_cell_hash - message_counter - in - let invalid_proof = Inbox.Internal_for_tests.{proof with payload = None} in - let head_cell_hash = latest_level_proof_hash proto_inbox in - verify_payloads_proof_fails - ~__LOC__ - "Expected a payload but none provided in the proof" - invalid_proof - head_cell_hash - message_counter - -(** Fail to verify a payloads proof about another index. *) -let test_payloads_proof_incorrect_proof payloads = - let open Lwt_result_syntax in - let*? node_inbox, proto_inbox = - construct_node_and_protocol_inbox - ~inbox_creation_level:Raw_level.root - [payloads] - in - let* proof = - let node_head_cell_hash = latest_level_proof_hash node_inbox.inbox in - Node_inbox.produce_payloads_proof node_inbox node_head_cell_hash Z.zero - in - let proof = Inbox.Internal_for_tests.{proof with payload = None} in - let head_cell_hash = latest_level_proof_hash proto_inbox in - let invalid_message_counter = Z.of_int (List.length payloads.inputs) in - verify_payloads_proof_fails - ~__LOC__ - "Provided proof is about a unexpected payload" - proof - head_cell_hash - invalid_message_counter - -(** Fail to verify a payloads proof about another payload. *) -let test_payloads_proof_incorrect_payload payloads = - let open Lwt_result_syntax in - let message_counter = Z.zero in - let*? node_inbox, proto_inbox = - construct_node_and_protocol_inbox - ~inbox_creation_level:Raw_level.root - [payloads] - in - let* proof = - let node_head_cell_hash = latest_level_proof_hash node_inbox.inbox in - Node_inbox.produce_payloads_proof - node_inbox - node_head_cell_hash - message_counter - in - let invalid_proof = - let payload = Some (make_internal_inbox_message End_of_level) in - Inbox.Internal_for_tests.{proof with payload} - in - let head_cell_hash = latest_level_proof_hash proto_inbox in - verify_payloads_proof_fails - ~__LOC__ - "the payload provided does not match the payload's hash found in the \ - message proof" - invalid_proof - head_cell_hash - message_counter - -(** Fail to verify a valid payloads proof for an invalid message counter. *) -let test_payloads_proof_incorrect_index payloads = - let open Lwt_result_syntax in - let message_counter = Z.zero in - let*? node_inbox, proto_inbox = - construct_node_and_protocol_inbox - ~inbox_creation_level:Raw_level.root - [payloads] - in - let* proof = - let node_head_cell_hash = latest_level_proof_hash node_inbox.inbox in - Node_inbox.produce_payloads_proof - node_inbox - node_head_cell_hash - message_counter - in - let head_cell_hash = latest_level_proof_hash proto_inbox in - let invalid_message_counter = Z.succ message_counter in - verify_payloads_proof_fails - ~__LOC__ - "found index in message_proof is incorrect" - proof - head_cell_hash - invalid_message_counter - -(** Fail to verify a payloads proof with an out of bound index. *) -let test_payloads_proof_out_of_bound_index payloads = - let open Lwt_result_syntax in - let message_counter = Z.zero in - let*? node_inbox, proto_inbox = - construct_node_and_protocol_inbox - ~inbox_creation_level:Raw_level.root - [payloads] - in - let* proof = - let node_head_cell_hash = latest_level_proof_hash node_inbox.inbox in - Node_inbox.produce_payloads_proof - node_inbox - node_head_cell_hash - message_counter - in - let head_cell_hash = latest_level_proof_hash proto_inbox in - let invalid_message_counter = - Z.of_int @@ succ (List.length payloads.inputs) - in - verify_payloads_proof_fails - ~__LOC__ - "Provided message counter is out of the valid range [0 -- (max_index + 1)]" - proof - head_cell_hash - invalid_message_counter - -(** Produce an inbox proof and verify it. *) -let test_inbox_proof_production (payloads_for_levels, level, message_counter) = - let open Lwt_result_wrap_syntax in - let exp_message = first_after payloads_for_levels level message_counter in - let*? node_inbox, proto_inbox = - construct_node_and_protocol_inbox - ~inbox_creation_level:Raw_level.root - payloads_for_levels - in - let node_inbox_snapshot = Inbox.take_snapshot node_inbox.inbox in - let* proof, input_of_produced_proof = - Node_inbox.produce_proof - node_inbox - node_inbox_snapshot - (level, message_counter) - in - let proto_inbox_snapshot = Inbox.take_snapshot proto_inbox in - let* () = - assert_equal_history_proof ~__LOC__ node_inbox_snapshot proto_inbox_snapshot - in - let*? input_in_proof = - Environment.wrap_tzresult - @@ Inbox.verify_proof (level, message_counter) proto_inbox_snapshot proof - in - let* () = - assert_inbox_message ~__LOC__ input_of_produced_proof input_in_proof - in - assert_inbox_message ~__LOC__ exp_message input_in_proof - -(** This test first produces two valid inbox proofs [proof1] and - [proof2] for two different levels [l1; l2], and message counters - [i1; i2]. Then combine the two proofs to create two invalid ones - [{proof1.inclusion_proof; proof2.payloads_prof}] and - [{proof2.inclusion_proof; proof1.payloads_prof}]. Both fail with - all combinations of levels [l1, l2] and messages counter [i1, - i2]. *) -let test_invalid_inbox_proof_fails - (payloads_for_levels, level, message_counter, level', message_counter') = - QCheck2.assume - ((not (Raw_level.equal level level')) - && not (Z.equal message_counter message_counter')) ; - let open Lwt_result_wrap_syntax in - let*? node_inbox, proto_inbox = - construct_node_and_protocol_inbox - ~inbox_creation_level:Raw_level.root - payloads_for_levels - in - let node_inbox_snapshot = Inbox.take_snapshot node_inbox.inbox in - let proto_inbox_snapshot = Inbox.take_snapshot proto_inbox in - assert (node_inbox_snapshot = proto_inbox_snapshot) ; - let* invalid_proof = - let* (inclusion_proof, _message_proof), _input = - Node_inbox.produce_and_expose_proof - node_inbox - node_inbox_snapshot - (level, message_counter) - in - let* (_inclusion_proof', message_proof'), _input = - Node_inbox.produce_and_expose_proof - node_inbox - node_inbox_snapshot - (level', message_counter') - in - return @@ Inbox.Internal_for_tests.make_proof inclusion_proof message_proof' - in - let assert_fails ~__LOC__ (level, message_counter) = - assert_inbox_proof_error ~__LOC__ "message_proof does not match history" - @@ Inbox.verify_proof - (level, message_counter) - proto_inbox_snapshot - invalid_proof - in - let* () = assert_fails ~__LOC__ (level, message_counter) in - let* () = assert_fails ~__LOC__ (level', message_counter) in - let* () = assert_fails ~__LOC__ (level, message_counter') in - let* () = assert_fails ~__LOC__ (level', message_counter') in - return_unit - -(** Verify that the inbox history is correctly filled by calling - {!Inbox.add_all_messages}. *) -let test_messages_are_correctly_added_in_history - {predecessor_timestamp; predecessor; messages; _} = - let open Lwt_result_syntax in - let inbox = dumb_init Raw_level.root in - let messages = List.map (fun message -> Message.External message) messages in - let*? payloads_history, _history, _inbox, witness, messages = - Environment.wrap_tzresult - @@ Inbox.add_all_messages - ~first_block:false - ~predecessor_timestamp - ~predecessor - (Inbox.History.empty ~capacity:0L) - inbox - messages - in - List.iteri_es - (fun i message -> - let index = Z.of_int i in - let*? expected_payload = - Environment.wrap_tzresult @@ Message.serialize message - in - let expected_hash = Message.hash_serialized_message expected_payload in - let found_merkelized_opt = - Sc_rollup.Inbox_merkelized_payload_hashes.Internal_for_tests - .find_predecessor_payload - payloads_history - ~index - witness - in - let* found_hash = - match found_merkelized_opt with - | Some x -> - return - (Sc_rollup.Inbox_merkelized_payload_hashes.get_payload_hash x) - | None -> - failwith - "The payload was not found in the payloads_history, this is \ - unexpected" - in - Assert.equal - ~loc:__LOC__ - Message.Hash.equal - "The message was not correctly added to the payloads history" - Message.Hash.pp - expected_hash - found_hash) - messages - -let merkelized_payload_hashes_tests = - [ - Tztest.tztest_qcheck2 - ~count:1000 - ~name: - "Add payloads to merkelized payload hashes then retrieve them from \ - history." - (gen_payloads ()) - test_merkelized_payload_hashes_history; - Tztest.tztest_qcheck2 - ~count:1000 - ~name:"Produce a merkelized payload hashes proof and verify its validity." - (gen_payloads_and_index ()) - test_merkelized_payload_hashes_proof; - Tztest.tztest - "Empty merkelized payload hashes proof fails." - `Quick - test_empty_merkelized_payload_hashes_proof_fails; - Tztest.tztest_qcheck2 - ~count:1000 - ~name:"Invalid merkelized payload hashes proof fails." - (gen_payloads_and_index - ~min_size:20 - ~max_size:100 - ~max_index_offset:10 - ()) - test_invalid_merkelized_payload_hashes_proof_fails; - ] - -let inbox_tests = - [ - Tztest.tztest_qcheck2 - ~count:1000 - ~name:"produce inclusion proof and verifies it." - (gen_payloads_for_levels_and_level ()) - test_inclusion_proof_production; - Tztest.tztest_qcheck2 - ~count:1000 - ~name:"negative test of inclusion proof." - (gen_payloads_for_levels_and_level ()) - test_inclusion_proof_verification; - Tztest.tztest_qcheck2 - ~count:1000 - ~name:"verify empty inclusion proof fails." - (gen_payloads_and_level ()) - test_empty_inclusion_proof_fails; - Tztest.tztest_qcheck2 - ~count:1000 - ~name:"produce payloads proof and verifies it." - (gen_payloads_and_level_and_index ()) - test_payloads_proof_production; - Tztest.tztest_qcheck2 - ~count:1000 - ~name:"test to verify a proof not using the correct current level proof." - (gen_payloads_and_level_and_index ()) - test_payloads_proof_invalid_inbox_snapshot; - Tztest.tztest_qcheck2 - ~count:1000 - ~name:"test to verify a proof without the payload." - (gen_payloads_and_level ()) - test_payloads_proof_no_payload_expected; - Tztest.tztest_qcheck2 - ~count:1000 - ~name:"test to verify a proof with payload when none is expected." - (gen_payloads_and_level ()) - test_payloads_proof_payload_expected; - Tztest.tztest_qcheck2 - ~count:1000 - ~name:"test to verify a proof with a proof for another payload." - (gen_payloads_and_level ()) - test_payloads_proof_incorrect_proof; - Tztest.tztest_qcheck2 - ~count:1000 - ~name:"test to verify a proof with another payload." - (gen_payloads_and_level ()) - test_payloads_proof_incorrect_payload; - Tztest.tztest_qcheck2 - ~count:1000 - ~name:"test to verify a proof with a payload with an incorrect index." - (gen_payloads_and_level ()) - test_payloads_proof_incorrect_index; - Tztest.tztest_qcheck2 - ~count:1000 - ~name:"test to verify a proof with an out of bound index." - (gen_payloads_and_level ()) - test_payloads_proof_out_of_bound_index; - Tztest.tztest_qcheck2 - ~count:1000 - ~name:"produce inbox proof and verifies it." - (gen_payloads_for_levels_and_level_and_index ()) - test_inbox_proof_production; - Tztest.tztest_qcheck2 - ~count:1000 - ~name:"negative test of inbox proof." - (gen_payloads_for_levels_and_two_levels_and_two_indexes ()) - test_invalid_inbox_proof_fails; - Tztest.tztest_qcheck2 - ~count:1000 - ~name:"messages are correctly added in payloads history" - (gen_payloads_for_level ()) - test_messages_are_correctly_added_in_history; - ] - -let tests = - merkelized_payload_hashes_tests @ inbox_tests - @ Test_sc_rollup_inbox_legacy.tests - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("sc rollup inbox", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_inbox_legacy.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_inbox_legacy.ml deleted file mode 100644 index 8cd4854e0d398c5b5a7d2faf27819ef9108632c6..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_inbox_legacy.ml +++ /dev/null @@ -1,548 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (smart contract rollup inbox) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe - Subject: These unit tests check the off-line inbox implementation for - smart contract rollups -*) - -(* This test file is going to soon disappear. Each tests here are going to be - rewritten in [test_sc_rollup_inbox] in multiples MR. *) -open Protocol -open Sc_rollup_inbox_repr - -exception Sc_rollup_inbox_test_error of string - -let err x = Exn (Sc_rollup_inbox_test_error x) - -let rollup = Sc_rollup_repr.Address.hash_string [""] - -let first_level = Raw_level_repr.(succ root) - -let inbox_message_testable = - Alcotest.testable - Sc_rollup_PVM_sig.pp_inbox_message - Sc_rollup_PVM_sig.inbox_message_equal - -module Payloads_histories = - Map.Make (Sc_rollup_inbox_merkelized_payload_hashes_repr.Hash) - -let get_level_tree_history payloads_histories witness_hash = - Payloads_histories.find witness_hash payloads_histories - |> WithExceptions.Option.get ~loc:__LOC__ - |> Lwt.return - -let make_payload message = - WithExceptions.Result.get_ok ~loc:__LOC__ - @@ Sc_rollup_inbox_message_repr.(serialize @@ External message) - -let make_message message = Sc_rollup_inbox_message_repr.(External message) - -let payloads_from_messages = - List.map (fun Sc_rollup_helpers.{input_repr = input; _} -> - match input with - | Inbox_message {payload; _} -> payload - | Reveal _ -> assert false) - -let populate_inboxes level history inbox inboxes list_of_messages = - let open Result_syntax in - let rec aux level history payloads_histories inbox inboxes witness = function - | [] -> return (payloads_histories, witness, history, inbox, inboxes) - | messages :: ps -> - let* payloads_history, history, inbox, witness, _messages = - Environment.wrap_tzresult - @@ add_all_messages - ~protocol_migration_message:None - ~predecessor_timestamp:Time.Protocol.epoch - ~predecessor:Block_hash.zero - history - inbox - messages - in - let witness_hash = - Sc_rollup_inbox_merkelized_payload_hashes_repr.hash witness - in - let payloads_histories = - Payloads_histories.add - witness_hash - payloads_history - payloads_histories - in - let level = Raw_level_repr.succ level in - aux - level - history - payloads_histories - inbox - (inbox :: inboxes) - (Some witness) - ps - in - let payloads_histories = Payloads_histories.empty in - aux level history payloads_histories inbox inboxes None list_of_messages - -let inbox = Sc_rollup_helpers.dumb_init_repr - -let setup_inbox_with_messages list_of_payloads f = - let inbox = inbox first_level in - let history = History.empty ~capacity:10000L in - populate_inboxes first_level history inbox [] list_of_payloads - >>?= fun (payloads_histories, witness, history, inbox, inboxes) -> - match witness with - | None -> fail (err "setup_inbox_with_messages called with no messages") - | Some tree -> f payloads_histories tree history inbox inboxes - -(* An external message is prefixed with a tag whose length is one byte, and - whose value is 1. *) -let encode_external_message message = - let prefix = "\001" in - Bytes.of_string (prefix ^ message) - -let check_payload messages external_message = - Environment.Context.Tree.find messages ["payload"] >>= function - | None -> fail (err "No payload in messages") - | Some payload -> - let expected_payload = encode_external_message external_message in - fail_unless - (expected_payload = payload) - (err - (Printf.sprintf - "Expected payload %s, got %s" - (Bytes.to_string expected_payload) - (Bytes.to_string payload))) - -(** This is basically identical to {!setup_inbox_with_messages}, except - that it uses the {!Node} instance instead of the protocol instance. *) -let setup_node_inbox_with_messages list_of_messages f = - let open Lwt_result_syntax in - let inbox = inbox first_level in - let history = History.empty ~capacity:10000L in - let payloads_histories = Payloads_histories.empty in - let rec aux level history payloads_histories inbox inboxes witness = function - | [] -> return (payloads_histories, witness, history, inbox, inboxes) - | messages :: ps -> - let*? payloads_history, history, inbox, witness, _messages = - Environment.wrap_tzresult - @@ add_all_messages - ~protocol_migration_message:None - ~predecessor_timestamp:Time.Protocol.epoch - ~predecessor:Block_hash.zero - history - inbox - messages - in - let witness_hash = - Sc_rollup_inbox_merkelized_payload_hashes_repr.hash witness - in - let payloads_histories = - Payloads_histories.add - witness_hash - payloads_history - payloads_histories - in - let level = Raw_level_repr.succ level in - aux - level - history - payloads_histories - inbox - (inbox :: inboxes) - (Some witness) - ps - in - let* payloads_histories, witness, history, inbox, inboxes = - aux first_level history payloads_histories inbox [] None list_of_messages - in - match witness with - | None -> failwith "setup_inbox_with_messages called with no messages" - | Some tree -> f payloads_histories tree history inbox inboxes - -let level_of_int n = Raw_level_repr.of_int32_exn (Int32.of_int n) - -let level_to_int l = Int32.to_int (Raw_level_repr.to_int32 l) - -let payload_string msg = - Sc_rollup_inbox_message_repr.unsafe_of_string - (Bytes.to_string (encode_external_message msg)) - -let inbox_message_of_input input = - match input with Sc_rollup_PVM_sig.Inbox_message x -> Some x | _ -> None - -let next_inbox_message levels_and_messages l n = - let equal = Raw_level_repr.( = ) in - let messages = - WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc ~equal l levels_and_messages - in - match List.nth messages (Z.to_int n) with - | Some Sc_rollup_helpers.{input_repr = input; _} -> - inbox_message_of_input input - | None -> ( - (* If no input at (l, n), the next input is (l+1, 0). *) - match List.assoc ~equal (Raw_level_repr.succ l) levels_and_messages with - | None -> None - | Some messages -> - let Sc_rollup_helpers.{input_repr = input; _} = - Stdlib.List.hd messages - in - inbox_message_of_input input) - -let fail_with_proof_error_msg errors fail_msg = - let msg = - List.find_map - (function - | Environment.Ecoproto_error - (Sc_rollup_inbox_repr.Inbox_proof_error msg) -> - Some msg - | Environment.Ecoproto_error - (Sc_rollup_inbox_merkelized_payload_hashes_repr - .Merkelized_payload_hashes_proof_error msg) -> - Some msg - | _ -> None) - errors - in - let msg = Option.(msg |> map (fun s -> ": " ^ s) |> value ~default:"") in - fail (err (fail_msg ^ msg)) - -(** This helper function initializes inboxes and histories with different - capacities and populates them. *) -let init_inboxes_histories_with_different_capacities - (nb_levels, default_capacity, small_capacity, next_index) = - let open Lwt_result_syntax in - let* () = - fail_when - Int64.(of_int nb_levels <= small_capacity) - (err - (Format.sprintf - "Bad inputs: nb_levels = %d should be greater than small_capacity \ - = %Ld" - nb_levels - small_capacity)) - in - let* () = - fail_when - Int64.(of_int nb_levels >= default_capacity) - (err - (Format.sprintf - "Bad inputs: nb_levels = %d should be smaller than \ - default_capacity = %Ld" - nb_levels - default_capacity)) - in - let*? messages = - List.init ~when_negative_length:[] nb_levels (fun i -> [string_of_int i]) - in - let mk_history ?(next_index = 0L) ~capacity () = - let inbox = inbox first_level in - let history = - Sc_rollup_inbox_repr.History.Internal_for_tests.empty - ~capacity - ~next_index - in - let messages = List.map (List.map make_message) messages in - populate_inboxes first_level history inbox [] messages - in - (* Here, we have `~capacity:0L`. So no history is kept *) - mk_history ~capacity:0L () >>?= fun no_history -> - (* Here, we set a [default_capacity] supposed to be greater than [nb_levels], - and keep the default [next_index]. This history will serve as a witeness *) - mk_history ~capacity:default_capacity () >>?= fun big_history -> - (* Here, we choose a small capacity supposed to be smaller than [nb_levels] to - cover cases where the history is full and older elements should be removed. - We also set a non-default [next_index] value to cover cases where the - incremented index may overflow or is negative. *) - mk_history ~next_index ~capacity:small_capacity () >>?= fun small_history -> - return (no_history, small_history, big_history) - -(** In this test, we mainly check that the number of entries in histories - doesn't exceed their respective capacities. *) -let test_history_length - ((_nb_levels, default_capacity, small_capacity, _next_index) as params) = - let open Lwt_result_syntax in - let module I = Sc_rollup_inbox_repr in - let err expected given ~exact = - err - @@ Format.sprintf - "We expect a history of %Ld capacity (%s), but we got %d elements" - expected - (if exact then "exactly" else "at most") - given - in - let no_capacity = 0L in - let* no_history, small_history, big_history = - init_inboxes_histories_with_different_capacities params - in - let _level_tree_histories0, _level_tree0, history0, _inbox0, _inboxes0 = - no_history - in - let _level_tree_histories1, _level_tree1, history1, _inbox1, _inboxes1 = - small_history - in - let _level_tree_histories2, _level_tree2, history2, _inbox2, _inboxes2 = - big_history - in - let hh0 = I.History.Internal_for_tests.keys history0 in - let hh1 = I.History.Internal_for_tests.keys history1 in - let hh2 = I.History.Internal_for_tests.keys history2 in - (* The first history is supposed to have exactly 0 elements *) - let* () = - let len = List.length hh0 in - fail_unless - Int64.(equal no_capacity (of_int @@ len)) - (err no_capacity len ~exact:true) - in - (* The second history is supposed to have exactly [small_capacity], because - we are supposed to add _nb_level > small_capacity entries. *) - let* () = - let len = List.length hh1 in - fail_unless - Int64.(small_capacity = of_int len) - (err small_capacity len ~exact:false) - in - (* The third history's capacity, named [default_capacity], is supposed to be - greater than _nb_level. So, we don't expect this history to be full. *) - let* () = - let len = List.length hh2 in - fail_unless - Int64.(default_capacity > of_int len) - (err default_capacity len ~exact:true) - in - return () - -(** In this test, we check that for two inboxes of the same content, the entries - of the history with the lower capacity, taken in the insertion order, is a - prefix of the entries of the history with the higher capacity. *) -let test_history_prefix params = - let open Lwt_result_syntax in - let module I = Sc_rollup_inbox_repr in - let* no_history, small_history, big_history = - init_inboxes_histories_with_different_capacities params - in - let _level_tree_histories0, _level_tree0, history0, _inbox0, _inboxes0 = - no_history - in - let _level_tree_histories1, _level_tree1, history1, _inbox1, _inboxes1 = - small_history - in - let _level_tree_histories2, _level_tree2, history2, _inbox2, _inboxes2 = - big_history - in - let hh0 = I.History.Internal_for_tests.keys history0 in - let hh1 = I.History.Internal_for_tests.keys history1 in - let hh2 = I.History.Internal_for_tests.keys history2 in - let check_is_suffix sub super = - let rec aux super to_remove = - let* () = - fail_unless - (to_remove >= 0) - (err "A bigger list cannot be a suffix of a smaller one.") - in - if to_remove = 0 then - fail_unless - (List.for_all2 ~when_different_lengths:false I.Hash.equal sub super - = Ok true) - (err "The smaller list is not a prefix the bigger one.") - else - match List.tl super with - | None -> assert false - | Some super -> aux super (to_remove - 1) - in - aux super (List.length super - List.length sub) - in - (* The empty history's hashes list is supposed to be a suffix of a history - with bigger capacity. *) - let* () = check_is_suffix hh0 hh1 in - (* The history's hashes list of the smaller capacity should be a prefix of - the history's hashes list of a bigger capacity. *) - check_is_suffix hh1 hh2 - -(** In this test, we make some checks on production and verification of - inclusion proofs depending on histories' capacity. *) -let test_inclusion_proofs_depending_on_history_capacity - ((_nb_levels, _default_capacity, _small_capacity, _next_index) as params) = - let open Lwt_result_syntax in - let module I = Sc_rollup_inbox_repr in - let* no_history, small_history, big_history = - init_inboxes_histories_with_different_capacities params - in - let _level_tree_histories0, _level_tree0, history0, inbox0, _inboxes0 = - no_history - in - let _level_tree_histories1, _level_tree1, history1, inbox1, _inboxes1 = - small_history - in - let _level_tree_histories2, _level_tree2, history2, inbox2, _inboxes2 = - big_history - in - let hp0 = I.old_levels_messages inbox0 in - let hp1 = I.old_levels_messages inbox1 in - let (hp2 as hp) = I.old_levels_messages inbox2 in - let pred_level_of_hp = - WithExceptions.Option.get ~loc:__LOC__ - @@ Raw_level_repr.pred - @@ I.Internal_for_tests.get_level_of_history_proof hp - in - let* () = - fail_unless - (I.equal_history_proof hp0 hp1 && I.equal_history_proof hp1 hp2) - (err - "History proof of equal inboxes shouldn't depend on the capacity of \ - history.") - in - let proof s v = - let open Lwt_result_syntax in - let*! v in - match Environment.wrap_tzresult v with - | Ok v -> return v - | Error _ -> tzfail (err (s ^ ": Expecting some inclusion proof.")) - in - let get_history history inbox = History.find inbox history |> Lwt.return in - (* Producing inclusion proofs using history1 and history2 should succeed. - But, we should not be able to produce any proof with history0 as bound - is 0. *) - let*! ip0 = - I.Internal_for_tests.produce_inclusion_proof - (get_history history0) - hp - pred_level_of_hp - in - let* ip1, hp1' = - proof "history1" - @@ I.Internal_for_tests.produce_inclusion_proof - (get_history history1) - hp - pred_level_of_hp - in - let* ip2, hp2' = - proof "history2" - @@ I.Internal_for_tests.produce_inclusion_proof - (get_history history2) - hp - pred_level_of_hp - in - let* () = - fail_unless - (Result.is_error ip0) - (err - "Should not be able to get inbox inclusion proofs without a history \ - (i.e., a history with no capacity). ") - in - let*? hp1'' = - I.Internal_for_tests.verify_inclusion_proof ip1 hp1 - |> Environment.wrap_tzresult - in - let*? hp2'' = - I.Internal_for_tests.verify_inclusion_proof ip2 hp2 - |> Environment.wrap_tzresult - in - fail_unless - (hp1' = hp1'' && hp2' = hp2'' && hp1' = hp2') - (err "Inclusion proofs are expected to be valid.") - -(** This test checks that inboxes of the same levels that are supposed to contain - the same messages are equal. It also check the level trees obtained from - the last calls to add_messages are equal. *) -let test_for_successive_add_messages_with_different_histories_capacities - ((_nb_levels, _default_capacity, _small_capacity, _next_index) as params) = - let open Lwt_result_syntax in - let module I = Sc_rollup_inbox_repr in - let* no_history, small_history, big_history = - init_inboxes_histories_with_different_capacities params - in - let _level_tree_histories0, level_tree0, _history0, _inbox0, inboxes0 = - no_history - in - let _level_tree_histories1, level_tree1, _history1, _inbox1, inboxes1 = - small_history - in - let _level_tree_histories2, level_tree2, _history2, _inbox2, inboxes2 = - big_history - in - (* The latest inbox's value shouldn't depend on the value of [bound]. *) - let eq_inboxes_list = List.for_all2 ~when_different_lengths:false I.equal in - let* () = - fail_unless - (eq_inboxes_list inboxes0 inboxes1 = Ok true - && eq_inboxes_list inboxes1 inboxes2 = Ok true) - (err "Inboxes at the same level with the same content should be equal.") - in - fail_unless - (Option.equal - Sc_rollup_inbox_merkelized_payload_hashes_repr.equal - level_tree0 - level_tree1 - && Option.equal - Sc_rollup_inbox_merkelized_payload_hashes_repr.equal - level_tree1 - level_tree2) - (err "Trees of (supposedly) equal inboxes should be equal.") - -let tests = - let gen_history_params = - QCheck2.Gen.( - (* We fix the number of levels/ inboxes. *) - let* nb_levels = pure 30 in - (* The default capacity is intentionally very big compared to [nb_levels]. *) - let* default_capacity = - frequencyl [(1, Int64.of_int (1000 * nb_levels)); (1, Int64.max_int)] - in - (* The small capacity is intended to be smaller than nb_levels - (but greater than zero). *) - let* small_capacity = 3 -- (nb_levels / 2) in - let* next_index_delta = -5000 -- 5000 in - let big_next_index = Int64.(add max_int (of_int next_index_delta)) in - (* for the [next_index] counter of the history, we test both default values - (i.e., 0L) and values close to [max_int]. *) - let* next_index = frequencyl [(1, 0L); (1, big_next_index)] in - return - (nb_levels, default_capacity, Int64.of_int small_capacity, next_index)) - in - [ - Tztest.tztest_qcheck2 - ~count:10 - ~name:"Checking inboxes history length" - gen_history_params - test_history_length; - Tztest.tztest_qcheck2 - ~count:10 - ~name:"Checking inboxes history content and order" - gen_history_params - test_history_prefix; - Tztest.tztest_qcheck2 - ~count:10 - ~name:"Checking inclusion proofs validity depending on history capacity" - gen_history_params - test_inclusion_proofs_depending_on_history_capacity; - Tztest.tztest_qcheck2 - ~count:10 - ~name: - "Checking results of add_messages when histories have different \ - capacities" - gen_history_params - test_for_successive_add_messages_with_different_histories_capacities; - ] diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml deleted file mode 100644 index bc859e1506d6528ae425f44d2d63d8150f420eb4..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_management_protocol.ml +++ /dev/null @@ -1,365 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (Rollup Management Protocol) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_sc_rollup_management_protocol.ml - Subject: Sanity checks for the Rollup Management Protocol module. -*) - -open Protocol -open Alpha_context - -let check_encode_decode_inbox_message message = - let open Lwt_result_wrap_syntax in - let open Sc_rollup_management_protocol in - let*? bytes = - Environment.wrap_tzresult @@ Sc_rollup.Inbox_message.serialize message - in - let*? message' = - Environment.wrap_tzresult - @@ Internal_for_tests.deserialize_inbox_message bytes - in - let*? bytes' = - Environment.wrap_tzresult @@ Sc_rollup.Inbox_message.serialize message' - in - Assert.equal_string - ~loc:__LOC__ - (Sc_rollup.Inbox_message.unsafe_to_string bytes) - (Sc_rollup.Inbox_message.unsafe_to_string bytes') - -let check_encode_decode_outbox_message_untyped ctxt message = - let open Lwt_result_wrap_syntax in - let open Sc_rollup_management_protocol in - let*? bytes = - Environment.wrap_tzresult - @@ Internal_for_tests.serialize_outbox_message_untyped message - in - let* message', _ctxt = - let*? message_repr = - Environment.wrap_tzresult @@ Sc_rollup.Outbox.Message.deserialize bytes - in - wrap @@ outbox_message_of_outbox_message_repr ctxt message_repr - in - let*? bytes' = - Environment.wrap_tzresult - @@ Internal_for_tests.serialize_outbox_message_untyped message' - in - Assert.equal_string - ~loc:__LOC__ - (Sc_rollup.Outbox.Message.unsafe_to_string bytes) - (Sc_rollup.Outbox.Message.unsafe_to_string bytes') - -let check_encode_decode_outbox_message_typed ctxt message = - let open Lwt_result_wrap_syntax in - let open Sc_rollup_management_protocol in - let*? bytes = - Environment.wrap_tzresult - @@ Internal_for_tests.serialize_outbox_message_typed message - in - let* message', _ctxt = - let*? message_repr = - Environment.wrap_tzresult @@ Sc_rollup.Outbox.Message.deserialize bytes - in - wrap @@ outbox_message_of_outbox_message_repr ctxt message_repr - in - let*? bytes' = - Environment.wrap_tzresult - @@ Internal_for_tests.serialize_outbox_message_typed message' - in - Assert.equal_string - ~loc:__LOC__ - (Sc_rollup.Outbox.Message.unsafe_to_string bytes) - (Sc_rollup.Outbox.Message.unsafe_to_string bytes') - -let string_ticket ticketer contents amount = - let open WithExceptions in - let amount = - Option.get ~loc:__LOC__ @@ Ticket_amount.of_n @@ Script_int.abs - @@ Script_int.of_int amount - in - let ticketer = Result.get_ok ~loc:__LOC__ (Contract.of_b58check ticketer) in - let contents = - Result.get_ok ~loc:__LOC__ (Script_string.of_string contents) - in - Script_typed_ir.{ticketer; contents; amount} - -let init_ctxt () = - let open Lwt_result_syntax in - let* block, _baker, _contract, _src2 = Contract_helpers.init () in - let+ incr = Incremental.begin_construction block in - Incremental.alpha_ctxt incr - -let assert_encoding_failure ~loc res = - Assert.proto_error_with_info - ~loc - res - "Failed to encode a rollup management protocol inbox message value" - -let test_encode_decode_internal_inbox_message_transfer () = - let open Lwt_result_wrap_syntax in - let open WithExceptions in - let* ctxt = init_ctxt () in - let destination = Sc_rollup.Address.zero in - let sender = - Contract_hash.of_b58check_exn "KT1BuEZtb68c1Q4yjtckcNjGELqWt56Xyesc" - in - let source = - Result.get_ok - ~loc:__LOC__ - (Signature.Public_key_hash.of_b58check - "tz1RjtZUVeLhADFHDL8UwDZA6vjWWhojpu5w") - in - let*? (Script_typed_ir.Ty_ex_c pair_nat_ticket_string_ty) = - Environment.wrap_tzresult - (let open Result_syntax in - let open Script_typed_ir in - let* ticket_t = ticket_t (-1) string_t in - pair_t (-1) nat_t ticket_t) - in - let payload = - ( Script_int.(abs @@ of_int 42), - string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1 ) - in - let*@ transfer, ctxt = - Sc_rollup_management_protocol.make_internal_transfer - ctxt - pair_nat_ticket_string_ty - ~payload - ~sender - ~source - ~destination - in - let* () = check_encode_decode_inbox_message transfer in - (* Check that the size of messages that can be encoded is bounded. *) - let msg = String.make 4050 'c' in - let*? payload = Environment.wrap_tzresult (Script_string.of_string msg) in - let*@ transfer, _ctxt = - let open Script_typed_ir in - Sc_rollup_management_protocol.make_internal_transfer - ctxt - String_t - ~payload - ~sender - ~source - ~destination - in - let*! res = check_encode_decode_inbox_message transfer in - assert_encoding_failure ~loc:__LOC__ res - -let test_encode_decode_internal_inbox_message_sol () = - let sol = Sc_rollup.Inbox_message.(Internal Start_of_level) in - check_encode_decode_inbox_message sol - -let test_encode_decode_internal_inbox_message_eol () = - let eol = Sc_rollup.Inbox_message.(Internal End_of_level) in - check_encode_decode_inbox_message eol - -let test_encode_decode_external_inbox_message () = - let open Lwt_result_wrap_syntax in - let assert_prefix message = - let inbox_message = Sc_rollup.Inbox_message.External message in - let*? real_encoding = - Environment.wrap_tzresult - @@ Sc_rollup.Inbox_message.serialize inbox_message - in - let real_encoding = - Sc_rollup.Inbox_message.unsafe_to_string real_encoding - in - (* The prefix consists of a tag (0 for internal, 1 for external). *) - let real_prefix = String.get real_encoding 0 in - let expected_prefix = '\001' in - let expected_encoding = Printf.sprintf "%c%s" expected_prefix message in - (* Check that the encode/decode matches. *) - let* () = check_encode_decode_inbox_message inbox_message in - (* Check that the prefix match. *) - let* () = Assert.equal_char ~loc:__LOC__ real_prefix expected_prefix in - (* Check that the encoded string consists of the prefix followed by the - original message. *) - Assert.equal_string ~loc:__LOC__ real_encoding expected_encoding - in - let* () = assert_prefix "" in - let* () = assert_prefix "A" in - let* () = assert_prefix "0123456789" in - let* () = assert_prefix (String.init 256 (Fun.const 'A')) in - let assert_encoding_success message = - let inbox_message = Sc_rollup.Inbox_message.External message in - let*! res = check_encode_decode_inbox_message inbox_message in - assert (Result.is_ok res) ; - return_unit - in - let assert_encoding_failure message = - let inbox_message = Sc_rollup.Inbox_message.External message in - let*! res = check_encode_decode_inbox_message inbox_message in - assert_encoding_failure ~loc:__LOC__ res - in - let max_msg_size = Constants_repr.sc_rollup_message_size_limit in - let message = String.init (max_msg_size - 1) (Fun.const 'A') in - let* () = assert_encoding_success message in - let message = String.init max_msg_size (Fun.const 'b') in - let* () = assert_encoding_failure message in - assert_encoding_failure message - -let init_env () = - let open Lwt_result_syntax in - let* block, baker, contract, _src2 = Contract_helpers.init () in - return (block, baker, contract) - -let ticket_receiver = - {| - { parameter (pair nat (ticket string)); - storage (list (ticket string)); - code { UNPAIR; # [(nat, ticket) ; list] - CDR; # [ticket ; list] - CONS; # [ticket :: list] - NIL operation ; # [[] ; ticket :: list] - PAIR; # [([], ticket :: list)] - } - } - |} - -let add_or_clear = - {| - { parameter (or (pair %add nat string) (unit %clear)) ; - storage (list (ticket string)) ; - code { UNPAIR ; - IF_LEFT - { UNPAIR ; DIG 2 ; SWAP ; DIG 2 ; TICKET ; ASSERT_SOME ; CONS ; NIL operation ; PAIR } - { DROP 2 ; NIL (ticket string) ; NIL operation ; PAIR } } } - |} - -let test_encode_decode_outbox_message () = - let open Lwt_result_wrap_syntax in - let* block, baker, source_contract = init_env () in - let* ticket_receiver, _, block = - Contract_helpers.originate_contract_from_string - ~script:ticket_receiver - ~storage:"{}" - ~source_contract - ~baker - block - in - let* add_or_clear, _, block = - Contract_helpers.originate_contract_from_string - ~script:add_or_clear - ~storage:"{}" - ~source_contract - ~baker - block - in - let* incr = Incremental.begin_construction block in - let ctxt = Incremental.alpha_ctxt incr in - let ticket_receiver_destination = - match ticket_receiver with - | Contract.Originated ch -> ch - | Implicit _ -> assert false - in - let add_or_clear_destination = - match add_or_clear with - | Contract.Originated ch -> ch - | Implicit _ -> assert false - in - (* Transaction to ticket receiver. *) - let* transaction1, ctxt = - let*?@ (Script_typed_ir.Ty_ex_c pair_nat_ticket_string_ty) = - let open Result_syntax in - let open Script_typed_ir in - let* ticket_t = ticket_t (-1) string_t in - pair_t (-1) nat_t ticket_t - in - let parameters = - ( Script_int.(abs @@ of_int 42), - string_ticket "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1 ) - in - wrap - @@ Sc_rollup_management_protocol.Internal_for_tests.make_transaction - ctxt - pair_nat_ticket_string_ty - ~parameters - ~destination:ticket_receiver_destination - ~entrypoint:Entrypoint.default - in - (* Transaction to the `add` endpoint of add-or-clear contract. *) - let*@ transaction2, ctxt = - let*? (Script_typed_ir.Ty_ex_c pair_nat_ticket_string_ty) = - Script_typed_ir.(pair_t (-1) nat_t string_t) - in - let*? content = Script_string.of_string "Hello" in - let parameters = (Script_int.(abs @@ of_int 11), content) in - Sc_rollup_management_protocol.Internal_for_tests.make_transaction - ctxt - pair_nat_ticket_string_ty - ~parameters - ~destination:add_or_clear_destination - ~entrypoint:(Entrypoint.of_string_strict_exn "add") - in - (* Transaction to the `clear` endpoint of add-or-clear contract. *) - let*@ transaction3, ctxt = - Sc_rollup_management_protocol.Internal_for_tests.make_transaction - ctxt - Script_typed_ir.unit_t - ~parameters:() - ~destination:add_or_clear_destination - ~entrypoint:(Entrypoint.of_string_strict_exn "clear") - in - let outbox_message = - Sc_rollup_management_protocol.Internal_for_tests.make_atomic_batch - [transaction1; transaction2; transaction3] - in - let* () = check_encode_decode_outbox_message_untyped ctxt outbox_message in - check_encode_decode_outbox_message_typed ctxt outbox_message - -let tests = - [ - Tztest.tztest - "Encode/decode internal inbox message transfer" - `Quick - test_encode_decode_internal_inbox_message_transfer; - Tztest.tztest - "Encode/decode internal inbox message start of level" - `Quick - test_encode_decode_internal_inbox_message_sol; - Tztest.tztest - "Encode/decode internal inbox message end of level" - `Quick - test_encode_decode_internal_inbox_message_eol; - Tztest.tztest - "Encode/decode external inbox message" - `Quick - test_encode_decode_external_inbox_message; - Tztest.tztest - "Encode/decode outbox message" - `Quick - test_encode_decode_outbox_message; - ] - -let () = - Alcotest_lwt.run - ~__FILE__ - Protocol.name - [("sc rollup management protocol", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_storage.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_storage.ml deleted file mode 100644 index eacf4255ec4bb72449aa011e6ab132b901454f9d..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_storage.ml +++ /dev/null @@ -1,2804 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Trili Tech, *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol Sc_rollup_storage - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_sc_rollup_storage.ml - Subject: Tests for the SCORU storage module -*) - -open Protocol -module Commitment_repr = Sc_rollup_commitment_repr - -(** [new_context_n n] creates a context with [n] accounts. *) -let new_context_n nb_stakers = - let open Lwt_result_syntax in - let* b, contracts = Context.init_n nb_stakers () in - let+ inc = Incremental.begin_construction b in - let ctxt = Incremental.alpha_ctxt inc in - (* Necessary to originate rollups. *) - let ctxt = Alpha_context.Origination_nonce.init ctxt Operation_hash.zero in - let ctxt = Alpha_context.Internal_for_tests.to_raw ctxt in - let accounts = - List.map - (function - | Alpha_context.Contract.Implicit key -> key | _ -> assert false) - contracts - in - (ctxt, accounts) - -let new_context () = - let open Lwt_result_syntax in - (* A context needs at least one account to bake. *) - let* ctxt, _accounts = new_context_n 1 in - return ctxt - -let new_context_1 () = - let open Lwt_result_syntax in - let* ctxt, accounts = new_context_n 1 in - match accounts with [account] -> return (ctxt, account) | _ -> assert false - -let new_context_2 () = - let open Lwt_result_syntax in - let* ctxt, accounts = new_context_n 2 in - match accounts with - | [account1; account2] -> return (ctxt, account1, account2) - | _ -> assert false - -let new_sc_rollup ctxt = - let open Lwt_result_wrap_syntax in - let {Michelson_v1_parser.expanded; _}, _ = - Michelson_v1_parser.parse_expression "unit" - in - let parameters_ty = Alpha_context.Script.lazy_expr expanded in - let boot_sector = "" in - let kind = Sc_rollups.Kind.Example_arith in - let*! genesis_commitment = - Sc_rollup_helpers.genesis_commitment_raw - ~boot_sector - ~origination_level:(Raw_context.current_level ctxt).level - kind - in - let* rollup, _size, genesis_hash, ctxt = - Sc_rollup_storage.originate ctxt ~kind ~parameters_ty ~genesis_commitment - in - return (rollup, genesis_hash, ctxt) - -let new_context_with_stakers_and_rollup nb_stakers = - let open Lwt_result_wrap_syntax in - let* ctxt, stakers = new_context_n nb_stakers in - let+@ rollup, genesis_hash, ctxt = new_sc_rollup ctxt in - (ctxt, rollup, genesis_hash, stakers) - -let new_context_with_rollup () = - let open Lwt_result_wrap_syntax in - let* ctxt = new_context () in - let+@ rollup, genesis_hash, ctxt = new_sc_rollup ctxt in - (ctxt, rollup, genesis_hash) - -let equal_tez ~loc = - Assert.equal ~loc Tez_repr.( = ) "Tez aren't equal" Tez_repr.pp - -let assert_not_exist ~loc ~pp comp_lwt = - let open Lwt_result_syntax in - let* _ctxt, res_opt = comp_lwt in - Assert.is_none ~loc ~pp res_opt - -let assert_balance_changed op ctxt ctxt' account amount = - let open Lwt_result_wrap_syntax in - let*@ _, balance = Token.balance ctxt account in - let*@ _, balance' = Token.balance ctxt' account in - let*@ balance_op_amount = op balance amount in - equal_tez balance' ~loc:__LOC__ balance_op_amount - -let assert_balance_increased ctxt ctxt' account amount = - let ( +? ) t1 t2 = Lwt.return Tez_repr.(t1 +? t2) in - assert_balance_changed ( +? ) ctxt ctxt' account amount - -let assert_balance_decreased ctxt ctxt' account amount = - let ( -? ) t1 t2 = Lwt.return Tez_repr.(t1 -? t2) in - assert_balance_changed ( -? ) ctxt ctxt' account amount - -let perform_staking_action_and_check ctxt rollup staker do_and_check = - let staker_contract = Contract_repr.Implicit staker in - let stake = Constants_storage.sc_rollup_stake_amount ctxt in - do_and_check ctxt rollup staker_contract stake - -let number_of_ticks_exn n = - match Sc_rollup_repr.Number_of_ticks.of_value n with - | Some x -> x - | None -> Stdlib.failwith "Bad Number_of_ticks" - -module Zero = struct - let staker = Sc_rollup_repr.Staker.zero - - let commitment = - Commitment_repr. - { - compressed_state = Sc_rollup_repr.State_hash.zero; - inbox_level = Raw_level_repr.root; - predecessor = Hash.zero; - number_of_ticks = number_of_ticks_exn 1L; - } - - let commitment_hash = Commitment_repr.Hash.zero - - let rollup = Sc_rollup_repr.Address.zero -end - -let deposit_stake_and_check_balances ctxt rollup staker = - let open Lwt_result_wrap_syntax in - perform_staking_action_and_check - ctxt - rollup - staker - (fun ctxt rollup staker_contract stake -> - let*@ ctxt', _, _ = - Sc_rollup_stake_storage.Internal_for_tests.deposit_stake - ctxt - rollup - staker - in - let* () = - assert_balance_decreased ctxt ctxt' (`Contract staker_contract) stake - in - let bond_id = Bond_id_repr.Sc_rollup_bond_id rollup in - let bonds_account = `Frozen_bonds (staker_contract, bond_id) in - let+ () = assert_balance_increased ctxt ctxt' bonds_account stake in - ctxt') - -(** Originate a rollup with [nb_stakers] stakers and make a deposit to the - initial LCC. *) -let originate_rollup_and_deposit_with_n_stakers nb_stakers = - let open Lwt_result_syntax in - let* ctxt, rollup, genesis_hash, stakers = - new_context_with_stakers_and_rollup nb_stakers - in - let deposit ctxt staker = - deposit_stake_and_check_balances ctxt rollup staker - in - let+ ctxt = List.fold_left_es deposit ctxt stakers in - (ctxt, rollup, genesis_hash, stakers) - -(** Originate a rollup with one staker and make a deposit to the initial LCC. *) -let originate_rollup_and_deposit_with_one_staker () = - let open Lwt_result_wrap_syntax in - let* ctxt, staker = new_context_1 () in - let*@ rollup, genesis_hash, ctxt = new_sc_rollup ctxt in - let+ ctxt = deposit_stake_and_check_balances ctxt rollup staker in - (ctxt, rollup, genesis_hash, staker) - -(** Originate a rollup with two stakers and make a deposit to the initial LCC. -*) -let originate_rollup_and_deposit_with_two_stakers () = - let open Lwt_result_wrap_syntax in - let* ctxt, staker1, staker2 = new_context_2 () in - let*@ rollup, genesis_hash, ctxt = new_sc_rollup ctxt in - let* ctxt = deposit_stake_and_check_balances ctxt rollup staker1 in - let+ ctxt = deposit_stake_and_check_balances ctxt rollup staker2 in - (ctxt, rollup, genesis_hash, staker1, staker2) - -(** Originate a rollup with three stakers and make a deposit to the initial LCC. -*) -let originate_rollup_and_deposit_with_three_stakers () = - let open Lwt_result_syntax in - let+ ctxt, rollup, genesis_hash, stakers = - originate_rollup_and_deposit_with_n_stakers 3 - in - match stakers with - | [staker1; staker2; staker3] -> - (ctxt, rollup, genesis_hash, staker1, staker2, staker3) - | _ -> assert false - -(** Trivial assertion. - - By convention, context is passed linearly as [ctxt]. This takes a context - argument to allow this. -*) -let assert_true _ctxt = return () - -(** Assert that the computation fails with the given message. *) -let assert_fails_with ~loc k expected_err = - let open Lwt_result_syntax in - let*! res = k in - let res = Environment.wrap_tzresult res in - Assert.proto_error ~loc res (( = ) expected_err) - -let assert_fails_with_f ~loc k pred = - let open Lwt_result_syntax in - let*! res = k in - let res = Environment.wrap_tzresult res in - Assert.proto_error ~loc res pred - -let assert_fails ~loc k = - let open Lwt_result_syntax in - let*! res = k in - let res = Environment.wrap_tzresult res in - Assert.error ~loc res (fun _ -> true) - -(** Assert operation fails because of missing rollup *) -let assert_fails_with_missing_rollup ~loc op = - let open Lwt_result_syntax in - let* ctxt = new_context () in - assert_fails_with - ~loc - (op ctxt Zero.rollup) - (Sc_rollup_errors.Sc_rollup_does_not_exist Zero.rollup) - -(** Assert commitment hash equality. *) -let assert_commitment_hash_equal ~loc x y = - Assert.equal - ~loc - Commitment_repr.Hash.equal - "Compare commitment hash" - Commitment_repr.Hash.pp - x - y - -let assert_level_equal ~loc = - Assert.equal ~loc Raw_level_repr.equal "Compare raw level" Raw_level_repr.pp - -let commitment_equal - Commitment_repr. - { - compressed_state = c1; - inbox_level = l1; - predecessor = p1; - number_of_ticks = n1; - } - Commitment_repr. - { - compressed_state = c2; - inbox_level = l2; - predecessor = p2; - number_of_ticks = n2; - } = - Sc_rollup_repr.State_hash.equal c1 c2 - && Raw_level_repr.equal l1 l2 - && Commitment_repr.Hash.equal p1 p2 - && Sc_rollup_repr.Number_of_ticks.equal n1 n2 - -let assert_commitment_equal ~loc x y = - Assert.equal ~loc commitment_equal "Compare commitment" Commitment_repr.pp x y - -let assert_commitments_with_levels_equal ~loc cs1 cs2 = - let commitment_with_level_pp ppf (hash, level) = - Format.fprintf - ppf - "(%a, %a)" - Sc_rollup_commitment_repr.Hash.pp - hash - Raw_level_repr.pp - level - in - Assert.assert_equal_list - ~loc - (fun (commitment1, level1) (commitment2, level2) -> - Sc_rollup_commitment_repr.Hash.(commitment1 = commitment2) - && Raw_level_repr.(level1 = level2)) - "Unexpected list of cemented commitments" - commitment_with_level_pp - cs1 - cs2 - -(* Artificially advance current level to make stake refinement possible. - The commitment can be posted after the inbox level commited. For example, - if you post a commitment for the inbox level 32, you will be able to - publish the commitment at level 33. -*) -let advance_level_for_commitment ctxt (commitment : Commitment_repr.t) = - let cur_level = Level_storage.(current ctxt).level in - if cur_level > commitment.inbox_level then ctxt - else - let offset = - let open Raw_level_repr in - let open Int32 in - succ @@ sub (to_int32 commitment.inbox_level) (to_int32 cur_level) - in - Raw_context.Internal_for_tests.add_level ctxt (Int32.to_int offset) - -let advance_level_for_cement ctxt rollup (commitment : Commitment_repr.t) = - let open Lwt_result_syntax in - let* ctxt, commitment_added = - Storage.Sc_rollup.Commitment_added.get - (ctxt, rollup) - (Commitment_repr.hash_uncarbonated commitment) - in - let challenge_window = - Constants_storage.sc_rollup_challenge_window_in_blocks ctxt - in - let cur_level = Level_storage.(current ctxt).level in - let target_level = Raw_level_repr.add commitment_added challenge_window in - if cur_level > target_level then return ctxt - else - let offset = Raw_level_repr.diff target_level cur_level in - return (Raw_context.Internal_for_tests.add_level ctxt (Int32.to_int offset)) - -let advance_level_n_refine_stake ctxt rollup staker commitment = - let ctxt = advance_level_for_commitment ctxt commitment in - Sc_rollup_stake_storage.Internal_for_tests.refine_stake - ctxt - rollup - staker - commitment - -let valid_inbox_level ctxt = - let root_level = Level_storage.(current ctxt).level in - let commitment_freq = - Constants_storage.sc_rollup_commitment_period_in_blocks ctxt - in - fun i -> - Raw_level_repr.add - root_level - Int32.(to_int (mul (of_int commitment_freq) i)) - -(** A more precise version of {!valid_inbox_level}. Not used everywhere - as it requires more information than {!valid_inbox_level} and is in - the lwt tzresult monad. *) -let proper_valid_inbox_level (ctxt, rollup) i = - let open Lwt_result_syntax in - let+ _, {level = genesis_level; _} = - Sc_rollup_storage.genesis_info ctxt rollup - in - let commitment_freq = - Constants_storage.sc_rollup_commitment_period_in_blocks ctxt - in - Raw_level_repr.add genesis_level (commitment_freq * i) - -let commitment ?compressed_state ?predecessor ?inbox_level ?number_of_ticks () = - let commitment = - Commitment_repr. - { - compressed_state = - Option.value - ~default:Zero.commitment.compressed_state - compressed_state; - predecessor = - Option.value ~default:Zero.commitment.predecessor predecessor; - inbox_level = - Option.value ~default:Zero.commitment.inbox_level inbox_level; - number_of_ticks = - Option.value ~default:Zero.commitment.number_of_ticks number_of_ticks; - } - in - (commitment, Commitment_repr.hash_uncarbonated commitment) - -(** [commitments ~predecessor ?start_at_level ctxt n] creates a branch of - commitment starting at [valid_inbox_level ctxt start_at_level] and with - [predecessor] as commitment's predecessor. The branch is [n] elements - deep. *) -let commitments ~predecessor ?(start_at = 1l) ctxt n = - let n = Int32.(add (of_int n) start_at) in - let rec go predecessor acc l = - if n = l then acc - else - let inbox_level = valid_inbox_level ctxt l in - let commitment, hash = commitment ~predecessor ~inbox_level () in - go hash (commitment :: acc) (Int32.succ l) - in - List.rev (go predecessor [] start_at) - -let publish_commitment ctxt rollup staker commitment = - let open Lwt_result_syntax in - let ctxt = advance_level_for_commitment ctxt commitment in - let* _hash, _publication_level, ctxt, _balance_updates = - Sc_rollup_stake_storage.publish_commitment ctxt rollup staker commitment - in - return ctxt - -let publish_commitments ctxt rollup staker commitments = - List.fold_left_es - (fun ctxt commitment -> publish_commitment ctxt rollup staker commitment) - ctxt - commitments - -let cement_commitment ctxt rollup commitment = - let open Lwt_result_syntax in - let* ctxt = advance_level_for_cement ctxt rollup commitment in - let* ctxt, _commitment, _commitment_hash = - Sc_rollup_stake_storage.cement_commitment ctxt rollup - in - return ctxt - -let cement_commitments ctxt rollup commitments = - List.fold_left_es - (fun ctxt commitment -> cement_commitment ctxt rollup commitment) - ctxt - commitments - -let publish_and_cement_commitment ctxt rollup staker commitment = - let open Lwt_result_syntax in - let* ctxt = publish_commitment ctxt rollup staker commitment in - cement_commitment ctxt rollup commitment - -let publish_and_cement_commitments ctxt rollup staker commitments = - List.fold_left_es - (fun ctxt commitment -> - publish_and_cement_commitment ctxt rollup staker commitment) - ctxt - commitments - -let withdraw ctxt rollup staker = - let open Lwt_result_syntax in - let* ctxt, _balance_updates = - Sc_rollup_stake_storage.withdraw_stake ctxt rollup staker - in - return ctxt - -let assert_staker_exists ctxt rollup staker = - let open Lwt_result_wrap_syntax in - (* Assert the stake was frozen from the balance. *) - let stake = Constants_storage.sc_rollup_stake_amount ctxt in - let*@ frozen_balance = - Contract_storage.(get_frozen_bonds ctxt (Contract_repr.Implicit staker)) - in - let* () = equal_tez ~loc:__LOC__ stake frozen_balance in - (* Assert [staker] was given an index. *) - let*@ ctxt, staker_index_opt = - Sc_rollup_staker_index_storage.find_staker_index_unsafe ctxt rollup staker - in - let* staker_index = Assert.get_some ~loc:__LOC__ staker_index_opt in - let*@ _ctxt, exists = - Sc_rollup_staker_index_storage.is_active ctxt rollup staker_index - in - Assert.equal_bool ~loc:__LOC__ true exists - -let assert_staker_dont_exists ctxt rollup staker = - let open Lwt_result_wrap_syntax in - (* Assert no stake was frozen from the balance. *) - let*@ frozen_balance = - Contract_storage.(get_frozen_bonds ctxt (Contract_repr.Implicit staker)) - in - let* () = equal_tez ~loc:__LOC__ Tez_repr.zero frozen_balance in - (* Assert [staker] has no index. *) - let*@ _ctxt, staker_index_opt = - Sc_rollup_staker_index_storage.find_staker_index_unsafe ctxt rollup staker - in - Assert.is_none ~loc:__LOC__ ~pp:Z.pp_print (staker_index_opt :> Z.t option) - -let assert_staked_or_not ~staked ctxt rollup hash staker = - let open Lwt_result_wrap_syntax in - let*@ _ctxt, stakers_index = - Storage.Sc_rollup.Commitment_stakers.get (ctxt, rollup) hash - in - let*@ _ctxt, staker_index = - Sc_rollup_staker_index_storage.get_staker_index_unsafe ctxt rollup staker - in - Assert.equal_bool - ~loc:__LOC__ - staked - (List.mem ~equal:Z.equal (staker_index :> Z.t) (stakers_index :> Z.t list)) - -let assert_staked_on = assert_staked_or_not ~staked:true - -let assert_not_staked_on = assert_staked_or_not ~staked:false - -let assert_commitment_metadata_exists ?publication_level ctxt rollup commitment - staker = - let open Lwt_result_wrap_syntax in - (* Assert the commitment's metadata exists. *) - let hash = Commitment_repr.hash_uncarbonated commitment in - let*@ _ctxt, actual_publication_level = - Storage.Sc_rollup.Commitment_added.get (ctxt, rollup) hash - in - let* () = - match publication_level with - | None -> return_unit - | Some publication_level -> - assert_level_equal - ~loc:__LOC__ - publication_level - actual_publication_level - in - let* () = assert_staked_on ctxt rollup hash staker in - let*@ _ctxt, commitments_hash = - Storage.Sc_rollup.Commitments_per_inbox_level.get - (ctxt, rollup) - commitment.inbox_level - in - Assert.equal_bool - ~loc:__LOC__ - true - (List.mem ~equal:Commitment_repr.Hash.equal hash commitments_hash) - -let assert_commitment_exists ctxt rollup commitment = - let open Lwt_result_wrap_syntax in - (* Assert commitment exists. *) - let hash = Commitment_repr.hash_uncarbonated commitment in - let*@ actual_commitment_opt, _ctxt = - Sc_rollup_commitment_storage.get_commitment_opt_unsafe ctxt rollup hash - in - let* actual_commitment = Assert.get_some ~loc:__LOC__ actual_commitment_opt in - let* () = assert_commitment_equal ~loc:__LOC__ commitment actual_commitment in - return_unit - -let assert_commitment_metadata_dont_exists ctxt rollup commitment = - let open Lwt_result_wrap_syntax in - (* Assert the commitment's metadata dont exists. *) - let hash = Commitment_repr.hash_uncarbonated commitment in - let*@ _ctxt, exists = - Storage.Sc_rollup.Commitment_added.mem (ctxt, rollup) hash - in - let* () = Assert.equal_bool ~loc:__LOC__ false exists in - let*@ _ctxt, exists = - Storage.Sc_rollup.Commitment_stakers.mem (ctxt, rollup) hash - in - let* () = Assert.equal_bool ~loc:__LOC__ false exists in - let*@ _ctxt, exists = - Storage.Sc_rollup.Commitments_per_inbox_level.mem - (ctxt, rollup) - commitment.inbox_level - in - Assert.equal_bool ~loc:__LOC__ false exists - -let assert_commitment_dont_exists ctxt rollup commitment = - let open Lwt_result_wrap_syntax in - let hash = Commitment_repr.hash_uncarbonated commitment in - let*@ commitment_opt, _ctxt = - Sc_rollup_commitment_storage.get_commitment_opt_unsafe ctxt rollup hash - in - Assert.is_none ~loc:__LOC__ ~pp:Commitment_repr.pp commitment_opt - -(** {2. Tests} *) - -module Stake_storage_tests = struct - let test_last_cemented_commitment_hash_with_level_when_genesis () = - let open Lwt_result_wrap_syntax in - let* ctxt = new_context () in - let*@ rollup, genesis_hash, ctxt = new_sc_rollup ctxt in - let*@ c1, inbox_level, ctxt = - Sc_rollup_commitment_storage.last_cemented_commitment_hash_with_level - ctxt - rollup - in - let* () = assert_commitment_hash_equal ~loc:__LOC__ genesis_hash c1 in - Assert.equal_int32 - ~loc:__LOC__ - (Raw_level_repr.to_int32 (Raw_context.current_level ctxt).level) - (Raw_level_repr.to_int32 inbox_level) - - (** {2. Deposit unit tests.} *) - - (** Test that deposit initializes the metadata for the staker. *) - let test_deposit () = - let open Lwt_result_wrap_syntax in - let* ctxt, staker = new_context_1 () in - let contract_staker = Contract_repr.Implicit staker in - let*@ rollup, _genesis_hash, ctxt = new_sc_rollup ctxt in - let*@ ctxt_after_deposit, _balance_updates, _staker_index = - Sc_rollup_stake_storage.Internal_for_tests.deposit_stake - ctxt - rollup - staker - in - (* Assert [staker]'s metadata exists. *) - let* () = assert_staker_exists ctxt_after_deposit rollup staker in - let stake = Constants_storage.sc_rollup_stake_amount ctxt in - (* Assert [staker]'s balance decreased of [stake]. *) - let* () = - assert_balance_decreased - ctxt - ctxt_after_deposit - (`Contract contract_staker) - stake - in - let bond_id = Bond_id_repr.Sc_rollup_bond_id rollup in - let bonds_account = `Frozen_bonds (contract_staker, bond_id) in - (* Assert [bond_account]'s balance increased of [stake]. *) - let* () = - assert_balance_increased ctxt ctxt_after_deposit bonds_account stake - in - return_unit - - (** Test that deposit fails if the staker is underfunded. *) - let test_deposit_by_underfunded_staker () = - let open Lwt_result_wrap_syntax in - let* ctxt, sc_rollup, _genesis_hash = new_context_with_rollup () in - let staker = - Sc_rollup_repr.Staker.of_b58check_exn - "tz1hhNZvjed6McQQLWtR7MRzPHpgSFZTXxdW" - in - let stake = Constants_storage.sc_rollup_stake_amount ctxt in - let* () = - assert_fails_with - ~loc:__LOC__ - (Sc_rollup_stake_storage.Internal_for_tests.deposit_stake - ctxt - sc_rollup - staker) - (Sc_rollup_errors.Sc_rollup_staker_funds_too_low - { - staker; - sc_rollup; - staker_balance = Tez_repr.zero; - min_expected_balance = stake; - }) - in - let staker_balance = Tez_repr.div_exn stake 2 in - let staker_contract = Contract_repr.Implicit staker in - let*@ ctxt, _ = - Token.transfer ctxt `Minted (`Contract staker_contract) staker_balance - in - assert_fails_with - ~loc:__LOC__ - (Sc_rollup_stake_storage.Internal_for_tests.deposit_stake - ctxt - sc_rollup - staker) - (Sc_rollup_errors.Sc_rollup_staker_funds_too_low - {staker; sc_rollup; staker_balance; min_expected_balance = stake}) - - (** Test that a staker can deposit and then withdraw. *) - let test_deposit_then_withdraw () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, _genesis_hash, staker = - originate_rollup_and_deposit_with_one_staker () - in - let* () = assert_staker_exists ctxt rollup staker in - let*@ ctxt, _balance_updates = - Sc_rollup_stake_storage.withdraw_stake ctxt rollup staker - in - assert_staker_dont_exists ctxt rollup staker - - (** Test that an account can stake on more than one rollup. *) - let test_deposit_on_two_rollups () = - let open Lwt_result_wrap_syntax in - let* ctxt, staker = new_context_1 () in - let assert_frozen_balance ctxt staker expected = - let*@ frozen_balance = - Contract_storage.(get_frozen_bonds ctxt (Contract_repr.Implicit staker)) - in - equal_tez ~loc:__LOC__ expected frozen_balance - in - let stake = Constants_storage.sc_rollup_stake_amount ctxt in - let* () = assert_frozen_balance ctxt staker Tez_repr.zero in - let*@ rollup1, _genesis_hash, ctxt = new_sc_rollup ctxt in - let*@ ctxt, _balance_updates, _staker_index = - Sc_rollup_stake_storage.Internal_for_tests.deposit_stake - ctxt - rollup1 - staker - in - let* () = assert_frozen_balance ctxt staker stake in - let*@ rollup2, _genesis_hash, ctxt = new_sc_rollup ctxt in - let*@ ctxt, _balance_updates, _staker_index = - Sc_rollup_stake_storage.Internal_for_tests.deposit_stake - ctxt - rollup2 - staker - in - assert_frozen_balance ctxt staker (Tez_repr.mul_exn stake 2) - - (** Test that deposit twice on the same rollup fails. *) - let test_deposit_twice_fails () = - let open Lwt_result_wrap_syntax in - let* ctxt, staker = new_context_1 () in - let*@ rollup, _genesis_hash, ctxt = new_sc_rollup ctxt in - let*@ ctxt, _balance_updates, _staker_index = - Sc_rollup_stake_storage.Internal_for_tests.deposit_stake - ctxt - rollup - staker - in - assert_fails - ~loc:__LOC__ - (Sc_rollup_stake_storage.Internal_for_tests.deposit_stake - ctxt - rollup - staker) - - (** {2. Publish unit tests.} *) - - (** Test that the staker, the commitment and its metadata exist after - the publish. *) - let test_publish () = - let open Lwt_result_wrap_syntax in - let* ctxt, staker = new_context_1 () in - let*@ rollup, genesis_hash, ctxt = new_sc_rollup ctxt in - let commitment, _hash = - commitment - ~predecessor:genesis_hash - ~inbox_level:(valid_inbox_level ctxt 1l) - () - in - let*@ ctxt = publish_commitment ctxt rollup staker commitment in - (* The staker exists as a stake was deposited. *) - let* () = assert_staker_exists ctxt rollup staker in - (* The commitment and its metadata exists in the storage. *) - let* () = assert_commitment_exists ctxt rollup commitment in - let* () = assert_commitment_metadata_exists ctxt rollup commitment staker in - return_unit - - (** Test that publish twice to the same level is not allowed. *) - let test_publish_twice () = - let open Lwt_result_wrap_syntax in - let* ctxt, staker = new_context_1 () in - let*@ rollup, genesis_hash, ctxt = new_sc_rollup ctxt in - let commitment, hash = - commitment - ~predecessor:genesis_hash - ~inbox_level:(valid_inbox_level ctxt 1l) - () - in - let*@ ctxt = publish_commitment ctxt rollup staker commitment in - let* () = assert_commitment_exists ctxt rollup commitment in - let* () = assert_commitment_metadata_exists ctxt rollup commitment staker in - (* Assert that publishing twice the same commitment fails. *) - let* () = - assert_fails_with - ~loc:__LOC__ - (publish_commitment ctxt rollup staker commitment) - (Sc_rollup_errors.Sc_rollup_double_publish hash) - in - (* Assert that publishing twice to the same inbox level but with - distinct commitment fails. *) - let new_commitment = - { - commitment with - compressed_state = - Sc_rollup_repr.State_hash.context_hash_to_state_hash - (Context_hash.hash_string ["honest"]); - } - in - let* () = - assert_fails_with - ~loc:__LOC__ - (publish_commitment ctxt rollup staker new_commitment) - Sc_rollup_errors.Sc_rollup_staker_double_stake - in - return_unit - - (** Test that the entrypoint [publish] fails with a nice error if - the rollup is missing. *) - let test_publish_to_missing_rollup () = - assert_fails_with_missing_rollup ~loc:__LOC__ (fun ctxt rollup -> - Sc_rollup_stake_storage.publish_commitment - ctxt - rollup - Zero.staker - Zero.commitment) - - (** Test that publish to a wrong inbox level is forbidden. *) - let test_publish_wrong_inbox_level () = - let open Lwt_result_syntax in - let* ctxt, rollup, genesis_hash, staker = - originate_rollup_and_deposit_with_one_staker () - in - let commitment, _hash = - commitment - ~predecessor:genesis_hash - ~inbox_level:(Raw_level_repr.of_int32_exn 42l) - () - in - assert_fails_with - ~loc:__LOC__ - (publish_commitment ctxt rollup staker commitment) - Sc_rollup_errors.Sc_rollup_bad_inbox_level - - (** Test that two stakers can publish the same commitment. *) - let test_publish_existing_commitment () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - let commitment, _hash = - commitment - ~predecessor:genesis_hash - ~inbox_level:(valid_inbox_level ctxt 1l) - () - in - let*@ ctxt = publish_commitment ctxt rollup staker1 commitment in - let*@ ctxt = publish_commitment ctxt rollup staker2 commitment in - (* [staker2] does exist and stakes on [commitment]. *) - let* () = assert_staker_exists ctxt rollup staker2 in - let* () = - assert_commitment_metadata_exists ctxt rollup commitment staker2 - in - let* () = assert_commitment_exists ctxt rollup commitment in - return_unit - - (** Test that publish returns the oldest level at which the commitment - was published. *) - let test_publish_returns_oldest_publish_level () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - let commitment, _hash = - commitment - ~predecessor:genesis_hash - ~inbox_level:(valid_inbox_level ctxt 1l) - () - in - let ctxt = advance_level_for_commitment ctxt commitment in - let*@ _hash, publish_level, ctxt, _balance_updates = - Sc_rollup_stake_storage.publish_commitment ctxt rollup staker1 commitment - in - let ctxt = Raw_context.Internal_for_tests.add_level ctxt 42 in - let*@ _hash, publish_level', _ctxt, _balance_updates = - Sc_rollup_stake_storage.publish_commitment ctxt rollup staker2 commitment - in - Assert.equal_int32 - ~loc:__LOC__ - (Raw_level_repr.to_int32 publish_level) - (Raw_level_repr.to_int32 publish_level') - - (** Test that a commitment can not be published from the future. *) - let test_publish_fails_on_commitment_from_future () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker = - originate_rollup_and_deposit_with_one_staker () - in - let inbox_level = valid_inbox_level ctxt 1l in - let commitment, _hash = - commitment ~predecessor:genesis_hash ~inbox_level () - in - let* () = - assert_fails_with - ~loc:__LOC__ - (Sc_rollup_stake_storage.publish_commitment - ctxt - rollup - staker - commitment) - (Sc_rollup_errors.Sc_rollup_commitment_from_future - {current_level = Raw_level_repr.of_int32_exn 1l; inbox_level}) - in - let ctxt = advance_level_for_commitment ctxt commitment in - let*@ _hash, _publish_level, ctxt, _balance_updates = - Sc_rollup_stake_storage.publish_commitment ctxt rollup staker commitment - in - let* () = assert_commitment_exists ctxt rollup commitment in - assert_commitment_metadata_exists ctxt rollup commitment staker - - (** Test that a staker can publish a commitment when its last commimtent was - cemented. *) - let test_publish_from_behind_lcc () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker = - originate_rollup_and_deposit_with_one_staker () - in - let level l = valid_inbox_level ctxt l in - let level1 = level 1l in - let level2 = level 2l in - let commitment1, hash = - commitment ~predecessor:genesis_hash ~inbox_level:level1 () - in - let*@ ctxt = publish_commitment ctxt rollup staker commitment1 in - let*@ ctxt = cement_commitment ctxt rollup commitment1 in - let commitment2, _hash = - commitment ~predecessor:hash ~inbox_level:level2 () - in - let*@ ctxt = publish_commitment ctxt rollup staker commitment2 in - let* () = assert_commitment_exists ctxt rollup commitment2 in - assert_commitment_metadata_exists ctxt rollup commitment2 staker - - (** Test that a staker can join another staker's branch without - staking explicitely on each commitment. *) - let test_publish_anywhere_on_branch () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - (* staker1 creates a first branch. *) - let commitments = commitments ~predecessor:genesis_hash ctxt 10 in - let*@ ctxt = publish_commitments ctxt rollup staker1 commitments in - - (* staker2 will stake on only one commitment. *) - let to_stake_commitment = Stdlib.List.nth commitments 6 in - let not_staked_commitments = - List.filter (( <> ) to_stake_commitment) commitments - in - let*@ ctxt = publish_commitment ctxt rollup staker2 to_stake_commitment in - (* Assert [staker2] is staked on [to_stake_commitment] and not on - other commitments. *) - let* () = - assert_staked_on - ctxt - rollup - (Commitment_repr.hash_uncarbonated to_stake_commitment) - staker2 - in - let* () = - List.iter_es - (fun commitment -> - assert_not_staked_on - ctxt - rollup - (Commitment_repr.hash_uncarbonated commitment) - staker2) - not_staked_commitments - in - return_unit - - (** Test that a commitment needs to have a predecessor. *) - let test_publish_without_predecessor_fails () = - let open Lwt_result_syntax in - let* ctxt, rollup, _genesis_hash, staker = - originate_rollup_and_deposit_with_one_staker () - in - let commitment, _hash = - commitment ~inbox_level:(valid_inbox_level ctxt 42l) () - in - assert_fails_with - ~loc:__LOC__ - (publish_commitment ctxt rollup staker commitment) - (Sc_rollup_errors.Sc_rollup_unknown_commitment commitment.predecessor) - - (** Test that publishing a commitment at the LCC or behind it fails. *) - let test_publish_behind_or_at_lcc_fails () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker = - originate_rollup_and_deposit_with_one_staker () - in - let commitments = commitments ~predecessor:genesis_hash ctxt 10 in - let*@ ctxt = - publish_and_cement_commitments ctxt rollup staker commitments - in - let*@ _ctxt, last_cemented_inbox_level, _ = - Sc_rollup_commitment_storage.last_cemented_commitment_hash_with_level - ctxt - rollup - in - (* Trying to publish a commitment behind or at lcc will fail. *) - List.iter_es - (fun commitment -> - assert_fails_with - ~loc:__LOC__ - (Sc_rollup_stake_storage.publish_commitment - ctxt - rollup - staker - commitment) - (Sc_rollup_errors.Sc_rollup_commitment_too_old - { - commitment_inbox_level = commitment.inbox_level; - last_cemented_inbox_level; - })) - commitments - - (** {2. Cement unit tests.} *) - - (** Test that cement cleans the commitment's metadata. *) - let test_cement () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker = - originate_rollup_and_deposit_with_one_staker () - in - let commitment, _hash = - commitment - ~predecessor:genesis_hash - ~inbox_level:(valid_inbox_level ctxt 1l) - () - in - let*@ ctxt = publish_commitment ctxt rollup staker commitment in - let* () = assert_commitment_exists ctxt rollup commitment in - let* () = assert_commitment_metadata_exists ctxt rollup commitment staker in - let*@ ctxt = cement_commitment ctxt rollup commitment in - assert_commitment_metadata_dont_exists ctxt rollup commitment - - (** Test that the entrypoint [cement] fails with a nice error if - the rollup is missing. *) - let test_cement_to_missing_rollup () = - assert_fails_with_missing_rollup ~loc:__LOC__ (fun ctxt rollup -> - Sc_rollup_stake_storage.cement_commitment ctxt rollup) - - (** Test that if [n] stakers stake on the same commitment, it can be - cemented. *) - let test_cement_with_n_stakers () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, stakers = - originate_rollup_and_deposit_with_n_stakers 10 - in - let commitment, _hash = - commitment - ~predecessor:genesis_hash - ~inbox_level:(valid_inbox_level ctxt 1l) - () - in - let*@ ctxt = - List.fold_left_es - (fun ctxt staker -> publish_commitment ctxt rollup staker commitment) - ctxt - stakers - in - let*@ ctxt = cement_commitment ctxt rollup commitment in - assert_commitment_metadata_dont_exists ctxt rollup commitment - - (** Create and cement three commitments: - - [c3 -> c2 -> c1 -> Commitment_hash.zero] - - This is useful to catch potential issues with de-allocation of [c2], - as we deallocate the old LCC when a new LCC is cemented. - *) - let test_cement_n_commitments () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker = - originate_rollup_and_deposit_with_one_staker () - in - let commitments = commitments ~predecessor:genesis_hash ctxt 10 in - let*@ ctxt = publish_commitments ctxt rollup staker commitments in - let*@ ctxt = - advance_level_for_cement - ctxt - rollup - (List.rev commitments |> Stdlib.List.hd) - in - let*@ _ctxt, cemented_commitments = - List.fold_left_es - (fun (ctxt, acc) _commitment -> - let* ctxt, cemented_commitment, _cemented_commitment_hash = - Sc_rollup_stake_storage.cement_commitment ctxt rollup - in - return (ctxt, cemented_commitment :: acc)) - (ctxt, []) - commitments - in - let* () = - List.iter2_es - ~when_different_lengths:[] - (fun commitment cemented_commitment -> - assert_commitment_equal ~loc:__LOC__ commitment cemented_commitment) - commitments - (List.rev cemented_commitments) - in - return_unit - - (** Test that a number of commitments are saved in the storage after - cementation, and other are completely removed. Note that the - metadata for both saved and removed commitments are removed. *) - let test_cement_clean_commitments () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker = - originate_rollup_and_deposit_with_one_staker () - in - let max_number_of_stored_commitments = - Constants_storage.max_number_of_stored_cemented_commitments ctxt - in - let commitments = - commitments - ~predecessor:genesis_hash - ctxt - (max_number_of_stored_commitments * 2) - in - let*@ ctxt = publish_commitments ctxt rollup staker commitments in - let*@ ctxt = cement_commitments ctxt rollup commitments in - (* Assert that [max_number_of_stored_commitments] cemented commitments - exists, i.e. the commitment and not its metadata. The rest are cleaned. *) - let* () = - List.iter_es - (assert_commitment_metadata_dont_exists ctxt rollup) - commitments - in - let removed_commitments, saved_commitments = - List.split_n max_number_of_stored_commitments commitments - in - let* () = - List.iter_es - (assert_commitment_dont_exists ctxt rollup) - removed_commitments - in - let* () = - List.iter_es - (fun commitment -> assert_commitment_exists ctxt rollup commitment) - saved_commitments - in - return_unit - - let test_cement_conflicted_branches () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker1, staker2, staker3 = - originate_rollup_and_deposit_with_three_stakers () - in - - (* Create an honest and dishonest branch. *) - let honest_commitment, honest_commitment_hash = - let compressed_state = - Sc_rollup_repr.State_hash.context_hash_to_state_hash - (Context_hash.hash_string ["honest"]) - in - commitment - ~predecessor:genesis_hash - ~compressed_state - ~inbox_level:(valid_inbox_level ctxt 1l) - () - in - let honest_commitments = - honest_commitment - :: commitments ~predecessor:honest_commitment_hash ~start_at:2l ctxt 10 - in - let dishonest_commitment, dishonest_commitment_hash = - let compressed_state = - Sc_rollup_repr.State_hash.context_hash_to_state_hash - (Context_hash.hash_string ["dishonest"]) - in - commitment - ~predecessor:genesis_hash - ~compressed_state - ~inbox_level:(valid_inbox_level ctxt 1l) - () - in - let dishonest_commitments = - dishonest_commitment - :: commitments ~predecessor:dishonest_commitment_hash ~start_at:2l ctxt 10 - in - (* Conflict begins. *) - let*@ ctxt = publish_commitments ctxt rollup staker1 honest_commitments in - let*@ ctxt = - publish_commitments ctxt rollup staker2 dishonest_commitments - in - let*@ ctxt = - publish_commitments ctxt rollup staker3 dishonest_commitments - in - - (* No one can cement their branches. *) - let cant_cement ctxt = - List.iter_es (fun commitment -> - assert_fails_with_f - ~loc:__LOC__ - (cement_commitment ctxt rollup commitment) - (let open Sc_rollup_errors in - function - | Sc_rollup_disputed | Sc_rollup_parent_not_lcc - | Raw_context.Storage_error (Missing_key _) (* missing commitment *) - -> - true - | _ -> false)) - in - let* () = cant_cement ctxt honest_commitments in - let* () = cant_cement ctxt dishonest_commitments in - - (* Simulate a conflict's resolution through [remove_staker]. *) - let*@ ctxt, _balance_updates = - Sc_rollup_stake_storage.remove_staker ctxt rollup staker2 - in - (* [staker1] is not yet able to cement, [staker3] still stake on the - dishonest branch. *) - let* () = cant_cement ctxt honest_commitments in - (* Simulate the second conflict's resolution. *) - let*@ ctxt, _balance_updates = - Sc_rollup_stake_storage.remove_staker ctxt rollup staker3 - in - (* [staker1] can now cement its branch. The dishonest branch can not - be cemented, before and after the honest branch was cemented. *) - let*@ _ctxt = cement_commitments ctxt rollup honest_commitments in - return_unit - - (** {2. Withdraw unit tests.} *) - - (** Test that the entrypoint [withdraw] fails with a nice error if - the rollup is missing. *) - let test_withdraw_to_missing_rollup () = - assert_fails_with_missing_rollup ~loc:__LOC__ (fun ctxt rollup -> - Sc_rollup_stake_storage.withdraw_stake ctxt rollup Zero.staker) - - (* Test that withdraw fail if the account has not deposited. *) - let test_withdraw_when_not_staked () = - let open Lwt_result_wrap_syntax in - let* ctxt, account = new_context_1 () in - let*@ rollup, _genesis_hash, ctxt = new_sc_rollup ctxt in - assert_fails_with - ~loc:__LOC__ - (Sc_rollup_stake_storage.withdraw_stake ctxt rollup account) - Sc_rollup_errors.Sc_rollup_not_staked - - (** Test that you can withdraw only once (you need to deposit again). *) - let test_withdraw_twice_fails () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, _genesis_hash, staker = - originate_rollup_and_deposit_with_one_staker () - in - let*@ ctxt, _balance_updates = - Sc_rollup_stake_storage.withdraw_stake ctxt rollup staker - in - assert_fails_with - ~loc:__LOC__ - (Sc_rollup_stake_storage.withdraw_stake ctxt rollup staker) - Sc_rollup_errors.Sc_rollup_not_staked - - (** Test that withdraw when the stakers's newest staked commitment is - after the LCC fails. *) - let test_withdraw_fails_staked_after_lcc () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker = - originate_rollup_and_deposit_with_one_staker () - in - let commitment, _hash = - commitment - ~predecessor:genesis_hash - ~inbox_level:(valid_inbox_level ctxt 1l) - () - in - let*@ ctxt = publish_commitment ctxt rollup staker commitment in - assert_fails_with - ~loc:__LOC__ - (Sc_rollup_stake_storage.withdraw_stake ctxt rollup staker) - Sc_rollup_errors.Sc_rollup_not_staked_on_lcc_or_ancestor - - (** Test that withdraw succeeds when the the staker staked on a branch older - than the LCC. *) - let test_withdraw_staked_before_or_at_lcc () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - let commitments = commitments ~predecessor:genesis_hash ctxt 10 in - let commitment, commitments = - match commitments with x :: xs -> (x, xs) | _ -> assert false - in - let*@ ctxt = publish_commitment ctxt rollup staker1 commitment in - let*@ ctxt = publish_commitments ctxt rollup staker2 commitments in - let*@ ctxt = cement_commitment ctxt rollup commitment in - let*@ ctxt = cement_commitments ctxt rollup commitments in - let*@ _ctxt = withdraw ctxt rollup staker1 in - return_unit - - (** Test that [remove_staker] cleans the stakers' metadata. *) - let test_remove_staker () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, _genesis_hash, staker = - originate_rollup_and_deposit_with_one_staker () - in - let*@ ctxt, _balance_updates = - Sc_rollup_stake_storage.remove_staker ctxt rollup staker - in - assert_staker_dont_exists ctxt rollup staker - - (** Test that a staker can come back after being slashed. *) - let test_come_back_after_remove_staker () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker = - originate_rollup_and_deposit_with_one_staker () - in - let* () = assert_staker_exists ctxt rollup staker in - let commitment, _hash = - commitment - ~predecessor:genesis_hash - ~inbox_level:(valid_inbox_level ctxt 1l) - () - in - let*@ ctxt = publish_commitment ctxt rollup staker commitment in - let* () = assert_commitment_exists ctxt rollup commitment in - let* () = assert_commitment_metadata_exists ctxt rollup commitment staker in - (* We simulate a conflict resolution through [remove_staker] *) - let*@ ctxt, _balance_updates = - Sc_rollup_stake_storage.remove_staker ctxt rollup staker - in - let* () = assert_staker_dont_exists ctxt rollup staker in - (* The staker can come back through a new index. *) - let new_commitment = - { - commitment with - compressed_state = - Sc_rollup_repr.State_hash.context_hash_to_state_hash - (Context_hash.hash_string ["honest"]); - } - in - let*@ ctxt = publish_commitment ctxt rollup staker new_commitment in - let* () = assert_commitment_exists ctxt rollup new_commitment in - let* () = - assert_commitment_metadata_exists ctxt rollup new_commitment staker - in - let* () = assert_staker_exists ctxt rollup staker in - (* Furthermore, the commitment can be cemented. *) - let*@ _ctxt = cement_commitment ctxt rollup commitment in - return_unit - - let assert_balance_unchanged ctxt ctxt' account = - let open Lwt_result_wrap_syntax in - let*@ _, balance = Token.balance ctxt account in - let*@ _, balance' = Token.balance ctxt' account in - equal_tez ~loc:__LOC__ balance' balance - - let remove_staker_and_check_balances ctxt rollup staker = - let open Lwt_result_wrap_syntax in - perform_staking_action_and_check - ctxt - rollup - staker - (fun ctxt rollup staker_contract stake -> - let*@ ctxt', _ = - Sc_rollup_stake_storage.remove_staker ctxt rollup staker - in - let* () = - assert_balance_unchanged ctxt ctxt' (`Contract staker_contract) - in - let bond_id = Bond_id_repr.Sc_rollup_bond_id rollup in - let bonds_account = `Frozen_bonds (staker_contract, bond_id) in - let+ () = assert_balance_decreased ctxt ctxt' bonds_account stake in - ctxt') - - let produce_and_refine ctxt ~number_of_commitments ?(start_at_level = 1) - ~predecessor staker rollup = - let open Lwt_result_syntax in - let inbox_level = proper_valid_inbox_level (ctxt, rollup) in - let rec aux ctxt n l predecessor result = - if n = 0 then return @@ (List.rev result, ctxt) - else - let* inbox_level = inbox_level l in - let commitment = - Commitment_repr. - { - predecessor; - inbox_level; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let* c, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker commitment - in - aux ctxt (n - 1) (l + 1) c (c :: result) - in - aux ctxt number_of_commitments start_at_level predecessor [] - - let rec cement_commitments ctxt commitments rollup = - let open Lwt_result_syntax in - match commitments with - | [] -> return ctxt - | _c :: commitments -> - let* ctxt, _commitment, _commitment_hash = - Sc_rollup_stake_storage.cement_commitment ctxt rollup - in - cement_commitments ctxt commitments rollup - - let test_cement_fail_too_recent () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker = - originate_rollup_and_deposit_with_one_staker () - in - let level = valid_inbox_level ctxt in - let challenge_window = - Constants_storage.sc_rollup_challenge_window_in_blocks ctxt - in - let commitment = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = level 1l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ _c1, level, ctxt = - advance_level_n_refine_stake ctxt rollup staker commitment - in - let min_cementation_level = Raw_level_repr.add level challenge_window in - let* () = - assert_fails_with - ~loc:__LOC__ - (Sc_rollup_stake_storage.cement_commitment ctxt rollup) - (Sc_rollup_errors.Sc_rollup_commitment_too_recent - {current_level = level; min_level = min_cementation_level}) - in - let ctxt = - Raw_context.Internal_for_tests.add_level ctxt (challenge_window - 1) - in - let level = (Raw_context.current_level ctxt).level in - assert_fails_with - ~loc:__LOC__ - (Sc_rollup_stake_storage.cement_commitment ctxt rollup) - (Sc_rollup_errors.Sc_rollup_commitment_too_recent - {current_level = level; min_level = min_cementation_level}) - - let test_cement_deadline_uses_oldest_add_time () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - let commitment = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = valid_inbox_level ctxt 1l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ c1, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker1 commitment - in - let challenge_window = - Constants_storage.sc_rollup_challenge_window_in_blocks ctxt - in - let ctxt = Raw_context.Internal_for_tests.add_level ctxt challenge_window in - - let*@ c2, _level, _ctxt = - Sc_rollup_stake_storage.Internal_for_tests.refine_stake - ctxt - rollup - staker2 - commitment - in - let*@ _ctxt = Sc_rollup_stake_storage.cement_commitment ctxt rollup in - assert_commitment_hash_equal ~loc:__LOC__ c1 c2 - - let test_last_cemented_commitment_hash_with_level () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker = - originate_rollup_and_deposit_with_one_staker () - in - let challenge_window = - Constants_storage.sc_rollup_challenge_window_in_blocks ctxt - in - let inbox_level = valid_inbox_level ctxt 1l in - let commitment = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ c1, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker commitment - in - let ctxt = Raw_context.Internal_for_tests.add_level ctxt challenge_window in - let*@ ctxt, _, _ = Sc_rollup_stake_storage.cement_commitment ctxt rollup in - let*@ c1', inbox_level', _ctxt = - Sc_rollup_commitment_storage.last_cemented_commitment_hash_with_level - ctxt - rollup - in - let* () = assert_commitment_hash_equal ~loc:__LOC__ c1 c1' in - Assert.equal_int32 - ~loc:__LOC__ - (Raw_level_repr.to_int32 inbox_level) - (Raw_level_repr.to_int32 inbox_level') - - let test_cement_with_two_stakers () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - let level = valid_inbox_level ctxt in - let commitment1 = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = level 1l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ c1, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker1 commitment1 - in - let commitment2 = - Commitment_repr. - { - predecessor = c1; - inbox_level = level 2l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ _node, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker2 commitment2 - in - let challenge_window = - Constants_storage.sc_rollup_challenge_window_in_blocks ctxt - in - let ctxt = Raw_context.Internal_for_tests.add_level ctxt challenge_window in - - let*@ ctxt = Sc_rollup_stake_storage.cement_commitment ctxt rollup in - assert_true ctxt - - let test_can_remove_staker () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - let level = valid_inbox_level ctxt in - let commitment1 = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = level 1l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ c1, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker1 commitment1 - in - let commitment2 = - Commitment_repr. - { - predecessor = c1; - inbox_level = level 2l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ _node, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker2 commitment2 - in - let* ctxt = remove_staker_and_check_balances ctxt rollup staker1 in - let challenge_window = - Constants_storage.sc_rollup_challenge_window_in_blocks ctxt - in - let ctxt = Raw_context.Internal_for_tests.add_level ctxt challenge_window in - (* It needs to have a staker on [c1] to cement it, otherwise it's not - an active commitment. *) - assert_fails - ~loc:__LOC__ - (Sc_rollup_stake_storage.cement_commitment ctxt rollup) - - let test_can_remove_staker2 () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - let level = valid_inbox_level ctxt in - let commitment1 = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = level 1l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ c1, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker1 commitment1 - in - let commitment2 = - Commitment_repr. - { - predecessor = c1; - inbox_level = level 2l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ _node, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker2 commitment2 - in - let* ctxt = remove_staker_and_check_balances ctxt rollup staker2 in - let challenge_window = - Constants_storage.sc_rollup_challenge_window_in_blocks ctxt - in - let ctxt = Raw_context.Internal_for_tests.add_level ctxt challenge_window in - let*@ ctxt = Sc_rollup_stake_storage.cement_commitment ctxt rollup in - assert_true ctxt - - let test_removed_staker_can_not_withdraw () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - let level = valid_inbox_level ctxt in - let commitment1 = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = level 1l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ c1, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker1 commitment1 - in - let commitment2 = - Commitment_repr. - { - predecessor = c1; - inbox_level = level 2l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ _node, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker2 commitment2 - in - let*@ ctxt, _ = Sc_rollup_stake_storage.remove_staker ctxt rollup staker2 in - assert_fails_with - ~loc:__LOC__ - (Sc_rollup_stake_storage.withdraw_stake ctxt rollup staker2) - Sc_rollup_errors.Sc_rollup_not_staked - - let test_no_cement_on_conflict () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - let level = valid_inbox_level ctxt in - let commitment1 = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = level 1l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ _c1, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker1 commitment1 - in - let commitment2 = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = level 1l; - number_of_ticks = number_of_ticks_exn 44L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ _node, _level, ctxt = - Sc_rollup_stake_storage.Internal_for_tests.refine_stake - ctxt - rollup - staker2 - commitment2 - in - let challenge_window = - Constants_storage.sc_rollup_challenge_window_in_blocks ctxt - in - let ctxt = Raw_context.Internal_for_tests.add_level ctxt challenge_window in - assert_fails_with - ~loc:__LOC__ - (Sc_rollup_stake_storage.cement_commitment ctxt rollup) - Sc_rollup_errors.Sc_rollup_disputed - - let test_finds_conflict_point_at_lcc () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - let level = valid_inbox_level ctxt in - let commitment1 = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = level 1l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ c1, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker1 commitment1 - in - let commitment2 = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = level 1l; - number_of_ticks = number_of_ticks_exn 55L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ _c2, _level, ctxt = - Sc_rollup_stake_storage.Internal_for_tests.refine_stake - ctxt - rollup - staker2 - commitment2 - in - let*@ (left, _right), _ctxt = - Sc_rollup_refutation_storage.Internal_for_tests.get_conflict_point - ctxt - rollup - staker1 - staker2 - in - assert_commitment_hash_equal ~loc:__LOC__ left.hash c1 - - let test_finds_conflict_point_beneath_lcc () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - let level = valid_inbox_level ctxt in - let commitment1 = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = level 1l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ c1, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker1 commitment1 - in - let commitment2 = - Commitment_repr. - { - predecessor = c1; - inbox_level = level 2l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ c2, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker1 commitment2 - in - let commitment3 = - Commitment_repr. - { - predecessor = c1; - inbox_level = level 2l; - number_of_ticks = number_of_ticks_exn 7373L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ c3, _level, ctxt = - Sc_rollup_stake_storage.Internal_for_tests.refine_stake - ctxt - rollup - staker2 - commitment3 - in - let*@ (left, right), _ctxt = - Sc_rollup_refutation_storage.Internal_for_tests.get_conflict_point - ctxt - rollup - staker1 - staker2 - in - let* () = assert_commitment_hash_equal ~loc:__LOC__ left.hash c2 in - assert_commitment_hash_equal ~loc:__LOC__ right.hash c3 - - let test_conflict_point_is_first_point_of_disagreement () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - let level = valid_inbox_level ctxt in - let commitment1 = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = level 1l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ c1, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker1 commitment1 - in - let commitment2 = - Commitment_repr. - { - predecessor = c1; - inbox_level = level 2l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ c2, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker1 commitment2 - in - let commitment3 = - Commitment_repr. - { - predecessor = c1; - inbox_level = level 2l; - number_of_ticks = number_of_ticks_exn 7373L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ c3, _level, ctxt = - Sc_rollup_stake_storage.Internal_for_tests.refine_stake - ctxt - rollup - staker2 - commitment3 - in - let commitment4 = - Commitment_repr. - { - predecessor = c2; - inbox_level = level 3l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ _c4, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker1 commitment4 - in - let*@ (left, right), _ctxt = - Sc_rollup_refutation_storage.Internal_for_tests.get_conflict_point - ctxt - rollup - staker1 - staker2 - in - let* () = assert_commitment_hash_equal ~loc:__LOC__ left.hash c2 in - assert_commitment_hash_equal ~loc:__LOC__ right.hash c3 - - let test_conflict_point_computation_fits_in_gas_limit () = - let open Lwt_result_wrap_syntax in - (* Worst case of conflict point computation: two branches of maximum - length rooted just after the LCC. *) - let* ctxt, rollup, genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - let level = valid_inbox_level ctxt in - let max_commits = - let commitment_freq = - Constants_storage.sc_rollup_commitment_period_in_blocks ctxt - in - Int32.div - (Constants_storage.sc_rollup_max_lookahead_in_blocks ctxt) - (Int32.of_int commitment_freq) - in - let root_commitment = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = level 1l; - number_of_ticks = number_of_ticks_exn 1L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ root_commitment_hash, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker1 root_commitment - in - let*@ _node, _level, ctxt = - Sc_rollup_stake_storage.Internal_for_tests.refine_stake - ctxt - rollup - staker2 - root_commitment - in - let rec branch ctxt staker_id predecessor i max acc = - let open Result_syntax in - let commitment = - Commitment_repr. - { - predecessor; - inbox_level = level i; - number_of_ticks = number_of_ticks_exn staker_id; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let* ctxt, commitment_hash = - Sc_rollup_commitment_storage.hash ctxt commitment - in - if i = max then - return (List.rev ((commitment, commitment_hash) :: acc), ctxt) - else - branch - ctxt - staker_id - commitment_hash - (Int32.succ i) - max - ((commitment, commitment_hash) :: acc) - in - let*?@ branch_1, ctxt = - branch ctxt 1L root_commitment_hash 2l max_commits [] - in - let*?@ branch_2, ctxt = - branch ctxt 2L root_commitment_hash 2l max_commits [] - in - let both_branches = List.combine_drop branch_1 branch_2 in - let*@ ctxt = - List.fold_left_es - (fun ctxt ((c1, _c1h), (c2, _c2h)) -> - let* _ch, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker1 c1 - in - let+ _ch, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker2 c2 - in - ctxt) - ctxt - both_branches - in - let ctxt = - Raw_context.set_gas_limit - ctxt - (Constants_storage.hard_gas_limit_per_operation ctxt) - in - let*@ (left, right), _ctxt = - Sc_rollup_refutation_storage.Internal_for_tests.get_conflict_point - ctxt - rollup - staker1 - staker2 - in - let head_hash branch = - match List.hd branch with Some x -> snd x | None -> assert false - in - let* () = - assert_commitment_hash_equal ~loc:__LOC__ left.hash (head_hash branch_1) - in - assert_commitment_hash_equal ~loc:__LOC__ right.hash (head_hash branch_2) - - let test_no_conflict_point_one_staker_at_lcc_preboot () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - let commitment = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = valid_inbox_level ctxt 1l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ _, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker1 commitment - in - assert_fails_with - ~loc:__LOC__ - (Sc_rollup_refutation_storage.Internal_for_tests.get_conflict_point - ctxt - rollup - staker1 - staker2) - Sc_rollup_errors.Sc_rollup_no_conflict - - let test_no_conflict_point_both_stakers_at_lcc_preboot () = - let open Lwt_result_syntax in - let* ctxt, rollup, _genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - assert_fails_with - ~loc:__LOC__ - (Sc_rollup_refutation_storage.Internal_for_tests.get_conflict_point - ctxt - rollup - staker1 - staker2) - Sc_rollup_errors.Sc_rollup_no_conflict - - let test_no_conflict_point_one_staker_at_lcc () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - let level = valid_inbox_level ctxt in - let commitment1 = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = level 1l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ c1, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker1 commitment1 - in - let commitment2 = - Commitment_repr. - { - predecessor = c1; - inbox_level = level 2l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ _node, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker2 commitment2 - in - let challenge_window = - Constants_storage.sc_rollup_challenge_window_in_blocks ctxt - in - let ctxt = Raw_context.Internal_for_tests.add_level ctxt challenge_window in - let*@ ctxt, _, _ = Sc_rollup_stake_storage.cement_commitment ctxt rollup in - assert_fails_with - ~loc:__LOC__ - (Sc_rollup_refutation_storage.Internal_for_tests.get_conflict_point - ctxt - rollup - staker1 - staker2) - Sc_rollup_errors.Sc_rollup_no_conflict - - let test_no_conflict_point_both_stakers_at_lcc () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - let commitment1 = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = valid_inbox_level ctxt 1l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ _c1, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker1 commitment1 - in - let*@ _node, _level, ctxt = - Sc_rollup_stake_storage.Internal_for_tests.refine_stake - ctxt - rollup - staker2 - commitment1 - in - let challenge_window = - Constants_storage.sc_rollup_challenge_window_in_blocks ctxt - in - let ctxt = Raw_context.Internal_for_tests.add_level ctxt challenge_window in - let*@ ctxt, _, _ = Sc_rollup_stake_storage.cement_commitment ctxt rollup in - assert_fails_with - ~loc:__LOC__ - (Sc_rollup_refutation_storage.Internal_for_tests.get_conflict_point - ctxt - rollup - staker1 - staker2) - Sc_rollup_errors.Sc_rollup_no_conflict - - let test_last_cemented_commitment_of_missing_rollup () = - assert_fails_with_missing_rollup - ~loc:__LOC__ - Sc_rollup_commitment_storage.last_cemented_commitment - - let test_last_cemented_commitment_hash_with_level_of_missing_rollup () = - assert_fails_with_missing_rollup - ~loc:__LOC__ - Sc_rollup_commitment_storage.last_cemented_commitment_hash_with_level - - let test_get_commitment_of_missing_rollup () = - assert_fails_with_missing_rollup ~loc:__LOC__ (fun ctxt rollup -> - Sc_rollup_commitment_storage.get_commitment - ctxt - rollup - Commitment_repr.Hash.zero) - - let test_get_missing_commitment () = - let open Lwt_result_wrap_syntax in - let* ctxt = new_context () in - let*@ rollup, _genesis_hash, ctxt = new_sc_rollup ctxt in - let commitment_hash = Commitment_repr.Hash.zero in - assert_fails_with - ~loc:__LOC__ - (Sc_rollup_commitment_storage.get_commitment ctxt rollup commitment_hash) - (Sc_rollup_errors.Sc_rollup_unknown_commitment commitment_hash) - - let test_genesis_info_of_missing_rollup () = - assert_fails_with_missing_rollup ~loc:__LOC__ Sc_rollup_storage.genesis_info - - let test_concurrent_refinement_point_of_conflict () = - let open Lwt_result_wrap_syntax in - let* before_ctxt, rollup, genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - let level = valid_inbox_level before_ctxt in - let commitment1 = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = level 1l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let commitment2 = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = level 1l; - number_of_ticks = number_of_ticks_exn 7373L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ (c1, c2), _ctxt = - let* _c1, _level, ctxt = - advance_level_n_refine_stake before_ctxt rollup staker1 commitment1 - in - let* _c2, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker2 commitment2 - in - Sc_rollup_refutation_storage.Internal_for_tests.get_conflict_point - ctxt - rollup - staker1 - staker2 - in - let*@ (c1', c2'), _ctxt = - let* _c2, _level, ctxt = - advance_level_n_refine_stake before_ctxt rollup staker2 commitment2 - in - let* _c1, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker1 commitment1 - in - Sc_rollup_refutation_storage.Internal_for_tests.get_conflict_point - ctxt - rollup - staker1 - staker2 - in - let* () = assert_commitment_hash_equal ~loc:__LOC__ c1.hash c1'.hash in - assert_commitment_hash_equal ~loc:__LOC__ c2.hash c2'.hash - - let test_concurrent_refinement_cement () = - let open Lwt_result_wrap_syntax in - let* before_ctxt, rollup, genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - let commitment = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = valid_inbox_level before_ctxt 1l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ c1, _ctxt = - let* _c1, _level, ctxt = - advance_level_n_refine_stake before_ctxt rollup staker1 commitment - in - let* _c2, _level, ctxt = - Sc_rollup_stake_storage.Internal_for_tests.refine_stake - ctxt - rollup - staker2 - commitment - in - let challenge_window = - Constants_storage.sc_rollup_challenge_window_in_blocks ctxt - in - let ctxt = - Raw_context.Internal_for_tests.add_level ctxt challenge_window - in - let* ctxt, _, _ = Sc_rollup_stake_storage.cement_commitment ctxt rollup in - Sc_rollup_commitment_storage.last_cemented_commitment ctxt rollup - in - let*@ c2, _ctxt = - let* _c2, _level, ctxt = - advance_level_n_refine_stake before_ctxt rollup staker2 commitment - in - let* _c1, _level, ctxt = - Sc_rollup_stake_storage.Internal_for_tests.refine_stake - ctxt - rollup - staker1 - commitment - in - let challenge_window = - Constants_storage.sc_rollup_challenge_window_in_blocks ctxt - in - let ctxt = - Raw_context.Internal_for_tests.add_level ctxt challenge_window - in - let* ctxt, _, _ = Sc_rollup_stake_storage.cement_commitment ctxt rollup in - Sc_rollup_commitment_storage.last_cemented_commitment ctxt rollup - in - assert_commitment_hash_equal ~loc:__LOC__ c1 c2 - - let record ctxt rollup level message_index = - Sc_rollup_outbox_storage.record_applied_message - ctxt - rollup - (Raw_level_repr.of_int32_exn @@ Int32.of_int level) - ~message_index - - (* Recreating the indexing logic to make sure messages are applied. *) - let assert_is_already_applied ~loc ctxt rollup level message_index = - let open Lwt_result_wrap_syntax in - let level = Raw_level_repr.of_int32_exn (Int32.of_int level) in - let level_index = - let max_active_levels = - Constants_storage.sc_rollup_max_active_outbox_levels ctxt - in - Int32.rem (Raw_level_repr.to_int32 level) max_active_levels - in - let*@ _ctxt, level_and_bitset_opt = - Storage.Sc_rollup.Applied_outbox_messages.find (ctxt, rollup) level_index - in - match level_and_bitset_opt with - | Some (existing_level, bitset) when Raw_level_repr.(existing_level = level) - -> - let*?@ is_set = Bitset.mem bitset message_index in - Assert.equal_bool ~loc is_set true - | _ -> Stdlib.failwith "Expected a bitset and a matching level." - - (** Test outbox for applied messages. *) - let test_storage_outbox () = - let open Lwt_result_wrap_syntax in - let* ctxt = new_context () in - let*@ rollup1, _genesis_hash, ctxt = new_sc_rollup ctxt in - let level1 = 100 in - (* Test that is-applied is false for non-recorded messages. *) - let*@ _size_diff, ctxt = record ctxt rollup1 level1 1 in - let* () = assert_is_already_applied ~loc:__LOC__ ctxt rollup1 level1 1 in - (* Record the same level and message twice should fail. *) - let* () = - assert_fails_with - ~loc:__LOC__ - (record ctxt rollup1 level1 1) - Sc_rollup_errors.Sc_rollup_outbox_message_already_applied - in - let*@ _size_diff, ctxt = record ctxt rollup1 level1 2 in - let* () = assert_is_already_applied ~loc:__LOC__ ctxt rollup1 level1 2 in - (* Record messages for new level. *) - let level2 = level1 + 3 in - let*@ _size_diff, ctxt = record ctxt rollup1 level2 47 in - let* () = assert_is_already_applied ~loc:__LOC__ ctxt rollup1 level2 47 in - let* () = assert_is_already_applied ~loc:__LOC__ ctxt rollup1 level1 1 in - (* Record for a new rollup. *) - let*@ rollup2, _genesis_hash, ctxt = new_sc_rollup ctxt in - let*@ _size_diff, ctxt = record ctxt rollup2 level1 1 in - let*@ _size_diff, ctxt = record ctxt rollup2 level1 3 in - let* () = assert_is_already_applied ~loc:__LOC__ ctxt rollup2 level1 1 in - let* () = assert_is_already_applied ~loc:__LOC__ ctxt rollup2 level1 3 in - assert_is_already_applied ~loc:__LOC__ ctxt rollup1 level1 1 - - (** Test limits for applied outbox messages. *) - let test_storage_outbox_exceed_limits () = - let open Lwt_result_wrap_syntax in - let level = 1234 in - let* ctxt = new_context () in - let*@ rollup, _genesis_hash, ctxt = new_sc_rollup ctxt in - (* Assert that recording a message index that exceeds max outbox messages per - level fails. *) - let* () = - let max_message_index = - Constants_storage.sc_rollup_max_outbox_messages_per_level ctxt - in - assert_fails_with - ~loc:__LOC__ - (record ctxt rollup level max_message_index) - Sc_rollup_errors.Sc_rollup_invalid_outbox_message_index - in - let* () = - assert_fails_with - ~loc:__LOC__ - (record ctxt rollup level (-1)) - Sc_rollup_errors.Sc_rollup_invalid_outbox_message_index - in - let max_active_levels = - Int32.to_int @@ Constants_storage.sc_rollup_max_active_outbox_levels ctxt - in - (* Record message 42 at level 15 *) - let*@ _size_diff, ctxt = record ctxt rollup 15 42 in - let* () = assert_is_already_applied ~loc:__LOC__ ctxt rollup 15 42 in - (* Record message 42 at level [max_active_levels + 15] *) - let*@ _size_diff, ctxt = record ctxt rollup (max_active_levels + 15) 42 in - (* Record message 42 at level 15 again should fail as it's expired. *) - let* () = - assert_fails_with - ~loc:__LOC__ - (record ctxt rollup 15 42) - Sc_rollup_errors.Sc_rollup_outbox_level_expired - in - return () - - (** Test storage outbox size diff. Note that these tests depend on the constant. - [sc_rollup_max_outbox_messages_per_level] which controls the maximum size - of bitsets required to store applied messages per level. - - Here's a breakdown of the size for applied-outbox-messages storage: - - [size_of_level = 4] - - [max_size_per_level < (2 * (sc_rollup_max_outbox_messages_per_level / 8))] - - [max_size_per_level < size_of_level + size_of_bitset] - - [total_size < sc_rollup_max_active_outbox_levels * max_size_per_level] - *) - let test_storage_outbox_size_diff () = - let open Lwt_result_wrap_syntax in - (* This is the maximum additional storage space required to store one message. - It depends on [sc_rollup_max_outbox_messages_per_level]. *) - let max_size_diff = 19 in - let* ctxt = new_context () in - let*@ rollup, _genesis_hash, ctxt = new_sc_rollup ctxt in - let level = 15 in - let max_message_index = - Constants_storage.sc_rollup_max_outbox_messages_per_level ctxt - 1 - in - let max_active_levels = - Int32.to_int @@ Constants_storage.sc_rollup_max_active_outbox_levels ctxt - in - (* Record a new message. *) - let*@ size_diff, ctxt = record ctxt rollup level 1 in - (* Size diff is 11 bytes. 4 bytes for level and 7 bytes for a new Z.t *) - let* () = Assert.equal_int ~loc:__LOC__ (Z.to_int size_diff) 5 in - let*@ size_diff, ctxt = record ctxt rollup level 2 in - (* Recording a new message in the bitset at a lower index does not occupy - any additional space. *) - let* () = Assert.equal_int ~loc:__LOC__ (Z.to_int size_diff) 0 in - (* Record a new message at the highest index at an existing level. This - expands the bitset but does not charge for the level. *) - let*@ size_diff, ctxt = record ctxt rollup level max_message_index in - let* () = Assert.equal_int ~loc:__LOC__ (Z.to_int size_diff) 14 in - (* Record a new message at the highest index at a new level. This charges for - space for level and maximum bitset. *) - let*@ size_diff, ctxt = record ctxt rollup (level + 1) max_message_index in - let* () = - Assert.equal_int ~loc:__LOC__ (Z.to_int size_diff) max_size_diff - in - (* Record a new message for a level that resets an index. This replaces the - bitset with a smaller one. Hence we get a negative size diff. *) - let*@ size_diff, _ctxt = record ctxt rollup (level + max_active_levels) 0 in - let* () = Assert.equal_int ~loc:__LOC__ (Z.to_int size_diff) (-14) in - return () - - let test_get_cemented_commitments_with_levels_of_missing_rollup () = - assert_fails_with_missing_rollup ~loc:__LOC__ (fun ctxt rollup -> - Sc_rollup_commitment_storage.Internal_for_tests - .get_cemented_commitments_with_levels - ctxt - rollup) - - let test_get_cemented_commitments_with_levels () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, c0, staker = - originate_rollup_and_deposit_with_one_staker () - in - let level = valid_inbox_level ctxt in - let challenge_window = - Constants_storage.sc_rollup_challenge_window_in_blocks ctxt - in - (* Produce and stake on n commitments, each on top of the other. *) - (* Fetch number of stored commitments in context. *) - let max_num_stored_cemented_commitments = - (Raw_context.constants ctxt).sc_rollup - .max_number_of_stored_cemented_commitments - in - (* Produce and stake more commitments than the number of cemented - commitments that can be stored. *) - let number_of_commitments = max_num_stored_cemented_commitments + 5 in - let*@ commitments, ctxt = - produce_and_refine - ~number_of_commitments - ~predecessor:c0 - ctxt - staker - rollup - in - let ctxt = Raw_context.Internal_for_tests.add_level ctxt challenge_window in - (* Cement all commitments that have been produced. *) - let*@ ctxt = cement_commitments ctxt commitments rollup in - (* Add genesis commitment to list of produced commitments. *) - let commitments = c0 :: commitments in - let number_of_cemented_commitments = List.length commitments in - (* Fetch cemented commitments that are kept in context. *) - let*@ cemented_commitments_with_levels, _ctxt = - Sc_rollup_commitment_storage.Internal_for_tests - .get_cemented_commitments_with_levels - ctxt - rollup - in - (* Check that only ctxt.sc_rollup.max_number_of_stored_cemented_commitments - are kept in context. *) - let* () = - Assert.equal_int - ~loc:__LOC__ - (List.length cemented_commitments_with_levels) - max_num_stored_cemented_commitments - in - (* Check that the commitments that are kept in context are the - last [ctxt.sc_rollup.max_number_of_stored_cemented_commitments]. - commitments that have been cemented. *) - let dropped_commitments = - number_of_cemented_commitments - max_num_stored_cemented_commitments - in - let expected_commitments_with_levels = - commitments - |> List.drop_n dropped_commitments - |> List.mapi (fun i c -> - (c, level @@ Int32.of_int (i + dropped_commitments))) - in - assert_commitments_with_levels_equal - ~loc:__LOC__ - cemented_commitments_with_levels - expected_commitments_with_levels - - (* Produces [max_num_stored_cemented_commitments] number of commitments and - verifies that each of them is an ancestor of the last cemented commitment. *) - let test_are_commitments_related_when_related () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, c0, staker = - originate_rollup_and_deposit_with_one_staker () - in - let challenge_window = - Constants_storage.sc_rollup_challenge_window_in_blocks ctxt - in - (* Produce and stake on n commitments, each on top of the other. *) - (* Fetch number of stored commitments in context. *) - let max_num_stored_cemented_commitments = - (Raw_context.constants ctxt).sc_rollup - .max_number_of_stored_cemented_commitments - in - (* Produce and store a number of commitments equal to the maximum number of - cemented commitments that can be stored. *) - let number_of_commitments = max_num_stored_cemented_commitments in - let*@ commitments, ctxt = - produce_and_refine - ~number_of_commitments - ~predecessor:c0 - ctxt - staker - rollup - in - let ctxt = Raw_context.Internal_for_tests.add_level ctxt challenge_window in - (* Cement all commitments that have been produced. *) - let*@ ctxt = cement_commitments ctxt commitments rollup in - (* Check that check_if_commitments_are_related detects that each - cemented commitment is an ancestor of the last cemented commitment. *) - let*@ lcc, ctxt = - Sc_rollup_commitment_storage.last_cemented_commitment ctxt rollup - in - commitments - |> List.iter_es (fun commitment -> - let*@ is_commitment_cemented, _ctxt = - Sc_rollup_commitment_storage.check_if_commitments_are_related - ctxt - rollup - ~descendant:lcc - ~ancestor:commitment - in - Assert.equal_bool ~loc:__LOC__ is_commitment_cemented true) - - (** Tests that [check_if_commitments_are_related] returns false for two - unrelated commitments. *) - let test_unrelated_commitments () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - let level = valid_inbox_level ctxt in - let commitment1 = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = level 1l; - number_of_ticks = number_of_ticks_exn 1232909L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ c1, _level, ctxt = - advance_level_n_refine_stake ctxt rollup staker1 commitment1 - in - let commitment2 = - Commitment_repr. - { - predecessor = genesis_hash; - inbox_level = level 1l; - number_of_ticks = number_of_ticks_exn 44L; - compressed_state = Sc_rollup_repr.State_hash.zero; - } - in - let*@ c2, _level, ctxt = - Sc_rollup_stake_storage.Internal_for_tests.refine_stake - ctxt - rollup - staker2 - commitment2 - in - let*@ are_commitments_related, _ctxt = - Sc_rollup_commitment_storage.check_if_commitments_are_related - ctxt - rollup - ~descendant:c1 - ~ancestor:c2 - in - Assert.equal_bool ~loc:__LOC__ are_commitments_related false - - let test_fresh_index_correctly_increment () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, _genesis_hash, staker1, staker2 = - originate_rollup_and_deposit_with_two_stakers () - in - let assert_staker_index ~__LOC__ ctxt staker expected_index = - let*@ _, (found_index : Sc_rollup_staker_index_repr.t) = - Storage.Sc_rollup.Staker_index.get (ctxt, rollup) staker - in - Assert.equal_z ~loc:__LOC__ (found_index :> Z.t) expected_index - in - let* () = assert_staker_index ~__LOC__ ctxt staker1 Z.zero in - let* () = assert_staker_index ~__LOC__ ctxt staker2 Z.one in - let Account.{pkh; _} = Account.new_account () in - let*@ ctxt, fresh_staker3_index = - Sc_rollup_staker_index_storage.fresh_staker_index ctxt rollup pkh - in - let* () = assert_staker_index ~__LOC__ ctxt pkh Z.(succ one) in - Assert.equal_z ~loc:__LOC__ (fresh_staker3_index :> Z.t) Z.(succ one) - - let tests = - [ - (* Deposit tests: *) - Tztest.tztest "deposit" `Quick test_deposit; - Tztest.tztest - "deposit by underfunded staker" - `Quick - test_deposit_by_underfunded_staker; - Tztest.tztest "deposit then withdraw" `Quick test_deposit_then_withdraw; - Tztest.tztest "deposit on two rollups" `Quick test_deposit_on_two_rollups; - Tztest.tztest "deposit twice fails" `Quick test_deposit_twice_fails; - (* Publish tests: *) - Tztest.tztest "publish" `Quick test_publish; - Tztest.tztest "publish twice" `Quick test_publish_twice; - Tztest.tztest - "publish to missing rollup fails" - `Quick - test_publish_to_missing_rollup; - Tztest.tztest - "publish to wrong inbox level" - `Quick - test_publish_wrong_inbox_level; - Tztest.tztest - "publish existing commitment" - `Quick - test_publish_existing_commitment; - Tztest.tztest - "publish commitment returns level when commitment was first published" - `Quick - test_publish_returns_oldest_publish_level; - Tztest.tztest - "publish from the future is not allowed" - `Quick - test_publish_fails_on_commitment_from_future; - Tztest.tztest - "publish from behind lcc is allowed" - `Quick - test_publish_from_behind_lcc; - Tztest.tztest - "publish to any commitment of a branch" - `Quick - test_publish_anywhere_on_branch; - Tztest.tztest - "publish needs a predecessor" - `Quick - test_publish_without_predecessor_fails; - Tztest.tztest - "publish behind or at LCC" - `Quick - test_publish_behind_or_at_lcc_fails; - (* Cement tests: *) - Tztest.tztest "cement" `Quick test_cement; - Tztest.tztest - "cement to missing rollup fails" - `Quick - test_cement_to_missing_rollup; - Tztest.tztest "cement with n stakers" `Quick test_cement_with_n_stakers; - Tztest.tztest "cement n commitments" `Quick test_cement_n_commitments; - Tztest.tztest - "cement clean commitment(s)" - `Quick - test_cement_clean_commitments; - Tztest.tztest - "cement conflicted branches" - `Quick - test_cement_conflicted_branches; - (* Withdraw tests: *) - Tztest.tztest - "withdraw to missing rollup fails" - `Quick - test_withdraw_to_missing_rollup; - Tztest.tztest - "withdraw when not staked fails" - `Quick - test_withdraw_when_not_staked; - Tztest.tztest "withdraw twice fails" `Quick test_withdraw_twice_fails; - Tztest.tztest - "withdraw fails when staked after LCC" - `Quick - test_withdraw_fails_staked_after_lcc; - Tztest.tztest - "withdraw when staked before or at LCC" - `Quick - test_withdraw_staked_before_or_at_lcc; - (* Remove staker tests: *) - Tztest.tztest "remove staker" `Quick test_remove_staker; - (* Misc tests: *) - Tztest.tztest - "staker come back after being slashed" - `Quick - test_come_back_after_remove_staker; - ] - - (* These tests were written for the old mechanism of staking (calling it - the old design would be a too strong statement). - They need to polished if necessary. - *) - let tests = - tests - @ [ - Tztest.tztest - "cement fails when too recent" - `Quick - test_cement_fail_too_recent; - Tztest.tztest - "cement deadline uses oldest add time" - `Quick - test_cement_deadline_uses_oldest_add_time; - Tztest.tztest - "last cemented commitment hash and level returns correct information" - `Quick - test_last_cemented_commitment_hash_with_level; - Tztest.tztest - "cement with two stakers" - `Quick - test_cement_with_two_stakers; - Tztest.tztest "no cement on conflict" `Quick test_no_cement_on_conflict; - Tztest.tztest - "finds conflict point at LCC" - `Quick - test_finds_conflict_point_at_lcc; - Tztest.tztest - "finds conflict point beneath LCC" - `Quick - test_finds_conflict_point_beneath_lcc; - Tztest.tztest - "finds first point of disagreement when as point of conflict" - `Quick - test_conflict_point_is_first_point_of_disagreement; - Tztest.tztest - "finds no conflict point with two stakers, one of which is at LCC \ - (PVM in preboot)" - `Quick - test_no_conflict_point_one_staker_at_lcc_preboot; - Tztest.tztest - "finds no conflict point when both stakers commit to LCC (PVM in \ - preboot)" - `Quick - test_no_conflict_point_both_stakers_at_lcc_preboot; - Tztest.tztest - "finds no conflict point with two stakers, one of which is at LCC" - `Quick - test_no_conflict_point_one_staker_at_lcc; - Tztest.tztest - "finds no conflict point when both stakers commit to LCC" - `Quick - test_no_conflict_point_both_stakers_at_lcc; - Tztest.tztest - "test_conflict_point_computation_fits_in_gas_limit" - `Quick - test_conflict_point_computation_fits_in_gas_limit; - Tztest.tztest "can remove staker 1" `Quick test_can_remove_staker; - Tztest.tztest "can remove staker 2" `Quick test_can_remove_staker2; - Tztest.tztest - "removed staker can not withdraw" - `Quick - test_removed_staker_can_not_withdraw; - Tztest.tztest - "fetching last final commitment of missing rollup fails" - `Quick - test_last_cemented_commitment_of_missing_rollup; - Tztest.tztest - "fetching last final commitment hash and level of missing rollup \ - fails" - `Quick - test_last_cemented_commitment_hash_with_level_of_missing_rollup; - Tztest.tztest - "fetching commitment of missing rollup fails" - `Quick - test_get_commitment_of_missing_rollup; - Tztest.tztest - "fetching non-existing commitment of rollup fails" - `Quick - test_get_missing_commitment; - Tztest.tztest - "initial level of missing rollup fails" - `Quick - test_genesis_info_of_missing_rollup; - Tztest.tztest - "Refinement operations are commutative (point of conflict)" - `Quick - test_concurrent_refinement_point_of_conflict; - Tztest.tztest - "Refinement operations are commutative (cement)" - `Quick - test_concurrent_refinement_cement; - Tztest.tztest - "Record messages in storage outbox" - `Quick - test_storage_outbox; - Tztest.tztest - "Record messages in storage outbox limits" - `Quick - test_storage_outbox_exceed_limits; - Tztest.tztest - "Record messages size diffs" - `Quick - test_storage_outbox_size_diff; - Tztest.tztest - "Originating a rollup creates a genesis commitment" - `Quick - test_last_cemented_commitment_hash_with_level_when_genesis; - Tztest.tztest - "Getting cemented commitments with levels of missing rollups fails" - `Quick - test_get_cemented_commitments_with_levels_of_missing_rollup; - Tztest.tztest - "Getting cemented commitments returns multiple cemented commitments" - `Quick - test_get_cemented_commitments_with_levels; - Tztest.tztest - "All cemented commitments are ancestors of last cemented commitment" - `Quick - test_are_commitments_related_when_related; - Tztest.tztest - "Unrelated commitments are classified as such" - `Quick - test_unrelated_commitments; - Tztest.tztest - "fresh index is correcly incremented" - `Quick - test_fresh_index_correctly_increment; - ] -end - -module Rollup_storage_tests = struct - let test_genesis_info_of_rollup () = - let open Lwt_result_wrap_syntax in - let* ctxt = new_context () in - let level_before_rollup = (Raw_context.current_level ctxt).level in - let*@ rollup, _genesis_hash, ctxt = new_sc_rollup ctxt in - let ctxt = Raw_context.Internal_for_tests.add_level ctxt 10 in - let*@ _ctxt, genesis_info = Sc_rollup_storage.genesis_info ctxt rollup in - let initial_level = genesis_info.level in - Assert.equal_int32 - ~loc:__LOC__ - (Raw_level_repr.to_int32 level_before_rollup) - (Raw_level_repr.to_int32 initial_level) - - let test_initial_state_is_pre_boot () = - let open Lwt_result_wrap_syntax in - let* ctxt, rollup, genesis_hash = new_context_with_rollup () in - let*@ lcc, _ctxt = - Sc_rollup_commitment_storage.last_cemented_commitment ctxt rollup - in - assert_commitment_hash_equal ~loc:__LOC__ lcc genesis_hash - - let test_kind_of_missing_rollup () = - assert_fails_with_missing_rollup ~loc:__LOC__ (fun ctxt rollup -> - Sc_rollup_storage.kind ctxt rollup) - - let tests = - [ - Tztest.tztest - "initial_level returns correct level" - `Quick - test_genesis_info_of_rollup; - Tztest.tztest - "rollup starts in pre-boot state" - `Quick - test_initial_state_is_pre_boot; - Tztest.tztest - "kind of missing rollup is None" - `Quick - test_kind_of_missing_rollup; - ] -end - -let tests = Stake_storage_tests.tests @ Rollup_storage_tests.tests - -(* FIXME: https://gitlab.com/tezos/tezos/-/issues/2460 - Further tests to be added. -*) - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("sc rollup storage", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_wasm.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_wasm.ml deleted file mode 100644 index 6696e2e5b4549787baebaff3f8d8cda93f6a92b9..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_sc_rollup_wasm.ml +++ /dev/null @@ -1,355 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* Copyright (c) 2022 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Rollup layer 1 logic - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_sc_rollup_wasm.ml - Subject: Unit test for the Wasm PVM -*) - -open Protocol -open Tezos_micheline.Micheline -open Michelson_v1_primitives -open Tezos_webassembly_interpreter -module Context = Tezos_context_memory.Context_binary -open Wasm_utils - -module Proof_encoding = - Tezos_context_merkle_proof_encoding.Merkle_proof_encoding - -module Wasm_context = struct - module Tree = struct - include Context.Tree - - type tree = Context.tree - - type t = Context.t - - type key = string list - - type value = bytes - end - - type tree = Context.tree - - type proof = Context.Proof.tree Context.Proof.t - - let verify_proof p f = - Lwt.map Result.to_option (Context.verify_tree_proof p f) - - let produce_proof context tree step = - let open Lwt_syntax in - let* context = Context.add_tree context [] tree in - let* (_hash : Context_hash.t) = - Context.commit ~time:Time.Protocol.epoch context - in - let index = Context.index context in - match Context.Tree.kinded_key tree with - | Some k -> - let* p = Context.produce_tree_proof index k step in - return (Some p) - | None -> return None - - let kinded_hash_to_state_hash = function - | `Value hash | `Node hash -> - Sc_rollup_repr.State_hash.context_hash_to_state_hash hash - - let proof_before proof = kinded_hash_to_state_hash proof.Context.Proof.before - - let proof_after proof = kinded_hash_to_state_hash proof.Context.Proof.after - - let proof_encoding = Proof_encoding.V2.Tree2.tree_proof_encoding -end - -module Full_Wasm = - Sc_rollup_wasm.V2_0_0.Make (Environment.Wasm_2_0_0.Make) (Wasm_context) - -let test_initial_state_hash_wasm_pvm () = - let open Alpha_context in - let open Lwt_result_syntax in - let empty = Sc_rollup_helpers.make_empty_tree () in - let*! state = Sc_rollup_helpers.Wasm_pvm.initial_state ~empty in - let*! hash = Sc_rollup_helpers.Wasm_pvm.state_hash state in - let expected = Sc_rollup.Wasm_2_0_0PVM.reference_initial_state_hash in - if Sc_rollup.State_hash.(hash = expected) then return_unit - else - failwith - "incorrect hash, expected %a, got %a" - Sc_rollup.State_hash.pp - expected - Sc_rollup.State_hash.pp - hash - -let test_metadata_size () = - let address = Sc_rollup_repr.Address.of_bytes_exn (Bytes.make 20 '\000') in - let metadata = - Sc_rollup_metadata_repr.{address; origination_level = Raw_level_repr.root} - in - let bytes = - Data_encoding.Binary.to_bytes_exn Sc_rollup_metadata_repr.encoding metadata - in - assert ( - Bytes.length bytes - = Tezos_scoru_wasm.Host_funcs.Internal_for_tests.metadata_size) ; - Lwt_result_syntax.return_unit - -let test_l1_input_kind () = - let open Lwt_result_syntax in - let open Sc_rollup_inbox_message_repr in - let open Tezos_scoru_wasm in - let check_msg msg expected = - let*? msg = Environment.wrap_tzresult @@ serialize msg in - let msg = unsafe_to_string msg |> Pvm_input_kind.from_raw_input in - assert (msg = expected) ; - return_unit - in - let* () = check_msg (Internal Start_of_level) (Internal Start_of_level) in - let* () = check_msg (Internal End_of_level) (Internal End_of_level) in - let* () = check_msg (External "payload") External in - - return_unit - -let make_transaction value text contract = - let entrypoint = Entrypoint_repr.default in - let destination : Contract_hash.t = - Contract_hash.of_bytes_exn @@ Bytes.of_string contract - in - let unparsed_parameters = - strip_locations - @@ Prim - ( 0, - I_TICKET, - [Prim (0, I_PAIR, [Int (0, Z.of_int32 value); String (1, text)], [])], - [] ) - in - Sc_rollup_outbox_message_repr.{unparsed_parameters; entrypoint; destination} - -let make_transactions () = - let l = - QCheck2.Gen.( - generate1 - @@ list_size - (return 3) - (triple (string_size @@ return 20) int32 (small_string ~gen:char))) - in - List.map (fun (contract, i, s) -> make_transaction i s contract) l - -(* This is simple "echo kernel" it spits out the first four inputs (SOL, - Info_per_level, input, EOL) it receives. It uses the [write_output] host - function and so it is used to test this function. *) -let test_output () = - let open Lwt_result_syntax in - let level_offset = 20 in - let dst = 60 in - let max_bytes = 3600 in - let dst_without_header = dst + 2 in - let modul = - Format.sprintf - {| - (module - (type $t0 (func (param i32 i32) (result i32))) - (type $t3 (func (param i32 i32 i32) (result i32))) - (import "smart_rollup_core" "read_input" (func $read_input (type $t3))) - (import "smart_rollup_core" "write_output" (func $write_output (type $t0))) - (memory 1) - (export "memory" (memory 0)) - (func (export "kernel_run") - (local $size i32) - (local.set $size (call $read_input - (i32.const %d) - (i32.const %d) - (i32.const %d))) - (call $write_output (i32.const %d) - (i32.sub (local.get $size) (i32.const 2))) - (local.set $size (call $read_input - (i32.const %d) - (i32.const %d) - (i32.const %d))) - (call $write_output (i32.const %d) - (i32.sub (local.get $size) (i32.const 2))) - (local.set $size (call $read_input - (i32.const %d) - (i32.const %d) - (i32.const %d))) - (call $write_output (i32.const %d) - (i32.sub (local.get $size) (i32.const 2))) - (local.set $size (call $read_input - (i32.const %d) - (i32.const %d) - (i32.const %d))) - (call $write_output (i32.const %d) - (local.get $size)) - drop) - ) - - |} - level_offset - dst - max_bytes - dst_without_header - level_offset - dst - max_bytes - dst_without_header - level_offset - dst - max_bytes - dst_without_header - level_offset - dst - max_bytes - dst_without_header - in - - let*! dummy = Context.init "/tmp" in - let dummy_context = Context.empty dummy in - let (empty_tree : Wasm.tree) = Context.Tree.empty dummy_context in - let parsed = Parse.string_to_module modul in - let parsed = - match parsed.it with Script.Textual m -> m | _ -> assert false - in - let*! boot_sector = Encode.encode parsed in - let*! tree = - Wasm.initial_state Sc_rollup_wasm.V2_0_0.current_version empty_tree - in - let*! tree = - Wasm.install_boot_sector - ~ticks_per_snapshot:Sc_rollup_wasm.V2_0_0.ticks_per_snapshot - ~outbox_validity_period:Sc_rollup_wasm.V2_0_0.outbox_validity_period - ~outbox_message_limit:Sc_rollup_wasm.V2_0_0.outbox_message_limit - boot_sector - tree - in - let*! tree = - Wasm.Internal_for_tests.set_max_nb_ticks (Z.of_int64 50_000_000L) tree - in - let transactions = make_transactions () in - let out = - Sc_rollup_outbox_message_repr.(Atomic_transaction_batch {transactions}) - in - let string_input_message = - Data_encoding.Binary.to_string_exn - Sc_rollup_outbox_message_repr.encoding - out - in - let*! tree = eval_until_input_requested tree in - let*! tree = set_full_input_step [string_input_message] 0l tree in - let*! final_tree = eval_until_input_requested tree in - let*! output = Wasm.Internal_for_tests.get_output_buffer final_tree in - let* last_outbox_level = - match output.Tezos_webassembly_interpreter.Output_buffer.last_level with - | Some level -> return level - | None -> failwith "The PVM output buffer does not contain any outbox." - in - let*! last_outbox = - Tezos_webassembly_interpreter.Output_buffer.Internal_for_tests.get_outbox - output - last_outbox_level - in - let* end_of_level_message_index = - match - Output_buffer.Internal_for_tests.get_outbox_last_message_index last_outbox - with - | Some index -> return index - | None -> failwith "The PVM output buffer does not contain any outbox." - in - (* The last message in the outbox corresponds to EOL, due to the nature of the - kernel. As such we must take the one preceding it. *) - let message_index = Z.pred end_of_level_message_index in - - let*! bytes_output_message = - Tezos_webassembly_interpreter.Output_buffer.( - get_message output {outbox_level = last_outbox_level; message_index}) - in - assert (string_input_message = Bytes.to_string bytes_output_message) ; - let message = - Data_encoding.Binary.of_bytes_exn - Sc_rollup_outbox_message_repr.encoding - bytes_output_message - in - assert (message = out) ; - let*? outbox_level = - Environment.wrap_tzresult @@ Raw_level_repr.of_int32 last_outbox_level - in - let output = Sc_rollup_PVM_sig.{outbox_level; message_index; message} in - - let*! pf = Full_Wasm.produce_output_proof dummy_context final_tree output in - - match pf with - | Ok proof -> - let*! valid = Full_Wasm.verify_output_proof proof in - fail_unless valid (Exn (Failure "An output proof is not valid.")) - | Error _ -> failwith "Error during proof generation" - -(* When snapshoting a new protocol, to fix this test, the following - action should be done. - - - In [src/lib_scoru_wasm/constants.ml], add a new variable before - [proto_alpha_name] using the name of the new protocol, and whose - value is [Raw_context.version_value]. - - Update [src/lib_scoru_wasm/pvm_input_kind.ml] to add a new case - to the type [protocol], and update the functions - [protocol_from_raw] and [Internal_for_tests.proto_to_binary] - accordingly (by copy/pasting the [Proto_alpha] case and doing - the necessary renaming. - - Update [src/lib_scoru_wasm/wasm_vm.ml], more precisely the - [version_for_protocol] function, to take into account the new - protocol. The expected result is the same as for - [Proto_alpha]. *) -let test_protocol_names () = - let open Alpha_context.Sc_rollup.Inbox_message in - let protocol_migration_message_str = - Data_encoding.Binary.to_string_exn - encoding - (Internal protocol_migration_internal_message) - in - let kind = - Tezos_scoru_wasm.Pvm_input_kind.from_raw_input - protocol_migration_message_str - in - assert (kind = Internal (Protocol_migration Nairobi)) ; - assert ( - protocol_migration_internal_message - = Protocol_migration Tezos_scoru_wasm.Constants.nairobi_name) ; - Lwt_result_syntax.return_unit - -let tests = - [ - Tztest.tztest - "initial state hash for Wasm" - `Quick - test_initial_state_hash_wasm_pvm; - Tztest.tztest "size of a rollup metadata" `Quick test_metadata_size; - Tztest.tztest "l1 input kind" `Quick test_l1_input_kind; - Tztest.tztest "output proofs" `Quick test_output; - Tztest.tztest "protocol names consistency" `Quick test_protocol_names; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("sc rollup wasm", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_skip_list_repr.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_skip_list_repr.ml deleted file mode 100644 index b024b4b0b815c41008feef3871ed06e1ca73056a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_skip_list_repr.ml +++ /dev/null @@ -1,681 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (skip lists) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_skip_list_repr.ml - Subject: Test skip list implementation -*) - -open Protocol - -exception Skip_list_test_error of string - -let err x = Exn (Skip_list_test_error x) - -module TestNat (Parameters : sig - val basis : int -end) = -struct - open Parameters - include Skip_list_repr.Make (Parameters) - - (* This represents cells of skip lists whose content are even - numbers from {!val:initial_value} and increase 2 by 2. *) - type t = {size : int; cells : (int * (int, int) cell) list} - - let deref list i = List.assoc ~equal:Compare.Int.equal i list.cells - - (* Must be an even number. See {!val:succ}. *) - let initial_value = 10 - - (* Since the list was initialised once/computed once, we can get - back its content from its index directly. *) - let content_from_index ~default list i = - match deref list i with None -> default | Some x -> content x - - let show_cell cell = - Printf.sprintf - "{ content = %d; back_pointers = %s }" - (content cell) - (back_pointers cell |> List.map string_of_int |> String.concat " ") - - let show_cells cells = - String.concat - "; " - (List.map - (fun (i, cell) -> Printf.sprintf "%d:%s" i (show_cell cell)) - cells) - - let show_list list = - Printf.sprintf - "basis: %d, size: %d, cells = %s" - basis - list.size - (show_cells list.cells) - - let show_path path = String.concat " " (List.map string_of_int path) - - let head list = - match List.hd list.cells with None -> assert false | Some h -> h - - let zero = {size = 1; cells = [(0, genesis initial_value)]} - - let succ list = - let prev_cell_ptr, prev_cell = head list in - (* Content of cells are only even numbers so that searching odd numbers will always fail. *) - let cell = - next ~prev_cell ~prev_cell_ptr ((2 * list.size) + initial_value) - in - {size = list.size + 1; cells = (list.size, cell) :: list.cells} - - let back_path list start stop = - back_path ~deref:(deref list) ~cell_ptr:start ~target_index:(Z.of_int stop) - - let find list start stop = - find ~deref:(deref list) ~cell_ptr:start ~target_index:(Z.of_int stop) - - let search list start target_content = - search - ~deref:(deref list) - ~compare:(fun x -> Compare.Int.(compare x target_content)) - ~cell:start - - let valid_back_path list start stop path = - valid_back_path - ~equal_ptr:( = ) - ~deref:(deref list) - ~cell_ptr:start - ~target_ptr:stop - path - - let rec nlist basis n = if n = 0 then zero else succ (nlist basis (n - 1)) - - let check_find i j = - let open Lwt_result_syntax in - let l = nlist basis i in - let*? () = - match find l i j with - | None -> error (err (Printf.sprintf "There must be a cell (%d)" i)) - | Some cell -> - let index = Z.to_int (index cell) in - error_unless - (index = j) - (err - (Printf.sprintf - "Found cell is not the correct one (found %d, expected %d)" - index - j)) - in - let*? path = - match back_path l i j with - | None -> - error (err (Printf.sprintf "There must be path from %d to %d" i j)) - | Some path -> ok path - in - let*? () = - match List.(hd (rev path)) with - | None -> - error - (err - (Printf.sprintf - " There can't be an empty path from %d to %d" - i - j)) - | Some stop_cell -> - error_unless - (j = stop_cell) - (err - (Printf.sprintf - "Found cell is not equal to stop cell of back path (%d to %d)" - i - j)) - in - return_unit - - let check_invalid_find i = - let open Lwt_result_syntax in - let l = nlist basis i in - let check_nothing_found i j = - match find l i j with - | None -> ok () - | Some _v -> - error - (err - (Printf.sprintf - "There should be no value found at %d from %d" - i - j)) - in - let*? () = check_nothing_found i (-1) in - let rec aux j = - if i <= j then return_unit - else - let*? () = check_nothing_found j i in - aux (j + 1) - in - aux 0 - - let check_path i j back_path_fn = - let open Lwt_result_syntax in - let l = nlist basis i in - let*! path = back_path_fn l i j in - match path with - | None -> - tzfail (err (Printf.sprintf "There must be path from %d to %d" i j)) - | Some path -> - let len = List.length path in - let log_basis x = - int_of_float @@ ceil (log (float_of_int x) /. log (float_of_int basis)) - in - let log_ij = log_basis (i - j + 1) in - let expected = max 1 (log_ij * basis) in - fail_unless - (len <= expected) - (err - (Format.sprintf - "The proof is too long! Expected = %d < len = %d [basis = %d, \ - i = %d, log = %d, j = %d]\n" - expected - len - basis - i - log_ij - j)) - >>=? fun () -> - fail_unless - (valid_back_path l i j path) - (err - (Printf.sprintf - "The path %s does not connect %d to %d (or is \ - invalid/non-minimal)" - (show_path path) - i - j)) - - let check_invalid_paths i = - let l = nlist basis i in - let rec aux j = - if i <= j then return () - else - (match back_path l j i with - | None -> return () - | Some _path -> - fail - (err - (Printf.sprintf - "There should be no path connecting %d to %d" - j - i))) - >>=? fun () -> aux (j + 1) - in - aux 0 - - let check_lower_path history rev_path target = - match rev_path with - | [] -> - (* checked before. *) - assert false - | [cell_x] -> - if - (* If there is a single element, we check the content of the - cell is smaller than the target. *) - Compare.Int.(content cell_x < target) - then return () - else fail (err (Printf.sprintf "Invalid path: %d" target)) - | rev_path -> ( - (* The path is returned from the start cell to the target. The - invariant we want to check is in the opposite direction. *) - match rev_path with - | cell_x :: cell_z :: _ -> ( - let i = Z.to_int (index cell_x) in - let next_index = i + 1 in - match - List.nth history.cells (List.length history.cells - next_index - 1) - with - | None -> assert false - | Some (_y, cell_y) -> - if - Compare.Int.( - content cell_x < target - && target < content cell_y - && content cell_y <= content cell_z) - then return () - else - fail (err (Printf.sprintf "Invariant for 'Lower' is broken"))) - | _ -> assert false) - - let check_invalid_search_paths i = - let open Lwt_result_syntax in - let l = nlist basis i in - let rec aux j = - if i <= j then return () - else - (* An odd number to make the search fails. *) - let shift_size = 5 in - (* delta is chosen so that j + delta is not in the list and - can be below the smallest element and greater than the - largest element. *) - let delta = - if List.length l.cells mod 2 = 0 then -shift_size else shift_size - in - let t = content_from_index ~default:(-1) l j + delta in - (* By construction, deref never fails since j <= List.length list. *) - match deref l i with - | None -> assert false - | Some start_content -> - (* For each case below, we check whether the last cell - returned is valid with respect to the current path. Two - cases are not possible. *) - (match search l start_content t with - | {last_cell = No_exact_or_lower_ptr; rev_path} -> ( - (* In that case, we check the path returned by search - is above the target. *) - match rev_path with - | [] -> tzfail (err (Printf.sprintf "unexpected empty path")) - | head :: _ -> - if Compare.Int.(content head > t) then return () - else - tzfail - (err - (Printf.sprintf - "Invariant for 'No_exact_or_lower_ptr' broken"))) - | {last_cell = Nearest _; rev_path} -> - (* In that case, we check the property of being a lower path. *) - check_lower_path l rev_path t - | {last_cell = Deref_returned_none; _} -> - (* deref should always work *) - assert false - | {last_cell = Found _; _} -> - (* Because we search for a cell that which is not in - the list, if the cell was found, we fail. *) - tzfail - (err - (Printf.sprintf - "There should be no search path connecting %d to a \ - node with content %d" - i - t))) - >>=? fun () -> aux (j + 1) - in - aux 0 - - let pp_search_result fmt = - pp_search_result - ~pp_cell:(fun fmt cell -> Format.fprintf fmt "%s" (show_cell cell)) - fmt -end - -let test_skip_list_nat_check_path (basis, i, j) = - let module M = TestNat (struct - let basis = basis - end) in - let back_path list start stop = Lwt.return (M.back_path list start stop) in - M.check_path i j back_path - -let test_skip_list_nat_check_find (basis, i, j) = - let module M = TestNat (struct - let basis = basis - end) in - M.check_find i j - -let test_skip_list_nat_check_invalid_find (basis, i) = - let module M = TestNat (struct - let basis = basis - end) in - M.check_invalid_find i - -let test_skip_list_nat_check_invalid_path (basis, i) = - let module M = TestNat (struct - let basis = basis - end) in - M.check_invalid_paths i - -let test_minimal_back_path () = - let basis = 4 in - let module M = TestNat (struct - let basis = basis - end) in - let l = M.nlist basis 20 in - let check_minimal_path = function - | None, _ -> failwith "empty path" - | Some path, expected_path -> - if path = expected_path then return () - else - failwith - "non-minimal path:[%s] != expected_path:[%s]" - (M.show_path path) - (M.show_path expected_path) - in - let cases = - [ - (6, 1, [6; 3; 2; 1]); - (6, 3, [6; 3]); - (10, 3, [10; 7; 3]); - (10, 5, [10; 7; 6; 5]); - (10, 7, [10; 7]); - (10, 9, [10; 9]); - ] - in - List.iter_es - check_minimal_path - (List.map - (fun (start, target, expected_path) -> - (M.back_path l start target, expected_path)) - cases) - -let test_search_non_minimal_back_path () = - let open Lwt_result_syntax in - let basis = 4 in - let module M = TestNat (struct - let basis = basis - end) in - let l = M.nlist basis 100 in - let index_of_content candidate = - match List.find (fun (_, cell) -> cell = candidate) l.cells with - | None -> assert false - | Some (x, _) -> x - in - let deref x = match M.deref l x with None -> assert false | Some x -> x in - (* This target is chosen to demonstrate that the path is not always - minimal, but this happens only on the very last node. [target] - must be odd to ensure the content is not in the list. *) - let target = 17 in - let start_index = 100 in - let start = deref start_index in - (* Since we are only checking the minimality of the path returned by - search, we assume the other part of the [search] specification to - be correct below (hence the [assert false]). *) - match M.search l start target with - | M.{last_cell = Nearest {lower; upper = Some upper}; rev_path} -> ( - match rev_path with - | [] -> - (* By specification of the function [search]. *) - assert false - | _lower :: upper_path as lower_path -> ( - (* We check the upper path is minimal. *) - let upper_index = index_of_content upper in - match M.back_path l start_index upper_index with - | None -> - (* By specification of the function [search]. *) - assert false - | Some upper_expected_path -> - if List.rev upper_path = List.map deref upper_expected_path then - (* We check the lower path is not minimal. *) - let lower_index = index_of_content lower in - match M.back_path l start_index lower_index with - | None -> - (* By specification of the function [search]. *) - assert false - | Some lower_expected_path -> - if List.rev lower_path = List.map deref lower_expected_path - then - failwith - "The path returned is minimal while it should not be \ - the case." - else return () - else (* By specification of the function [search]. *) - assert false)) - | _ -> - (* The cell does not exist in the list. *) - assert false - -let test_skip_list_nat_check_path_with_search (basis, i, j) = - let module M = TestNat (struct - let basis = basis - end) in - M.check_path i j (fun l i j -> - let target = M.content_from_index ~default:(-1) l j in - let start = - match M.deref l i with None -> assert false | Some start -> start - in - match M.search l start target with - | {last_cell = Found _; rev_path} -> - List.rev_map - (fun cell -> - let x = M.content cell in - (x - 10) / 2) - rev_path - |> Lwt.return_some - | _result -> Lwt.return_none) - -let test_skip_list_nat_check_invalid_path_with_search (basis, i) = - let module M = TestNat (struct - let basis = basis - end) in - M.check_invalid_search_paths i - -(* - - In this test, we check that [best_basis] should be used to optimize - the size of Merkel proofs based on skip lists. In such a context, - the skip lists are referenced by Blake2B hashes (32 bytes-long) and - their contents are also Blake2B hashes. Besides, a Merkel proof is - a list of cells. - - To that end, we consider a deterministic sample of pairs [(n, - target)] when [n] is the length of the skip list and [target] is - the index of a cell in the skip list. Then, for each basis in [2 - .. max_basis] distinct from [best_basis], we check that the largest - proof is larger than the largest proof of [best_basis]. - -*) -let test_skip_list_proof_size () = - let module H = Sc_rollup_inbox_merkelized_payload_hashes_repr.Hash in - (* - - Basis [4] is very close to [3] as the best basis... therefore, we - use a fixed seed for the random number generator to avoid any - flakiness in the test. - - *) - let () = Random.init 0xC0FFEE in - let best_basis = 4 in - - (* - - For the CI, we use relatively small values to avoid slowdowns. - - We choose [max_length] to be of the same order of magnitude as - the longest lists we can meet in practice in the smart rollups - inboxes. - - The real [max_length] can be found in [constants_repr.ml]. At the time - of writing this message, the value is [1_000_000]. - - *) - let max_basis = 7 and nsample = 2048 and max_length = 100_000 in - - (* - - Locally, one can we use large values to get higher confidence: - - *) - (* let max_basis = 13 and nsample = 4096 and max_length = 200_000 in *) - - (* A sample is a pair [(n, k)] where [k <= n]. *) - let samples = - let get () = - let n = 1 + Random.int (max_length - 1) in - let target = Random.int (1 + n) in - (n, Z.of_int target) - in - let rec aux r n = if n = 0 then r else aux (get () :: r) (n - 1) in - aux [] nsample - in - - (* - - For a given [basis], we compute the largest proof when processing - [samples]. The considered lists hold the same contents in each cell, - allowing us to store lists of size [k] in a cache. - - *) - let largest_proof basis = - let module M = Skip_list_repr.Make (struct - let basis = basis - end) in - let cell_encoding = M.encoding H.encoding H.encoding in - let proof_encoding = Data_encoding.list cell_encoding in - let hash_cell cell = - let payload_hash = M.content cell in - let back_pointers_hashes = M.back_pointers cell in - H.to_bytes payload_hash :: List.map H.to_bytes back_pointers_hashes - |> H.hash_bytes - in - let dummy_content = H.hash_string ["HumptyDumpty"] in - let cache = - let cache = Stdlib.Hashtbl.create 13 in - let rec make_list k n map prev_cell = - if n = k then - let prev_cell_ptr = hash_cell prev_cell in - let map = H.Map.add prev_cell_ptr prev_cell map in - Stdlib.Hashtbl.add cache k (map, prev_cell_ptr) - else - let prev_cell_ptr = hash_cell prev_cell in - let next_cell = M.next ~prev_cell ~prev_cell_ptr dummy_content in - let map = H.Map.add prev_cell_ptr prev_cell map in - Stdlib.Hashtbl.add cache k (map, prev_cell_ptr) ; - make_list (succ k) n map next_cell - in - make_list 0 max_length H.Map.empty (M.genesis dummy_content) ; - cache - in - let proof_of_path deref = - List.map (fun ptr -> Stdlib.Option.get (deref ptr)) - in - let proof_size (n, target_index) = - let make_list n = Stdlib.Hashtbl.find cache n in - let map, cell_ptr = make_list n in - let deref ptr = H.Map.find ptr map in - let path = - Stdlib.Option.get @@ M.back_path ~deref ~cell_ptr ~target_index - in - let proof = proof_of_path deref path in - let encoded_proof = - Data_encoding.Binary.to_bytes_exn proof_encoding proof - in - Bytes.length encoded_proof - in - List.map proof_size samples |> List.fold_left max min_int - in - let largest_proofs = - List.map (fun basis -> (basis, largest_proof basis)) (2 -- max_basis) - in - let () = - List.iter - (fun (b, p) -> - Format.eprintf "@[Basis = %d,@, Largest proof = %d@]@;" b p) - largest_proofs - in - let smallest_largest_proofs_basis, _ = - List.fold_left - (fun (b1, p1) (b2, p2) -> if p1 < p2 then (b1, p1) else (b2, p2)) - (Stdlib.List.hd largest_proofs) - (Stdlib.List.tl largest_proofs) - in - fail_unless - (smallest_largest_proofs_basis = best_basis) - (err - (Format.asprintf - "According to the test, %d is the best basis, not %d." - smallest_largest_proofs_basis - best_basis)) - -let tests = - [ - Tztest.tztest_qcheck2 - ~name:"Skip list: produce paths with `back_path` and check" - ~count:10 - QCheck2.Gen.( - let* basis = frequency [(5, pure 4); (1, 2 -- 73)] in - let* i = 0 -- 100 in - let* j = 0 -- i in - return (basis, i, j)) - test_skip_list_nat_check_path; - Tztest.tztest_qcheck2 - ~name:"Skip list: find cell with `find` and `check`" - ~count:10 - QCheck2.Gen.( - let* basis = frequency [(5, pure 4); (1, 2 -- 73)] in - let* i = 0 -- 100 in - let* j = 0 -- i in - return (basis, i, j)) - test_skip_list_nat_check_find; - Tztest.tztest_qcheck2 - ~name:"Skip list: `find` won't produce invalid value" - ~count:10 - QCheck2.Gen.( - let* basis = frequency [(5, pure 4); (1, 2 -- 73)] in - let* i = 0 -- 100 in - return (basis, i)) - test_skip_list_nat_check_invalid_find; - Tztest.tztest_qcheck2 - ~name:"Skip list: `back_path` won't produce invalid paths" - ~count:10 - QCheck2.Gen.( - let* basis = frequency [(5, pure 4); (1, 2 -- 73)] in - let* i = 0 -- 100 in - return (basis, i)) - test_skip_list_nat_check_invalid_path; - Tztest.tztest - "Skip list: check if the back_path is minimal" - `Quick - test_minimal_back_path; - Tztest.tztest_qcheck2 - ~name:"Skip list: produce paths with `search` and check" - ~count:10 - QCheck2.Gen.( - let* basis = frequency [(5, pure 4); (1, 2 -- 73)] in - let* i = 0 -- 100 in - let* j = 0 -- i in - return (basis, i, j)) - test_skip_list_nat_check_path_with_search; - Tztest.tztest_qcheck2 - ~name:"Skip list: `search` won't produce invalid paths" - ~count:10 - QCheck2.Gen.( - let* basis = frequency [(5, pure 4); (1, 2 -- 73)] in - let* i = 0 -- 10 in - return (basis, i)) - test_skip_list_nat_check_invalid_path_with_search; - (* We cheat here to avoid mixing non-pbt tests with pbt tests. *) - Tztest.tztest_qcheck2 - ~name:"Skip list: `search` may not produce minimal path" - ~count:10 - QCheck2.Gen.unit - test_search_non_minimal_back_path; - Tztest.tztest - "Skip list: check if the best basis for merkelized skip list is indeed \ - the best" - `Quick - test_skip_list_proof_size; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("skip list", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_tez_repr.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_tez_repr.ml deleted file mode 100644 index c2de2f3a08d2476e76a3f48ade406cbfcd30d0bb..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_tez_repr.ml +++ /dev/null @@ -1,203 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Marigold *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Tez_repr - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_tez_repr.ml - Dependencies: -- - Subject: To test the modules (including the top-level) - in tez_repr.ml as individual units, particularly - failure cases. Superficial goal: increase coverage percentage. -*) -open Protocol - -open Tztest - -module Test_tez_repr = struct - (** Testing predefined units: zero, one_mutez etc *) - let test_predefined_values () = - let zero_int64 = Tez_repr.to_mutez Tez_repr.zero in - Assert.equal_int64 ~loc:__LOC__ zero_int64 0L >>=? fun () -> - let one_mutez_int64 = Tez_repr.to_mutez Tez_repr.one_mutez in - Assert.equal_int64 ~loc:__LOC__ one_mutez_int64 1L >>=? fun () -> - let one_cent_int64 = Tez_repr.to_mutez Tez_repr.one_cent in - Assert.equal_int64 ~loc:__LOC__ one_cent_int64 10000L >>=? fun () -> - let fifty_cents_int64 = Tez_repr.to_mutez Tez_repr.fifty_cents in - Assert.equal_int64 ~loc:__LOC__ fifty_cents_int64 500000L >>=? fun () -> - let one_int64 = Tez_repr.to_mutez Tez_repr.one in - Assert.equal_int64 ~loc:__LOC__ one_int64 1000000L - - let test_subtract () = - (Lwt.return @@ Tez_repr.(one -? zero)) >|= Environment.wrap_tzresult - >>=? fun res -> - Assert.equal_int64 ~loc:__LOC__ (Tez_repr.to_mutez res) 1000000L - - let test_substract_underflow () = - (Lwt.return @@ Tez_repr.(zero -? one)) >|= Environment.wrap_tzresult - >>= function - | Ok _ -> failwith "Expected to underflow" - | Error _ -> return_unit - - let test_addition () = - (Lwt.return @@ Tez_repr.(one +? zero)) >|= Environment.wrap_tzresult - >>=? fun res -> - Assert.equal_int64 ~loc:__LOC__ (Tez_repr.to_mutez res) 1000000L - - let test_addition_overflow () = - (Lwt.return @@ Tez_repr.(of_mutez_exn 0x7fffffffffffffffL +? one)) - >|= Environment.wrap_tzresult - >>= function - | Ok _ -> failwith "Expected to overflow" - | Error _ -> return_unit - - let test_mul () = - (Lwt.return @@ Tez_repr.(zero *? 1L)) >|= Environment.wrap_tzresult - >>=? fun res -> Assert.equal_int64 ~loc:__LOC__ (Tez_repr.to_mutez res) 0L - - let test_mul_overflow () = - (Lwt.return @@ Tez_repr.(of_mutez_exn 0x7fffffffffffffffL *? 2L)) - >|= Environment.wrap_tzresult - >>= function - | Ok _ -> failwith "Expected to overflow" - | Error _ -> return_unit - - let test_div () = - (Lwt.return @@ Tez_repr.(one *? 1L)) >|= Environment.wrap_tzresult - >>=? fun res -> - Assert.equal_int64 ~loc:__LOC__ (Tez_repr.to_mutez res) 1000000L - - let test_div_by_zero () = - (Lwt.return @@ Tez_repr.(one /? 0L)) >|= Environment.wrap_tzresult - >>= function - | Ok _ -> failwith "Expected to overflow" - | Error _ -> return_unit - - let test_to_mutez () = - let int64v = Tez_repr.(to_mutez one) in - Assert.equal_int64 ~loc:__LOC__ int64v 1000000L - - let test_of_mutez_non_negative () = - match Tez_repr.of_mutez 1000000L with - | Some tz -> - Assert.equal_int64 - ~loc:__LOC__ - (Tez_repr.to_mutez tz) - Tez_repr.(to_mutez one) - | None -> failwith "should have successfully converted 1000000L to tez" - - let test_of_mutez_negative () = - match Tez_repr.of_mutez (-1000000L) with - | Some _ -> failwith "should have failed to converted -1000000L to tez" - | None -> return_unit - - let test_of_mutez_exn () = - try - let tz = Tez_repr.of_mutez_exn 1000000L in - Assert.equal_int64 - ~loc:__LOC__ - (Tez_repr.to_mutez tz) - Tez_repr.(to_mutez one) - with e -> - let msg = Printexc.to_string e and stack = Printexc.get_backtrace () in - failwith "Unexpected exception: %s %s" msg stack - - let test_of_mutez_exn_negative () = - try - let (_ : Tez_repr.t) = Tez_repr.of_mutez_exn (-1000000L) in - failwith "should have failed to converted -1000000L to tez" - with - | Invalid_argument _ -> return_unit - | e -> - let msg = Printexc.to_string e and stack = Printexc.get_backtrace () in - failwith "Unexpected exception: %s %s" msg stack - - (* NOTE: Avoid assertions against too many functions from Tez_repr. Convert them to - int64 and compare instead of using [Tez_repr]'s compare *) - - (** Testing [encoding], int64 underneath, by applying it with Data_encoding *) - let test_data_encoding () = - let encoding = Tez_repr.encoding in - let bytes = - Data_encoding.Binary.to_bytes_exn Data_encoding.n (Z.of_int 1000000) - in - (Data_encoding.Binary.of_bytes encoding bytes |> function - | Ok x -> Lwt.return (Ok x) - | Error e -> - failwith - "Data_encoding.Binary.read shouldn't have failed with \ - Tez_repr.encoding: %a" - Data_encoding.Binary.pp_read_error - e) - >>=? fun v -> Assert.equal_int64 ~loc:__LOC__ (Tez_repr.to_mutez v) 1000000L -end - -let tests = - [ - tztest - "Check if predefined values hold expected values" - `Quick - Test_tez_repr.test_predefined_values; - tztest "Tez.substract: basic behaviour" `Quick Test_tez_repr.test_subtract; - tztest - "Tez.substract: underflow case" - `Quick - Test_tez_repr.test_substract_underflow; - tztest - "Tez.add: basic behaviour (one + zero)" - `Quick - Test_tez_repr.test_addition; - tztest "Tez.add: overflow" `Quick Test_tez_repr.test_addition_overflow; - tztest "Tez.mul: basic case" `Quick Test_tez_repr.test_mul; - tztest "Tez.mul: overflow case" `Quick Test_tez_repr.test_mul_overflow; - tztest "Tez.div: basic case" `Quick Test_tez_repr.test_div; - tztest "Tez.div: division by zero" `Quick Test_tez_repr.test_div_by_zero; - tztest "Tez.to_mutez: basic assertion" `Quick Test_tez_repr.test_to_mutez; - tztest - "Tez.of_mutez: of non-negative ints" - `Quick - Test_tez_repr.test_of_mutez_non_negative; - tztest - "Tez.of_mutez: of negative ints" - `Quick - Test_tez_repr.test_of_mutez_negative; - tztest - "Tez.of_mutez_exn: of non-negative ints" - `Quick - Test_tez_repr.test_of_mutez_non_negative; - tztest - "Tez.of_mutez_exn: of negative ints" - `Quick - Test_tez_repr.test_of_mutez_negative; - tztest - "Tez.data_encoding: must encode tezzies correctly" - `Quick - Test_tez_repr.test_data_encoding; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("Tez_repr.ml", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_time_repr.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_time_repr.ml deleted file mode 100644 index a8e48e3065433cbdb688721eaf344d56196428a4..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_time_repr.ml +++ /dev/null @@ -1,48 +0,0 @@ -(** Testing - ------- - Component: Protocol (time repr) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_time_repr.ml - Subject: Error handling of time operations -*) - -open Protocol - -let test_nominal_add () = - let t = Time_repr.of_seconds (Int64.of_int 2) in - let addition = - Period_repr.of_seconds Int64.one >>? fun p -> Time_repr.( +? ) t p - in - match addition with - | Ok v -> - Assert.equal - ~loc:__LOC__ - Time_repr.equal - "test_nominal_add" - Time_repr.pp_hum - v - (Time_repr.of_seconds (Int64.of_int 3)) - | Error _ -> failwith "Addition has overflowed" - -let test_overflow_add () = - let t = Time_repr.of_seconds Int64.max_int in - match Period_repr.of_seconds Int64.one with - | Error _ -> failwith "period_repr conversion" - | Ok p -> ( - match Time_repr.( +? ) t p with - | Error _ -> return_unit - | Ok tres -> - failwith - "No overflow: %Ld + %Ld = %Ld" - (Time_repr.to_seconds t) - (Period_repr.to_seconds p) - (Time_repr.to_seconds tres)) - -let tests = - [ - Tztest.tztest "non-overflowing addition" `Quick test_nominal_add; - Tztest.tztest "overflowing addition" `Quick test_overflow_add; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("time", tests)] |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_protocol/test/unit/test_zk_rollup_storage.ml b/src/proto_017_PtNairob/lib_protocol/test/unit/test_zk_rollup_storage.ml deleted file mode 100644 index b67b4eac8aaff4de763f564e2a1b074d0fafed3a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_protocol/test/unit/test_zk_rollup_storage.ml +++ /dev/null @@ -1,398 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (Zk_rollup) - Invocation: dune exec src/proto_017_PtNairob/lib_protocol/test/unit/main.exe \ - -- --file test_zk_rollup_storage.ml - Subject: On ZK Rollup storage -*) - -open Protocol - -let wrap e = Lwt.return (Environment.wrap_tzresult e) - -let ( let** ) m f = - let open Lwt_result_syntax in - let* x = m >>= wrap in - f x - -let batch_size = 10 - -module ZKRU = struct - include Alpha_context.Zk_rollup - - type pkh = Signature.Public_key_hash.t - - let pkh_encoding = Signature.Public_key_hash.encoding - - type ticket_hash = Alpha_context.Ticket_hash.t - - let ticket_hash_encoding = Alpha_context.Ticket_hash.encoding -end - -module Operator = Dummy_zk_rollup.Operator (struct - let batch_size = batch_size -end) - -let no_ticket op = (op, None) - -module Raw_context_tests = struct - module Helpers = struct - let is_empty : Zk_rollup_repr.pending_list -> bool = function - | Zk_rollup_repr.Empty _ -> true - | _ -> false - - let pending_length : Zk_rollup_repr.pending_list -> int = - let open Zk_rollup_repr in - function Empty _ -> 0 | Pending {length; _} -> length - - let get_pending_list = - let open Lwt_result_syntax in - let open Zk_rollup_repr in - fun ctx rollup -> function - | Empty _ -> return (ctx, []) - | Pending {next_index; length} -> - let head = Int64.(sub next_index (of_int length)) in - let to_get = - Stdlib.List.init length (fun x -> Int64.(add (of_int x) head)) - in - let* ctx, ops = - List.fold_left_es - (fun (ctx, acc) i -> - let** ctx, op = - Storage.Zk_rollup.Pending_operation.get (ctx, rollup) i - in - return (ctx, op :: acc)) - (ctx, []) - to_get - in - return (ctx, List.rev ops) - end - - let initial_ctx () = - let open Lwt_result_syntax in - let* b, contract = Context.init1 () in - let** ctx = - Raw_context.prepare - b.context - ~level:b.header.shell.level - ~predecessor_timestamp:b.header.shell.timestamp - ~timestamp:b.header.shell.timestamp - in - let nonce = Operation_hash.hash_string ["nonce_hash"] in - return (Raw_context.init_origination_nonce ctx nonce, contract) - - (* Context with an originated ZKRU *) - let originate_ctx () = - let open Lwt_result_syntax in - let open Zk_rollup_account_repr in - let* ctx, contract = initial_ctx () in - let _prover_pp, public_parameters = Lazy.force Operator.lazy_pp in - let state = Operator.init_state in - let state_length = Array.length state in - let circuits_info = SMap.of_seq @@ Kzg.SMap.to_seq Operator.circuits in - let nb_ops = 1 in - let* ctx, rollup, _size = - Zk_rollup_storage.originate - ctx - {public_parameters; state_length; circuits_info; nb_ops} - ~init_state:state - >>= wrap - in - return (ctx, rollup, contract) - - (* Check that the pending list of a new ZKRU is empty *) - let pending_list_origination_is_empty () = - let open Lwt_result_syntax in - let* ctx, rollup, _contract = originate_ctx () in - let** _ctx, pending = Storage.Zk_rollup.Pending_list.get ctx rollup in - assert (Helpers.is_empty pending) ; - return_unit - - (* Check that appending an L2 operation with the [add_to_pending] helper - correctly updates both the pending list descriptor and the actual - operations under the [pending_operations] directory. *) - let pending_list_append () = - let open Lwt_result_syntax in - let* ctx, rollup, _contract = originate_ctx () in - let pkh, _, _ = Signature.generate_key () in - let op = - no_ticket - Zk_rollup_operation_repr. - { - op_code = 0; - price = {id = Ticket_hash_repr.zero; amount = Z.zero}; - l1_dst = pkh; - rollup_id = rollup; - payload = [||]; - } - in - (* Append first operation *) - let** ctx, _size = Zk_rollup_storage.add_to_pending ctx rollup [op] in - let** ctx, pending = Storage.Zk_rollup.Pending_list.get ctx rollup in - assert (Helpers.pending_length pending = 1) ; - let* ctx, ops = Helpers.get_pending_list ctx rollup pending in - assert (List.length ops = 1) ; - (* Append second operation *) - let** ctx, _size = Zk_rollup_storage.add_to_pending ctx rollup [op] in - let** ctx, pending = Storage.Zk_rollup.Pending_list.get ctx rollup in - let* _ctx, ops = Helpers.get_pending_list ctx rollup pending in - assert (Helpers.pending_length pending = 2) ; - assert (List.length ops = 2) ; - return_unit - - let pending_list_append_errors () = - let open Lwt_result_syntax in - let* ctx, rollup, _contract = originate_ctx () in - let pkh, _, _ = Signature.generate_key () in - let op = - no_ticket - Zk_rollup_operation_repr. - { - op_code = 0; - price = {id = Ticket_hash_repr.zero; amount = Z.zero}; - l1_dst = pkh; - rollup_id = rollup; - payload = [||]; - } - in - (* Append first operation *) - let** ctx, _size = Zk_rollup_storage.add_to_pending ctx rollup [op] in - let** ctx, pending = Storage.Zk_rollup.Pending_list.get ctx rollup in - assert (Helpers.pending_length pending = 1) ; - let* ctx, ops = Helpers.get_pending_list ctx rollup pending in - assert (List.length ops = 1) ; - (* Invalid op code *) - let wrong_op = - no_ticket - Zk_rollup_operation_repr. - { - op_code = 1; - price = {id = Ticket_hash_repr.zero; amount = Z.zero}; - l1_dst = pkh; - rollup_id = rollup; - payload = [||]; - } - in - let*! e = Zk_rollup_storage.add_to_pending ctx rollup [wrong_op] >>= wrap in - let* () = - Assert.proto_error_with_info ~loc:__LOC__ e "Invalid op code in append" - in - (* Invalid rollup address *) - let* _ctx, nonce = Raw_context.increment_origination_nonce ctx |> wrap in - let* address = - Zk_rollup_repr.Address.from_nonce (Origination_nonce.incr nonce) |> wrap - in - let*! e = Zk_rollup_storage.add_to_pending ctx address [op] >>= wrap in - let expected_message = "Storage error (fatal internal error)" in - Assert.proto_error_with_info ~loc:__LOC__ e expected_message - - (* Check that the [get_prefix] helper actually returns a list of the - desired length. *) - let pending_list_get () = - let open Lwt_result_syntax in - let* ctx, rollup, _contract = originate_ctx () in - let pkh, _pk, _sk = Signature.generate_key () in - let op = - no_ticket - Zk_rollup_operation_repr. - { - op_code = 0; - price = {id = Ticket_hash_repr.zero; amount = Z.zero}; - l1_dst = pkh; - rollup_id = rollup; - payload = [|Bls12_381.Fr.one|]; - } - in - let** ctx, _size = Zk_rollup_storage.add_to_pending ctx rollup [op; op] in - let** _ctx, prefix = Zk_rollup_storage.get_prefix ctx rollup 1 in - assert (List.length prefix = 1) ; - return_unit - - (* Check the [get_prefix] errors. *) - let pending_list_errors () = - let open Lwt_result_syntax in - let* ctx, rollup, _contract = originate_ctx () in - let pkh, _pk, _sk = Signature.generate_key () in - let op = - no_ticket - Zk_rollup_operation_repr. - { - op_code = 0; - price = {id = Ticket_hash_repr.zero; amount = Z.zero}; - l1_dst = pkh; - rollup_id = rollup; - payload = [|Bls12_381.Fr.one|]; - } - in - (* Initialise the pending list with 2 operations *) - let** ctx, _size = Zk_rollup_storage.add_to_pending ctx rollup [op; op] in - (* Check that retrieving too many ops returns an error *) - let*! e = Zk_rollup_storage.get_prefix ctx rollup 3 >>= wrap in - let* () = - Assert.proto_error_with_info ~loc:__LOC__ e "Pending list is too short" - in - (* Check that retrieving a negative number of ops returns an error *) - let*! e = Zk_rollup_storage.get_prefix ctx rollup (-1) >>= wrap in - let* () = - Assert.proto_error_with_info - ~loc:__LOC__ - e - "Negative length for pending list prefix" - in - (* Check that get prefix fails with invalid zkru address *) - let* _ctx, nonce = Raw_context.increment_origination_nonce ctx |> wrap in - let* address = - Zk_rollup_repr.Address.from_nonce (Origination_nonce.incr nonce) |> wrap - in - let*! e = Zk_rollup_storage.get_prefix ctx address (-1) >>= wrap in - Assert.proto_error_with_info - ~loc:__LOC__ - e - "Storage error (fatal internal error)" - - (* Check that the [update] helper correctly removes a prefix of the - pending list (both in the descriptor and the actual operations storage). - *) - let test_update () = - let open Lwt_result_syntax in - (* Originate rollup and contract *) - let* ctx, rollup, contract = originate_ctx () in - let pkh = - match contract with Originated _ -> assert false | Implicit pkh -> pkh - in - let op = - no_ticket - Zk_rollup_operation_repr. - { - op_code = 0; - price = {id = Ticket_hash_repr.zero; amount = Z.zero}; - l1_dst = pkh; - rollup_id = rollup; - payload = [|Bls12_381.Fr.one|]; - } - in - (* Populate rollup with 2 ops *) - let** ctx, _size = Zk_rollup_storage.add_to_pending ctx rollup [op; op] in - let** ctx, acc = Storage.Zk_rollup.Account.get ctx rollup in - (* Processing first pending op *) - let** ctx = - Zk_rollup_storage.update ctx rollup ~pending_to_drop:1 ~new_account:acc - in - (* Check that op at index 0 has been removed *) - let** ctx, opt = - Storage.Zk_rollup.Pending_operation.find (ctx, rollup) 0L - in - assert (Option.is_none opt) ; - (* Check that pending list still has one op *) - let** ctx, pending = Storage.Zk_rollup.Pending_list.get ctx rollup in - assert (Helpers.pending_length pending = 1) ; - let* _ctx, ops = Helpers.get_pending_list ctx rollup pending in - assert (List.length ops = 1) ; - return_unit - - let test_update_errors () = - let open Lwt_result_syntax in - (* Originate rollup and contract *) - let* ctx, rollup, contract = originate_ctx () in - let pkh = - match contract with Originated _ -> assert false | Implicit pkh -> pkh - in - let op = - no_ticket - Zk_rollup_operation_repr. - { - op_code = 0; - price = {id = Ticket_hash_repr.zero; amount = Z.zero}; - l1_dst = pkh; - rollup_id = rollup; - payload = [|Bls12_381.Fr.one|]; - } - in - (* Populate rollup with 2 ops *) - let** ctx, _size = Zk_rollup_storage.add_to_pending ctx rollup [op; op] in - let** ctx, acc = Storage.Zk_rollup.Account.get ctx rollup in - (* Processing too many ops *) - let*! e = - Zk_rollup_storage.update ctx rollup ~pending_to_drop:3 ~new_account:acc - >>= wrap - in - let* () = - Assert.proto_error_with_info ~loc:__LOC__ e "Pending list is too short" - in - (* Processing negative number of ops *) - let*! e = - Zk_rollup_storage.update ctx rollup ~pending_to_drop:(-3) ~new_account:acc - >>= wrap - in - let* () = - Assert.proto_error_with_info - ~loc:__LOC__ - e - "Negative length for pending list prefix" - in - (* Update with wrong address *) - let* _ctx, nonce = Raw_context.increment_origination_nonce ctx |> wrap in - let* address = - Zk_rollup_repr.Address.from_nonce (Origination_nonce.incr nonce) |> wrap - in - let*! e = - Zk_rollup_storage.update ctx address ~pending_to_drop:1 ~new_account:acc - >>= wrap - in - Assert.proto_error_with_info - ~loc:__LOC__ - e - "Storage error (fatal internal error)" -end - -let tests = - [ - Tztest.tztest - "origination_pending_is_empty" - `Quick - Raw_context_tests.pending_list_origination_is_empty; - Tztest.tztest - "pending_list_append" - `Quick - Raw_context_tests.pending_list_append; - Tztest.tztest - "pending_list_append errors" - `Quick - Raw_context_tests.pending_list_append_errors; - Tztest.tztest "pending_list_get" `Quick Raw_context_tests.pending_list_get; - Tztest.tztest - "pending_list_get errors" - `Quick - Raw_context_tests.pending_list_errors; - Tztest.tztest "update" `Quick Raw_context_tests.test_update; - Tztest.tztest "update errors" `Quick Raw_context_tests.test_update_errors; - ] - -let () = - Alcotest_lwt.run ~__FILE__ Protocol.name [("zk rollup storage", tests)] - |> Lwt_main.run diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/RPC_directory.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/RPC_directory.ml deleted file mode 100644 index ecea15fb6eb315b341249a0f5f09ac2294606383..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/RPC_directory.ml +++ /dev/null @@ -1,299 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* Copyright (c) 2022-2023 TriliTech *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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 Rpc_directory_helpers -open Protocol -open Context_wrapper.Irmin - -module Slot_pages_map = struct - open Protocol - open Alpha_context - include Map.Make (Dal.Slot_index) -end - -let get_dal_processed_slots node_ctxt block = - Node_context.list_slots_statuses node_ctxt ~confirmed_in_block_hash:block - -module Block_directory = Make_sub_directory (struct - include Sc_rollup_services.Block - - type context = Node_context.rw - - type subcontext = Node_context.ro * Block_hash.t - - let context_of_prefix node_ctxt (((), block) : prefix) = - let open Lwt_result_syntax in - let+ block = Block_directory_helpers.block_of_prefix node_ctxt block in - (Node_context.readonly node_ctxt, block) -end) - -module Block_helpers_directory = Make_sub_directory (struct - include Sc_rollup_services.Block.Helpers - - (* The context needs to be accessed with write permissions because we need to - commit on disk to generate the proofs. *) - type context = Node_context.rw - - (* The context needs to be accessed with write permissions because we need to - commit on disk to generate the proofs. *) - type subcontext = Node_context.rw * Block_hash.t - - let context_of_prefix node_ctxt (((), block) : prefix) = - let open Lwt_result_syntax in - let+ block = Block_directory_helpers.block_of_prefix node_ctxt block in - (node_ctxt, block) -end) - -module Common = struct - let () = - Block_directory.register0 Sc_rollup_services.Block.block - @@ fun (node_ctxt, block) () () -> - Node_context.get_full_l2_block node_ctxt block - - let () = - Block_directory.register0 Sc_rollup_services.Block.num_messages - @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let* l2_block = Node_context.get_l2_block node_ctxt block in - let+ num_messages = - Node_context.get_num_messages node_ctxt l2_block.header.inbox_witness - in - Z.of_int num_messages - - let () = - Block_directory.register0 Sc_rollup_services.Block.hash - @@ fun (_node_ctxt, block) () () -> return block - - let () = - Block_directory.register0 Sc_rollup_services.Block.level - @@ fun (node_ctxt, block) () () -> - Node_context.level_of_hash node_ctxt block - - let () = - Block_directory.register0 Sc_rollup_services.Block.inbox - @@ fun (node_ctxt, block) () () -> - Node_context.get_inbox_by_block_hash node_ctxt block - - let () = - Block_directory.register0 Sc_rollup_services.Block.ticks - @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let+ l2_block = Node_context.get_l2_block node_ctxt block in - Z.of_int64 l2_block.num_ticks -end - -let get_state (node_ctxt : _ Node_context.t) block_hash = - let open Lwt_result_syntax in - let* ctxt = Node_context.checkout_context node_ctxt block_hash in - let*! state = Context.PVMState.find ctxt in - match state with - | None -> failwith "No state" - | Some state -> return (state, of_node_pvmstate state) - -let simulate_messages (node_ctxt : Node_context.ro) block ~reveal_pages - ~insight_requests ~log_kernel_debug_file messages = - let open Lwt_result_syntax in - let open Alpha_context in - let module PVM = (val Pvm.of_kind node_ctxt.kind) in - let reveal_map = - match reveal_pages with - | Some pages -> - let (module DAC_plugin) = - WithExceptions.Option.get ~loc:__LOC__ @@ Dac_plugin.get Protocol.hash - in - let map = - List.fold_left - (fun map page -> - let hash = DAC_plugin.hash_string ~scheme:Blake2B [page] in - Utils.Reveal_hash_map.add hash page map) - Utils.Reveal_hash_map.empty - pages - in - Some map - | None -> None - in - let* level = Node_context.level_of_hash node_ctxt block in - let* sim = - Simulation.start_simulation - node_ctxt - ~reveal_map - ?log_kernel_debug_file - Layer1.{hash = block; level} - in - let* sim, num_ticks_0 = Simulation.simulate_messages sim messages in - let* {state; inbox_level; _}, num_ticks_end = Simulation.end_simulation sim in - let*! insights = - List.map_p - (function - | Sc_rollup_services.Pvm_state_key key -> - PVM.State.lookup (of_node_pvmstate state) key - | Durable_storage_key key -> - PVM.Inspect_durable_state.lookup (of_node_pvmstate state) key) - insight_requests - in - let num_ticks = Z.(num_ticks_0 + num_ticks_end) in - let level = Raw_level.of_int32_exn inbox_level in - let*! outbox = PVM.get_outbox level (of_node_pvmstate state) in - let output = - List.filter (fun Sc_rollup.{outbox_level; _} -> outbox_level = level) outbox - in - let*! state_hash = PVM.state_hash (of_node_pvmstate state) in - let*! status = PVM.get_status (of_node_pvmstate state) in - let status = PVM.string_of_status status in - return - Sc_rollup_services. - {state_hash; status; output; inbox_level; num_ticks; insights} - -let () = - Block_directory.register0 Sc_rollup_services.Block.total_ticks - @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let* _, state = get_state node_ctxt block in - let module PVM = (val Pvm.of_kind node_ctxt.kind) in - let*! tick = PVM.get_tick state in - return tick - -let () = - Block_directory.register0 Sc_rollup_services.Block.state_hash - @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let* _, state = get_state node_ctxt block in - let module PVM = (val Pvm.of_kind node_ctxt.kind) in - let*! hash = PVM.state_hash state in - return hash - -let () = - Block_directory.register0 Sc_rollup_services.Block.state_current_level - @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let* _, state = get_state node_ctxt block in - let module PVM = (val Pvm.of_kind node_ctxt.kind) in - let*! current_level = PVM.get_current_level state in - return current_level - -let () = - Block_directory.register0 Sc_rollup_services.Block.state_value - @@ fun (node_ctxt, block) {key} () -> - let open Lwt_result_syntax in - let* ctx, _state = get_state node_ctxt block in - let path = String.split_on_char '/' key in - let*! value = Context.PVMState.lookup ctx path in - match value with - | None -> failwith "No such key in PVM state" - | Some value -> - Format.eprintf "Encoded %S\n@.%!" (Bytes.to_string value) ; - return value - -let () = - Block_directory.register0 Sc_rollup_services.Block.status - @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let* _, state = get_state node_ctxt block in - let module PVM = (val Pvm.of_kind node_ctxt.kind) in - let*! status = PVM.get_status state in - return (PVM.string_of_status status) - -let () = - Block_directory.register0 Sc_rollup_services.Block.dal_slots - @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let+ slots = - Node_context.get_all_slot_headers node_ctxt ~published_in_block_hash:block - in - List.rev_map Sc_rollup_proto_types.Dal.Slot_header.of_octez slots |> List.rev - -let () = - Block_directory.register0 Sc_rollup_services.Block.dal_processed_slots - @@ fun (node_ctxt, block) () () -> get_dal_processed_slots node_ctxt block - -let () = - Block_directory.register0 Sc_rollup_services.Block.outbox - @@ fun (node_ctxt, block) outbox_level () -> - let open Lwt_result_syntax in - let* _, state = get_state node_ctxt block in - let module PVM = (val Pvm.of_kind node_ctxt.kind) in - let*! outbox = PVM.get_outbox outbox_level state in - return outbox - -let () = - Block_directory.register1 Sc_rollup_services.Block.outbox_messages - @@ fun (node_ctxt, block) outbox_level () () -> - let open Lwt_result_syntax in - let* _, state = get_state node_ctxt block in - let module PVM = (val Pvm.of_kind node_ctxt.kind) in - let*! outbox = PVM.get_outbox outbox_level state in - return outbox - -let () = - Block_helpers_directory.register0 - Sc_rollup_services.Block.Helpers.outbox_proof - @@ fun (node_ctxt, _block_hash) output () -> - let open Lwt_result_syntax in - let+ commitment, proof = Outbox.proof_of_output node_ctxt output in - (Sc_rollup_proto_types.Commitment_hash.of_octez commitment, proof) - -let () = - Block_helpers_directory.register1 - Sc_rollup_services.Block.Helpers.outbox_proof_simple - @@ fun (node_ctxt, _block_hash) outbox_level message_index () -> - let open Lwt_result_syntax in - let+ commitment, proof = - Outbox.proof_of_output_simple node_ctxt ~outbox_level ~message_index - in - (Sc_rollup_proto_types.Commitment_hash.of_octez commitment, proof) - -let () = - Block_directory.register0 Sc_rollup_services.Block.simulate - @@ fun (node_ctxt, block) - () - {messages; reveal_pages; insight_requests; log_kernel_debug_file} - -> - simulate_messages - node_ctxt - block - ~reveal_pages - ~insight_requests - ~log_kernel_debug_file - messages - -let block_directory (node_ctxt : _ Node_context.t) = - let module PVM = (val Pvm_rpc.of_kind node_ctxt.kind) in - List.fold_left - (fun dir f -> Tezos_rpc.Directory.merge dir (f node_ctxt)) - Tezos_rpc.Directory.empty - [ - Block_directory.build_sub_directory; - Block_helpers_directory.build_sub_directory; - PVM.build_sub_directory; - ] - -let directory (node_ctxt : _ Node_context.t) = - Tezos_rpc.Directory.merge - (Octez_smart_rollup_node.Rpc_directory.top_directory node_ctxt) - (Tezos_rpc.Directory.prefix - Sc_rollup_services.Block.prefix - (block_directory node_ctxt)) diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/RPC_directory.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/RPC_directory.mli deleted file mode 100644 index 1cac46c2ded4ff6d534f64eb1db05f8599832038..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/RPC_directory.mli +++ /dev/null @@ -1,33 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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 RPC directory, specific to blocks, for this rollup node. *) -val block_directory : - Node_context.rw -> - (unit * Rollup_node_services.Arg.block_id) Tezos_rpc.Directory.t - -(** The full RPC directory for this rollup node, merging the top level directory - and the block directory. *) -val directory : Node_context.rw -> unit Tezos_rpc.Directory.t diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/arith_pvm.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/arith_pvm.ml deleted file mode 100644 index 276d555ce826397c7755db28ee3e4bea2e5a19b7..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/arith_pvm.ml +++ /dev/null @@ -1,91 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022-2023 TriliTech *) -(* *) -(* 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 -open Alpha_context - -(** This module manifests the proof format used by the Arith PVM as defined by - the Layer 1 implementation for it. - - It is imperative that this is aligned with the protocol's implementation. -*) -module Arith_proof_format = - Irmin_context.Proof - (struct - include Sc_rollup.State_hash - - let of_context_hash = Sc_rollup.State_hash.context_hash_to_state_hash - end) - (struct - let proof_encoding = - Tezos_context_merkle_proof_encoding.Merkle_proof_encoding.V2.Tree2 - .tree_proof_encoding - end) - -module Impl : Pvm_sig.S = struct - module PVM = Sc_rollup.ArithPVM.Make (Arith_proof_format) - include PVM - - let kind = Sc_rollup.Kind.Example_arith - - module State = Irmin_context.PVMState - - module Inspect_durable_state = struct - let lookup _state _keys = - raise (Invalid_argument "No durable storage for arith PVM") - end - - let new_dissection = Game_helpers.default_new_dissection - - let string_of_status status = - match status with - | Halted -> "Halted" - | Waiting_for_input_message -> "Waiting for input message" - | Waiting_for_reveal -> "Waiting for reveal" - | Waiting_for_metadata -> "Waiting for metadata" - | Parsing -> "Parsing" - | Evaluating -> "Evaluating" - - let eval_many ~reveal_builtins:_ ~write_debug:_ ?stop_at_snapshot ~max_steps - initial_state = - ignore stop_at_snapshot ; - let rec go state step = - let open Lwt.Syntax in - let* is_input_required = is_input_state state in - - if is_input_required = No_input_required && step < max_steps then - let open Lwt.Syntax in - (* Note: This is not an efficient implementation because the state is - decoded/encoded to/from the tree at each step but for Arith PVM - it doesn't matter - *) - let* next_state = eval state in - go next_state (Int64.succ step) - else Lwt.return (state, step) - in - go initial_state 0L -end - -include Impl diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/batcher_constants.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/batcher_constants.ml deleted file mode 100644 index edfa3ea32f006f8995fb2ca4999e28d87e98df71..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/batcher_constants.ml +++ /dev/null @@ -1,56 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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 message_size_limit = Protocol.Constants_repr.sc_rollup_message_size_limit - -let protocol_max_batch_size = - let open Protocol in - let open Alpha_context in - let empty_message_op : _ Operation.t = - let open Operation in - { - shell = {branch = Block_hash.zero}; - protocol_data = - { - signature = Some Signature.zero; - contents = - Single - (Manager_operation - { - source = Signature.Public_key_hash.zero; - fee = Tez.of_mutez_exn Int64.max_int; - counter = Manager_counter.Internal_for_tests.of_int max_int; - gas_limit = - Gas.Arith.integral_of_int_exn ((max_int - 1) / 1000); - storage_limit = Z.of_int max_int; - operation = Sc_rollup_add_messages {messages = [""]}; - }); - }; - } - in - Protocol.Constants_repr.max_operation_data_length - - Data_encoding.Binary.length - Operation.encoding - (Operation.pack empty_message_op) diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/batcher_constants.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/batcher_constants.mli deleted file mode 100644 index dda41ddc6be1ad185be0997f1f289daae059f0c2..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/batcher_constants.mli +++ /dev/null @@ -1,32 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Maximum size of an L2 message allowed by the prototcol. Is - {!val:Protocol.Constants_repr.sc_rollup_message_size_limit}. *) -val message_size_limit : int - -(** Maximum size in bytes of an batch of L2 messages that can fit in an - operation on L1. It is protocol dependent. *) -val protocol_max_batch_size : int diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/context_wrapper.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/context_wrapper.ml deleted file mode 100644 index 9708f39af66f9a7e16662751c02868607e10c1fe..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/context_wrapper.ml +++ /dev/null @@ -1,88 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* *) -(* 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 Context_sigs - -(* Context *) -let of_node_context : - type repo tree. - (repo, tree) equality_witness -> - 'a Context.t -> - ('a, repo, tree) Context_sigs.t = - fun eqw (Context {equality_witness; tree; index; _}) -> - match Context.equiv equality_witness eqw with - | Some Refl, Some Refl -> {index; tree} - | _ -> - (* This could happen if the context backend was to change for a - given pvm/rollup. For now we only use Irmin, if this changes, - this will demand to provide migration functions from prior - pmv_context to the next one. *) - assert false - -let to_node_context : - type repo tree. - (module Context_sigs.S with type tree = tree and type repo = repo) -> - ('a, repo, tree) Context_sigs.t -> - 'a Context.t = - fun (module C) {index; tree} -> - Context.make - ~index - ~tree - ~pvm_context_impl:(module C) - ~equality_witness:C.equality_witness - ~impl_name:C.impl_name - -(* PVMState *) -let of_node_pvmstate : - type repo tree. (repo, tree) equality_witness -> Context.pvmstate -> tree = - fun eqw (PVMState {equality_witness; pvmstate; _}) -> - match Context.equiv equality_witness eqw with - | Some Refl, Some Refl -> pvmstate - | _ -> assert false - -let to_node_pvmstate : - type tree. - (module Context_sigs.S with type tree = tree) -> tree -> Context.pvmstate = - fun (module C) pvmstate -> - Context.make_pvmstate - ~pvmstate - ~pvm_context_impl:(module C) - ~equality_witness:C.equality_witness - ~impl_name:"Irmin" - -module Irmin = struct - module I = Irmin_context - - let of_node_context : 'a Context.t -> ('a, I.repo, I.tree) Context_sigs.t = - fun ctxt -> of_node_context I.equality_witness ctxt - - let to_node_context : ('a, I.repo, I.tree) Context_sigs.t -> 'a Context.t = - fun ctxt -> to_node_context (module I) ctxt - - let of_node_pvmstate : Context.pvmstate -> I.tree = - fun c -> of_node_pvmstate I.equality_witness c - - let to_node_pvmstate : I.tree -> Context.pvmstate = - to_node_pvmstate (module I) -end diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/context_wrapper.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/context_wrapper.mli deleted file mode 100644 index e476055db70f2d668cb65cc62e5da7ebd0aa7099..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/context_wrapper.mli +++ /dev/null @@ -1,59 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* *) -(* 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 modules offers functions to translate from node-context and - node-pvmstate representation to those used in the PVM *) -open Context_sigs - -(* Context *) -val of_node_context : - ('repo, 'tree) equality_witness -> - [`Read | `Write] Context.t -> - ([`Read | `Write], 'repo, 'tree) Context_sigs.t - -val to_node_context : - (module Context_sigs.S with type tree = 'tree and type repo = 'repo) -> - ('a, 'repo, 'tree) Context_sigs.t -> - 'a Context.t - -(* PVMState *) -val of_node_pvmstate : - ('repo, 'tree) equality_witness -> Context.pvmstate -> 'tree - -val to_node_pvmstate : - (module Context_sigs.S with type tree = 'tree) -> 'tree -> Context.pvmstate - -(** Specialized module to handle translation to/from Irmin_context *) -module Irmin : sig - val of_node_context : - 'a Context.t -> ('a, Irmin_context.repo, Irmin_context.tree) Context_sigs.t - - val to_node_context : - ('a, Irmin_context.repo, Irmin_context.tree) Context_sigs.t -> 'a Context.t - - val of_node_pvmstate : Context.pvmstate -> Irmin_context.tree - - val to_node_pvmstate : Irmin_context.tree -> Context.pvmstate -end diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/daemon_helpers.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/daemon_helpers.ml deleted file mode 100644 index c974a66a962dd0eb872a8a1dbdefcaad08617fd9..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/daemon_helpers.ml +++ /dev/null @@ -1,344 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* Copyright (c) 2023 TriliTech *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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 -open Alpha_context -open Apply_results - -let check_pvm_initial_state_hash {Node_context.cctxt; config; kind; _} = - let open Lwt_result_syntax in - let module PVM = (val Pvm.of_kind kind) in - let* l1_reference_initial_state_hash = - RPC.Sc_rollup.initial_pvm_state_hash - (new Protocol_client_context.wrap_full cctxt) - (cctxt#chain, cctxt#block) - (Sc_rollup_proto_types.Address.of_octez config.sc_rollup_address) - in - let*! s = PVM.initial_state ~empty:(PVM.State.empty ()) in - let*! l2_initial_state_hash = PVM.state_hash s in - let l1_reference_initial_state_hash = - Sc_rollup_proto_types.State_hash.to_octez l1_reference_initial_state_hash - in - let l2_initial_state_hash = - Sc_rollup_proto_types.State_hash.to_octez l2_initial_state_hash - in - fail_unless - Octez_smart_rollup.State_hash.( - l1_reference_initial_state_hash = l2_initial_state_hash) - (Sc_rollup_node_errors.Wrong_initial_pvm_state - { - initial_state_hash = l2_initial_state_hash; - expected_state_hash = l1_reference_initial_state_hash; - }) - -(** Returns [Some c] if [their_commitment] is refutable where [c] is our - commitment for the same inbox level. *) -let is_refutable_commitment node_ctxt - (their_commitment : Octez_smart_rollup.Commitment.t) their_commitment_hash = - let open Lwt_result_syntax in - let* l2_block = - Node_context.get_l2_block_by_level node_ctxt their_commitment.inbox_level - in - let* our_commitment_and_hash = - Option.filter_map_es - (fun hash -> - let+ commitment = Node_context.find_commitment node_ctxt hash in - Option.map (fun c -> (c, hash)) commitment) - l2_block.header.commitment_hash - in - match our_commitment_and_hash with - | Some (our_commitment, our_commitment_hash) - when Octez_smart_rollup.Commitment.Hash.( - their_commitment_hash <> our_commitment_hash - && their_commitment.predecessor = our_commitment.predecessor) -> - return our_commitment_and_hash - | _ -> return_none - -(** Publish a commitment when an accuser node sees a refutable commitment. *) -let accuser_publish_commitment_when_refutable node_ctxt ~other rollup - their_commitment their_commitment_hash = - let open Lwt_result_syntax in - when_ (Node_context.is_accuser node_ctxt) @@ fun () -> - (* We are seeing a commitment from someone else. We check if we agree - with it, otherwise the accuser publishes our commitment in order to - play the refutation game. *) - let* refutable = - is_refutable_commitment node_ctxt their_commitment their_commitment_hash - in - match refutable with - | None -> return_unit - | Some (our_commitment, our_commitment_hash) -> - let*! () = - Refutation_game_event.potential_conflict_detected - ~our_commitment_hash - ~their_commitment_hash - ~level:their_commitment.inbox_level - ~other - in - assert ( - Octez_smart_rollup.Address.(node_ctxt.config.sc_rollup_address = rollup)) ; - Publisher.publish_single_commitment node_ctxt our_commitment - -(** If in bailout mode and when the operator is not staked on any - commitment, the bond is recovered. *) -let maybe_recover_bond node_ctxt = - let open Lwt_result_syntax in - if Node_context.is_bailout node_ctxt then - let operating_pkh = Node_context.get_operator node_ctxt Operating in - match operating_pkh with - | None -> return_unit - | Some (Single operating_pkh) -> ( - let* staked_on_commitment = - RPC.Sc_rollup.staked_on_commitment - (new Protocol_client_context.wrap_full node_ctxt.cctxt) - (node_ctxt.cctxt#chain, `Head 0) - (Sc_rollup_proto_types.Address.of_octez - node_ctxt.config.sc_rollup_address) - operating_pkh - in - match staked_on_commitment with - | None -> Publisher.recover_bond node_ctxt - | Some _ (* operator still staked on something *) -> return_unit) - else return_unit - -(** Process an L1 SCORU operation (for the node's rollup) which is included - for the first time. {b Note}: this function does not process inboxes for - the rollup, which is done instead by {!Inbox.process_head}. *) -let process_included_l1_operation (type kind) (node_ctxt : Node_context.rw) - (head : Layer1.header) ~source (operation : kind manager_operation) - (result : kind successful_manager_operation_result) = - let open Lwt_result_syntax in - match (operation, result) with - | ( Sc_rollup_publish {commitment; _}, - Sc_rollup_publish_result {published_at_level; _} ) - when Node_context.is_operator node_ctxt source -> - (* Published commitment --------------------------------------------- *) - let commitment = Sc_rollup_proto_types.Commitment.to_octez commitment in - let commitment_hash = Octez_smart_rollup.Commitment.hash commitment in - let* () = - Node_context.register_published_commitment - node_ctxt - commitment - ~first_published_at_level:(Raw_level.to_int32 published_at_level) - ~level:head.Layer1.level - ~published_by_us:true - in - let*! () = - Commitment_event.last_published_commitment_updated - commitment_hash - head.Layer1.level - in - return_unit - | ( Sc_rollup_publish {commitment = their_commitment; rollup}, - Sc_rollup_publish_result - {published_at_level; staked_hash = their_commitment_hash; _} ) -> - (* Commitment published by someone else *) - (* We first register the publication information *) - let their_commitment_hash = - Sc_rollup_proto_types.Commitment_hash.to_octez their_commitment_hash - in - let* known_commitment = - Node_context.commitment_exists node_ctxt their_commitment_hash - in - let* () = - if not known_commitment then return_unit - else - Node_context.register_published_commitment - node_ctxt - (Sc_rollup_proto_types.Commitment.to_octez their_commitment) - ~first_published_at_level:(Raw_level.to_int32 published_at_level) - ~level:head.Layer1.level - ~published_by_us:false - in - (* An accuser node will publish its commitment if the other one is - refutable. *) - let rollup = Sc_rollup_proto_types.Address.to_octez rollup in - let their_commitment = - Sc_rollup_proto_types.Commitment.to_octez their_commitment - in - accuser_publish_commitment_when_refutable - node_ctxt - ~other:source - rollup - their_commitment - their_commitment_hash - | ( Sc_rollup_cement _, - Sc_rollup_cement_result {inbox_level; commitment_hash; _} ) -> - (* Cemented commitment ---------------------------------------------- *) - let inbox_level = Raw_level.to_int32 inbox_level in - let commitment_hash = - Sc_rollup_proto_types.Commitment_hash.to_octez commitment_hash - in - let* inbox_block = - Node_context.get_l2_block_by_level node_ctxt inbox_level - in - let*? () = - (* We stop the node if we disagree with a cemented commitment *) - let our_commitment_hash = inbox_block.header.commitment_hash in - error_unless - (Option.equal - Octez_smart_rollup.Commitment.Hash.( = ) - our_commitment_hash - (Some commitment_hash)) - (Sc_rollup_node_errors.Disagree_with_cemented - {inbox_level; ours = our_commitment_hash; on_l1 = commitment_hash}) - in - let* () = - Node_context.set_lcc - node_ctxt - {commitment = commitment_hash; level = inbox_level} - in - let* () = maybe_recover_bond node_ctxt in - return_unit - | ( Sc_rollup_refute _, - Sc_rollup_refute_result {game_status = Ended end_status; _} ) - | ( Sc_rollup_timeout _, - Sc_rollup_timeout_result {game_status = Ended end_status; _} ) -> ( - match end_status with - | Loser {loser; reason} when Node_context.is_operator node_ctxt loser -> - let result = - match reason with - | Conflict_resolved -> Sc_rollup_node_errors.Conflict_resolved - | Timeout -> Timeout - in - tzfail (Sc_rollup_node_errors.Lost_game result) - | Loser _ -> - (* Other player lost *) - return_unit - | Draw -> - let stakers = - match operation with - | Sc_rollup_refute {opponent; _} -> [source; opponent] - | Sc_rollup_timeout {stakers = {alice; bob}; _} -> [alice; bob] - | _ -> assert false - in - fail_when - (List.exists (Node_context.is_operator node_ctxt) stakers) - (Sc_rollup_node_errors.Lost_game Draw)) - | Dal_publish_slot_header _, Dal_publish_slot_header_result {slot_header; _} - when Node_context.dal_supported node_ctxt -> - let* () = - Node_context.save_slot_header - node_ctxt - ~published_in_block_hash:head.Layer1.hash - (Sc_rollup_proto_types.Dal.Slot_header.to_octez slot_header) - in - return_unit - (* If the node is in bailout mode and the bond of the operator has - been recovered then initiate an exit from bailout mode and - gracefully shut down the process. Otherwise, no action is - taken. *) - | Sc_rollup_recover_bond {staker; _}, Sc_rollup_recover_bond_result _ - when Node_context.is_bailout node_ctxt -> ( - match Node_context.get_operator node_ctxt Operating with - | Some (Single operating_pkh) -> - fail_when - Signature.Public_key_hash.(operating_pkh = staker) - Sc_rollup_node_errors.Exit_bond_recovered_bailout_mode - | _ -> return_unit) - | _, _ -> - (* Other manager operations *) - return_unit - -let process_l1_operation (type kind) node_ctxt (head : Layer1.header) ~source - (operation : kind manager_operation) - (result : kind Apply_results.manager_operation_result) = - let open Lwt_result_syntax in - let is_for_my_rollup : type kind. kind manager_operation -> bool = function - | Sc_rollup_add_messages _ -> true - | Sc_rollup_cement {rollup; _} - | Sc_rollup_publish {rollup; _} - | Sc_rollup_refute {rollup; _} - | Sc_rollup_timeout {rollup; _} - | Sc_rollup_execute_outbox_message {rollup; _} - | Sc_rollup_recover_bond {sc_rollup = rollup; staker = _} -> - Octez_smart_rollup.Address.( - Sc_rollup_proto_types.Address.to_octez rollup - = node_ctxt.Node_context.config.sc_rollup_address) - | Dal_publish_slot_header _ -> true - | Reveal _ | Transaction _ | Origination _ | Delegation _ - | Update_consensus_key _ | Register_global_constant _ | Set_deposits_limit _ - | Increase_paid_storage _ | Transfer_ticket _ | Sc_rollup_originate _ - | Zk_rollup_origination _ | Zk_rollup_publish _ | Zk_rollup_update _ -> - false - in - (* Only look at operations that are for the node's rollup *) - if not (is_for_my_rollup operation) then return_unit - else - let*! () = - (* Only event for rollup node's own operations *) - if not (Node_context.is_operator node_ctxt source) then Lwt.return_unit - else - match Sc_rollup_injector.injector_operation_of_manager operation with - | None -> Lwt.return_unit - | Some op -> - let status, errors = - match result with - | Applied _ -> (`Applied, None) - | Backtracked (_, e) -> - (`Backtracked, Option.map Environment.wrap_tztrace e) - | Failed (_, e) -> (`Failed, Some (Environment.wrap_tztrace e)) - | Skipped _ -> (`Skipped, None) - in - Daemon_event.included_operation ?errors status op - in - match result with - | Applied success_result -> - process_included_l1_operation - node_ctxt - head - ~source - operation - success_result - | _ -> - (* No action for non successful operations *) - return_unit - -let process_l1_block_operations ~catching_up:_ node_ctxt (head : Layer1.header) - = - let open Lwt_result_syntax in - let* block = - Layer1_helpers.fetch_tezos_block node_ctxt.Node_context.l1_ctxt head.hash - in - let apply (type kind) accu ~source (operation : kind manager_operation) result - = - let open Lwt_result_syntax in - let* () = accu in - process_l1_operation node_ctxt head ~source operation result - in - let apply_internal (type kind) accu ~source:_ - (_operation : kind Apply_internal_results.internal_operation) - (_result : kind Apply_internal_results.internal_operation_result) = - accu - in - let* () = - Layer1_services.process_manager_operations - return_unit - block.operations - {apply; apply_internal} - in - return_unit diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/daemon_helpers.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/daemon_helpers.mli deleted file mode 100644 index af7d9135f34996027b79c8c639b4bbdabe2c0184..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/daemon_helpers.mli +++ /dev/null @@ -1,34 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* Copyright (c) 2023 TriliTech *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Ensure that the initial state hash of the PVM as defined by the rollup node - matches the one of the PVM on the L1 node. *) -val check_pvm_initial_state_hash : _ Node_context.t -> unit tzresult Lwt.t - -(** React to L1 operations included in a block of the chain. *) -val process_l1_block_operations : - catching_up:bool -> Node_context.rw -> Layer1.header -> unit tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/dal_pages_request.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/dal_pages_request.ml deleted file mode 100644 index f95fc6e4b0e04ad1762fb4a8dd056c95dd743212..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/dal_pages_request.ml +++ /dev/null @@ -1,158 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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 -open Alpha_context - -(** If a slot, published at some level L, is expected to be confirmed at level - L+D then, once the confirmation level is over, the rollup node is supposed to: - - Download and save the content of the slot's pages in the store, if the slot - is confirmed; - - Add entries [None] for the slot's pages in the store, if the slot - is not confirmed. *) - -type error += - | Dal_slot_not_found_in_store of Dal.Slot.Header.id - | Dal_invalid_page_for_slot of Dal.Page.t - -let () = - Sc_rollup_node_errors.register_error_kind - `Permanent - ~id:"dal_pages_request.dal_slot_not_found_in_store" - ~title:"Dal slot not found in store" - ~description:"The Dal slot whose ID is given is not found in the store" - ~pp:(fun ppf -> - Format.fprintf ppf "Dal slot not found in store %a" Dal.Slot.Header.pp_id) - Data_encoding.(obj1 (req "slot_id" Dal.Slot.Header.id_encoding)) - (function Dal_slot_not_found_in_store slot_id -> Some slot_id | _ -> None) - (fun slot_id -> Dal_slot_not_found_in_store slot_id) ; - Sc_rollup_node_errors.register_error_kind - `Permanent - ~id:"dal_pages_request.dal_invalid_page_for_slot" - ~title:"Invalid Dal page requested for slot" - ~description:"The requested Dal page for a given slot is invalid" - ~pp:(fun ppf -> - Format.fprintf ppf "Invalid Dal page requested %a" Dal.Page.pp) - Data_encoding.(obj1 (req "page_id" Dal.Page.encoding)) - (function Dal_invalid_page_for_slot page_id -> Some page_id | _ -> None) - (fun page_id -> Dal_invalid_page_for_slot page_id) - -let store_entry_from_published_level ~dal_attestation_lag ~published_level - node_ctxt = - Node_context.hash_of_level node_ctxt - @@ Int32.( - add (of_int dal_attestation_lag) (Raw_level.to_int32 published_level)) - -(* The cache allows to not fetch pages on the DAL node more than necessary. *) -module Pages_cache = - Aches_lwt.Lache.Make - (Aches.Rache.Transfer - (Aches.Rache.LRU) - (struct - include Cryptobox.Commitment - - let hash commitment = - Data_encoding.Binary.to_string_exn - Cryptobox.Commitment.encoding - commitment - |> Hashtbl.hash - end)) - -let get_slot_pages = - let pages_cache = Pages_cache.create 16 (* 130MB *) in - fun dal_cctxt commitment -> - Pages_cache.bind_or_put - pages_cache - commitment - (Dal_node_client.get_slot_pages dal_cctxt) - Lwt.return - -let download_confirmed_slot_pages ({Node_context.dal_cctxt; _} as node_ctxt) - ~published_level ~index = - let open Lwt_result_syntax in - let* published_in_block_hash = - Node_context.hash_of_level node_ctxt (Raw_level.to_int32 published_level) - in - let* header = - Node_context.get_slot_header node_ctxt ~published_in_block_hash index - in - let dal_cctxt = WithExceptions.Option.get ~loc:__LOC__ dal_cctxt in - (* DAL must be configured for this point to be reached *) - get_slot_pages dal_cctxt header.commitment - -let storage_invariant_broken published_level index = - failwith - "Internal error: [Node_context.find_slot_status] is supposed to have \ - registered the status of the slot %d published at level %a in the store" - index - Raw_level.pp - published_level - -let slot_pages ~dal_attestation_lag node_ctxt - Dal.Slot.Header.{published_level; index} = - let open Lwt_result_syntax in - let* confirmed_in_block_hash = - store_entry_from_published_level - ~dal_attestation_lag - ~published_level - node_ctxt - in - let index = Dal.Slot_index.to_int index in - let* processed = - Node_context.find_slot_status node_ctxt ~confirmed_in_block_hash index - in - match processed with - | Some `Confirmed -> - let* pages = - download_confirmed_slot_pages node_ctxt ~published_level ~index - in - return (Some pages) - | Some `Unconfirmed -> return None - | None -> storage_invariant_broken published_level index - -let page_content ~dal_attestation_lag node_ctxt page_id = - let open Lwt_result_syntax in - let Dal.Page.{slot_id; page_index} = page_id in - let Dal.Slot.Header.{published_level; index} = slot_id in - let* confirmed_in_block_hash = - store_entry_from_published_level - ~dal_attestation_lag - ~published_level - node_ctxt - in - let index = Dal.Slot_index.to_int index in - let* processed = - Node_context.find_slot_status node_ctxt ~confirmed_in_block_hash index - in - match processed with - | Some `Confirmed -> ( - let* pages = - download_confirmed_slot_pages node_ctxt ~published_level ~index - in - match List.nth_opt pages page_index with - | Some page -> return @@ Some page - | None -> tzfail @@ Dal_invalid_page_for_slot page_id) - | Some `Unconfirmed -> return None - | None -> storage_invariant_broken published_level index diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/dal_pages_request.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/dal_pages_request.mli deleted file mode 100644 index f27d737fbc29eb109f1e6799425491e8c9256231..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/dal_pages_request.mli +++ /dev/null @@ -1,76 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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 -open Alpha_context - -(** Access DAL slots and pages content. - - This module is a wrapper on top of {!Store.Dal_slot_pages} module to - access DAL slots and pages' data that have been previously fetched by - the rollup node. -*) - -(** This error is returned when a slot, identified by its ID, is not found in - the store. *) -type error += Dal_slot_not_found_in_store of Dal.Slot.Header.id - -(** Retrieve the pages' content of the given slot ID's from the store. - - The function returns [Dal_slot_not_found_in_store] if no entry is found in - the store for the given ID (i.e. no page is registered with or without content). - - If the returned value is [Some pages], the slot whose ID is given is - supposed to be confirmed and [pages] correspond to the pages of the slot. - Otherwise [None] is returned. - - The function relies on {!Store.Dal_slot_pages}'s invariants to guarantee that: - - the pages are returned in increasing order w.r.t. their indexes in the slot; - - the size of the list, in case it is not empty, is equal to the expected - number of pages in a slot. - - [dal_attestation_lag] is used to retrieve the correct entry in [store]. -*) -val slot_pages : - dal_attestation_lag:int -> - _ Node_context.t -> - Dal.slot_id -> - Dal.Page.content list option tzresult Lwt.t - -(** Retrieve the content of the page identified by the given ID from the store. - - The function returns [Dal_slot_not_found_in_store] if no entry is found in - the store for the given ID. It - returns [None] in case the entry is found, but the slot is not confirmed. Said - otherwise, some content is only returned for confirmed pages (slots) for - which the content has already been downloaded and saved to the store. - - [dal_attestation_lag] is used to retrieve the correct entry in [store]. -*) -val page_content : - dal_attestation_lag:int -> - _ Node_context.t -> - Dal.Page.t -> - Dal.Page.content option tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/dal_slots_tracker.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/dal_slots_tracker.ml deleted file mode 100644 index 9413217988da641b3d8d9ef51649ef29004d567f..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/dal_slots_tracker.ml +++ /dev/null @@ -1,358 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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 -open Alpha_context - -let ancestor_hash ~number_of_levels - ({Node_context.genesis_info; _} as node_ctxt) head = - let genesis_level = genesis_info.level in - let rec go number_of_levels (Layer1.{hash; level} as head) = - let open Lwt_result_syntax in - if level < genesis_level then return_none - else if number_of_levels = 0 then return_some hash - else - let* pred_head = Node_context.get_predecessor_opt node_ctxt head in - match pred_head with - | None -> return_none - | Some pred_head -> go (number_of_levels - 1) pred_head - in - go number_of_levels head - -(* Values of type `confirmations_info` are used to catalog the status of slots - published in a given block hash. These values record whether - the slot has been confirmed after the attestation_lag has passed. *) -type confirmations_info = { - (* The hash of the block in which the slots have been published. *) - published_block_hash : Block_hash.t; - (* The indexes of slots that have beenp published in block - with hash `published_block_hash`, and have later been confirmed. *) - confirmed_slots_indexes : Bitset.t; -} - -(** [slots_info constants node_ctxt head] gathers information about the slot confirmations - of slot indexes. It reads the slot indexes that have been declared available - from [head]'s block receipt. It then returns the hash of - the block where the slot headers have been published and the list of - slot indexes that have been confirmed for that block. *) -let slots_info constants node_ctxt (Layer1.{hash; _} as head) = - (* DAL/FIXME: https://gitlab.com/tezos/tezos/-/issues/3722 - The case for protocol migrations when the lag constant has - been changed is tricky, especially if the lag is reduced. - Suppose that a slot header is published at the second last level of a - cycle, and the lag is 2. The block is expected to be confirmed at the - first level of the new cycle. However, if during the protocol migration - we reduce the lag to 1, then the slots header will never be confirmed. - *) - let open Lwt_result_syntax in - let lag = constants.Rollup_constants.dal.attestation_lag in - (* we are downloading endorsemented for slots at level [level], so - we need to download the data at level [level - lag]. - *) - let* published_slots_block_hash = - ancestor_hash ~number_of_levels:lag node_ctxt head - in - match published_slots_block_hash with - | None -> - (* Less then lag levels have passed from the rollup origination, and - confirmed slots should not be applied *) - return None - | Some published_block_hash -> - let* {metadata; _} = - Layer1_helpers.fetch_tezos_block node_ctxt.Node_context.l1_ctxt hash - in - let*? metadata = - Option.to_result - ~none:(TzTrace.make @@ Layer1_services.Cannot_read_block_metadata hash) - metadata - in - (* `metadata.protocol_data.dal_attestation` is `None` if we are behind - the `Dal feature flag`: in this case we return an empty slot endorsement. - *) - let confirmed_slots = - Option.value - ~default:Dal.Attestation.empty - metadata.protocol_data.dal_attestation - in - let* published_slots_indexes = - Node_context.get_slot_indexes - node_ctxt - ~published_in_block_hash:published_block_hash - in - let confirmed_slots_indexes_list = - List.filter - (Dal.Attestation.is_attested confirmed_slots) - (List.filter_map Dal.Slot_index.of_int_opt published_slots_indexes) - in - let*? confirmed_slots_indexes = - Environment.wrap_tzresult - (confirmed_slots_indexes_list - |> List.map Dal.Slot_index.to_int - |> Bitset.from_list) - in - return @@ Some {published_block_hash; confirmed_slots_indexes} - -(* DAL/FIXME: https://gitlab.com/tezos/tezos/-/issues/3884 - avoid going back and forth between bitsets and lists of slot indexes. *) -let to_slot_index_list (constants : Rollup_constants.protocol_constants) bitset - = - let all_slots = Misc.(0 --> (constants.dal.number_of_slots - 1)) in - List.filter_e (Bitset.mem bitset) all_slots - -(* DAL/FIXME: https://gitlab.com/tezos/tezos/-/issues/4139. - Use a shared storage between dal and rollup node to store slots data. -*) - -let download_and_save_slots constants (node_context : _ Node_context.t) - ~current_block_hash {published_block_hash; confirmed_slots_indexes} = - let open Lwt_result_syntax in - let*? all_slots = - Bitset.fill ~length:constants.Rollup_constants.dal.number_of_slots - |> Environment.wrap_tzresult - in - let*? not_confirmed = - Environment.wrap_tzresult - @@ to_slot_index_list constants - @@ Bitset.diff all_slots confirmed_slots_indexes - in - let*? confirmed = - Environment.wrap_tzresult - @@ to_slot_index_list constants confirmed_slots_indexes - in - (* The contents of each slot index are written to a different location on - disk, therefore calls to store contents for different slot indexes can - be parallelized. *) - let* () = - List.iter_ep - (fun s_slot -> - Node_context.save_slot_status - node_context - current_block_hash - s_slot - `Unconfirmed) - not_confirmed - in - List.iter_ep - (fun s_slot -> - let* () = - Node_context.save_slot_status - node_context - current_block_hash - s_slot - `Confirmed - in - let*? s_slot = - Environment.wrap_tzresult @@ Dal.Slot_index.of_int s_slot - in - let*! () = - Dal_slots_tracker_event.slot_has_been_confirmed - s_slot - published_block_hash - current_block_hash - in - return_unit) - confirmed - -module Confirmed_slots_history = struct - (** [confirmed_slots_with_headers constants node_ctxt confirmations_info] returns the - headers of confirmed slot indexes for the block with hash - [confirmations_info.published_block_hash]. *) - let confirmed_slots_with_headers constants node_ctxt - {published_block_hash; confirmed_slots_indexes; _} = - let open Lwt_result_syntax in - let*? relevant_slots_indexes = - Environment.wrap_tzresult - @@ to_slot_index_list constants confirmed_slots_indexes - in - List.map_ep - (fun slot_index -> - let+ h = - Node_context.get_slot_header - node_ctxt - ~published_in_block_hash:published_block_hash - slot_index - in - Sc_rollup_proto_types.Dal.Slot_header.of_octez h) - relevant_slots_indexes - - let read_slots_history_from_l1 _constants {Node_context.cctxt; _} block = - let open Lwt_result_syntax in - (* We return the empty Slots_history if DAL is not enabled. *) - let* slots_list_opt = - RPC.Dal.dal_confirmed_slots_history - (new Protocol_client_context.wrap_full cctxt) - (cctxt#chain, `Hash (block, 0)) - in - return @@ Option.value slots_list_opt ~default:Dal.Slots_history.genesis - - (** Depending on the rollup's origination level and on the DAL's endorsement - lag, the rollup node should start processing confirmed slots and update its - slots_history and slots_history's cache entries in the store after - [origination_level + attestation_lag] blocks. This function checks if - that level is reached or not. *) - let should_process_dal_slots constants node_ctxt block_level = - let open Node_context in - let lag = Int32.of_int constants.Rollup_constants.dal.attestation_lag in - let block_level = Raw_level.to_int32 block_level in - let genesis_level = node_ctxt.genesis_info.level in - Int32.(block_level >= add lag genesis_level) - - let dal_entry_of_block_hash node_ctxt - Layer1.{hash = block_hash; level = block_level} ~entry_kind ~find ~default - = - let open Lwt_result_syntax in - let* confirmed_slots_history_opt = find node_ctxt block_hash in - let* constants = - Protocol_plugins.get_constants_of_level node_ctxt block_level - in - let block_level = Raw_level.of_int32_exn block_level in - let should_process_dal_slots = - should_process_dal_slots constants node_ctxt block_level - in - match (confirmed_slots_history_opt, should_process_dal_slots) with - | Some confirmed_dal_slots, true -> return confirmed_dal_slots - | None, false -> default constants node_ctxt block_hash - | Some _confirmed_dal_slots, false -> - failwith - "The confirmed DAL %S for block hash %a (level = %a) is not expected \ - to be found in the store, but is exists." - entry_kind - Block_hash.pp - block_hash - Raw_level.pp - block_level - | None, true -> - failwith - "The confirmed DAL %S for block hash %a (level = %a) is expected to \ - be found in the store, but is missing." - entry_kind - Block_hash.pp - block_hash - Raw_level.pp - block_level - - let slots_history_of_hash node_ctxt block = - let find node_ctxt block = - let open Lwt_result_syntax in - let+ hist = Node_context.find_confirmed_slots_history node_ctxt block in - Option.map Sc_rollup_proto_types.Dal.Slot_history.of_octez hist - in - dal_entry_of_block_hash - node_ctxt - block - ~entry_kind:"slots history" - ~find - ~default:read_slots_history_from_l1 - - let slots_history_cache_of_hash node_ctxt block = - let find node_ctxt block = - let open Lwt_result_syntax in - let+ hist = Node_context.find_confirmed_slots_histories node_ctxt block in - Option.map Sc_rollup_proto_types.Dal.Slot_history_cache.of_octez hist - in - dal_entry_of_block_hash - node_ctxt - block - ~entry_kind:"slots history cache" - ~find - ~default:(fun constants _node_ctxt _block -> - let num_slots = constants.Rollup_constants.dal.number_of_slots in - (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3788 - Put an accurate value for capacity. The value - `num_slots * 60000` below is chosen based on: - - The number of remembered L1 inboxes in their corresponding - cache (60000), - - The (max) number of slots (num_slots) that could be attested - per L1 block, - - The way the Slots_history.t skip list is implemented (one slot - per cell). *) - return - @@ Dal.Slots_history.History_cache.empty - ~capacity:(Int64.of_int @@ (num_slots * 60000))) - - let update constants node_ctxt Layer1.({hash = head_hash; _} as head) - confirmation_info = - let open Lwt_result_syntax in - let* slots_to_save = - confirmed_slots_with_headers constants node_ctxt confirmation_info - in - let slots_to_save = - let open Dal in - List.fast_sort - (fun Slot.Header.{id = {index = a; _}; _} {id = {index = b; _}; _} -> - Slot_index.compare a b) - slots_to_save - in - let* pred = Node_context.get_predecessor node_ctxt head in - let* slots_history = slots_history_of_hash node_ctxt pred in - let* slots_cache = slots_history_cache_of_hash node_ctxt pred in - let*? slots_history, slots_cache = - Dal.Slots_history.add_confirmed_slot_headers - slots_history - slots_cache - slots_to_save - |> Environment.wrap_tzresult - in - (* The value of [slots_history] computed here is supposed to be equal to the - one computed stored for block [head_hash] on L1, we basically re-do the - computation here because we need to build/maintain the [slots_cache] - bounded cache in case we need it for refutation game. *) - (* TODO/DAL: https://gitlab.com/tezos/tezos/-/issues/3856 - Attempt to improve this process. *) - let* () = - Node_context.save_confirmed_slots_history - node_ctxt - head_hash - (Sc_rollup_proto_types.Dal.Slot_history.to_octez slots_history) - in - let* () = - Node_context.save_confirmed_slots_histories - node_ctxt - head_hash - (Sc_rollup_proto_types.Dal.Slot_history_cache.to_octez slots_cache) - in - return () -end - -let process_head node_ctxt (Layer1.{hash = head_hash; level} as head) = - let open Lwt_result_syntax in - let* constants = Protocol_plugins.get_constants_of_level node_ctxt level in - let* confirmation_info = slots_info constants node_ctxt head in - match confirmation_info with - | None -> return_unit - | Some confirmation_info -> - let* () = - download_and_save_slots - ~current_block_hash:head_hash - constants - node_ctxt - confirmation_info - in - Confirmed_slots_history.update constants node_ctxt head confirmation_info - -let slots_history_of_hash = Confirmed_slots_history.slots_history_of_hash - -let slots_history_cache_of_hash = - Confirmed_slots_history.slots_history_cache_of_hash diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/dal_slots_tracker.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/dal_slots_tracker.mli deleted file mode 100644 index c05672d93a0e21dbe29c76bd3f43d7e00ffbf37c..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/dal_slots_tracker.mli +++ /dev/null @@ -1,55 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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 rollup node keeps the list of dal slots for each block it needs to - process. This is to determine whether the inbox for a given block will need - to be retrieved from the block operations, or from the data availability - layer after lag levels have passed and the slot for the block has been - declared available. - - The state of slots per block is persistent. *) - -(** [process_head node_ctxt head] performs the following operations: - {ul - {li it reads the endorsements for headers published attestation_lag - levels preceding [head] from the block metadata, determines which - ones the rollup node will download, and stores the results in - [Store.Dal_confirmed_slots].} - } *) -val process_head : Node_context.rw -> Layer1.head -> unit tzresult Lwt.t - -(** [slots_history_of_hash node_ctxt block_hash] returns the DAL confirmed slots - history at the end of the given [block_hash] validation. *) -val slots_history_of_hash : - _ Node_context.t -> - Layer1.head -> - Protocol.Alpha_context.Dal.Slots_history.t tzresult Lwt.t - -(** [slots_history_cache_of_hash node_ctxt block_hash] returns the DAL confirmed - slots history cache at the end of the given [block_hash] validation. *) -val slots_history_cache_of_hash : - _ Node_context.t -> - Layer1.head -> - Protocol.Alpha_context.Dal.Slots_history.History_cache.t tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/dal_slots_tracker_event.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/dal_slots_tracker_event.ml deleted file mode 100644 index 05620638edb998237635252ebe5799f9fb3e1013..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/dal_slots_tracker_event.ml +++ /dev/null @@ -1,49 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 TriliTech *) -(* *) -(* 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 -open Alpha_context - -module Simple = struct - include Internal_event.Simple - - let section = [Protocol.name; "sc_rollup_node"; "dal_slots_tracker"] - - let slot_has_been_confirmed = - declare_3 - ~section - ~name:"dal_confirmed_slot" - ~msg: - "Slot header for index {slot_index} was published at block \ - {published_hash}. The slot header has been confirmed at \ - {confirmed_hash}. The slot contents will be downloaded." - ~level:Notice - ("slot_index", Dal.Slot_index.encoding) - ("published_hash", Block_hash.encoding) - ("confirmed_hash", Block_hash.encoding) -end - -let slot_has_been_confirmed slot published_hash confirmed_hash = - Simple.(emit slot_has_been_confirmed (slot, published_hash, confirmed_hash)) diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/dune b/src/proto_017_PtNairob/lib_sc_rollup_node/dune deleted file mode 100644 index 265f046e5e4d668fffbe71bdac6e263e954124e7..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/dune +++ /dev/null @@ -1,71 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name octez_smart_rollup_node_PtNairob) - (package octez-smart-rollup-node-PtNairob) - (instrumentation (backend bisect_ppx)) - (libraries - octez-libs.base - octez-libs.stdlib-unix - octez-shell-libs.client-base - octez-shell-libs.client-base-unix - octez-protocol-017-PtNairob-libs.client - octez-libs.tezos-context.encoding - octez-libs.tezos-context.helpers - tezos-protocol-017-PtNairob.protocol - octez-protocol-017-PtNairob-libs.plugin - tezos-protocol-017-PtNairob.parameters - octez-libs.rpc - octez-libs.rpc-http - octez-libs.rpc-http-server - octez-libs.tezos-workers - tezos-dal-node-services - tezos-dal-node-lib - tezos-dac-lib - octez-shell-libs.shell-services - octez-l2-libs.smart-rollup - octez-protocol-017-PtNairob-libs.smart-rollup - octez-protocol-017-PtNairob-libs.smart-rollup-layer2 - octez-protocol-017-PtNairob-libs.layer2-utils - octez-l2-libs.layer2_store - octez-crawler - octez-libs.tree-encoding - data-encoding - octez-internal-libs.irmin_pack - octez-internal-libs.irmin_pack.unix - octez-internal-libs.irmin - aches - aches-lwt - octez-injector - octez-smart-rollup-node-lib - octez-l2-libs.scoru-wasm - octez-l2-libs.scoru-wasm-fast - octez-libs.crypto-dal - octez-version.value) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezos_base - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_stdlib_unix - -open Tezos_client_base - -open Tezos_client_base_unix - -open Tezos_client_017_PtNairob - -open Tezos_protocol_017_PtNairob - -open Tezos_protocol_plugin_017_PtNairob - -open Tezos_protocol_017_PtNairob_parameters - -open Tezos_workers - -open Tezos_dal_node_lib - -open Tezos_dac_lib - -open Tezos_shell_services - -open Octez_smart_rollup - -open Tezos_smart_rollup_017_PtNairob - -open Tezos_smart_rollup_layer2_017_PtNairob - -open Tezos_layer2_utils_017_PtNairob - -open Tezos_layer2_store - -open Octez_crawler - -open Octez_injector - -open Octez_smart_rollup_node - -open Tezos_crypto_dal)) diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/fueled_pvm.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/fueled_pvm.ml deleted file mode 100644 index cc97633c422755930c86f5bb6bd36e9e192541a2..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/fueled_pvm.ml +++ /dev/null @@ -1,477 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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 -open Alpha_context -open Context_wrapper.Irmin -module Inbox = Sc_rollup.Inbox -open Pvm_plugin_sig - -module Make_fueled (F : Fuel.S) : FUELED_PVM with type fuel = F.t = struct - type fuel = F.t - - type pvm_state = Irmin_context.tree - - let get_reveal ~pre_images_endpoint ~data_dir ~pvm_kind reveal_map hash = - let found_in_map = - match reveal_map with - | None -> None - | Some map -> - Utils.Reveal_hash_map.find_opt - (Reveals.proto_hash_to_dac_hash hash) - map - in - match found_in_map with - | Some data -> return data - | None -> Reveals.get ~pre_images_endpoint ~data_dir ~pvm_kind ~hash - - type eval_completion = - | Aborted of {state : pvm_state; fuel : fuel; current_tick : int64} - | Completed of { - state : pvm_state; - fuel : fuel; - current_tick : int64; - failing_ticks : int64 list; - } - - exception Error_wrapper of tztrace - - let metadata (node_ctxt : _ Node_context.t) = - let address = - Sc_rollup_proto_types.Address.of_octez node_ctxt.config.sc_rollup_address - in - let origination_level = - Raw_level.of_int32_exn node_ctxt.genesis_info.level - in - Sc_rollup.Metadata.{address; origination_level} - - (** [eval_until_input node_ctxt reveal_map level message_index ~fuel - start_tick failing_ticks state] advances a PVM [state] until it wants - more inputs or there are no more [fuel] (if [Some fuel] is - specified). The evaluation is running under the processing of some - [message_index] at a given [level] and this is the [start_tick] of this - message processing. If some [failing_ticks] are planned by the loser - mode, they will be made. *) - let eval_until_input (node_ctxt : _ Node_context.t) reveal_map level - message_index ~fuel start_tick failing_ticks state = - let open Lwt_result_syntax in - let open Delayed_write_monad.Lwt_result_syntax in - let* constants = - Protocol_plugins.get_constants_of_level node_ctxt (Int32.of_int level) - in - let module PVM = (val Pvm.of_kind node_ctxt.kind) in - let metadata = metadata node_ctxt in - let dal_attestation_lag = constants.dal.attestation_lag in - let decode_reveal (Tezos_scoru_wasm.Wasm_pvm_state.Reveal_raw payload) = - match - Data_encoding.Binary.of_string_opt - Sc_rollup_PVM_sig.reveal_encoding - payload - with - | Some reveal -> reveal - | None -> - (* If the kernel has tried to submit an incorrect reveal request, - we don’t stuck the rollup. Instead, we fallback to the - requesting the [well_known_reveal_hash] preimage *) - Reveal_raw_data Sc_rollup.Wasm_2_0_0PVM.well_known_reveal_hash - in - let reveal_builtins request = - match decode_reveal request with - | Reveal_raw_data hash -> ( - let*! data = - get_reveal - ~pre_images_endpoint:node_ctxt.config.pre_images_endpoint - ~data_dir:node_ctxt.data_dir - ~pvm_kind:node_ctxt.kind - reveal_map - hash - in - match data with - | Error error -> - (* The [Error_wrapper] must be caught upstream and converted into - a tzresult. *) - Lwt.fail (Error_wrapper error) - | Ok data -> Lwt.return data) - | Reveal_metadata -> - Lwt.return - (Data_encoding.Binary.to_string_exn - Sc_rollup.Metadata.encoding - metadata) - | Request_dal_page _ -> - (* DAL in the Fast Execution WASM PVM is not supported for Mumbai. *) - assert false - in - let eval_tick fuel failing_ticks state = - let max_steps = F.max_ticks fuel in - let normal_eval ?(max_steps = max_steps) state = - Lwt.catch - (fun () -> - let*! state, executed_ticks = - PVM.eval_many - ~reveal_builtins - ~write_debug:(Printer node_ctxt.kernel_debug_logger) - ~max_steps - state - in - return (state, executed_ticks, failing_ticks)) - (function - | Error_wrapper error -> Lwt.return (Error error) - | exn -> Lwt.reraise exn) - in - let failure_insertion_eval state tick failing_ticks' = - let*! () = - Interpreter_event.intended_failure - ~level - ~message_index - ~message_tick:tick - ~internal:true - in - let*! state = PVM.Internal_for_tests.insert_failure state in - return (state, 1L, failing_ticks') - in - match failing_ticks with - | xtick :: failing_ticks' -> - let jump = Int64.(max 0L (pred xtick)) in - if Compare.Int64.(jump = 0L) then - (* Insert the failure in the first tick. *) - failure_insertion_eval state xtick failing_ticks' - else - (* Jump just before the tick where we'll insert a failure. - Nevertheless, we don't execute more than [max_steps]. *) - let max_steps = Int64.max 0L max_steps |> Int64.min max_steps in - let open Delayed_write_monad.Lwt_result_syntax in - let>* state, executed_ticks, _failing_ticks = - normal_eval ~max_steps state - in - (* Insert the failure. *) - let>* state, executed_ticks', failing_ticks' = - failure_insertion_eval state xtick failing_ticks' - in - let executed_ticks = Int64.add executed_ticks executed_ticks' in - return (state, executed_ticks, failing_ticks') - | _ -> normal_eval state - in - let abort state fuel current_tick = - return (Aborted {state; fuel; current_tick}) - in - let complete state fuel current_tick failing_ticks = - return (Completed {state; fuel; current_tick; failing_ticks}) - in - let rec go (fuel : fuel) current_tick failing_ticks state = - let*! input_request = PVM.is_input_state state in - match input_request with - | No_input_required when F.is_empty fuel -> abort state fuel current_tick - | No_input_required -> ( - let>* next_state, executed_ticks, failing_ticks = - eval_tick fuel failing_ticks state - in - let fuel_executed = F.of_ticks executed_ticks in - match F.consume fuel_executed fuel with - | None -> abort state fuel current_tick - | Some fuel -> - go - fuel - (Int64.add current_tick executed_ticks) - failing_ticks - next_state) - | Needs_reveal (Reveal_raw_data hash) -> ( - let* data = - get_reveal - ~pre_images_endpoint:node_ctxt.config.pre_images_endpoint - ~data_dir:node_ctxt.data_dir - ~pvm_kind:node_ctxt.kind - reveal_map - hash - in - let*! next_state = PVM.set_input (Reveal (Raw_data data)) state in - match F.consume F.one_tick_consumption fuel with - | None -> abort state fuel current_tick - | Some fuel -> - go fuel (Int64.succ current_tick) failing_ticks next_state) - | Needs_reveal Reveal_metadata -> ( - let*! next_state = PVM.set_input (Reveal (Metadata metadata)) state in - match F.consume F.one_tick_consumption fuel with - | None -> abort state fuel current_tick - | Some fuel -> - go fuel (Int64.succ current_tick) failing_ticks next_state) - | Needs_reveal (Request_dal_page page_id) -> ( - let* content_opt = - Dal_pages_request.page_content - ~dal_attestation_lag - node_ctxt - page_id - in - let*! next_state = - PVM.set_input (Reveal (Dal_page content_opt)) state - in - match F.consume F.one_tick_consumption fuel with - | None -> abort state fuel current_tick - | Some fuel -> - go fuel (Int64.succ current_tick) failing_ticks next_state) - | Initial | First_after _ -> - complete state fuel current_tick failing_ticks - in - go fuel start_tick failing_ticks state - - (** [mutate input] corrupts the payload of [input] for testing purposes. *) - let mutate input = - let payload = - Sc_rollup.Inbox_message.unsafe_of_string - "\001to the cheater we promise pain and misery" - in - {input with Sc_rollup.payload} - - type feed_input_completion = - | Feed_input_aborted of {state : pvm_state; fuel : fuel; fed_input : bool} - | Feed_input_completed of {state : pvm_state; fuel : fuel} - - (** [feed_input node_ctxt reveal_map level message_index ~fuel - ~failing_ticks state input] feeds [input] (that has a given - [message_index] in inbox of [level]) to the PVM in order to advance - [state] to the next step that requires an input. This function is - controlled by some [fuel] and may introduce intended failures at some - given [failing_ticks]. *) - let feed_input (node_ctxt : _ Node_context.t) reveal_map level message_index - ~fuel ~failing_ticks state input = - let open Lwt_result_syntax in - let open Delayed_write_monad.Lwt_result_syntax in - let module PVM = (val Pvm.of_kind node_ctxt.kind) in - let>* res = - eval_until_input - node_ctxt - reveal_map - level - message_index - ~fuel - 0L - failing_ticks - state - in - match res with - | Aborted {state; fuel; _} -> - return (Feed_input_aborted {state; fuel; fed_input = false}) - | Completed {state; fuel; current_tick = tick; failing_ticks} -> ( - let open Delayed_write_monad.Lwt_result_syntax in - match F.consume F.one_tick_consumption fuel with - | None -> return (Feed_input_aborted {state; fuel; fed_input = false}) - | Some fuel -> ( - let>* input, failing_ticks = - match failing_ticks with - | xtick :: failing_ticks' -> - if xtick = tick then - let*! () = - Interpreter_event.intended_failure - ~level - ~message_index - ~message_tick:tick - ~internal:false - in - return (mutate input, failing_ticks') - else return (input, failing_ticks) - | [] -> return (input, failing_ticks) - in - let*! state = PVM.set_input (Inbox_message input) state in - let>* res = - eval_until_input - node_ctxt - reveal_map - level - message_index - ~fuel - tick - failing_ticks - state - in - match res with - | Aborted {state; fuel; _} -> - return (Feed_input_aborted {state; fuel; fed_input = true}) - | Completed {state; fuel; _} -> - return (Feed_input_completed {state; fuel}))) - - let eval_messages ~reveal_map ~fuel node_ctxt ~message_counter_offset state - inbox_level messages = - let open Delayed_write_monad.Lwt_result_syntax in - let level = Int32.to_int inbox_level in - (* Iterate the PVM state with all the messages. *) - let rec feed_messages (state, fuel) message_index = function - | [] -> - (* Fed all messages *) - return (state, fuel, message_index - message_counter_offset, []) - | messages when F.is_empty fuel -> - (* Consumed all fuel *) - return (state, fuel, message_index - message_counter_offset, messages) - | message :: messages -> ( - let payload = Sc_rollup.Inbox_message.unsafe_of_string message in - let message_counter = Z.of_int message_index in - let input = - Sc_rollup. - { - inbox_level = Raw_level.of_int32_exn inbox_level; - message_counter; - payload; - } - in - let failing_ticks = - Loser_mode.is_failure - node_ctxt.Node_context.config.loser_mode - ~level - ~message_index - in - let>* res = - feed_input - node_ctxt - reveal_map - level - message_index - ~fuel - ~failing_ticks - state - input - in - match res with - | Feed_input_completed {state; fuel} -> - feed_messages (state, fuel) (message_index + 1) messages - | Feed_input_aborted {state; fuel; fed_input = false} -> - return - ( state, - fuel, - message_index - message_counter_offset, - message :: messages ) - | Feed_input_aborted {state; fuel; fed_input = true} -> - return - ( state, - fuel, - message_index + 1 - message_counter_offset, - messages )) - in - (feed_messages [@tailcall]) (state, fuel) message_counter_offset messages - - let eval_block_inbox ~fuel (node_ctxt : _ Node_context.t) (inbox, messages) - (state : Context.pvmstate) : - fuel eval_result Node_context.delayed_write tzresult Lwt.t = - let open Lwt_result_syntax in - let open Delayed_write_monad.Lwt_result_syntax in - let module PVM = (val Pvm.of_kind node_ctxt.kind) in - (* Obtain inbox and its messages for this block. *) - let inbox_level = Octez_smart_rollup.Inbox.inbox_level inbox in - let*! initial_tick = PVM.get_tick (of_node_pvmstate state) in - (* Evaluate all the messages for this level. *) - let>* state, remaining_fuel, num_messages, remaining_messages = - eval_messages - ~reveal_map:None - ~fuel - node_ctxt - ~message_counter_offset:0 - (of_node_pvmstate state) - inbox_level - messages - in - let*! final_tick = PVM.get_tick state in - let*! state_hash = PVM.state_hash state in - let num_ticks = Sc_rollup.Tick.distance initial_tick final_tick in - let eval_state = - { - state = to_node_pvmstate state; - state_hash = Sc_rollup_proto_types.State_hash.to_octez state_hash; - tick = Sc_rollup.Tick.to_z final_tick; - inbox_level; - message_counter_offset = num_messages; - remaining_fuel; - remaining_messages; - } - in - return {state = eval_state; num_ticks; num_messages} - - let eval_messages ?reveal_map (node_ctxt : _ Node_context.t) - { - state; - tick = initial_tick; - inbox_level; - message_counter_offset; - remaining_fuel = fuel; - remaining_messages = messages; - _; - } = - let open Lwt_result_syntax in - let open Delayed_write_monad.Lwt_result_syntax in - let module PVM = (val Pvm.of_kind node_ctxt.kind) in - let>* state, remaining_fuel, num_messages, remaining_messages = - match messages with - | [] -> - let level = Int32.to_int inbox_level in - let message_index = message_counter_offset - 1 in - let failing_ticks = - Loser_mode.is_failure - node_ctxt.Node_context.config.loser_mode - ~level - ~message_index - in - let>* res = - eval_until_input - node_ctxt - reveal_map - level - message_index - ~fuel - 0L - failing_ticks - (of_node_pvmstate state) - in - let state, remaining_fuel = - match res with - | Aborted {state; fuel; _} | Completed {state; fuel; _} -> - (state, fuel) - in - return (state, remaining_fuel, 0, []) - | _ -> - eval_messages - ~reveal_map - ~fuel - node_ctxt - ~message_counter_offset - (of_node_pvmstate state) - inbox_level - messages - in - let*! final_tick = PVM.get_tick state in - let final_tick = Sc_rollup.Tick.to_z final_tick in - let*! state_hash = PVM.state_hash state in - let num_ticks = Z.sub final_tick initial_tick in - let eval_state = - { - state = to_node_pvmstate state; - state_hash = Sc_rollup_proto_types.State_hash.to_octez state_hash; - tick = final_tick; - inbox_level; - message_counter_offset = message_counter_offset + num_messages; - remaining_fuel; - remaining_messages; - } - in - return {state = eval_state; num_ticks; num_messages} -end - -module Free = Make_fueled (Fuel.Free) -module Accounted = Make_fueled (Fuel.Accounted) diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/inbox.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/inbox.ml deleted file mode 100644 index 753cc7ba13f21b29aa78165f64244eb23a0c18a9..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/inbox.ml +++ /dev/null @@ -1,308 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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 Constants will be shadowed by Alpha_context.Constansts - once we open Alpha_context, hence we we alias it to Rollup_node_constants -*) -open Protocol -open Alpha_context - -let lift promise = Lwt.map Environment.wrap_tzresult promise - -let get_messages Node_context.{l1_ctxt; _} head = - let open Lwt_result_syntax in - let* block = Layer1_helpers.fetch_tezos_block l1_ctxt head in - let apply (type kind) accu ~source:_ (operation : kind manager_operation) - _result = - let open Result_syntax in - let+ accu in - match operation with - | Sc_rollup_add_messages {messages} -> - let messages = - List.map - (fun message -> Sc_rollup.Inbox_message.External message) - messages - in - List.rev_append messages accu - | _ -> accu - in - let apply_internal (type kind) accu ~source - (operation : kind Apply_internal_results.internal_operation) - (result : - kind Apply_internal_results.successful_internal_operation_result) = - let open Result_syntax in - let* accu in - match (operation, result) with - | ( { - operation = Transaction {destination = Sc_rollup rollup; parameters; _}; - source = Contract (Originated sender); - _; - }, - ITransaction_result (Transaction_to_sc_rollup_result _) ) -> - let+ payload = - Environment.wrap_tzresult @@ Script_repr.force_decode parameters - in - let message = - Sc_rollup.Inbox_message.Transfer - {destination = rollup; payload; sender; source} - in - Sc_rollup.Inbox_message.Internal message :: accu - | _ -> return accu - in - let*? rev_messages = - Layer1_services.( - process_applied_manager_operations - (Ok []) - block.operations - {apply; apply_internal}) - in - let*? messages = - Environment.wrap_tzresult - @@ List.rev_map_e - (fun msg -> - let open Result_syntax in - let+ msg = Sc_rollup.Inbox_message.serialize msg in - Sc_rollup.Inbox_message.unsafe_to_string msg) - rev_messages - in - return messages - -let same_as_layer_1 node_ctxt head_hash inbox = - let open Lwt_result_syntax in - let head_block = `Hash (head_hash, 0) in - let Node_context.{cctxt; _} = node_ctxt in - let cctxt = new Protocol_client_context.wrap_full cctxt in - let* layer1_inbox = - Plugin.RPC.Sc_rollup.inbox cctxt (cctxt#chain, head_block) - in - let layer1_inbox = Sc_rollup_proto_types.Inbox.to_octez layer1_inbox in - fail_unless - (Octez_smart_rollup.Inbox.equal layer1_inbox inbox) - (Sc_rollup_node_errors.Inconsistent_inbox {layer1_inbox; inbox}) - -let add_messages ~is_first_block ~predecessor_timestamp ~predecessor inbox - messages = - let open Lwt_result_syntax in - let no_history = Sc_rollup.Inbox.History.empty ~capacity:0L in - lift - @@ let*? ( messages_history, - _no_history, - inbox, - witness, - messages_with_protocol_internal_messages ) = - Sc_rollup.Inbox.add_all_messages - ~first_block:is_first_block - ~predecessor_timestamp - ~predecessor - no_history - inbox - messages - in - let witness_hash = - Sc_rollup.Inbox_merkelized_payload_hashes.hash witness - in - return - ( messages_history, - witness_hash, - inbox, - messages_with_protocol_internal_messages ) - -let process_messages (node_ctxt : _ Node_context.t) ~is_first_block - ~(predecessor : Layer1.header) (head : Layer1.header) messages = - let open Lwt_result_syntax in - let level = head.level in - let* inbox = - Node_context.inbox_of_head node_ctxt (Layer1.head_of_header predecessor) - in - let predecessor_timestamp = predecessor.header.timestamp in - let inbox_metrics = Metrics.Inbox.metrics in - Prometheus.Gauge.set inbox_metrics.head_inbox_level @@ Int32.to_float level ; - let inbox = Sc_rollup_proto_types.Inbox.of_octez inbox in - let*? messages = - Environment.wrap_tzresult - @@ List.map_e - (fun msg -> - Sc_rollup.Inbox_message.(deserialize @@ unsafe_of_string msg)) - messages - in - let* ( _messages_history, - witness_hash, - inbox, - messages_with_protocol_internal_messages ) = - add_messages - ~is_first_block - ~predecessor_timestamp - ~predecessor:predecessor.hash - inbox - messages - in - let inbox = Sc_rollup_proto_types.Inbox.to_octez inbox in - let* inbox_hash = Node_context.save_inbox node_ctxt inbox in - let witness_hash = - Sc_rollup_proto_types.Merkelized_payload_hashes_hash.to_octez witness_hash - in - Metrics.Inbox.Stats.set - messages_with_protocol_internal_messages - ~is_internal:(function - | Sc_rollup.Inbox_message.Internal _ -> true - | External _ -> false) ; - let*? messages_with_protocol_internal_messages = - Environment.wrap_tzresult - @@ List.map_e - (fun msg -> - let open Result_syntax in - let+ msg = Sc_rollup.Inbox_message.serialize msg in - Sc_rollup.Inbox_message.unsafe_to_string msg) - messages_with_protocol_internal_messages - in - let* () = - Node_context.save_messages - node_ctxt - witness_hash - ~predecessor:predecessor.hash - messages_with_protocol_internal_messages - in - return - (inbox_hash, inbox, witness_hash, messages_with_protocol_internal_messages) - -let process_head (node_ctxt : _ Node_context.t) ~(predecessor : Layer1.header) - (head : Layer1.header) = - let open Lwt_result_syntax in - let first_inbox_level = node_ctxt.genesis_info.level |> Int32.succ in - if head.level >= first_inbox_level then - (* We compute the inbox of this block using the inbox of its - predecessor. That way, the computation of inboxes is robust to chain - reorganization. *) - let* collected_messages = get_messages node_ctxt head.hash in - let*! () = - Inbox_event.get_messages - head.hash - head.level - (List.length collected_messages) - in - let* head_proto = Node_context.protocol_of_level node_ctxt head.level in - let is_first_block = head_proto.first_level_of_protocol in - process_messages - node_ctxt - ~is_first_block - ~predecessor - head - collected_messages - else - let* inbox = - Layer1_helpers.genesis_inbox - node_ctxt.cctxt - ~genesis_level:node_ctxt.genesis_info.level - in - let Octez_smart_rollup.Inbox.{hash = witness; _} = - Octez_smart_rollup.Inbox.Skip_list.content inbox.old_levels_messages - in - let* () = - Node_context.save_messages - node_ctxt - witness - ~predecessor:predecessor.hash - [] - in - let* inbox_hash = Node_context.save_inbox node_ctxt inbox in - return (inbox_hash, inbox, witness, []) - -let payloads_history_of_messages ~is_first_block ~predecessor - ~predecessor_timestamp messages = - let open Result_syntax in - let dummy_inbox = - (* The inbox is not necessary to compute the payloads *) - Sc_rollup.Inbox.genesis ~predecessor_timestamp ~predecessor Raw_level.root - in - let* messages = - Environment.wrap_tzresult - @@ List.map_e - (fun msg -> - Sc_rollup.Inbox_message.(deserialize @@ unsafe_of_string msg)) - messages - in - let+ ( payloads_history, - _history, - _inbox, - _witness, - _messages_with_protocol_internal_messages ) = - (* TODO: https://gitlab.com/tezos/tezos/-/issues/4918 Inject - [Protocol_migration (Proto_017)] when migrating to proto_alpha - (N after next snapshot). *) - Environment.wrap_tzresult - @@ Sc_rollup.Inbox.add_all_messages - ~first_block:is_first_block - ~predecessor_timestamp - ~predecessor - (Sc_rollup.Inbox.History.empty ~capacity:0L) - dummy_inbox - messages - in - payloads_history - -let payloads_history_of_all_messages messages = - let open Result_syntax in - let payloads_history = - let capacity = List.length messages |> Int64.of_int in - Sc_rollup.Inbox_merkelized_payload_hashes.History.empty ~capacity - in - match List.map Sc_rollup.Inbox_message.unsafe_of_string messages with - | [] -> assert false - | first :: messages -> - Environment.wrap_tzresult - @@ let* payloads_history, witness = - Sc_rollup.Inbox_merkelized_payload_hashes.genesis - payloads_history - first - in - let* payloads_history, _witness = - List.fold_left_e - (fun (payloads_history, witness) -> - Sc_rollup.Inbox_merkelized_payload_hashes.add_payload - payloads_history - witness) - (payloads_history, witness) - messages - in - return payloads_history - -let serialize_external_message msg = - Environment.wrap_tzresult - @@ - let open Result_syntax in - let open Sc_rollup.Inbox_message in - let+ msg = serialize @@ External msg in - unsafe_to_string msg - -let init ~predecessor_timestamp ~predecessor ~level = - Sc_rollup.Inbox.genesis - ~predecessor_timestamp - ~predecessor - (Raw_level.of_int32_exn level) - |> Sc_rollup_proto_types.Inbox.to_octez - -module Internal_for_tests = struct - let process_messages = process_messages -end diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/inbox.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/inbox.mli deleted file mode 100644 index f9264289de5b687f847e1a1729acbb08fc13d9a0..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/inbox.mli +++ /dev/null @@ -1,122 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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 rollup node maintains an inbox of incoming messages. - - The incoming messages for a rollup are published on the layer 1. To - maintain the state of its inbox, a rollup node retrieves these - messages each time the tezos blockchain is updated. - - The inbox state is persistent. - -*) - -open Protocol.Alpha_context -open Sc_rollup - -(** [process_head node_ctxt ~predecessor head operations] changes the state of - the inbox to react to [head] (where [predecessor] is the predecessor of - [head] in the L1 chain). In particular, this process filters the provided - [operations] of the [head] block. *) -val process_head : - Node_context.rw -> - predecessor:Layer1.header -> - Layer1.header -> - (Octez_smart_rollup.Inbox.Hash.t - * Octez_smart_rollup.Inbox.t - * Merkelized_payload_hashes_hash.t - * string list) - tzresult - Lwt.t - -(** [add_messages ~is_first_block ~predecessor_timestamp - ~predecessor inbox messages] adds [messages] to the [inbox] using - {!Sc_rollup.Inbox.add_all_messages}. *) -val add_messages : - is_first_block:bool -> - predecessor_timestamp:Timestamp.time -> - predecessor:Block_hash.t -> - Inbox.t -> - Inbox_message.t list -> - (Inbox_merkelized_payload_hashes.History.t - * Inbox_merkelized_payload_hashes.Hash.t - * Inbox.t - * Inbox_message.t list) - tzresult - Lwt.t - -(** [payloads_history_of_messages ~is_first_block ~predecessor - ~predecessor_timestamp messages] builds the payloads history for - the list of [messages]. This allows to not store payloads - histories (which contain merkelized skip lists) but simply - messages. *) -val payloads_history_of_messages : - is_first_block:bool -> - predecessor:Block_hash.t -> - predecessor_timestamp:Timestamp.time -> - string list -> - Sc_rollup.Inbox_merkelized_payload_hashes.History.t tzresult - -(** [payloads_history_of_all_messages messages] builds the merkelized payloads - history for the list of serialzied messages [messages]. *) -val payloads_history_of_all_messages : - string list -> Sc_rollup.Inbox_merkelized_payload_hashes.History.t tzresult - -(** [same_as_layer_1 node_ctxt block node_inbox] ensures that the rollup - node agrees with the L1 node that inbox for [block] is [node_inbox]. *) -val same_as_layer_1 : - _ Node_context.t -> - Block_hash.t -> - Octez_smart_rollup.Inbox.t -> - unit tzresult Lwt.t - -(** Serialize an external messages to the protocol representation. NOTE: this - adds a tag ['\001'] at the beginning. *) -val serialize_external_message : string -> string tzresult - -(** Returns the initial global inbox where [level] is the first level of the - protocol with smart rollups. *) -val init : - predecessor_timestamp:Time.Protocol.t -> - predecessor:Block_hash.t -> - level:int32 -> - Octez_smart_rollup.Inbox.t - -(**/**) - -module Internal_for_tests : sig - val process_messages : - Node_context.rw -> - is_first_block:bool -> - predecessor:Layer1.header -> - Layer1.header -> - string list -> - (Octez_smart_rollup.Inbox.Hash.t - * Octez_smart_rollup.Inbox.t - * Merkelized_payload_hashes_hash.t - * string list) - tzresult - Lwt.t -end diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/inbox_event.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/inbox_event.ml deleted file mode 100644 index 346a494bcd560dffdc75ad3fe8b919add1368e97..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/inbox_event.ml +++ /dev/null @@ -1,45 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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 Simple = struct - include Internal_event.Simple - - let section = [Protocol.name; "smart_rollup_node"; "inbox"] - - let get_messages = - declare_3 - ~section - ~name:"smart_rollup_node_layer_1_get_messages" - ~msg: - "Fetching {number_of_messages} messages from block {hash} at level \ - {level}" - ~level:Notice - ("hash", Block_hash.encoding) - ("level", Data_encoding.int32) - ("number_of_messages", Data_encoding.int32) -end - -let get_messages hash level number_of_messages = - Simple.(emit get_messages (hash, level, Int32.of_int number_of_messages)) diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/inbox_event.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/inbox_event.mli deleted file mode 100644 index 4e313d39797bf1bc088713e5a48857178add590b..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/inbox_event.mli +++ /dev/null @@ -1,28 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** [get_messages hash level n] emits the event that [n] messages are being - fetched from the block of the given [hash] at the given [level]. *) -val get_messages : Block_hash.t -> int32 -> int -> unit Lwt.t diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/layer1_event.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/layer1_event.ml deleted file mode 100644 index 6a0987632b05f33897697fb843de8c909db21eb6..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/layer1_event.ml +++ /dev/null @@ -1,61 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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 Simple = struct - include Internal_event.Simple - - let section = [Protocol.name; "sc_rollup_node"; "layer_1"] - - let starting = - declare_0 - ~section - ~name:"sc_rollup_node_layer_1_starting" - ~msg:"Starting layer 1 tracker of the smart rollup node" - ~level:Notice - () - - let stopping = - declare_0 - ~section - ~name:"sc_rollup_node_layer_1_stopping" - ~msg:"Stopping layer 1 tracker of the smart rollup node" - ~level:Notice - () - - let switched_new_head = - declare_2 - ~section - ~name:"sc_rollup_node_layer_1_new_head" - ~msg:"Layer 1 node has switched to head {hash} at level {level}" - ~level:Notice - ("hash", Block_hash.encoding) - ("level", Data_encoding.int32) -end - -let starting = Simple.(emit starting) - -let stopping = Simple.(emit stopping) - -let switched_new_head hash level = Simple.(emit switched_new_head (hash, level)) diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/layer1_event.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/layer1_event.mli deleted file mode 100644 index 5b8ff83a660c8f47c23e8596b35c9ee19b2aba44..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/layer1_event.mli +++ /dev/null @@ -1,35 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* 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 module defines functions that emit the events used by the layer 1 chain - (see {!Layer}). *) - -val starting : unit -> unit Lwt.t - -val stopping : unit -> unit Lwt.t - -(** [switched_new_head hash level] emits the event that the layer 1 has notified - a new head with [hash] at some given [level]. *) -val switched_new_head : Block_hash.t -> int32 -> unit Lwt.t diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/layer1_helpers.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/layer1_helpers.ml deleted file mode 100644 index fa347dda9529d3f987df12c34ba1d927477dd0b7..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/layer1_helpers.ml +++ /dev/null @@ -1,255 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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_client_context - -type Layer1.block += Block of Alpha_block_services.block_info - -let fetch cctxt ?metadata ?chain ?block () = - let open Lwt_result_syntax in - let+ block = Alpha_block_services.info cctxt ?metadata ?chain ?block () in - Block block - -let extract_header = function - | Block block -> block.header.shell - | _ -> - invalid_arg ("Internal error: Block is not of protocol " ^ Protocol.name) - -let fetch_tezos_block l1_ctxt hash = - let open Lwt_result_syntax in - let+ block = Layer1.fetch_tezos_block fetch extract_header l1_ctxt hash in - match block with - | Block block -> block - | _ -> - Format.kasprintf - invalid_arg - "Internal error: Block %a is not of protocol %s" - Block_hash.pp - hash - Protocol.name - -let prefetch_tezos_blocks = Layer1.prefetch_tezos_blocks fetch extract_header - -let get_last_cemented_commitment (cctxt : #Client_context.full) rollup_address : - Node_context.lcc tzresult Lwt.t = - let open Lwt_result_syntax in - let cctxt = - new Protocol_client_context.wrap_full (cctxt :> Client_context.full) - in - let rollup_address = Sc_rollup_proto_types.Address.of_octez rollup_address in - let+ commitment, level = - Plugin.RPC.Sc_rollup.last_cemented_commitment_hash_with_level - cctxt - (cctxt#chain, `Head 0) - rollup_address - in - { - Node_context.commitment = - Sc_rollup_proto_types.Commitment_hash.to_octez commitment; - level = Protocol.Alpha_context.Raw_level.to_int32 level; - } - -let get_last_published_commitment ?(allow_unstake = true) - (cctxt : #Client_context.full) rollup_address operator = - let open Lwt_result_syntax in - let cctxt = - new Protocol_client_context.wrap_full (cctxt :> Client_context.full) - in - let rollup_address = Sc_rollup_proto_types.Address.of_octez rollup_address in - let*! res = - Plugin.RPC.Sc_rollup.staked_on_commitment - cctxt - (cctxt#chain, `Head 0) - rollup_address - operator - in - match res with - | Error trace - when allow_unstake - && TzTrace.fold - (fun exists -> function - | Environment.Ecoproto_error - Protocol.Sc_rollup_errors.Sc_rollup_not_staked -> - true - | _ -> exists) - false - trace -> - return_none - | Error trace -> fail trace - | Ok None -> return_none - | Ok (Some (_staked_hash, staked_commitment)) -> - return_some (Sc_rollup_proto_types.Commitment.to_octez staked_commitment) - -let get_kind cctxt rollup_address = - let open Lwt_result_syntax in - let cctxt = - new Protocol_client_context.wrap_full (cctxt :> Client_context.full) - in - let rollup_address = Sc_rollup_proto_types.Address.of_octez rollup_address in - let+ kind = - RPC.Sc_rollup.kind cctxt (cctxt#chain, cctxt#block) rollup_address () - in - Sc_rollup_proto_types.Kind.to_octez kind - -let genesis_inbox cctxt ~genesis_level = - let open Lwt_result_syntax in - let cctxt = - new Protocol_client_context.wrap_full (cctxt :> Client_context.full) - in - let+ inbox = - Plugin.RPC.Sc_rollup.inbox cctxt (cctxt#chain, `Level genesis_level) - in - Sc_rollup_proto_types.Inbox.to_octez inbox - -let constants_of_parametric - Protocol.Alpha_context.Constants.Parametric. - { - minimal_block_delay; - delay_increment_per_round; - sc_rollup = - { - challenge_window_in_blocks; - commitment_period_in_blocks; - max_number_of_stored_cemented_commitments; - _; - }; - dal = - { - feature_enable; - attestation_lag; - number_of_slots; - cryptobox_parameters; - _; - }; - _; - } = - let open Protocol.Alpha_context in - Rollup_constants. - { - minimal_block_delay = Period.to_seconds minimal_block_delay; - delay_increment_per_round = Period.to_seconds delay_increment_per_round; - sc_rollup = - { - challenge_window_in_blocks; - commitment_period_in_blocks; - reveal_activation_level = None; - max_number_of_stored_cemented_commitments; - }; - dal = - {feature_enable; attestation_lag; number_of_slots; cryptobox_parameters}; - } - -(* TODO: https://gitlab.com/tezos/tezos/-/issues/2901 - The constants are retrieved from the latest tezos block. These constants can - be different from the ones used at the creation at the rollup because of a - protocol amendment that modifies some of them. This need to be fixed when the - rollup nodes will be able to handle the migration of protocol. -*) -let retrieve_constants ?(block = `Head 0) cctxt = - let open Lwt_result_syntax in - let cctxt = - new Protocol_client_context.wrap_full (cctxt :> Client_context.full) - in - let+ {parametric; _} = - Protocol.Constants_services.all cctxt (cctxt#chain, block) - in - constants_of_parametric parametric - -let retrieve_genesis_info cctxt rollup_address = - let open Lwt_result_syntax in - let open Protocol.Alpha_context in - let cctxt = - new Protocol_client_context.wrap_full (cctxt :> Client_context.full) - in - let+ {level; commitment_hash} = - RPC.Sc_rollup.genesis_info - cctxt - (cctxt#chain, `Head 0) - (Sc_rollup_proto_types.Address.of_octez rollup_address) - in - Node_context. - { - level = Raw_level.to_int32 level; - commitment_hash = - Sc_rollup_proto_types.Commitment_hash.to_octez commitment_hash; - } - -let get_boot_sector block_hash (node_ctxt : _ Node_context.t) = - let open Protocol in - let open Alpha_context in - let open Lwt_result_syntax in - let exception Found_boot_sector of string in - let* block = fetch_tezos_block node_ctxt.l1_ctxt block_hash in - let missing_boot_sector () = - failwith "Boot sector not found in Tezos block %a" Block_hash.pp block_hash - in - Lwt.catch - (fun () -> - let apply (type kind) accu ~source:_ (operation : kind manager_operation) - (result : kind Apply_results.successful_manager_operation_result) = - match (operation, result) with - | ( Sc_rollup_originate {boot_sector; _}, - Sc_rollup_originate_result {address; _} ) - when Octez_smart_rollup.Address.( - node_ctxt.config.sc_rollup_address - = Sc_rollup_proto_types.Address.to_octez address) -> - raise (Found_boot_sector boot_sector) - | _ -> accu - in - let apply_internal (type kind) accu ~source:_ - (_operation : kind Apply_internal_results.internal_operation) - (_result : - kind Apply_internal_results.successful_internal_operation_result) = - accu - in - let*? () = - Layer1_services.( - process_applied_manager_operations - (Ok ()) - block.operations - {apply; apply_internal}) - in - missing_boot_sector ()) - (function - | Found_boot_sector boot_sector -> return boot_sector - | _ -> missing_boot_sector ()) - -let find_whitelist _cctxt _rollup_address : - Signature.public_key_hash trace option tzresult Lwt.t = - return None - -let find_last_whitelist_update _cctxt _rollup_address = return_none - -let get_commitment cctxt rollup_address commitment_hash = - let open Lwt_result_syntax in - let+ commitment = - Plugin.RPC.Sc_rollup.commitment - (new Protocol_client_context.wrap_full (cctxt :> Client_context.full)) - (cctxt#chain, `Head 0) - (Sc_rollup_proto_types.Address.of_octez rollup_address) - (Sc_rollup_proto_types.Commitment_hash.of_octez commitment_hash) - in - Sc_rollup_proto_types.Commitment.to_octez commitment diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/layer1_helpers.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/layer1_helpers.mli deleted file mode 100644 index 55bdef4ae9ee041c8b21b1480c26e8861645f861..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/layer1_helpers.mli +++ /dev/null @@ -1,93 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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 Octez_smart_rollup_node.Layer1 - -(** [fetch_tezos_block cctxt hash] returns a block info given a block hash. - Looks for the block in the blocks cache first, and fetches it from the L1 - node otherwise. *) -val fetch_tezos_block : - t -> - Block_hash.t -> - Protocol_client_context.Alpha_block_services.block_info tzresult Lwt.t - -(** [prefetch_tezos_blocks l1_ctxt blocks] prefetches the blocks - asynchronously. NOTE: the number of blocks to prefetch must not be greater - than the size of the blocks cache otherwise they will be lost. *) -val prefetch_tezos_blocks : t -> head list -> unit - -val get_last_cemented_commitment : - #Client_context.full -> Address.t -> Node_context.lcc tzresult Lwt.t - -val get_last_published_commitment : - ?allow_unstake:bool -> - #Client_context.full -> - Address.t -> - Signature.public_key_hash -> - Commitment.t option tzresult Lwt.t - -val get_kind : #Client_context.full -> Address.t -> Kind.t tzresult Lwt.t - -val genesis_inbox : - #Client_context.full -> - genesis_level:int32 -> - Octez_smart_rollup.Inbox.t tzresult Lwt.t - -(** Convert protocol constants to their protocol agnostic representation. *) -val constants_of_parametric : - Protocol.Alpha_context.Constants.Parametric.t -> - Rollup_constants.protocol_constants - -(** Retrieve protocol agnotic constants for the head of the chain. *) -val retrieve_constants : - ?block:Block_services.block -> - #Client_context.full -> - Rollup_constants.protocol_constants tzresult Lwt.t - -val retrieve_genesis_info : - #Client_context.full -> Address.t -> Node_context.genesis_info tzresult Lwt.t - -(** [get_boot_sector block_hash node_ctxt] retrieves the boot sector from the - rollup origination operation in block [block_hash]. Precondition: - [block_hash] has to be the block where the rollup was originated. *) -val get_boot_sector : Block_hash.t -> _ Node_context.t -> string tzresult Lwt.t - -(** Find and retrieve the whitelist the rollup. *) -val find_whitelist : - #Client_context.full -> - Address.t -> - Signature.public_key_hash list option tzresult Lwt.t - -(** Find and retrieve information about the last whitelist update. *) -val find_last_whitelist_update : - #Client_context.full -> Address.t -> (Z.t * Int32.t) option tzresult Lwt.t - -(** Retrieve a commitment published on L1. *) -val get_commitment : - #Client_context.full -> - Address.t -> - Commitment.Hash.t -> - Commitment.t tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/outbox.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/outbox.ml deleted file mode 100644 index d5b876b98a4aaaa66c5125c0ffa2abdc965237d0..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/outbox.ml +++ /dev/null @@ -1,90 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* Copyright (c) 2023 TriliTech, *) -(* *) -(* 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 Node_context -open Context_sigs -open Context_wrapper.Irmin - -let get_state_of_lcc node_ctxt = - let open Lwt_result_syntax in - let lcc = Reference.get node_ctxt.lcc in - let* block_hash = Node_context.hash_of_level node_ctxt lcc.level in - let* ctxt = Node_context.checkout_context node_ctxt block_hash in - let*! state = Context.PVMState.find ctxt in - return state - -let proof_of_output node_ctxt output = - let open Lwt_result_syntax in - let* state = get_state_of_lcc node_ctxt in - let lcc = Reference.get node_ctxt.lcc in - match state with - | None -> - (* - This case should never happen as origination creates an LCC which - must have been considered by the rollup node at startup time. - *) - failwith "Error producing outbox proof (no cemented state in the node)" - | Some state -> ( - let module PVM = (val Pvm.of_kind node_ctxt.kind) in - let*! proof = - PVM.produce_output_proof - (of_node_context node_ctxt.context).index - (of_node_pvmstate state) - output - in - match proof with - | Ok proof -> - let serialized_proof = - Data_encoding.Binary.to_string_exn PVM.output_proof_encoding proof - in - return @@ (lcc.commitment, serialized_proof) - | Error err -> - failwith - "Error producing outbox proof (%a)" - Environment.Error_monad.pp - err) - -let proof_of_output_simple node_ctxt ~outbox_level ~message_index = - let open Lwt_result_syntax in - let outbox_level = Protocol.Alpha_context.Raw_level.to_int32 outbox_level in - let* state = get_state_of_lcc node_ctxt in - let lcc = Reference.get node_ctxt.lcc in - match state with - | None -> - (* - This case should never happen as origination creates an LCC which - must have been considered by the rollup node at startup time. - *) - failwith "Error producing outbox proof (no cemented state in the node)" - | Some state -> - let+ proof = - Pvm_plugin.produce_serialized_output_proof - node_ctxt - state - ~outbox_level - ~message_index - in - (lcc.commitment, proof) diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/outbox.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/outbox.mli deleted file mode 100644 index a1fe87d186a2778ffa3fc563741ea3dba26d98e0..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/outbox.mli +++ /dev/null @@ -1,44 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* Copyright (c) 2023 TriliTech, *) -(* *) -(* 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 module provides helper to interact with PVM outboxes. *) - -open Protocol.Alpha_context - -(** [proof_of_output node_ctxt output] returns the last cemented commitment hash - and the proof of the output in the LCC. *) -val proof_of_output : - Node_context.rw -> - Sc_rollup.output -> - (Octez_smart_rollup.Commitment.Hash.t * string) tzresult Lwt.t - -(** [proof_of_output_at node_ctxt ~level ~message_index] returns the last cemented - commitment hash and the proof of the output in the LCC. *) -val proof_of_output_simple : - Node_context.rw -> - outbox_level:Raw_level.t -> - message_index:int -> - (Octez_smart_rollup.Commitment.Hash.t * string) tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/pvm.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/pvm.ml deleted file mode 100644 index 341c40c2aefe72aa0ab0b247713a2a3aa5526672..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/pvm.ml +++ /dev/null @@ -1,35 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022-2023 TriliTech *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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 S = Pvm_sig.S - -let of_kind : Kind.t -> (module S) = function - | Example_arith -> (module Arith_pvm) - | Wasm_2_0_0 -> (module Wasm_2_0_0_pvm) - | Riscv -> invalid_arg "Riscv rollup is inactive in this protocol" - -let context : Kind.t -> (module Context_sigs.S) = function - | _ -> (module Irmin_context) diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/pvm_plugin.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/pvm_plugin.ml deleted file mode 100644 index 9a69a4f65f5e54ccef883ba142626dd0493aad90..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/pvm_plugin.ml +++ /dev/null @@ -1,142 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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 -open Alpha_context -open Context_wrapper.Irmin - -let context = Pvm.context - -module Context = Irmin_context - -let get_tick kind state = - let open Lwt_syntax in - let module PVM = (val Pvm.of_kind kind) in - let+ tick = PVM.get_tick (of_node_pvmstate state) in - Sc_rollup.Tick.to_z tick - -let state_hash kind state = - let open Lwt_syntax in - let module PVM = (val Pvm.of_kind kind) in - let+ hash = PVM.state_hash (of_node_pvmstate state) in - Sc_rollup_proto_types.State_hash.to_octez hash - -let initial_state kind = - let open Lwt_syntax in - let module PVM = (val Pvm.of_kind kind) in - let+ state = PVM.initial_state ~empty:(PVM.State.empty ()) in - to_node_pvmstate state - -let parse_boot_sector kind = - let module PVM = (val Pvm.of_kind kind) in - PVM.parse_boot_sector - -let install_boot_sector kind state boot_sector = - let open Lwt_syntax in - let module PVM = (val Pvm.of_kind kind) in - let+ state = PVM.install_boot_sector (of_node_pvmstate state) boot_sector in - to_node_pvmstate state - -let get_status node_ctxt state = - let open Lwt_result_syntax in - let module PVM = (val Pvm.of_kind node_ctxt.Node_context.kind) in - let*! status = PVM.get_status (of_node_pvmstate state) in - return (PVM.string_of_status status) - -let get_current_level kind state = - let open Lwt_option_syntax in - let module PVM = (val Pvm.of_kind kind) in - let+ current_level = PVM.get_current_level (of_node_pvmstate state) in - Raw_level.to_int32 current_level - -module Fueled = Fueled_pvm - -let start_of_level_serialized = - let open Sc_rollup_inbox_message_repr in - unsafe_to_string start_of_level_serialized - -let end_of_level_serialized = - let open Sc_rollup_inbox_message_repr in - unsafe_to_string end_of_level_serialized - -let protocol_migration_serialized = - let open Sc_rollup_inbox_message_repr in - Some (unsafe_to_string Raw_context.protocol_migration_serialized_message) - -let info_per_level_serialized ~predecessor ~predecessor_timestamp = - let open Sc_rollup_inbox_message_repr in - unsafe_to_string - (info_per_level_serialized ~predecessor ~predecessor_timestamp) - -let find_whitelist_update_output_index _node_ctxt _state ~outbox_level:_ = - Lwt.return_none - -let produce_serialized_output_proof node_ctxt state ~outbox_level ~message_index - = - let open Lwt_result_syntax in - let state = of_node_pvmstate state in - let module PVM = (val Pvm.of_kind node_ctxt.Node_context.kind) in - let outbox_level = Raw_level.of_int32_exn outbox_level in - let*! outbox = PVM.get_outbox outbox_level state in - let output = List.nth outbox message_index in - match output with - | None -> invalid_arg "invalid index" - | Some output -> ( - let*! proof = - PVM.produce_output_proof - (of_node_context node_ctxt.context).index - state - output - in - match proof with - | Ok proof -> - let serialized_proof = - Data_encoding.Binary.to_string_exn PVM.output_proof_encoding proof - in - return serialized_proof - | Error err -> - failwith - "Error producing outbox proof (%a)" - Environment.Error_monad.pp - err) - -module Wasm_2_0_0 = struct - let decode_durable_state enc tree = - Wasm_2_0_0_pvm.Durable_state.Tree_encoding_runner.decode - enc - (of_node_pvmstate tree) - - let proof_mem_tree tree = - Wasm_2_0_0_pvm.Wasm_2_0_0_proof_format.Tree.mem_tree (of_node_pvmstate tree) - - let proof_fold_tree ?depth tree key ~order ~init ~f = - Wasm_2_0_0_pvm.Wasm_2_0_0_proof_format.Tree.fold - ?depth - (of_node_pvmstate tree) - key - ~order - ~init - ~f:(fun a b c -> f a (to_node_pvmstate b) c) -end diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/pvm_plugin.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/pvm_plugin.mli deleted file mode 100644 index e0183f81e6368cf6a620b4ec9d3c185465b832bc..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/pvm_plugin.mli +++ /dev/null @@ -1,27 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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 Pvm_plugin_sig.S diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/pvm_rpc.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/pvm_rpc.ml deleted file mode 100644 index f1180236418279b0b73f78090a3bc84941525dbc..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/pvm_rpc.ml +++ /dev/null @@ -1,45 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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 S = sig - (** Build RPC directory of the PVM *) - val build_sub_directory : - Node_context.rw -> - (unit * Rollup_node_services.Arg.block_id) Tezos_rpc.Directory.t -end - -module No_rpc = struct - let build_sub_directory _node_ctxt = Tezos_rpc.Directory.empty -end - -let no_rpc = (module No_rpc : S) - -let of_kind = function - | Kind.Example_arith -> no_rpc - | Wasm_2_0_0 -> - (module Wasm_2_0_0_rpc.Make_RPC (Wasm_2_0_0_pvm.Durable_state) : S) - | Riscv -> - (* Riscv rollup is inactive in this protocol *) - no_rpc diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/pvm_sig.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/pvm_sig.ml deleted file mode 100644 index 1d7f5e8c1685ce4b9b6f14b531c81b7493ed816a..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/pvm_sig.ml +++ /dev/null @@ -1,101 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022-2023 TriliTech *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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 -open Alpha_context - -(** Desired module type of a PVM from the L2 node's perspective *) -module type S = sig - include - Sc_rollup.PVM.S - with type context = Irmin_context.rw_index - and type state = Irmin_context.tree - and type hash = Sc_rollup.State_hash.t - - (** Kind of the PVM. *) - val kind : Sc_rollup.Kind.t - - (** [get_tick state] gets the total tick counter for the given PVM state. *) - val get_tick : state -> Sc_rollup.Tick.t Lwt.t - - (** PVM status *) - type status - - (** [get_status state] gives you the current execution status for the PVM. *) - val get_status : state -> status Lwt.t - - (** [string_of_status status] returns a string representation of [status]. *) - val string_of_status : status -> string - - (** [get_outbox outbox_level state] returns a list of outputs - available in the outbox of [state] at a given [outbox_level]. *) - val get_outbox : Raw_level.t -> state -> Sc_rollup.output list Lwt.t - - (** [eval_many ~max_steps s0] returns a state [s1] resulting from the - execution of up to [~max_steps] steps of the rollup at state [s0]. *) - val eval_many : - reveal_builtins:Tezos_scoru_wasm.Builtins.reveals -> - write_debug:Tezos_scoru_wasm.Builtins.write_debug -> - ?stop_at_snapshot:bool -> - max_steps:int64 -> - state -> - (state * int64) Lwt.t - - val new_dissection : - default_number_of_sections:int -> - start_chunk:Sc_rollup.Dissection_chunk.t -> - our_stop_chunk:Sc_rollup.Dissection_chunk.t -> - Sc_rollup.Tick.t list - - (** State storage for this PVM. *) - module State : sig - (** [empty ()] is the empty state. *) - val empty : unit -> state - - (** [find context] returns the PVM state stored in the [context], if any. *) - val find : _ Irmin_context.t -> state option Lwt.t - - (** [lookup state path] returns the data stored for the path [path] in the - PVM state [state]. *) - val lookup : state -> string list -> bytes option Lwt.t - - (** [set context state] saves the PVM state [state] in the context and - returns the updated context. Note: [set] does not perform any write on - disk, this information must be committed using {!val:Irmin_context.commit}. *) - val set : 'a Irmin_context.t -> state -> 'a Irmin_context.t Lwt.t - end - - (** Inspect durable state using a more specialised way of reading the - PVM state. - For example in WASM, it decodes the durable storage in the state - before reading values. - *) - module Inspect_durable_state : sig - (** [lookup state path] returns the data stored for the path [path] in the - PVM state [state]. *) - val lookup : state -> string list -> bytes option Lwt.t - end -end diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_game_helpers.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_game_helpers.ml deleted file mode 100644 index 6d032fcc38f9566d2341d72b5de5027ff546570d..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_game_helpers.ml +++ /dev/null @@ -1,352 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* Copyright (c) 2023 TriliTech *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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 -open Alpha_context -open Context_wrapper.Irmin - -(** This function computes the inclusion/membership proof of the page - identified by [page_id] in the slot whose data are provided in - [slot_data]. *) -let page_membership_proof params page_index slot_data = - (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/4048 - Rely on DAL node to compute page membership proof and drop - the dal-crypto dependency from the rollup node. *) - let proof = - let open Result_syntax in - (* The computation of the page's proof below can be a bit costly. In fact, - it involves initialising a cryptobox environment and some non-trivial - crypto processing. *) - let* dal = Cryptobox.make params in - let* polynomial = Cryptobox.polynomial_from_slot dal slot_data in - Cryptobox.prove_page dal polynomial page_index - in - let open Lwt_result_syntax in - match proof with - | Ok proof -> return proof - | Error e -> - failwith - "%s" - (match e with - | `Fail s -> "Fail " ^ s - | `Page_index_out_of_range -> "Page_index_out_of_range" - | `Slot_wrong_size s -> "Slot_wrong_size: " ^ s - | ( `Invalid_degree_strictly_less_than_expected _ - | `Prover_SRS_not_loaded ) as commit_error -> - Cryptobox.string_of_commit_error commit_error) - -(** When the PVM is waiting for a Dal page input, this function attempts to - retrieve the page's content from the store, the data of its slot. Then it - computes the proof that the page is part of the slot and returns the - content along with the proof. - - If the PVM is not waiting for a Dal page input, or if the slot is known to - be unconfirmed on L1, this function returns [None]. If the data of the - slot are not saved to the store, the function returns a failure - in the error monad. *) -let page_info_from_pvm_state (node_ctxt : _ Node_context.t) ~dal_attestation_lag - (dal_params : Dal.parameters) start_state = - let open Lwt_result_syntax in - let module PVM = (val Pvm.of_kind node_ctxt.kind) in - let*! input_request = PVM.is_input_state start_state in - match input_request with - | Sc_rollup.(Needs_reveal (Request_dal_page page_id)) -> ( - let Dal.Page.{slot_id; page_index} = page_id in - let* pages = - Dal_pages_request.slot_pages ~dal_attestation_lag node_ctxt slot_id - in - match pages with - | None -> return_none (* The slot is not confirmed. *) - | Some pages -> ( - let pages_per_slot = dal_params.slot_size / dal_params.page_size in - (* check invariant that pages' length is correct. *) - (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/4031 - It's better to do the check when the slots are saved into disk. *) - (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3997 - This check is not resilient to dal parameters change. *) - match List.nth_opt pages page_index with - | Some content -> - let* page_proof = - page_membership_proof dal_params page_index - @@ Bytes.concat Bytes.empty pages - in - return_some (content, page_proof) - | None -> - failwith - "Page index %d too big or negative.\n\ - Number of pages in a slot is %d." - page_index - pages_per_slot)) - | _ -> return_none - -let metadata (node_ctxt : _ Node_context.t) = - let address = - Sc_rollup_proto_types.Address.of_octez node_ctxt.config.sc_rollup_address - in - let origination_level = Raw_level.of_int32_exn node_ctxt.genesis_info.level in - Sc_rollup.Metadata.{address; origination_level} - -let generate_proof (node_ctxt : _ Node_context.t) - (game : Octez_smart_rollup.Game.t) (start_state : Context.pvmstate) = - let open Lwt_result_syntax in - let module PVM = (val Pvm.of_kind node_ctxt.kind) in - let snapshot = - Sc_rollup_proto_types.Inbox.history_proof_of_octez game.inbox_snapshot - in - (* NOTE: [snapshot_level_int32] below refers to the level of the snapshotted - inbox (from the skip list) which also matches [game.start_level - 1]. *) - let snapshot_level_int32 = - (Octez_smart_rollup.Inbox.Skip_list.content game.inbox_snapshot).level - in - let get_snapshot_head () = - let+ hash = Node_context.hash_of_level node_ctxt snapshot_level_int32 in - Layer1.{hash; level = snapshot_level_int32} - in - let* context = - let* start_hash = Node_context.hash_of_level node_ctxt game.inbox_level in - let+ context = Node_context.checkout_context node_ctxt start_hash in - Context.index context - in - let* dal_slots_history = - if Node_context.dal_supported node_ctxt then - let* snapshot_head = get_snapshot_head () in - Dal_slots_tracker.slots_history_of_hash node_ctxt snapshot_head - else return Dal.Slots_history.genesis - in - let* dal_slots_history_cache = - if Node_context.dal_supported node_ctxt then - let* snapshot_head = get_snapshot_head () in - Dal_slots_tracker.slots_history_cache_of_hash node_ctxt snapshot_head - else return (Dal.Slots_history.History_cache.empty ~capacity:0L) - in - (* We fetch the value of protocol constants at block snapshot level - where the game started. *) - let* constants = - Protocol_plugins.get_constants_of_level node_ctxt snapshot_level_int32 - in - let dal_l1_parameters = constants.dal in - let dal_parameters = dal_l1_parameters.cryptobox_parameters in - let dal_attestation_lag = dal_l1_parameters.attestation_lag in - - let* page_info = - page_info_from_pvm_state - ~dal_attestation_lag - node_ctxt - dal_parameters - (of_node_pvmstate start_state) - in - let module P = struct - include PVM - - let context : context = (of_node_context context).index - - let state = of_node_pvmstate start_state - - let reveal hash = - let open Lwt_syntax in - let* res = - Reveals.get - ~pre_images_endpoint:node_ctxt.config.pre_images_endpoint - ~data_dir:node_ctxt.data_dir - ~pvm_kind:(Sc_rollup_proto_types.Kind.to_octez PVM.kind) - ~hash - in - match res with Ok data -> return @@ Some data | Error _ -> return None - - module Inbox_with_history = struct - let inbox = snapshot - - let get_history inbox_hash = - let open Lwt_syntax in - let+ inbox = - Node_context.find_inbox - node_ctxt - (Sc_rollup_proto_types.Inbox_hash.to_octez inbox_hash) - in - match inbox with - | Error err -> - Format.kasprintf - Stdlib.failwith - "Refutation game: Cannot get inbox history for %a, %a" - Sc_rollup.Inbox.Hash.pp - inbox_hash - pp_print_trace - err - | Ok inbox -> - Option.map - (fun i -> - Sc_rollup.Inbox.take_snapshot - (Sc_rollup_proto_types.Inbox.of_octez i)) - inbox - - let get_payloads_history witness = - Lwt.map - (WithExceptions.Result.to_exn_f - ~error:(Format.kasprintf Stdlib.failwith "%a" pp_print_trace)) - @@ - let open Lwt_result_syntax in - let* messages = - Messages.get - node_ctxt - (Sc_rollup_proto_types.Merkelized_payload_hashes_hash.to_octez - witness) - in - let*? hist = Inbox.payloads_history_of_all_messages messages in - return hist - end - - module Dal_with_history = struct - let confirmed_slots_history = dal_slots_history - - let get_history ptr = - Dal.Slots_history.History_cache.find ptr dal_slots_history_cache - |> Lwt.return - - let dal_attestation_lag = dal_attestation_lag - - let dal_parameters = dal_parameters - - let page_info = page_info - end - end in - let metadata = metadata node_ctxt in - let*! start_tick = PVM.get_tick (of_node_pvmstate start_state) in - let* proof = - trace - (Sc_rollup_node_errors.Cannot_produce_proof - { - inbox_level = game.inbox_level; - start_tick = Sc_rollup.Tick.to_z start_tick; - }) - @@ (Sc_rollup.Proof.produce - ~metadata - (module P) - (Raw_level.of_int32_exn game.inbox_level) - >|= Environment.wrap_tzresult) - in - let*? pvm_step = - Sc_rollup.Proof.unserialize_pvm_step ~pvm:(module PVM) proof.pvm_step - |> Environment.wrap_tzresult - in - let unserialized_proof = {proof with pvm_step} in - let*! res = - Sc_rollup.Proof.valid - ~metadata - snapshot - (Raw_level.of_int32_exn game.inbox_level) - dal_slots_history - dal_parameters - ~dal_attestation_lag - ~pvm:(module PVM) - unserialized_proof - >|= Environment.wrap_tzresult - in - assert (Result.is_ok res) ; - let proof = - Data_encoding.Binary.to_string_exn Sc_rollup.Proof.encoding proof - in - return proof - -let make_dissection plugin (node_ctxt : _ Node_context.t) ~start_state - ~start_chunk ~our_stop_chunk ~default_number_of_sections ~last_level = - let open Lwt_result_syntax in - let module PVM = (val Pvm.of_kind node_ctxt.kind) in - let state_of_tick ?start_state tick = - Interpreter.state_of_tick - plugin - node_ctxt - ?start_state - ~tick:(Sc_rollup.Tick.to_z tick) - last_level - in - let state_hash_of_eval_state Pvm_plugin_sig.{state_hash; _} = - Sc_rollup_proto_types.State_hash.of_octez state_hash - in - let start_chunk = - Sc_rollup_proto_types.Game.dissection_chunk_of_octez start_chunk - in - let our_stop_chunk = - Sc_rollup_proto_types.Game.dissection_chunk_of_octez our_stop_chunk - in - let+ dissection = - Game_helpers.make_dissection - ~state_of_tick - ~state_hash_of_eval_state - ?start_state - ~start_chunk - ~our_stop_chunk - @@ PVM.new_dissection - ~start_chunk - ~our_stop_chunk - ~default_number_of_sections - in - List.map Sc_rollup_proto_types.Game.dissection_chunk_to_octez dissection - -let timeout_reached node_ctxt ~self ~opponent = - let open Lwt_result_syntax in - let Node_context.{config; cctxt; _} = node_ctxt in - let+ game_result = - Plugin.RPC.Sc_rollup.timeout_reached - (new Protocol_client_context.wrap_full cctxt) - (cctxt#chain, `Head 0) - (Sc_rollup_proto_types.Address.of_octez config.sc_rollup_address) - self - opponent - in - let open Sc_rollup.Game in - match game_result with - | Some (Loser {loser; _}) -> - let is_it_me = Signature.Public_key_hash.(self = loser) in - not is_it_me - | _ -> false - -let get_conflicts cctxt rollup staker = - let open Lwt_result_syntax in - let cctxt = new Protocol_client_context.wrap_full cctxt in - let+ conflicts = - Plugin.RPC.Sc_rollup.conflicts - cctxt - (cctxt#chain, `Head 0) - (Sc_rollup_proto_types.Address.of_octez rollup) - staker - in - List.map Sc_rollup_proto_types.Game.conflict_to_octez conflicts - -let get_ongoing_games cctxt rollup staker = - let open Lwt_result_syntax in - let cctxt = new Protocol_client_context.wrap_full cctxt in - let+ games = - Plugin.RPC.Sc_rollup.ongoing_refutation_games - cctxt - (cctxt#chain, `Head 0) - (Sc_rollup_proto_types.Address.of_octez rollup) - staker - in - List.map - (fun (game, staker1, staker2) -> - (Sc_rollup_proto_types.Game.to_octez game, staker1, staker2)) - games diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_game_helpers.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_game_helpers.mli deleted file mode 100644 index f1cb92984580169289922b4e9e06d3e6de84ab0d..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_game_helpers.mli +++ /dev/null @@ -1,28 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* Copyright (c) 2023 TriliTech *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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 Protocol_plugin_sig.REFUTATION_GAME_HELPERS diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/reveals.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/reveals.ml deleted file mode 100644 index 9257609685ca1287bb8fb61680ba55990049aa93..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/reveals.ml +++ /dev/null @@ -1,159 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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.Alpha_context -module Reveal_hash = Protocol.Sc_rollup_reveal_hash - -type error += Wrong_hash of {found : Reveal_hash.t; expected : Reveal_hash.t} - -let () = - Sc_rollup_node_errors.register_error_kind - ~id:"sc_rollup.node.wrong_hash_of_reveal_preimage" - ~title:"Hash of reveal preimage is not correct" - ~description:"Hash of reveal preimage is not correct." - ~pp:(fun ppf (found, expected) -> - Format.fprintf - ppf - "The hash of reveal preimage is %a while a value of %a is expected" - Reveal_hash.pp - found - Reveal_hash.pp - expected) - `Permanent - Data_encoding.( - obj2 - (req "found" Reveal_hash.encoding) - (req "expected" Reveal_hash.encoding)) - (function - | Wrong_hash {found; expected} -> Some (found, expected) | _ -> None) - (fun (found, expected) -> Wrong_hash {found; expected}) - -type source = String of string | File of string - -let file_contents filename = - let open Lwt_result_syntax in - Lwt.catch - (fun () -> - let*! contents = Lwt_utils_unix.read_file filename in - return_some contents) - (fun _ -> return_none) - -let path data_dir pvm_name hash = - let hash = Protocol.Sc_rollup_reveal_hash.to_hex hash in - Filename.(concat (concat data_dir pvm_name) hash) - -let proto_hash_to_dac_hash ((module Plugin) : Dac_plugin.t) proto_reveal_hash = - proto_reveal_hash - |> Data_encoding.Binary.to_bytes_exn Protocol.Sc_rollup_reveal_hash.encoding - |> Data_encoding.Binary.of_bytes_exn Plugin.encoding - -let get_from_preimages_service ~pre_images_endpoint ~local_filename hash = - let open Lwt_result_syntax in - let hash_hex = Protocol.Sc_rollup_reveal_hash.to_hex hash in - let*! () = Interpreter_event.missing_pre_image ~hash:hash_hex in - let url = - Uri.with_path - pre_images_endpoint - String.(concat "/" [Uri.path pre_images_endpoint; hash_hex]) - in - let*! resp, body = Cohttp_lwt_unix.Client.get url in - let*! body_str = Cohttp_lwt.Body.to_string body in - match resp.status with - | `OK -> - let contents_hash = - Reveal_hash.hash_string ~scheme:Reveal_hash.Blake2B [body_str] - in - if Reveal_hash.equal contents_hash hash then - let*! () = - Lwt_utils_unix.create_dir (Filename.dirname local_filename) - in - let*! () = Lwt_utils_unix.create_file local_filename body_str in - return_some body_str - else - let*! () = - Interpreter_event.fetched_incorrect_pre_image - ~expected_hash:hash_hex - ~content_hash:(Protocol.Sc_rollup_reveal_hash.to_hex contents_hash) - in - return_none - | #Cohttp.Code.status_code -> - tzfail (Layer_1.Http_connection_error (resp.status, body_str)) - -let get ~pre_images_endpoint ~data_dir ~pvm_kind ~hash = - let open Lwt_result_syntax in - let filename = - path data_dir (Octez_smart_rollup.Kind.to_string pvm_kind) hash - in - (* TODO: https://gitlab.com/tezos/tezos/-/issues/5296 - Use DAC observer client when [filename] doesn't exist. *) - let* contents = - let* file_contents = file_contents filename in - match file_contents with - | Some contents -> return contents - | None -> ( - match pre_images_endpoint with - | None -> - tzfail (Sc_rollup_node_errors.Could_not_open_preimage_file filename) - | Some pre_images_endpoint -> ( - let* contents = - get_from_preimages_service - ~pre_images_endpoint - ~local_filename:filename - hash - in - match contents with - | Some contents -> return contents - | None -> - tzfail - (Sc_rollup_node_errors.Could_not_open_preimage_file filename)) - ) - in - let*? () = - let contents_hash = - Reveal_hash.hash_string ~scheme:Reveal_hash.Blake2B [contents] - in - error_unless - (Reveal_hash.equal contents_hash hash) - (Wrong_hash {found = contents_hash; expected = hash}) - in - let* _encoded = - (* Check that the reveal input can be encoded within the bounds enforced by - the protocol. *) - trace Sc_rollup_node_errors.Could_not_encode_raw_data - @@ protect - @@ fun () -> - Data_encoding.Binary.to_bytes_exn - Sc_rollup.input_encoding - (Reveal (Raw_data contents)) - |> return - in - return contents - -let proto_hash_to_dac_hash proto_reveal_hash = - let dac_plugin = - WithExceptions.Option.get ~loc:__LOC__ @@ Dac_plugin.get Protocol.hash - in - proto_hash_to_dac_hash dac_plugin proto_reveal_hash diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/reveals.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/reveals.mli deleted file mode 100644 index 539d739d3ce9490a376421793c0ec310065ef4d5..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/reveals.mli +++ /dev/null @@ -1,79 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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 module provides basic support for reveals. - - The rollup can ask for data being the reveal of some hash. This - allows transferring data directly to the rollup without going - through the L1 inbox. - - Data length must be under 4KB to be refutable in a single L1 - operation. - - Data must be made available by off-chain mechanisms: it is the - responsibility of the rollup kernel to make sure that the reveal - data is available: otherwise, there is a potential safety issue. - - For the moment, the support is basic and mostly manual as the operator - needs to explicitly import a file in the rollup node data directoy to - enable the rollup node to answer reveal requests. - -*) - -(* FIXME:https://gitlab.com/tezos/tezos/-/issues/3854 - - We should probably have a mechanism to let the kernel declare - sources of reveal data so that the rollup node can automatically - download data in advance. *) - -(** Source of data *) -type source = - | String of string (** A string containing the whole data *) - | File of string - (** A file name whose associated file contains the whole data *) - -(** [get ~pre_images_endpoint ~data_dir ~pvm_name ~hash] retrieves - the data associated with the reveal hash [hash] from disk. If the data is - not already on disk, it will be retrieved from an - HTTP service at [pre_images_endpoint]. May fail with: - {ul - {li [Wrong_hash {found; expected}] where [expected = hash], and - [found <> hash], if the data is retrieved and hashes to the wrong - hash [found],} - {li [Could_not_open_preimage_file filename] if the function tries to - retrieve the data from [filename], but it cannot read the contents - of the file.} - {li [Could_not_encode_raw_data] if the data is too large (more than - 4kB) to be revealed.} - } *) -val get : - pre_images_endpoint:Uri.t option -> - data_dir:string -> - pvm_kind:Kind.t -> - hash:Protocol.Sc_rollup_reveal_hash.t -> - string tzresult Lwt.t - -(** Conversion from protocol reveal hash to protocol agnostic DAC hash. *) -val proto_hash_to_dac_hash : Protocol.Sc_rollup_reveal_hash.t -> Dac_plugin.hash diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/rollup_node_plugin.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/rollup_node_plugin.ml deleted file mode 100644 index 4c5dd5e5cfe44af177cd455e62b8dd74819996ad..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/rollup_node_plugin.ml +++ /dev/null @@ -1,40 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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 Plugin : Protocol_plugin_sig.S = struct - let protocol = Protocol.hash - - module RPC_directory = RPC_directory - module Dal_slots_tracker = Dal_slots_tracker - module Inbox = Inbox - module Interpreter = Interpreter - module Refutation_game_helpers = Refutation_game_helpers - module Batcher_constants = Batcher_constants - module Layer1_helpers = Layer1_helpers - module L1_processing = Daemon_helpers - module Pvm = Pvm_plugin -end - -let () = Protocol_plugins.register (module Plugin) diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/sc_rollup_injector.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/sc_rollup_injector.ml deleted file mode 100644 index 8f05f57aa5d88674e63719ed84ee7731798dc65b..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/sc_rollup_injector.ml +++ /dev/null @@ -1,469 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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 -open Alpha_context -open Injector_common -open Injector_sigs -module Block_cache = - Aches_lwt.Lache.Make_result - (Aches.Rache.Transfer (Aches.Rache.LRU) (Block_hash)) - -let injector_operation_to_manager : - L1_operation.t -> Protocol.Alpha_context.packed_manager_operation = function - | Add_messages {messages} -> Manager (Sc_rollup_add_messages {messages}) - | Cement {rollup; commitment} -> - let rollup = Sc_rollup_proto_types.Address.of_octez rollup in - let commitment = - Sc_rollup_proto_types.Commitment_hash.of_octez commitment - in - Manager (Sc_rollup_cement {rollup; commitment}) - | Publish {rollup; commitment} -> - let rollup = Sc_rollup_proto_types.Address.of_octez rollup in - let commitment = Sc_rollup_proto_types.Commitment.of_octez commitment in - Manager (Sc_rollup_publish {rollup; commitment}) - | Refute {rollup; opponent; refutation} -> - let rollup = Sc_rollup_proto_types.Address.of_octez rollup in - let refutation = - Sc_rollup_proto_types.Game.refutation_of_octez refutation - in - Manager (Sc_rollup_refute {rollup; opponent; refutation}) - | Timeout {rollup; stakers} -> - let rollup = Sc_rollup_proto_types.Address.of_octez rollup in - let stakers = Sc_rollup_proto_types.Game.index_of_octez stakers in - Manager (Sc_rollup_timeout {rollup; stakers}) - | Recover_bond {rollup; staker} -> - let rollup = Sc_rollup_proto_types.Address.of_octez rollup in - Manager (Sc_rollup_recover_bond {sc_rollup = rollup; staker}) - | Execute_outbox_message {rollup; cemented_commitment; output_proof} -> - let rollup = Sc_rollup_proto_types.Address.of_octez rollup in - let cemented_commitment = - Sc_rollup_proto_types.Commitment_hash.of_octez cemented_commitment - in - Manager - (Sc_rollup_execute_outbox_message - {rollup; cemented_commitment; output_proof}) - -let injector_operation_of_manager : - type kind. - kind Protocol.Alpha_context.manager_operation -> L1_operation.t option = - function - | Sc_rollup_add_messages {messages} -> Some (Add_messages {messages}) - | Sc_rollup_cement {rollup; commitment} -> - let rollup = Sc_rollup_proto_types.Address.to_octez rollup in - let commitment = - Sc_rollup_proto_types.Commitment_hash.to_octez commitment - in - Some (Cement {rollup; commitment}) - | Sc_rollup_publish {rollup; commitment} -> - let rollup = Sc_rollup_proto_types.Address.to_octez rollup in - let commitment = Sc_rollup_proto_types.Commitment.to_octez commitment in - Some (Publish {rollup; commitment}) - | Sc_rollup_refute {rollup; opponent; refutation} -> - let rollup = Sc_rollup_proto_types.Address.to_octez rollup in - let refutation = - Sc_rollup_proto_types.Game.refutation_to_octez refutation - in - Some (Refute {rollup; opponent; refutation}) - | Sc_rollup_timeout {rollup; stakers} -> - let rollup = Sc_rollup_proto_types.Address.to_octez rollup in - let stakers = Sc_rollup_proto_types.Game.index_to_octez stakers in - Some (Timeout {rollup; stakers}) - | Sc_rollup_execute_outbox_message {rollup; cemented_commitment; output_proof} - -> - let rollup = Sc_rollup_proto_types.Address.to_octez rollup in - let cemented_commitment = - Sc_rollup_proto_types.Commitment_hash.to_octez cemented_commitment - in - Some (Execute_outbox_message {rollup; cemented_commitment; output_proof}) - | _ -> None - -module Proto_client = struct - open Protocol_client_context - - type operation = L1_operation.t - - type state = Injector.state - - type unsigned_operation = - Tezos_base.Operation.shell_header * packed_contents_list - - let max_operation_data_length = Constants.max_operation_data_length - - let manager_pass = Operation_repr.manager_pass - - let manager_operation_size (Manager operation) = - let contents = - Manager_operation - { - source = Signature.Public_key_hash.zero; - operation; - fee = Tez.zero; - counter = Manager_counter.Internal_for_tests.of_int 0; - gas_limit = Gas.Arith.zero; - storage_limit = Z.zero; - } - in - Data_encoding.Binary.length Operation.contents_encoding (Contents contents) - - let operation_size op = - manager_operation_size (injector_operation_to_manager op) - - (* The operation size overhead is an upper bound (in practice) of the overhead - that will be added to a manager operation. To compute it we can use any - manager operation (here a revelation), add an overhead with upper bounds as - values (for the fees, limits, counters, etc.) and compare the encoded - operations with respect to their size. - NOTE: This information is only used to pre-select operations from the - injector queue as a candidate batch. *) - let operation_size_overhead = - let dummy_operation = - Reveal - (Signature.Public_key.of_b58check_exn - "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav") - in - let dummy_contents = - Manager_operation - { - source = Signature.Public_key_hash.zero; - operation = dummy_operation; - fee = Tez.of_mutez_exn 3_000_000L; - counter = Manager_counter.Internal_for_tests.of_int 500_000; - gas_limit = Gas.Arith.integral_of_int_exn 500_000; - storage_limit = Z.of_int 500_000; - } - in - let dummy_size = - Data_encoding.Binary.length - Operation.contents_encoding - (Contents dummy_contents) - in - dummy_size - manager_operation_size (Manager dummy_operation) - - let manager_operation_result_status (type kind) - (op_result : kind Apply_results.manager_operation_result) : - operation_status = - match op_result with - | Applied _ -> Successful - | Backtracked (_, None) -> Unsuccessful Backtracked - | Skipped _ -> Unsuccessful Skipped - | Backtracked (_, Some err) - (* Backtracked because internal operation failed *) - | Failed (_, err) -> - Unsuccessful (Failed (Environment.wrap_tztrace err)) - - let operation_result_status (type kind) - (op_result : kind Apply_results.contents_result) : operation_status = - match op_result with - | Preendorsement_result _ -> Successful - | Endorsement_result _ -> Successful - | Dal_attestation_result _ -> Successful - | Seed_nonce_revelation_result _ -> Successful - | Vdf_revelation_result _ -> Successful - | Double_endorsement_evidence_result _ -> Successful - | Double_preendorsement_evidence_result _ -> Successful - | Double_baking_evidence_result _ -> Successful - | Activate_account_result _ -> Successful - | Proposals_result -> Successful - | Ballot_result -> Successful - | Drain_delegate_result _ -> Successful - | Manager_operation_result {operation_result; _} -> - manager_operation_result_status operation_result - - let operation_contents_status (type kind) - (contents : kind Apply_results.contents_result_list) ~index : - operation_status tzresult = - let rec rec_status : - type kind. int -> kind Apply_results.contents_result_list -> _ = - fun n -> function - | Apply_results.Single_result _ when n <> 0 -> - error_with "No operation with index %d" index - | Single_result result -> Ok (operation_result_status result) - | Cons_result (result, _rest) when n = 0 -> - Ok (operation_result_status result) - | Cons_result (_result, rest) -> rec_status (n - 1) rest - in - rec_status index contents - - let operation_status_of_receipt (operation : Protocol.operation_receipt) - ~index : operation_status tzresult = - match (operation : _) with - | No_operation_metadata -> - error_with "Cannot find operation status because metadata is missing" - | Operation_metadata {contents} -> operation_contents_status contents ~index - - let get_block_operations = - let ops_cache = Block_cache.create 32 in - fun cctxt block_hash -> - Block_cache.bind_or_put - ops_cache - block_hash - (fun block_hash -> - let open Lwt_result_syntax in - let+ operations = - Alpha_block_services.Operations.operations_in_pass - cctxt - ~chain:cctxt#chain - ~block:(`Hash (block_hash, 0)) - ~metadata:`Always - manager_pass - in - List.fold_left - (fun acc (op : Alpha_block_services.operation) -> - Operation_hash.Map.add op.hash op acc) - Operation_hash.Map.empty - operations) - Lwt.return - - let operation_status {Injector.cctxt; _} block_hash operation_hash ~index = - let open Lwt_result_syntax in - let* operations = get_block_operations cctxt block_hash in - match Operation_hash.Map.find_opt operation_hash operations with - | None -> return_none - | Some operation -> ( - match operation.receipt with - | Empty -> - failwith "Cannot find operation status because metadata is empty" - | Too_large -> - failwith - "Cannot find operation status because metadata is too large" - | Receipt receipt -> - let*? status = operation_status_of_receipt receipt ~index in - return_some status) - - let dummy_sk_uri = - WithExceptions.Result.get_ok ~loc:__LOC__ - @@ Tezos_signer_backends.Unencrypted.make_sk - @@ Signature.Secret_key.of_b58check_exn - "edsk3UqeiQWXX7NFEY1wUs6J1t2ez5aQ3hEWdqX5Jr5edZiGLW8nZr" - - let simulate_operations cctxt ~force ~source ~src_pk ~successor_level - ~fee_parameter ?safety_guard operations = - let open Lwt_result_syntax in - let fee_parameter : Injection.fee_parameter = - { - minimal_fees = Tez.of_mutez_exn fee_parameter.minimal_fees.mutez; - minimal_nanotez_per_byte = fee_parameter.minimal_nanotez_per_byte; - minimal_nanotez_per_gas_unit = - fee_parameter.minimal_nanotez_per_gas_unit; - force_low_fee = fee_parameter.force_low_fee; - fee_cap = Tez.of_mutez_exn fee_parameter.fee_cap.mutez; - burn_cap = Tez.of_mutez_exn fee_parameter.burn_cap.mutez; - } - in - let open Annotated_manager_operation in - let annotated_operations = - List.map - (fun operation -> - let (Manager operation) = injector_operation_to_manager operation in - Annotated_manager_operation - (Injection.prepare_manager_operation - ~fee:Limit.unknown - ~gas_limit:Limit.unknown - ~storage_limit:Limit.unknown - operation)) - operations - in - let (Manager_list annot_op) = - Annotated_manager_operation.manager_of_list annotated_operations - in - let cctxt = - new Protocol_client_context.wrap_full (cctxt :> Client_context.full) - in - let safety_guard = Option.map Gas.Arith.integral_of_int_exn safety_guard in - let*! simulation_result = - Injection.inject_manager_operation - cctxt - ~simulation:true (* Only simulation here *) - ~force - ~chain:cctxt#chain - ~block:(`Head 0) - ~source - ~src_pk - ~src_sk:dummy_sk_uri - (* Use dummy secret key as it is not used by simulation *) - ~successor_level - ~fee:Limit.unknown - ~gas_limit:Limit.unknown - ~storage_limit:Limit.unknown - ?safety_guard - ~fee_parameter - annot_op - in - match simulation_result with - | Error trace -> - let exceeds_quota = - TzTrace.fold - (fun exceeds -> function - | Environment.Ecoproto_error - (Gas.Block_quota_exceeded | Gas.Operation_quota_exceeded) -> - true - | _ -> exceeds) - false - trace - in - fail (if exceeds_quota then `Exceeds_quotas trace else `TzError trace) - | Ok (_oph, packed_op, _contents, results) -> - let nb_ops = List.length operations in - let results = Apply_results.to_list (Contents_result_list results) in - (* packed_op can have reveal operations added automatically. *) - let start_index = List.length results - nb_ops in - (* remove extra reveal operations *) - let operations_statuses = - List.fold_left_i - (fun index_in_batch acc (Apply_results.Contents_result result) -> - if index_in_batch < start_index then acc - else - {index_in_batch; status = operation_result_status result} :: acc) - [] - results - |> List.rev - in - let unsigned_operation = - let {shell; protocol_data = Operation_data {contents; signature = _}} - = - packed_op - in - (shell, Contents_list contents) - in - return {operations_statuses; unsigned_operation} - - let sign_operation cctxt src_sk - ((shell, Contents_list contents) as unsigned_op) = - let open Lwt_result_syntax in - let unsigned_bytes = - Data_encoding.Binary.to_bytes_exn Operation.unsigned_encoding unsigned_op - in - let cctxt = - new Protocol_client_context.wrap_full (cctxt :> Client_context.full) - in - let+ signature = - Client_keys.sign - cctxt - ~watermark:Signature.Generic_operation - src_sk - unsigned_bytes - in - let op : packed_operation = - { - shell; - protocol_data = Operation_data {contents; signature = Some signature}; - } - in - Data_encoding.Binary.to_bytes_exn Operation.encoding op - - let time_until_next_block - {Injector.minimal_block_delay; delay_increment_per_round; _} - (header : Tezos_base.Block_header.shell_header option) = - let open Result_syntax in - match header with - | None -> minimal_block_delay |> Int64.to_int |> Ptime.Span.of_int_s - | Some header -> - let minimal_block_delay = Period.of_seconds_exn minimal_block_delay in - let delay_increment_per_round = - Period.of_seconds_exn delay_increment_per_round - in - let next_level_timestamp = - let* durations = - Round.Durations.create - ~first_round_duration:minimal_block_delay - ~delay_increment_per_round - in - let* predecessor_round = Fitness.round_from_raw header.fitness in - Round.timestamp_of_round - durations - ~predecessor_timestamp:header.timestamp - ~predecessor_round - ~round:Round.zero - in - let next_level_timestamp = - Result.value - next_level_timestamp - ~default: - (WithExceptions.Result.get_ok - ~loc:__LOC__ - Timestamp.(header.timestamp +? minimal_block_delay)) - in - Ptime.diff - (Time.System.of_protocol_exn next_level_timestamp) - (Time.System.now ()) - - let check_fee_parameters Injector.{fee_parameters; _} = - let check_value operation_kind name compare to_string mempool_default value - = - if compare mempool_default value > 0 then - error_with - "Bad configuration fee_parameter.%s for %s. It must be at least %s \ - for operations of the injector to be propagated." - name - (Operation_kind.to_string operation_kind) - (to_string mempool_default) - else Ok () - in - let check purpose - { - minimal_fees; - minimal_nanotez_per_byte; - minimal_nanotez_per_gas_unit; - force_low_fee = _; - fee_cap = _; - burn_cap = _; - } = - let open Result_syntax in - let+ () = - check_value - purpose - "minimal_fees" - Int64.compare - Int64.to_string - (Protocol.Alpha_context.Tez.to_mutez - Plugin.Mempool.default_minimal_fees) - minimal_fees.mutez - and+ () = - check_value - purpose - "minimal_nanotez_per_byte" - Q.compare - Q.to_string - Plugin.Mempool.default_minimal_nanotez_per_byte - minimal_nanotez_per_byte - and+ () = - check_value - purpose - "minimal_nanotez_per_gas_unit" - Q.compare - Q.to_string - Plugin.Mempool.default_minimal_nanotez_per_gas_unit - minimal_nanotez_per_gas_unit - in - () - in - Operation_kind.Map.iter_e check fee_parameters - - let checks state = check_fee_parameters state -end - -let () = Injector.register_proto_client Protocol.hash (module Proto_client) diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/sc_rollup_injector.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/sc_rollup_injector.mli deleted file mode 100644 index ca4112313ef6449d4ec20d700049ae0d28263944..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/sc_rollup_injector.mli +++ /dev/null @@ -1,32 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Manager operation for a given L1 operation. *) -val injector_operation_to_manager : - L1_operation.t -> Protocol.Alpha_context.packed_manager_operation - -(** L1 operation corresponding to a manager operation if any. *) -val injector_operation_of_manager : - 'a Protocol.Alpha_context.manager_operation -> L1_operation.t option diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/sc_rollup_node_errors.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/sc_rollup_node_errors.ml deleted file mode 100644 index bf57c29eda9b498b56c5e7775eb30e5caaaf9e3e..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/sc_rollup_node_errors.ml +++ /dev/null @@ -1,33 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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 Rollup_node_errors - -(** Registering protocol specific errors *) - -let make_id id = String.concat "." [Protocol.name; id] - -let register_error_kind ~id = register_error_kind ~id:(make_id id) diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/test/dune b/src/proto_017_PtNairob/lib_sc_rollup_node/test/dune deleted file mode 100644 index 2dfddc1ccdad3e3b7903c1277d168750c24809a4..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/test/dune +++ /dev/null @@ -1,48 +0,0 @@ -; This file was automatically generated, do not edit. -; Edit file manifest/main.ml instead. - -(library - (name src_proto_017_PtNairob_lib_sc_rollup_node_test_tezt_lib) - (instrumentation (backend bisect_ppx)) - (libraries - tezt.core - octez-libs.base - tezos-protocol-017-PtNairob.protocol - octez-libs.test-helpers - octez-protocol-017-PtNairob-libs.smart-rollup-layer2 - octez_smart_rollup_node_PtNairob - octez-alcotezt) - (library_flags (:standard -linkall)) - (flags - (:standard) - -open Tezt_core - -open Tezt_core.Base - -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals - -open Tezos_protocol_017_PtNairob - -open Tezos_test_helpers - -open Tezos_smart_rollup_layer2_017_PtNairob - -open Octez_smart_rollup_node_PtNairob - -open Octez_alcotezt) - (modules serialized_proofs test_octez_conversions)) - -(executable - (name main) - (instrumentation (backend bisect_ppx --bisect-sigterm)) - (libraries - src_proto_017_PtNairob_lib_sc_rollup_node_test_tezt_lib - tezt) - (link_flags - (:standard) - (:include %{workspace_root}/macos-link-flags.sexp)) - (modules main)) - -(rule - (alias runtest) - (package tezos-sc-rollup-node-test) - (enabled_if (<> false %{env:RUNTEZTALIAS=true})) - (action (run %{dep:./main.exe}))) - -(rule - (targets main.ml) - (action (with-stdout-to %{targets} (echo "let () = Tezt.Test.run ()")))) diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/test/serialized_proofs.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/test/serialized_proofs.ml deleted file mode 100644 index 8ca3226daeb108d02d67379f51c0449405464de5..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/test/serialized_proofs.ml +++ /dev/null @@ -1,121 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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 proofs : string list ref = ref [] - -(* Each serialized proof is added to the list with a side effect, so that it is - easy to generate (or augment) this file by instrumenting the rollup node. *) - -let () = - proofs := - "0000007b030002db10db4d3b595f59e0b53740f164bf951bcfae9e0873fd23fbce82fac4f404e1126f1b6c5546a5aeff4f59893ab63211a80e6f88e11b67339186109bf569d74a820b626f6f745f736563746f72c8baff5f78423676a25d9cd27a412dd932327b9b3e1cc26e754a36410a5efbf7b406737461747573c0010000" - :: !proofs - -let () = - proofs := - "000001e2030002dff7b99fc09bd426898107f2a430633c61dde3863a0e29a795826f064d838b4a344b4f2d13d32e6bf10caf9a59ed667666d644bff87fb5ce85243fe46a62d0d400110007c094fb4ab02d1eaeebb21ddb7da4996ab4663db3e1d7b227f2c501aa13ced50e300004c003c40612363f2296a21ab5f72bd8106d16f1189d2512533c14fe023fe2a9505b8204636f6465d04e8c2629e50b60cab76e6c91232e771d142ebcb0467889de40e2a27c168a5591086d65746164617461c01901073e4cb15d82dc12ed63e0f86679a085a8bb3d9400000002000a0005000482116576616c756174696f6e5f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905047469636bc00176820b626f6f745f736563746f72c8baff5f78423676a25d9cd27a412dd932327b9b3e1cc26e754a36410a5efbf7b418696e7465726e616c5f6d6573736167655f636f756e746572c00106810d63757272656e745f6c6576656cc0040000000400050003810f6d6573736167655f636f756e746572c00201078206737461747573c001010476617273d0c8883069b5a30e9ece9f91b68e759f1909bed7c0ccc0f1a3aee8d2d8473765edc04203ac25917e1d6ded20b0a57bab57da15ba6edfaa63b5c885c2c9985ddc2265ff0000000004070000027b0000020d11e1cf8d8d6637edc27e04a3b6861fbc06336c950314d2f0be3a19bebdd873f47400000012000000607e9df5467aa1c14b8482c20a3e29168879697801892fbb1e896a89904ec1705fc999d259dc5ef030f190d45cfd7e4e503b2b2cad3bbd87b7f481dedbb3bf077fc999d259dc5ef030f190d45cfd7e4e503b2b2cad3bbd87b7f481dedbb3bf077f0f868a1d495f0e46265daaf4edfcc451fdd0e4d178c96807f775b68686e4b6c3ad0000001000000040c8e206c6092f3b50cef178a5ca373722684bf1d4bc4e6a3cf6f18ec8977c4f9ff7f922f475e8ee6eec9078395a379a2a1b905caefc92c75e9d474b8ff7f421440b0bd6c62766cfb2a314d827cead108848c389a9f7d824f5b6baa6920d74757b590000000c0000004020911b9f0a604aa0a669c82cca6015a73e06da67790efc1622e905d3cc7deb0441be5bf60ef04d6806f946483d16974c847e13696b97a5c57679e77bb43ebd520750eb5f108b13387d9bf493d38655d4e49e92958b296b50e11c91ecc37338f0240000000800000040f624258bca6f66863aa5dc00d781a68d01617a4e57c7eeb571586cfd5d4fa42feceb7013cb9a3709f1fabd85eeb1d29f94f01fae86ea1bd48b96d9dc5f2c6e06037aea153e62097eb669959c79ba91e715db84e411ffffee26ee17415e14f9adaf000000040000002033a66cd216417b22be5ff5b40a2884efd21b41ba30710151c8c8b631f78d872900000065078f1f9fd0816a310a79d0e0c4bf605a544c260c561740bcdeb175ea46f5312890000000406aa2f7281c84f94013408e9be51c00f0c269a9e0168bc4e1487f8bd158712b2a0223eb4ac4e1f8d91f67b451f8368483543437958eb47c656650b141eff001d300" - :: !proofs - -let () = - proofs := - "000001e2030002dff7b99fc09bd426898107f2a430633c61dde3863a0e29a795826f064d838b4a344b4f2d13d32e6bf10caf9a59ed667666d644bff87fb5ce85243fe46a62d0d400110007c094fb4ab02d1eaeebb21ddb7da4996ab4663db3e1d7b227f2c501aa13ced50e300004c003c40612363f2296a21ab5f72bd8106d16f1189d2512533c14fe023fe2a9505b8204636f6465d04e8c2629e50b60cab76e6c91232e771d142ebcb0467889de40e2a27c168a5591086d65746164617461c01901073e4cb15d82dc12ed63e0f86679a085a8bb3d9400000002000a0005000482116576616c756174696f6e5f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905047469636bc00176820b626f6f745f736563746f72c8baff5f78423676a25d9cd27a412dd932327b9b3e1cc26e754a36410a5efbf7b418696e7465726e616c5f6d6573736167655f636f756e746572c00106810d63757272656e745f6c6576656cc0040000000400050003810f6d6573736167655f636f756e746572c00201078206737461747573c001010476617273d0c8883069b5a30e9ece9f91b68e759f1909bed7c0ccc0f1a3aee8d2d8473765edc04203ac25917e1d6ded20b0a57bab57da15ba6edfaa63b5c885c2c9985ddc2265ff0000000004070000027b0000020d118c4447d72cefb932b0ca79afe7e83680a3f5f940af12e510130890de093704e600000012000000608dfebf6bc80d3a6576db8bc05fdca115f1792bc708889f6c1e426a8fba62e41aec379b342e355104630c030f9fcdb2b45c8c1095ab4009aca365bceadabdcfb3ec379b342e355104630c030f9fcdb2b45c8c1095ab4009aca365bceadabdcfb30fbb838b70dafcb73c9fa937401a6b33dd4da8bfb1cc13518986029bd37814e280000000100000004069ef7e20a1f91d679504ab5a48899eec79e079a45f91939f0221a7a508358ef290e46fb7603c1723c2f698460a79f1e9642c1169fa2958961a87a74b9ff9e6430b480a065cd7198a5dc043acedef20e46dc7920c8592cca659cd961f5ea1dd90f00000000c000000406d802c5daf40c7215b73280efba85f67f0cc5747fcd2a0fe2328b5fdc252fd646920e1ffdb78b41f97546e80ad8a7287a1ba422057cad6f65c86c62a472aacfd0787e2b620f5c09d654e85e713d546450d660fc4988c658ddd3914d4bfc699d5cf000000080000004081b3c6ca730810be90b2f5ae9c4886e511f31933be84c0ac30af3b49b61fcdbfca6edbc188119ab8cf16b9e116af5f5a1de725fbaff2804f2508262b8d5dbc5a0347b79ca5ad4b09f9d7e9ead9854c082b664e51fba5558f2830fde4a5762367410000000400000020a17b14300c882553060d2694e5189fb3d86a998504248a47f4d359a29d2d6d6d00000065078f1f9fd0816a310a79d0e0c4bf605a544c260c561740bcdeb175ea46f53128900000004086f216dfb0131becbcc6a7a7e901db744c5030d09830fa3bbd5d0690eb5e2ec36877e8620a9491faa4d1a7c14b9fa50c394d69f699d239c1dce145d86566b49c00" - :: !proofs - -let () = - proofs := - "000001e2030002d83a6fcbfa317ba868d42fae27ddce20ad903cbb357a1b16823a14bce0631d733bdcad893d1ec690f5e7f44b73cc9e7a9119eda7942d6776b70b02b8276cdfcb00110007c0f16246649211503c309f0679ac228a4c510e90cf699d0dd1c71123465e3b1f340004c003c40612363f2296a21ab5f72bd8106d16f1189d2512533c14fe023fe2a9505b8204636f6465d04e8c2629e50b60cab76e6c91232e771d142ebcb0467889de40e2a27c168a5591086d65746164617461c01901073e4cb15d82dc12ed63e0f86679a085a8bb3d9400000002000a0005000482116576616c756174696f6e5f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905047469636bc00179820b626f6f745f736563746f72c8baff5f78423676a25d9cd27a412dd932327b9b3e1cc26e754a36410a5efbf7b418696e7465726e616c5f6d6573736167655f636f756e746572c00109810d63757272656e745f6c6576656cc0040000000500050003810f6d6573736167655f636f756e746572c00201078206737461747573c001010476617273d0c8883069b5a30e9ece9f91b68e759f1909bed7c0ccc0f1a3aee8d2d8473765edc04203ac25917e1d6ded20b0a57bab57da15ba6edfaa63b5c885c2c9985ddc2265ff0000000005070000036d000002ff11fc6cf0426308d2bffb18bf2b478124887feabcb245cd6b0b9e129588192a54c40000001200000060b12f07c7d9af455f96ddc30c0006cae6a47d4012a1d9ee52381a6ac466b90282a6d0f8cd48d167078b8277d8ea52a7a2b289c1cd57253953d8152987bf527508a6d0f8cd48d167078b8277d8ea52a7a2b289c1cd57253953d8152987bf5275080f064a0994f5eb055ea8e9611989f2af420bbfd91b1114f92f2bc12fe6b7a0cf0e00000010000000406036dc7a4a6e3dd4d7c53e1d31f3ca11949539681aef75c98a1a6e99e5c8023389e71f2788c0928cf48c78e78f4262386d05c26b7afd22a9e8b825bb2641d8140b687657f959d8f4d09d4a5d0dc02a92fad1d4c0c1834cfa52de824c68b71e82220000000c0000004099e839e62f772ca0b40026794b9e375dc254545aa597b3ac92f5769b64be931b59946ddfb2e26dd43fb1b183e13a0676055bdc96c9afec634562f967c16b17a3078d3709187faab160b53420e44f31bf89247940d19c42e0ffb8f741c31eedf49f0000000800000040d02e518af31bb716c6c2b217d488f919a9c358985585a9bc36764e49b1a06d83787ada119155f533cfd8ae0dcf26eee797ad414c4a9cfd77e5bfb25ad9db49180646d0cfe6a53bd991515525f0b69234f6bd255e13f2268b0e7056cc9749fe96a80000000700000040641a59b4d74772af88bd26b01930fdc833e4da32a6a8b134a83eefd5a891c67f787ada119155f533cfd8ae0dcf26eee797ad414c4a9cfd77e5bfb25ad9db491805e3292cfbce3f99c456c357448caf12dbb8d94ae727713e76204070ee7f93ec6f000000060000004025cc6a901f1677467a5effacdbea5918e4fe1db847ca23aa2d32a6009f4e49c3787ada119155f533cfd8ae0dcf26eee797ad414c4a9cfd77e5bfb25ad9db491804440a917893d879e6d120791d6f3686ef0e138f1aafa4218b9f2986f3e6fa83c20000000500000040787ada119155f533cfd8ae0dcf26eee797ad414c4a9cfd77e5bfb25ad9db4918787ada119155f533cfd8ae0dcf26eee797ad414c4a9cfd77e5bfb25ad9db491800000065078f1f9fd0816a310a79d0e0c4bf605a544c260c561740bcdeb175ea46f531289000000040d5177419909a1fbbf44e4d765d6fb055eade688bab86c66f22464dc90d9646a9136cb726c83432b2cf178eb3b1a1c32245d8b30adcc01468dfdd84665824dbb900" - :: !proofs - -let () = - proofs := - "000001e3030002dcfa6603288699daee959046196b807c6802422775a28aefa8955743b22be772b65ed549e8fc86fd1b0e4bfc2fe2e3562fa78bca93b48a46450d259daead220400110007c001fdc52ab8835ab29356f398abd306ece6190f2832649449a075fa02873be7870004c073b11921186a3ad9f169f3ce0b2f80b767ad931ff6e7828e8992ba73b3e72b918204636f6465d04e8c2629e50b60cab76e6c91232e771d142ebcb0467889de40e2a27c168a5591086d65746164617461c01901073e4cb15d82dc12ed63e0f86679a085a8bb3d9400000002000a0005000482116576616c756174696f6e5f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905047469636bc002b901820b626f6f745f736563746f72c8baff5f78423676a25d9cd27a412dd932327b9b3e1cc26e754a36410a5efbf7b418696e7465726e616c5f6d6573736167655f636f756e746572c00112810d63757272656e745f6c6576656cc0040000000800050003810f6d6573736167655f636f756e746572c00201078206737461747573c001010476617273d0c8883069b5a30e9ece9f91b68e759f1909bed7c0ccc0f1a3aee8d2d8473765edc04203ac25917e1d6ded20b0a57bab57da15ba6edfaa63b5c885c2c9985ddc2265ff00000000080700000232000001c411de172a5abce9a9a316b4d55bddb1f6208bd58546a42224aae7afe87e75103fbe00000012000000600babc274ae5da75f613af0b96c064841dc055fb086c7aee7c5cf59afc7a3c5eadda87e4df1828b9f40e4b3ddcb69903f1eceed5b45f796d5793a2406fc77a1e8dda87e4df1828b9f40e4b3ddcb69903f1eceed5b45f796d5793a2406fc77a1e80f96b234fd8fb7e2b70e9a773d91932d11a8cd2f58c5cff42f7756b4ae5982d2b00000001000000040a21c42cf974f22f9eeddc1cca859cee5e7e74a1d98571b4a48e78a70c867d1e99ae8cd149c8d4389f819cd04167e27b5339537f99a0ec1821b6fff92a92659130b29a8d6c8b6b112bb72dd52f8d68224a240340ebc707053997e1d140cc1625b090000000c00000040b982ce951ef7e4ddca7c1b9371d3dfc7840c1a5b661cdf28d0a727d3a34055fc2ddf903372525d24bca2cb46409f65960a1bb7dec7d4d3cf6107e6bed52c5a62079e4bad092eecab56a6945c7223ec0c7622d91724b7a26106b9bf3efbb0285e960000000800000040803d9fb1c0a3d81cc4806db2b519321bc7873a5e44dcc10f5948b47fc05ff827b0a464db5c39fe5809e2509465b36c17e24c18458175551c746256f129c6882000000065078f1f9fd0816a310a79d0e0c4bf605a544c260c561740bcdeb175ea46f5312890000000402f0b8c5524863a7d8b851a05f51888de954fd75bdb39638fba73bee6cd9f848238b7acf195d72a42ce6594d54911c2d544f581288c71502550916a1a32088f4100" - :: !proofs - -let () = - proofs := - "00000214030002e077bef17af38499b44807fabde3837e2355f4988146b065236bac172087929e24bc4324adefe61ff70a912adfce146400586b408d46b371c287b5df9fcdba4000100006d0030170000382066f7574707574d033ba419fa9cc8b769d0a76f2839bdaee68f7e12566131d1edbebaaa1e12169900c7061727365725f7374617465c00102c0fca618d8cfb53c29e8b61bcf584028571b6b1f563e164df093810f07a93265060003820c6e6578745f6d657373616765c0060100000001310e6f75747075745f636f756e746572c00102c0322d95cbadd30a23603872646abd7b0d341c5f3eca8f39da9da74bd3264d9775000a0005000482116576616c756174696f6e5f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905047469636bc00179c03b85b8bcac7168100efeb43114a4679d17808ab9309d16a22be916283fbde863c0d22ceeb53dad5d5a36f1caca13fb2cce988bed6679f7370d0d2e5aa042c6556c00050003c0cb0d5024ea71731c4142bd8b8ce738c9d44298b45ccc3d4fc2717db8d4eb78068206737461747573c001040476617273d0c8883069b5a30e9ece9f91b68e759f1909bed7c0ccc0f1a3aee8d2d8473765ed820c6c657865725f627566666572c00800000000000000000e70617273696e675f726573756c74c87a31b1c8e3af61756b336bcfc3b0c292c89b40cc8a5080ba99c45463d110ce8b00" - :: !proofs - -let () = - proofs := - "000002a7030002d918c66aa95d5080874df90faea75962fc4a4443996f8a6be3996739f9a2008804940e7d9453c3a83f99858741988f1b5056f21295ae698df95731c1ca00d70a00110007d0030170000382066f7574707574d0772e6802b1bb0a8f0553b122347b071e426307db4a54ca247a479f51d20c91170c7061727365725f7374617465c00101c0bf2d23e703638502856d46d16407070d7c47a5af5f5e33daa4d46a2d311eba870004820c6e6578745f6d657373616765c8794bebd4366203e527989fc7421c01bfc2976975f118a341ac007b5e0f53a1180e6f75747075745f636f756e746572c88a7ae305885619a2566d1c7fd87e3d67444fb5ce517a8fca5bee68a4061997ed8204636f6465d04e8c2629e50b60cab76e6c91232e771d142ebcb0467889de40e2a27c168a5591086d65746164617461c81bd59bb6258d782bad96d2164548403ee6b50359b81a885f3e11b988dfafe3ae000a0005000482116576616c756174696f6e5f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905047469636bc002ec01820b626f6f745f736563746f72c0040000000018696e7465726e616c5f6d6573736167655f636f756e746572c896f1f45bb65c0c32557f9a65d161156b248f2a1e62e1678892300949bd0589a2810d63757272656e745f6c6576656cc0040000000700050003810f6d6573736167655f636f756e746572c00201018206737461747573c001010476617273d0c8883069b5a30e9ece9f91b68e759f1909bed7c0ccc0f1a3aee8d2d8473765ed820c6c657865725f627566666572c8a8b484dd0c8b746c1a15618f6fb51a7b37f8c275afc6499d9c524fa0fbb743cc0e70617273696e675f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905ff0000000007010000032b0000022d112216fa511da8cf0ef50a29f5990dc65135aa9a72d1a686b2f1aba0bbdc1710f100000012000000608e03cd7fd0e4aafdb620093525a182431bc198b0ef56218f6e4d1253787df95c4f152285b05c88d8cbd414385df68dc0038a0949a6a2150a5835b64f620225404f152285b05c88d8cbd414385df68dc0038a0949a6a2150a5835b64f620225400f7c5d2e20abd394499b89ff0f01f8ca785cd4b83ac033a2b72bf6fc3ff6f72b76000000100000004030548b2d65eed411aab93a1050898da8b6560560efdeb6f5352ce25edf8990a1033e7e19ba33f12cc42a917f19767d2b0e9517855f905ce9f9b03edc4716511a0be7bc438063c29553e43fc7e0ad8672f2e47bac5622849003df6b29b11a01d4250000000c0000004003ad25557b67a5b5b0d5f484d69b5639d49290e57edbbcfab845a44c6d3caccaccc0ac98c43158ffc5dc55d3370c6a0d95e6f282b3f5c6c9bf924803f603636207797fef9633643ebdee8710d2481f2fe58af4201ef62570c79c1370f48108b5940000000800000040b69cf6e3364934b1d8e2f45152c899f1f787713d362b2d0962e5d2ed603b56f1722208556ce9c4cdffc91825b29d757bd81ef39b074b03b0afb5f9dd6f5601ee06c14c15749c2323c5571de585825120b0fcd8eaeffdbb3f38908581308d0312170000000700000040eabbe433d155ea8739a38e9c24bcfc7e23f4f3d69bdc9bdcb75ed722a605aa8a722208556ce9c4cdffc91825b29d757bd81ef39b074b03b0afb5f9dd6f5601ee000000ef078f1f9fd0816a310a79d0e0c4bf605a544c260c561740bcdeb175ea46f5312890000000401fb49ce2d7b7e3be61d2b4ca1774aa4740a1e1d12413f4a2a7597a9374645d422c20099c6029bbaa5a7cdeec1e3ddddbc5e4630af0ba11554535f657c27e38de035efc3165465aff68d3e5bd549d711f9e0e06e786bc1d6873f2e7e4faa43bbe130000002030cc84dad07aa536dbaaaccba95d4dabd7c5d6c6ca411372ca9326afeae3eed30228a91be1e75d0b3a4f6634ffbe25947d0bd042d41d1ab2f2a2a7d81b564312c000000020b384576e8dfeacafe447c7555442ed6057ec637adc6d72a1863b5e6a8094adf8ff000000020131" - :: !proofs - -let () = - proofs := - "0000021503000204940e7d9453c3a83f99858741988f1b5056f21295ae698df95731c1ca00d70aeb9288624e864a8aeecbb882b30fa04c28830cd6331d1697fd6d78570a47f43e00100006d0030170000382066f7574707574d0772e6802b1bb0a8f0553b122347b071e426307db4a54ca247a479f51d20c91170c7061727365725f7374617465c00102c0bf2d23e703638502856d46d16407070d7c47a5af5f5e33daa4d46a2d311eba870003820c6e6578745f6d657373616765c0060100000001310e6f75747075745f636f756e746572c00104c0322d95cbadd30a23603872646abd7b0d341c5f3eca8f39da9da74bd3264d9775000a0005000482116576616c756174696f6e5f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905047469636bc002ed01c052c196fbe4546e163fd1d777dfb388cece157a88fe10cc0e1ae48aa053fac3fec0e0590ca6ea22f7dabe3889c02d87873535203b5a450ef9e5ce102d2f99d8c0b800050003c0cb0d5024ea71731c4142bd8b8ce738c9d44298b45ccc3d4fc2717db8d4eb78068206737461747573c001040476617273d0c8883069b5a30e9ece9f91b68e759f1909bed7c0ccc0f1a3aee8d2d8473765ed820c6c657865725f627566666572c00800000000000000000e70617273696e675f726573756c74c87a31b1c8e3af61756b336bcfc3b0c292c89b40cc8a5080ba99c45463d110ce8b00" - :: !proofs - -let () = - proofs := - "00000215030002f677d054c8e623d1b22ecc8aea74f5074bf0c9529f898cac90db26a3992831d77b74a66258cc09c792da869b9b3bc683e35d9583c4206adc20d3b0296245408a00100006d0030170000382066f7574707574d0d5983c50395ec6533657eccf10ccf8d9c4062ff6501c2074868953ffee9073830c7061727365725f7374617465c00102c0bf2d23e703638502856d46d16407070d7c47a5af5f5e33daa4d46a2d311eba870003820c6e6578745f6d657373616765c0060100000001310e6f75747075745f636f756e746572c00104c0322d95cbadd30a23603872646abd7b0d341c5f3eca8f39da9da74bd3264d9775000a0005000482116576616c756174696f6e5f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905047469636bc002f301c01c1fab5de0181afb420733a2d6b0a12ce0b70c494b7dfccff1e2447eee86380fc04607fa9b3ac608330ef58339fb3dc505880bae0b9fae4f3f10ff9f8534a3856a00050003c0cb0d5024ea71731c4142bd8b8ce738c9d44298b45ccc3d4fc2717db8d4eb78068206737461747573c001040476617273d0c8883069b5a30e9ece9f91b68e759f1909bed7c0ccc0f1a3aee8d2d8473765ed820c6c657865725f627566666572c00800000000000000000e70617273696e675f726573756c74c87a31b1c8e3af61756b336bcfc3b0c292c89b40cc8a5080ba99c45463d110ce8b00" - :: !proofs - -let () = - proofs := - "00000214030002e077bef17af38499b44807fabde3837e2355f4988146b065236bac172087929e24bc4324adefe61ff70a912adfce146400586b408d46b371c287b5df9fcdba4000100006d0030170000382066f7574707574d033ba419fa9cc8b769d0a76f2839bdaee68f7e12566131d1edbebaaa1e12169900c7061727365725f7374617465c00102c0fca618d8cfb53c29e8b61bcf584028571b6b1f563e164df093810f07a93265060003820c6e6578745f6d657373616765c0060100000001310e6f75747075745f636f756e746572c00102c0322d95cbadd30a23603872646abd7b0d341c5f3eca8f39da9da74bd3264d9775000a0005000482116576616c756174696f6e5f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905047469636bc00179c03b85b8bcac7168100efeb43114a4679d17808ab9309d16a22be916283fbde863c0d22ceeb53dad5d5a36f1caca13fb2cce988bed6679f7370d0d2e5aa042c6556c00050003c0cb0d5024ea71731c4142bd8b8ce738c9d44298b45ccc3d4fc2717db8d4eb78068206737461747573c001040476617273d0c8883069b5a30e9ece9f91b68e759f1909bed7c0ccc0f1a3aee8d2d8473765ed820c6c657865725f627566666572c00800000000000000000e70617273696e675f726573756c74c87a31b1c8e3af61756b336bcfc3b0c292c89b40cc8a5080ba99c45463d110ce8b00" - :: !proofs - -let () = - proofs := - "00000214030002e077bef17af38499b44807fabde3837e2355f4988146b065236bac172087929e24bc4324adefe61ff70a912adfce146400586b408d46b371c287b5df9fcdba4000100006d0030170000382066f7574707574d033ba419fa9cc8b769d0a76f2839bdaee68f7e12566131d1edbebaaa1e12169900c7061727365725f7374617465c00102c0fca618d8cfb53c29e8b61bcf584028571b6b1f563e164df093810f07a93265060003820c6e6578745f6d657373616765c0060100000001310e6f75747075745f636f756e746572c00102c0322d95cbadd30a23603872646abd7b0d341c5f3eca8f39da9da74bd3264d9775000a0005000482116576616c756174696f6e5f726573756c74c8eda4dcfc891aa48bb021d3ed729b7efc072bfccb367c623f60ed227bc4de4905047469636bc00179c03b85b8bcac7168100efeb43114a4679d17808ab9309d16a22be916283fbde863c0d22ceeb53dad5d5a36f1caca13fb2cce988bed6679f7370d0d2e5aa042c6556c00050003c0cb0d5024ea71731c4142bd8b8ce738c9d44298b45ccc3d4fc2717db8d4eb78068206737461747573c001040476617273d0c8883069b5a30e9ece9f91b68e759f1909bed7c0ccc0f1a3aee8d2d8473765ed820c6c657865725f627566666572c00800000000000000000e70617273696e675f726573756c74c87a31b1c8e3af61756b336bcfc3b0c292c89b40cc8a5080ba99c45463d110ce8b00" - :: !proofs - -let () = - proofs := - "000001af03000203fad519c60ce458d8173d60347a7165a47f94f34bb09563e3f916508a568ae5160daf16732031127d85916da8a2b2ed0b80e2ec6f76aeb5aed05f20e29535aa0005820764757261626c65d0700600b5ba8846f05688abbc84be210e9841df14210b69ecc81768bc2d7fa5be03746167c00800000004536f6d650003810370766d00050004000381166f7574626f785f76616c69646974795f706572696f64c00400013b0082136c6173745f746f705f6c6576656c5f63616c6cc00100196d6178696d756d5f7265626f6f74735f7065725f696e707574c002e80781146f7574626f785f6d6573736167655f6c696d6974c002a401810c6d61785f6e625f7469636b73c00580dc9afd28820576616c7565810370766d8107627566666572738205696e707574820468656164c00100066c656e677468c00100066f7574707574820133810f76616c69646974795f706572696f64c00400013b000134810d6d6573736167655f6c696d6974c002a401047761736d00038103746167c00b00000007636f6c6c656374820c63757272656e745f7469636bc001000e7265626f6f745f636f756e746572c002e907ff02" - :: !proofs - -let () = - proofs := - "000004a20300029154c3457e545055d89ece682b7699aa6468646bc118d31183e606af03c8720d8fdb2e43063ba2e4eb6227939439718b119ff743d5c7f1c0cb53efca9290cebd0005820764757261626c65d0700600b5ba8846f05688abbc84be210e9841df14210b69ecc81768bc2d7fa5be03746167c00800000004536f6d650003810370766d00050004000381166f7574626f785f76616c69646974795f706572696f64c00400013b0082136c6173745f746f705f6c6576656c5f63616c6cc00100196d6178696d756d5f7265626f6f74735f7065725f696e707574c002e80781146f7574626f785f6d6573736167655f6c696d6974c002a401810c6d61785f6e625f7469636b73c00580dc9afd28820576616c7565810370766d8107627566666572738205696e7075740003810468656164c001008208636f6e74656e747300040003c0a06eb14bc76138f3404aa3d1907e8ea56cdcab66fd9774fa42ceb0b5db70f3678101330004810f6d6573736167652d636f756e746572c00103000381066c656e677468c00800000000000000028208636f6e74656e7473810130c102000131000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000097261772d6c6576656cc00400000003810131d02be9203590ff323f40bb2e6123792ea6fe582c3004e90f2f07e341c357bb256f066c656e677468c00104066f75747075740004820132810a6c6173745f6c6576656cc004000000030133810f76616c69646974795f706572696f64c00400013b0082013181086f7574626f786573d085c221543585cc73785d90b8205fb70e0ff5fb3ec7cfb237c9de35507cdb04f70134810d6d6573736167655f6c696d6974c002a401047761736d00048205696e707574c005000000030303746167c00b00000007636f6c6c656374820c63757272656e745f7469636bc001040e7265626f6f745f636f756e746572c002e907ff000000000303000003fd00000256119e0f517b258ebaafc3b80f9580736196820e85a89a8b1dbcabc188dffb3c202e00000012000000609d64ecb31e24cbae9bffefb6398aeddbf63848d77a09f8abe6ec870520e52824f5ac4a20922d7f69815f53f2bc1d7e814237f7671dddb9b1da294c2dfc4c71def5ac4a20922d7f69815f53f2bc1d7e814237f7671dddb9b1da294c2dfc4c71de0fb08d67fcd4ee0d497ddf6d75ac8e18dc4828b7eaa24c9bab0d177ef15c0042f100000010000000403918d146062923546523ea77f9f279659b3ef195d3b078438f982c027b1d8917a9d39f2691329b1c8c9f7d42b4ebb7dafd332674e52f8abe2a1ab969e64e2fe50b7a898bab55e92ba1d139db2630c207cf08d698cd0a45b87d4f31ad0f863208db0000000c0000004007f78428e527a26c52b3663fe94540c0dcebc5c06812ac73483dc9e163aba6054734bbd10c6f776cfc899e2ed68c9922c46761ddaef39a7d6ad74f51db9a6ba007c33fc08871ca22ec9f40c437074d7c036c0f7f73847d1c06c9a17e1996b7d9440000000800000040b9229c6473b0774f80374639e5a5d67d9cf2a44a3791e716cd9c344158f95d43d1bd41e8f0d23a94f58094dfdd6138fd1789f68a675fac5315ed813d38fa5b9e0364a4a59f6b439e7e70cc6a3db142f3389ebe3c825c0e6415880ce60e4983db260000000400000020426a3cc0ad6a52091e3d0e0db02ee1fcd56f50c46b7d292502485c175d63c9b9020a5f043148e900d19d02f79abf24b4bd582f6e93abfb9bd8c988eaf75408af3a0000000300000020ed9e0e19c20a3b721dab18672f6970178470220ead77baa226397a08bd7e876b00000194078f1f9fd0816a310a79d0e0c4bf605a544c260c561740bcdeb175ea46f531289000000040157503c39a941b28605440c02809ba0c46e7d2f467898c8fb686ce2f3b2468734dd4e700aae1d5046368abd3874e2381a67183a76ee0c0d4470980a6b26c963006a1d6ed77f0922b69266702ace9a97f218b0b5d575e2bbe6a6b01b9412d8c58a000000040c8f36f8363b363b45329f572116fba1982f4d2d733dc6f8088ff3a0157b931874dd4e700aae1d5046368abd3874e2381a67183a76ee0c0d4470980a6b26c963005474c297bef20ab15fb8d93783d324d6f07fb1a017891890f3b606bac241f144c000000400a5735bc6db3536eba3b549320c870fd51ee99747f79d5702cb3c5982224d3ec4dd4e700aae1d5046368abd3874e2381a67183a76ee0c0d4470980a6b26c9630045efc3165465aff68d3e5bd549d711f9e0e06e786bc1d6873f2e7e4faa43bbe13000000404dd4e700aae1d5046368abd3874e2381a67183a76ee0c0d4470980a6b26c96304dd4e700aae1d5046368abd3874e2381a67183a76ee0c0d4470980a6b26c9630ff00000006013120312078" - :: !proofs - -let () = - proofs := - "000004a2030002833ec3c4a0325b95cebe5505e305cc43ff64e52411b9363fe287f55b2dbd84d5499a79571ba2d9e172052e13d1eac510810ac4eca1d5157a65782d50a84b34690005820764757261626c6582066b65726e656cd07d20c53bdd5b536a6be9c4cdad16e69a9af40b93a6564655fffd88bba050519008726561646f6e6c7982066b65726e656cd0a645771d9d5228a31312b282119c596699ccb6b60b93d759c2072a493ddbb5740c7761736d5f76657273696f6e8101408208636f6e74656e7473810130c10200322e302e302d7231000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000066c656e677468c008000000000000000803746167c00800000004536f6d650003810370766d00050004000381166f7574626f785f76616c69646974795f706572696f64c00400013b0082136c6173745f746f705f6c6576656c5f63616c6cc00680f8e0cde105196d6178696d756d5f7265626f6f74735f7065725f696e707574c002e80781146f7574626f785f6d6573736167655f6c696d6974c002a401810c6d61785f6e625f7469636b73c00580dc9afd28820576616c7565810370766d8107627566666572738205696e7075740003810468656164c001008208636f6e74656e7473d029ca9b037bc58b2e8795cb5a78a9923e992ecb747d73aea69221f0bbf8862d9c066c656e677468c00108066f75747075740004820132810a6c6173745f6c6576656cc004000000050133810f76616c69646974795f706572696f64c00400013b0082013181086f7574626f786573d012db3a74b0a7328b572a034fb36111e11ca8db9beeee251c1b636e62b1a369500134810d6d6573736167655f6c696d6974c002a401047761736d00048205696e707574c005000000050703746167c00b0000000770616464696e67820c63757272656e745f7469636bc00688f8e0cde1050e7265626f6f745f636f756e746572c002e90700" - :: !proofs - -let () = - proofs := - "000004a2030002b45db06e873356846dc9bec6df51256edf0ede76c2c4c1fb856ff62a1dd3a71bb4591da0e6a078af531c232280cb8e68554a1879eb6a9e4308c006395fa45d770005820764757261626c6582066b65726e656cd07d20c53bdd5b536a6be9c4cdad16e69a9af40b93a6564655fffd88bba050519008726561646f6e6c7982066b65726e656cd0a645771d9d5228a31312b282119c596699ccb6b60b93d759c2072a493ddbb5740c7761736d5f76657273696f6e8101408208636f6e74656e7473810130c10200322e302e302d7231000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000066c656e677468c008000000000000000803746167c00800000004536f6d650003810370766d00050004000381166f7574626f785f76616c69646974795f706572696f64c00400013b0082136c6173745f746f705f6c6576656c5f63616c6cc00680f0c19bc30b196d6178696d756d5f7265626f6f74735f7065725f696e707574c002e80781146f7574626f785f6d6573736167655f6c696d6974c002a401810c6d61785f6e625f7469636b73c00580dc9afd28820576616c7565810370766d8107627566666572738205696e7075740003810468656164c001008208636f6e74656e7473d06a600b954d7302fba4b55875e6025671f6e6364ed0514556b0554107b4c2d245066c656e677468c00108066f75747075740004820132810a6c6173745f6c6576656cc004000000070133810f76616c69646974795f706572696f64c00400013b0082013181086f7574626f786573d0652e374ff90771cb8ec84a7106d62b8cf29b46632699c378aec1afc4aceb3d960134810d6d6573736167655f6c696d6974c002a401047761736d00048205696e707574c005000000070703746167c00b0000000770616464696e67820c63757272656e745f7469636bc00688f0c19bc30b0e7265626f6f745f636f756e746572c002e90700" - :: !proofs - -let () = - proofs := - "000004a203000298c8c12aa31ddb519d4848eca5b5faafafb686fc18232a7af3b9738eedbbf18b1b7a054f5dff5ac3a71c5b54d284633aa8390b7bcfcaad9f6cfab30466dc499c0005820764757261626c6582066b65726e656cd07d20c53bdd5b536a6be9c4cdad16e69a9af40b93a6564655fffd88bba050519008726561646f6e6c7982066b65726e656cd0a645771d9d5228a31312b282119c596699ccb6b60b93d759c2072a493ddbb5740c7761736d5f76657273696f6e8101408208636f6e74656e7473810130c10200322e302e302d7231000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000066c656e677468c008000000000000000803746167c00800000004536f6d650003810370766d00050004000381166f7574626f785f76616c69646974795f706572696f64c00400013b0082136c6173745f746f705f6c6576656c5f63616c6cc00680f0c19bc30b196d6178696d756d5f7265626f6f74735f7065725f696e707574c002e80781146f7574626f785f6d6573736167655f6c696d6974c002a401810c6d61785f6e625f7469636b73c00580dc9afd28820576616c7565810370766d8107627566666572738205696e7075740003810468656164c001008208636f6e74656e7473d095d3888221e81b7ccc795571fe150fca0b0b4f8fa6439bc3ad441f6677aa4238066c656e677468c00108066f75747075740004820132810a6c6173745f6c6576656cc004000000070133810f76616c69646974795f706572696f64c00400013b0082013181086f7574626f786573d0652e374ff90771cb8ec84a7106d62b8cf29b46632699c378aec1afc4aceb3d960134810d6d6573736167655f6c696d6974c002a401047761736d00048205696e707574c005000000070703746167c00b0000000770616464696e67820c63757272656e745f7469636bc00688f0c19bc30b0e7265626f6f745f636f756e746572c002e90700" - :: !proofs - -let () = - proofs := - "000004a20300029287c2d0b68cd84c11b0950becf1f954cd26ea6661ce417ee1e871c85d42744a29e1c7e29367c4b40f7d63966bf15195f125a711a800b82f646cd7acc2ef818f0005820764757261626c6582066b65726e656cd07d20c53bdd5b536a6be9c4cdad16e69a9af40b93a6564655fffd88bba050519008726561646f6e6c7982066b65726e656cd0a645771d9d5228a31312b282119c596699ccb6b60b93d759c2072a493ddbb5740c7761736d5f76657273696f6e8101408208636f6e74656e7473810130c10200322e302e302d7231000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000066c656e677468c008000000000000000803746167c00800000004536f6d650003810370766d00050004000381166f7574626f785f76616c69646974795f706572696f64c00400013b0082136c6173745f746f705f6c6576656c5f63616c6cc00680f0c19bc30b196d6178696d756d5f7265626f6f74735f7065725f696e707574c002e80781146f7574626f785f6d6573736167655f6c696d6974c002a401810c6d61785f6e625f7469636b73c00580dc9afd28820576616c7565810370766d8107627566666572738205696e7075740003810468656164c001008208636f6e74656e7473d09488f46e420b9e6a86886b62f56f5be815250291de20e0bb901503c473029a24066c656e677468c00108066f75747075740004820132810a6c6173745f6c6576656cc004000000070133810f76616c69646974795f706572696f64c00400013b0082013181086f7574626f786573d0652e374ff90771cb8ec84a7106d62b8cf29b46632699c378aec1afc4aceb3d960134810d6d6573736167655f6c696d6974c002a401047761736d00048205696e707574c005000000070703746167c00b0000000770616464696e67820c63757272656e745f7469636bc00688f0c19bc30b0e7265626f6f745f636f756e746572c002e90700" - :: !proofs - -let () = - proofs := - "000004a20300026c04959b2eeb9719f2fff009b30b1a3e056b2e303e00f30c6fa25649b2db6b6aa82b2e3cf2f36f0dbf44209528859e2ae36f77fc4cc844c91ec349a64e6f2c4f0005820764757261626c6582066b65726e656cd07d20c53bdd5b536a6be9c4cdad16e69a9af40b93a6564655fffd88bba050519008726561646f6e6c7982066b65726e656cd0a645771d9d5228a31312b282119c596699ccb6b60b93d759c2072a493ddbb5740c7761736d5f76657273696f6e8101408208636f6e74656e7473810130c10200322e302e302d7231000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000066c656e677468c008000000000000000803746167c00800000004536f6d650003810370766d00050004000381166f7574626f785f76616c69646974795f706572696f64c00400013b0082136c6173745f746f705f6c6576656c5f63616c6cc00680f0c19bc30b196d6178696d756d5f7265626f6f74735f7065725f696e707574c002e80781146f7574626f785f6d6573736167655f6c696d6974c002a401810c6d61785f6e625f7469636b73c00580dc9afd28820576616c7565810370766d8107627566666572738205696e7075740003810468656164c001008208636f6e74656e7473d02a07f402a57a796a07ac3ad8c832391cbf3b09435464e3c181c171a67ccf2dcc066c656e677468c00108066f75747075740004820132810a6c6173745f6c6576656cc004000000070133810f76616c69646974795f706572696f64c00400013b0082013181086f7574626f786573d0652e374ff90771cb8ec84a7106d62b8cf29b46632699c378aec1afc4aceb3d960134810d6d6573736167655f6c696d6974c002a401047761736d00048205696e707574c005000000070703746167c00b0000000770616464696e67820c63757272656e745f7469636bc00688f0c19bc30b0e7265626f6f745f636f756e746572c002e90700" - :: !proofs - -let proofs = !proofs diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/test/serialized_proofs.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/test/serialized_proofs.mli deleted file mode 100644 index 7f39b3313c891bcc1b2b687e980f9f9ba01f9876..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/test/serialized_proofs.mli +++ /dev/null @@ -1,27 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** List of pre-computed serialized refutation proofs. *) -val proofs : string list diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/test/test_octez_conversions.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/test/test_octez_conversions.ml deleted file mode 100644 index f099fdb8e4ffa7edb7b1ee3ef84a99dcc5e0cfa2..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/test/test_octez_conversions.ml +++ /dev/null @@ -1,441 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Functori, *) -(* *) -(* 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. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Smart rollup node library, type conversions - Invocation: dune exec src/proto_alpha/lib_sc_rollup_node/test/main.exe \ - -- -f test_octez_conversions.ml - Subject: Ensure conversions between octez smart rollup structures and - protocol ones are bijective. -*) - -open Qcheck2_helpers -open Octez_smart_rollup - -let gen_hash ~size of_bytes = - let open QCheck2.Gen in - let gen = - let* x = bytes_size (pure size) in - return @@ of_bytes x - in - (* This is not beautiful, but there is currently no other way to - remove the shrinker. *) - make_primitive - ~gen:(fun rand -> generate1 ~rand gen) - ~shrink:(fun _ -> Seq.empty) - -let gen_address = gen_hash ~size:Address.size Address.of_bytes_exn - -let gen_state_hash = gen_hash ~size:State_hash.size State_hash.of_bytes_exn - -let gen_inbox_hash = gen_hash ~size:Inbox.Hash.size Inbox.Hash.of_bytes_exn - -let gen_commitment_hash = - gen_hash ~size:Commitment.Hash.size Commitment.Hash.of_bytes_exn - -let gen_payload_hash = - gen_hash - ~size:Merkelized_payload_hashes_hash.size - Merkelized_payload_hashes_hash.of_bytes_exn - -let gen_kind = QCheck2.Gen.oneofl Kind.[Example_arith; Wasm_2_0_0] - -let gen_level = int32_range_gen 0l Int32.max_int - -let uint64 = int64_range_gen 0L Int64.max_int - -let gen_tick = - let open QCheck2.Gen in - let+ i = uint64 in - Z.of_int64 i - -let gen_commitment = - let open QCheck2.Gen in - let* compressed_state = gen_state_hash in - let* inbox_level = gen_level in - let* predecessor = gen_commitment_hash in - let+ number_of_ticks = uint64 in - Octez_smart_rollup.Commitment. - {compressed_state; inbox_level; predecessor; number_of_ticks} - -let gen_dissection_chunk = - let open QCheck2.Gen in - let* state_hash = option gen_state_hash in - let+ tick = gen_tick in - Octez_smart_rollup.Game.{state_hash; tick} - -let gen_dissection = QCheck2.Gen.small_list gen_dissection_chunk - -let gen_proof = - let open QCheck2.Gen in - let+ hex = oneofl Serialized_proofs.proofs in - Hex.to_string (`Hex hex) |> WithExceptions.Option.get ~loc:__LOC__ - -let gen_step = - let open QCheck2.Gen in - let* what = option ~ratio:0.1 (pure ()) in - match what with - | None -> - (* shrink there *) - let+ dissection = gen_dissection in - Octez_smart_rollup.Game.Dissection dissection - | Some () -> - let+ proof = gen_proof in - Octez_smart_rollup.Game.Proof proof - -let random_seed ~rng_state = - Bytes.init Tezos_crypto.Hacl.Ed25519.sk_size (fun _i -> - Char.chr (Random.State.int rng_state 256)) - -let random_algo ~rng_state : Signature.algo = - match Random.State.int rng_state 3 with - | 0 -> Ed25519 - | 1 -> Secp256k1 - | 2 -> P256 - | 3 -> Bls - | _ -> assert false - -let gen_algo = QCheck2.Gen.oneofl [Signature.Ed25519; Secp256k1; P256; Bls] - -let gen_pkh = - let open QCheck2.Gen in - let+ algo = gen_algo in - let pkh, _pk, _sk = Signature.generate_key ~algo () in - pkh - -let gen_stakers = - let open QCheck2.Gen in - let* p1 = gen_pkh in - let+ p2 = gen_pkh in - Octez_smart_rollup.Game.make_index p1 p2 - -let gen_refutation = - let open QCheck2.Gen in - let* b = bool in - match b with - | true -> - let* player_commitment_hash = gen_commitment_hash in - let+ opponent_commitment_hash = gen_commitment_hash in - Octez_smart_rollup.Game.Start - {player_commitment_hash; opponent_commitment_hash} - | false -> - let* choice = gen_tick in - let+ step = gen_step in - Octez_smart_rollup.Game.Move {choice; step} - -let gen_inbox = - let open Protocol in - let open Alpha_context in - let open QCheck2.Gen in - let gen_msg = small_string ~gen:printable in - let* hd = gen_msg in - let* tail = small_list gen_msg in - let payloads = hd :: tail in - let* level = gen_level in - let level = Raw_level.of_int32_exn level in - let witness_and_inbox = - let open Result_syntax in - let inbox = - Sc_rollup.Inbox.genesis - ~predecessor_timestamp:Time.Protocol.epoch - ~predecessor:Block_hash.zero - level - in - Environment.wrap_tzresult - @@ - let witness = Sc_rollup.Inbox.init_witness_no_history in - let witness = - Sc_rollup.Inbox.add_info_per_level_no_history - ~predecessor_timestamp:Time.Protocol.epoch - ~predecessor:Block_hash.zero - witness - in - let* input_messages = - List.map_e - (fun msg -> Sc_rollup.Inbox_message.(serialize (External msg))) - payloads - in - let* witness = - Sc_rollup.Inbox.add_messages_no_history input_messages witness - in - return (Sc_rollup.Inbox.finalize_inbox_level_no_history inbox witness) - in - return - @@ (witness_and_inbox |> function - | Ok v -> Sc_rollup_proto_types.Inbox.to_octez v - | Error e -> - Stdlib.failwith (Format.asprintf "%a" Error_monad.pp_print_trace e)) - -let gen_slot_index = - let open QCheck2.Gen in - graft_corners (int_bound 0xff) [0; 1; 2; 0xff] () - -let gen_page_index = - let open QCheck2.Gen in - let max = 0xfff / 2 in - graft_corners (int_bound max) [0; 1; 2; max] () - -let gen_slot_header_commitment = - let open QCheck2.Gen in - make_primitive - ~gen:(fun state -> - Tezos_crypto_dal.Cryptobox.Internal_for_tests.dummy_commitment ~state ()) - ~shrink:(fun _ -> Seq.empty) - -let gen_slot_header = - let open QCheck2.Gen in - let* published_level = gen_level in - let* index = gen_slot_index in - let+ commitment = gen_slot_header_commitment in - Octez_smart_rollup.Dal.Slot_header.{id = {published_level; index}; commitment} - -let compare_slot_header_id (s1 : Octez_smart_rollup.Dal.Slot_header.id) - (s2 : Octez_smart_rollup.Dal.Slot_header.id) = - let c = Int32.compare s1.published_level s2.published_level in - if c <> 0 then c else Int.compare s1.index s2.index - -let gen_slot_headers = - let open QCheck2.Gen in - let size = int_bound 50 in - let+ l = list_size size gen_slot_header in - List.sort - (fun (h1 : Octez_smart_rollup.Dal.Slot_header.t) - (h2 : Octez_smart_rollup.Dal.Slot_header.t) -> - compare_slot_header_id h1.id h2.id) - l - -let gen_slot_history = - let open Protocol.Alpha_context in - let open QCheck2.Gen in - let h = Dal.Slots_history.genesis in - let+ l = gen_slot_headers in - let l = List.map Sc_rollup_proto_types.Dal.Slot_header.of_octez l in - Dal.Slots_history.add_confirmed_slot_headers_no_cache h l |> function - | Error e -> - Stdlib.failwith (Format.asprintf "%a" Environment.Error_monad.pp_trace e) - | Ok v -> Sc_rollup_proto_types.Dal.Slot_history.to_octez v - -let gen_slot_history_cache = - let open Protocol.Alpha_context in - let open QCheck2.Gen in - let h = Dal.Slots_history.genesis in - let c = Dal.Slots_history.History_cache.empty ~capacity:Int64.max_int in - let+ l = gen_slot_headers in - let l = List.map Sc_rollup_proto_types.Dal.Slot_header.of_octez l in - Dal.Slots_history.add_confirmed_slot_headers h c l |> function - | Error e -> - Stdlib.failwith (Format.asprintf "%a" Environment.Error_monad.pp_trace e) - | Ok (_, c) -> Sc_rollup_proto_types.Dal.Slot_history_cache.to_octez c - -let test_roundtrip ~count name gen to_octez from_octez octez_encoding - proto_encoding = - let test octez1 = - try - let proto1 = from_octez octez1 in - let octez2 = to_octez proto1 in - let proto2 = from_octez octez2 in - let check version enc v1 v2 = - let b1 = Data_encoding.Binary.to_bytes_exn enc v1 in - let b2 = Data_encoding.Binary.to_bytes_exn enc v2 in - if not (Bytes.equal b1 b2) then - QCheck2.Test.fail_reportf - "%s-%s not identical after roundtrip conversion" - name - version - in - check "protocol" proto_encoding proto1 proto2 ; - check "octez" octez_encoding octez1 octez2 ; - true - with exn -> - QCheck2.Test.fail_reportf - "%s roundtrip conversion error: %s" - name - (Printexc.to_string exn) - in - let print v = - Data_encoding.Json.construct octez_encoding v - |> Data_encoding.Json.to_string ~minify:false - in - QCheck2.Test.make - ~count - ~print - ~name:(Format.asprintf "roundtrip %s" name) - gen - test - -let test_address = - test_roundtrip - ~count:1000 - "address" - gen_address - Sc_rollup_proto_types.Address.to_octez - Sc_rollup_proto_types.Address.of_octez - Octez_smart_rollup.Address.encoding - Protocol.Alpha_context.Sc_rollup.Address.encoding - -let test_state_hash = - test_roundtrip - ~count:1000 - "state_hash" - gen_state_hash - Sc_rollup_proto_types.State_hash.to_octez - Sc_rollup_proto_types.State_hash.of_octez - Octez_smart_rollup.State_hash.encoding - Protocol.Alpha_context.Sc_rollup.State_hash.encoding - -let test_payload_hash = - test_roundtrip - ~count:1000 - "payload_hash" - gen_payload_hash - Sc_rollup_proto_types.Merkelized_payload_hashes_hash.to_octez - Sc_rollup_proto_types.Merkelized_payload_hashes_hash.of_octez - Octez_smart_rollup.Merkelized_payload_hashes_hash.encoding - Protocol.Alpha_context.Sc_rollup.Inbox_merkelized_payload_hashes.Hash - .encoding - -let test_commitment_hash = - test_roundtrip - ~count:1000 - "commitment_hash" - gen_commitment_hash - Sc_rollup_proto_types.Commitment_hash.to_octez - Sc_rollup_proto_types.Commitment_hash.of_octez - Octez_smart_rollup.Commitment.Hash.encoding - Protocol.Alpha_context.Sc_rollup.Commitment.Hash.encoding - -let test_commitment = - test_roundtrip - ~count:1000 - "commitment" - gen_commitment - Sc_rollup_proto_types.Commitment.to_octez - Sc_rollup_proto_types.Commitment.of_octez - Octez_smart_rollup.Commitment.encoding - Protocol.Alpha_context.Sc_rollup.Commitment.encoding - -let test_stakers = - test_roundtrip - ~count:1000 - "stakers" - gen_stakers - Sc_rollup_proto_types.Game.index_to_octez - Sc_rollup_proto_types.Game.index_of_octez - Octez_smart_rollup.Game.index_encoding - Protocol.Alpha_context.Sc_rollup.Game.Index.encoding - -let test_refutation = - test_roundtrip - ~count:1000 - "refutation" - gen_refutation - Sc_rollup_proto_types.Game.refutation_to_octez - Sc_rollup_proto_types.Game.refutation_of_octez - Octez_smart_rollup.Game.refutation_encoding - Protocol.Alpha_context.Sc_rollup.Game.refutation_encoding - -let test_inbox = - test_roundtrip - ~count:1000 - "inbox" - gen_inbox - Sc_rollup_proto_types.Inbox.to_octez - Sc_rollup_proto_types.Inbox.of_octez - Octez_smart_rollup.Inbox.encoding - Protocol.Alpha_context.Sc_rollup.Inbox.encoding - -let test_slot_index = - test_roundtrip - ~count:100 - "dal_slot_index" - gen_slot_index - Sc_rollup_proto_types.Dal.Slot_index.to_octez - Sc_rollup_proto_types.Dal.Slot_index.of_octez - Octez_smart_rollup.Dal.Slot_index.encoding - Protocol.Alpha_context.Dal.Slot_index.encoding - -let test_page_index = - test_roundtrip - ~count:100 - "dal_page_index" - gen_page_index - Sc_rollup_proto_types.Dal.Page_index.to_octez - Sc_rollup_proto_types.Dal.Page_index.of_octez - Octez_smart_rollup.Dal.Page_index.encoding - Protocol.Alpha_context.Dal.Page.Index.encoding - -let test_slot_header = - test_roundtrip - ~count:1000 - "dal_slot_header" - gen_slot_header - Sc_rollup_proto_types.Dal.Slot_header.to_octez - Sc_rollup_proto_types.Dal.Slot_header.of_octez - Octez_smart_rollup.Dal.Slot_header.encoding - Protocol.Alpha_context.Dal.Slot.Header.encoding - -let test_slot_history = - test_roundtrip - ~count:300 - "dal_slot_history" - gen_slot_history - Sc_rollup_proto_types.Dal.Slot_history.to_octez - Sc_rollup_proto_types.Dal.Slot_history.of_octez - Octez_smart_rollup.Dal.Slot_history.encoding - Protocol.Alpha_context.Dal.Slots_history.encoding - -let test_slot_history_cache = - test_roundtrip - ~count:300 - "dal_slot_history_cache" - gen_slot_history_cache - Sc_rollup_proto_types.Dal.Slot_history_cache.to_octez - Sc_rollup_proto_types.Dal.Slot_history_cache.of_octez - Octez_smart_rollup.Dal.Slot_history_cache.encoding - Protocol.Alpha_context.Dal.Slots_history.History_cache.encoding - -let tests = - [ - test_address; - test_state_hash; - test_payload_hash; - test_commitment_hash; - test_commitment; - test_stakers; - test_refutation; - test_inbox; - test_slot_index; - test_page_index; - test_slot_header; - test_slot_history; - test_slot_history_cache; - ] - -let () = - Alcotest.run - ~__FILE__ - (Protocol.name ^ ": Smart rollup types octez conversions") - [("roundtrip", qcheck_wrap tests)] diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/wasm_2_0_0_pvm.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/wasm_2_0_0_pvm.ml deleted file mode 100644 index 332381409f24d8318c6d75ee0a2cb77e50b38d13..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/wasm_2_0_0_pvm.ml +++ /dev/null @@ -1,203 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022-2023 TriliTech *) -(* *) -(* 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 -open Alpha_context - -(** This module manifests the proof format used by the Wasm PVM as defined by - the Layer 1 implementation for it. - - It is imperative that this is aligned with the protocol's implementation. -*) -module Wasm_2_0_0_proof_format = - Irmin_context.Proof - (struct - include Sc_rollup.State_hash - - let of_context_hash = Sc_rollup.State_hash.context_hash_to_state_hash - end) - (struct - let proof_encoding = - Tezos_context_merkle_proof_encoding.Merkle_proof_encoding.V2.Tree2 - .tree_proof_encoding - end) - -module type TreeS = - Tezos_context_sigs.Context.TREE - with type key = string list - and type value = bytes - -module Make_wrapped_tree (Tree : TreeS) : - Tezos_tree_encoding.TREE with type tree = Tree.tree = struct - type Tezos_tree_encoding.tree_instance += PVM_tree of Tree.tree - - include Tree - - let select = function - | PVM_tree t -> t - | _ -> raise Tezos_tree_encoding.Incorrect_tree_type - - let wrap t = PVM_tree t -end - -module Make_backend (Tree : TreeS) = struct - include Tezos_scoru_wasm_fast.Pvm.Make (Make_wrapped_tree (Tree)) - - let compute_step = - compute_step ~wasm_entrypoint:Tezos_scoru_wasm.Constants.wasm_entrypoint - - let reveal_exn reveal = - match - Tezos_scoru_wasm.Wasm_pvm_state.Compatibility.of_current_opt reveal - with - | Some r -> r - | None -> - (* The WASM PVM before environment V11 will not request a value - outside of the [Compatibility.reveal] domain. *) - Stdlib.failwith - "The rollup node tried to interact with an inconsistent state." - - let input_request_exn = function - | Tezos_scoru_wasm.Wasm_pvm_state.No_input_required -> - Environment.Wasm_2_0_0.No_input_required - | Input_required -> Input_required - | Reveal_required req -> Reveal_required (reveal_exn req) - - let info_exn - Tezos_scoru_wasm.Wasm_pvm_state. - {current_tick; last_input_read; input_request} = - Environment.Wasm_2_0_0. - { - current_tick; - last_input_read; - input_request = input_request_exn input_request; - } - - let get_info tree = - let open Lwt_syntax in - let+ info = get_info tree in - info_exn info -end - -(** Durable part of the storage of this PVM. *) -module type Durable_state = sig - type state - - (** [value_length state key] returns the length of data stored - for the [key] in the durable storage of the PVM state [state], if any. *) - val value_length : state -> string -> int64 option Lwt.t - - (** [lookup state key] returns the data stored - for the [key] in the durable storage of the PVM state [state], if any. *) - val lookup : state -> string -> bytes option Lwt.t - - (** [subtrees state key] returns subtrees - for the [key] in the durable storage of the PVM state [state]. - Empty list in case if path doesn't exist. *) - val list : state -> string -> string list Lwt.t - - module Tree_encoding_runner : - Tezos_tree_encoding.Runner.S with type tree = state -end - -module Make_durable_state - (T : Tezos_tree_encoding.TREE with type tree = Irmin_context.tree) : - Durable_state with type state = T.tree = struct - module Tree_encoding_runner = Tezos_tree_encoding.Runner.Make (T) - - type state = T.tree - - let decode_durable tree = - Tree_encoding_runner.decode - Tezos_scoru_wasm.Wasm_pvm.durable_storage_encoding - tree - - let value_length tree key_str = - let open Lwt_syntax in - let key = Tezos_scoru_wasm.Durable.key_of_string_exn key_str in - let* durable = decode_durable tree in - let+ res_opt = Tezos_scoru_wasm.Durable.find_value durable key in - Option.map Tezos_lazy_containers.Chunked_byte_vector.length res_opt - - let lookup tree key_str = - let open Lwt_syntax in - let key = Tezos_scoru_wasm.Durable.key_of_string_exn key_str in - let* durable = decode_durable tree in - let* res_opt = Tezos_scoru_wasm.Durable.find_value durable key in - match res_opt with - | None -> return_none - | Some v -> - let+ bts = Tezos_lazy_containers.Chunked_byte_vector.to_bytes v in - Some bts - - let list tree key_str = - let open Lwt_syntax in - let key = Tezos_scoru_wasm.Durable.key_of_string_exn key_str in - let* durable = decode_durable tree in - Tezos_scoru_wasm.Durable.list durable key -end - -module Durable_state = - Make_durable_state (Make_wrapped_tree (Wasm_2_0_0_proof_format.Tree)) - -module Impl : Pvm_sig.S = struct - module PVM = - Sc_rollup.Wasm_2_0_0PVM.Make (Make_backend) (Wasm_2_0_0_proof_format) - include PVM - - let kind = Sc_rollup.Kind.Wasm_2_0_0 - - let new_dissection = Game_helpers.Wasm.new_dissection - - module State = Irmin_context.PVMState - - module Inspect_durable_state = struct - let lookup state keys = - let key = "/" ^ String.concat "/" keys in - Durable_state.lookup state key - end - - let string_of_status : status -> string = function - | Waiting_for_input_message -> "Waiting for input message" - | Waiting_for_reveal (Sc_rollup.Reveal_raw_data hash) -> - Format.asprintf - "Waiting for preimage reveal %a" - Sc_rollup_reveal_hash.pp - hash - | Waiting_for_reveal Sc_rollup.Reveal_metadata -> "Waiting for metadata" - | Waiting_for_reveal (Sc_rollup.Request_dal_page page_id) -> - Format.asprintf "Waiting for page data %a" Dal.Page.pp page_id - | Computing -> "Computing" - - module Backend = Make_backend (Wasm_2_0_0_proof_format.Tree) - - let eval_many ~reveal_builtins ~write_debug = - Backend.compute_step_many - ~wasm_entrypoint:Tezos_scoru_wasm.Constants.wasm_entrypoint - ~reveal_builtins - ~write_debug -end - -include Impl diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/wasm_2_0_0_rpc.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/wasm_2_0_0_rpc.ml deleted file mode 100644 index fe4d530eb9d65b9d233cc824fc44298b7dc055cf..0000000000000000000000000000000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/wasm_2_0_0_rpc.ml +++ /dev/null @@ -1,82 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2023 Nomadic Labs, *) -(* Copyright (c) 2023 Trili Tech *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Rpc_directory_helpers -open Context_wrapper.Irmin - -module Make_RPC - (Durable_state : Wasm_2_0_0_pvm.Durable_state - with type state = Irmin_context.tree) = -struct - module Block_directory = Make_sub_directory (struct - include Sc_rollup_services.Block - - type context = Node_context.rw - - type subcontext = Node_context.ro * Block_hash.t - - let context_of_prefix node_ctxt (((), block) : prefix) = - let open Lwt_result_syntax in - let+ block = Block_directory_helpers.block_of_prefix node_ctxt block in - (Node_context.readonly node_ctxt, block) - end) - - let get_state (node_ctxt : _ Node_context.t) block_hash = - let open Lwt_result_syntax in - let* ctxt = Node_context.checkout_context node_ctxt block_hash in - let*! state = Context.PVMState.find ctxt in - match state with None -> failwith "No state" | Some state -> return state - - let register () = - let open Protocol.Alpha_context.Sc_rollup in - ( Block_directory.register0 - (Sc_rollup_services.Block.durable_state_value Kind.Wasm_2_0_0) - @@ fun (node_ctxt, block) {key} () -> - let open Lwt_result_syntax in - let* state = get_state node_ctxt block in - let*! value = Durable_state.lookup (of_node_pvmstate state) key in - return value ) ; - - ( Block_directory.register0 - (Sc_rollup_services.Block.durable_state_length Kind.Wasm_2_0_0) - @@ fun (node_ctxt, block) {key} () -> - let open Lwt_result_syntax in - let* state = get_state node_ctxt block in - let*! leng = Durable_state.value_length (of_node_pvmstate state) key in - return leng ) ; - - Block_directory.register0 - (Sc_rollup_services.Block.durable_state_subkeys Kind.Wasm_2_0_0) - @@ fun (node_ctxt, block) {key} () -> - let open Lwt_result_syntax in - let* state = get_state node_ctxt block in - let*! subkeys = Durable_state.list (of_node_pvmstate state) key in - return subkeys - - let build_sub_directory node_ctxt = - register () ; - Block_directory.build_sub_directory node_ctxt -end diff --git a/tezt/lib_tezos/constant.ml b/tezt/lib_tezos/constant.ml index d7d56cff09c40607dc7e19779f0f2a40e001b058..5b4b8d12c33e9dea76049fb030db52151a4f64df 100644 --- a/tezt/lib_tezos/constant.ml +++ b/tezt/lib_tezos/constant.ml @@ -73,14 +73,6 @@ let smart_rollup_installer = let _octez_smart_rollup_wasm_debugger = Uses.make ~tag:"wasm_debugger" ~path:"./octez-smart-rollup-wasm-debugger" -(* To be removed after Nairobi is frozen *) -let _octez_accuser_PtNairob = - Uses.make ~tag:"accuser_ptnairob" ~path:"./octez-accuser-PtNairob" - -(* To be removed after Nairobi is frozen *) -let _octez_baker_PtNairob = - Uses.make ~tag:"baker_ptnairob" ~path:"./octez-baker-PtNairob" - module WASM = struct let dal_echo_kernel = Uses.make ~tag:"dal_echo_kernel" ~path:"dal_echo_kernel.wasm" diff --git a/tezt/lib_wrapper/expected/tezt_wrapper.ml/runtime-dependency-tags.out b/tezt/lib_wrapper/expected/tezt_wrapper.ml/runtime-dependency-tags.out index ae2745a8ef01cf8ca41a780a142bb3d4df0f0af4..1a6a88d7772d2814edadef151248b2cbbfc6213e 100644 --- a/tezt/lib_wrapper/expected/tezt_wrapper.ml/runtime-dependency-tags.out +++ b/tezt/lib_wrapper/expected/tezt_wrapper.ml/runtime-dependency-tags.out @@ -5,11 +5,9 @@ failed_migration: etherlink/kernel_evm/kernel/tests/resources/failed_migration.w ghostnet_evm_kernel: etherlink/kernel_evm/kernel/tests/resources/ghostnet_evm_kernel.wasm evm_kernel: evm_kernel.wasm accuser_proxford: octez-accuser-Proxford -accuser_ptnairob: octez-accuser-PtNairob accuser_alpha: octez-accuser-alpha admin_client: octez-admin-client baker_proxford: octez-baker-Proxford -baker_ptnairob: octez-baker-PtNairob baker_alpha: octez-baker-alpha client: octez-client codec: octez-codec diff --git a/tezt/tests/dune b/tezt/tests/dune index 4d501813d933d4e1461baec4171192d2b77a9f68..c9d3e9b2aa638524ca72325d13f4fb1035edce15 100644 --- a/tezt/tests/dune +++ b/tezt/tests/dune @@ -49,21 +49,6 @@ src_proto_018_Proxford_lib_dal_test_tezt_lib src_proto_018_Proxford_lib_dac_plugin_test_tezt_lib src_proto_018_Proxford_lib_client_test_tezt_lib - src_proto_017_PtNairob_lib_sc_rollup_node_test_tezt_lib - src_proto_017_PtNairob_lib_protocol_test_unit_tezt_lib - src_proto_017_PtNairob_lib_protocol_test_regression_tezt_lib - src_proto_017_PtNairob_lib_protocol_test_pbt_tezt_lib - src_proto_017_PtNairob_lib_protocol_test_integration_validate_tezt_lib - src_proto_017_PtNairob_lib_protocol_test_integration_operations_tezt_lib - src_proto_017_PtNairob_lib_protocol_test_integration_michelson_tezt_lib - src_proto_017_PtNairob_lib_protocol_test_integration_gas_tezt_lib - src_proto_017_PtNairob_lib_protocol_test_integration_consensus_tezt_lib - src_proto_017_PtNairob_lib_protocol_test_integration_tezt_lib - src_proto_017_PtNairob_lib_plugin_test_tezt_lib - src_proto_017_PtNairob_lib_delegate_test_tezt_lib - src_proto_017_PtNairob_lib_dal_test_tezt_lib - src_proto_017_PtNairob_lib_dac_plugin_test_tezt_lib - src_proto_017_PtNairob_lib_client_test_tezt_lib src_lib_workers_test_tezt_lib src_lib_webassembly_tests_tezt_lib src_lib_wasmer_test_tezt_lib