From 5da1f9c6fd92b1e8acd0765a4e22ece6b198b559 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Wed, 6 Jul 2022 11:23:07 +0200 Subject: [PATCH 01/11] CI: enable precheck integration tests --- .gitlab/ci/test/unit.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitlab/ci/test/unit.yml b/.gitlab/ci/test/unit.yml index 0dfb65e5aa50..b5610f258d31 100644 --- a/.gitlab/ci/test/unit.yml +++ b/.gitlab/ci/test/unit.yml @@ -119,6 +119,7 @@ unit:014_PtKathma: proto_014_PtKathma__lib_protocol__2: > @src/proto_014_PtKathma/lib_protocol/test/integration/michelson/runtest @src/proto_014_PtKathma/lib_protocol/test/integration/operations/runtest + @src/proto_014_PtKathma/lib_protocol/test/integration/precheck/runtest proto_014_PtKathma__lib_protocol__3: > @src/proto_014_PtKathma/lib_protocol/test/pbt/runtest @src/proto_014_PtKathma/lib_protocol/test/unit/runtest @@ -151,6 +152,7 @@ unit:alpha: proto_alpha__lib_protocol__2: > @src/proto_alpha/lib_protocol/test/integration/michelson/runtest @src/proto_alpha/lib_protocol/test/integration/operations/runtest + @src/proto_alpha/lib_protocol/test/integration/precheck/runtest proto_alpha__lib_protocol__3: > @src/proto_alpha/lib_protocol/test/pbt/runtest @src/proto_alpha/lib_protocol/test/unit/runtest -- GitLab From 0561ecef476ebbd04399ffc3cdc36fe8f8a24fc1 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 17 Jun 2022 08:52:13 +0200 Subject: [PATCH 02/11] Proto/tests: rename precheck tests in validate Co-authored-by: Zaynah Dargaye --- .gitlab/ci/test/unit.yml | 4 +- manifest/main.ml | 4 +- .../lib_protocol/test/helpers/incremental.ml | 4 +- .../lib_protocol/test/helpers/incremental.mli | 26 +-- .../integration/{precheck => validate}/dune | 0 .../test/integration/validate}/main.ml | 25 ++- .../manager_operation_helpers.ml | 113 +++++----- ...t_batched_manager_operation_validation.ml} | 44 ++-- .../test_manager_operation_validation.ml} | 208 +++++++++--------- .../lib_protocol/test/helpers/incremental.ml | 4 +- .../lib_protocol/test/helpers/incremental.mli | 26 +-- .../integration/{precheck => validate}/dune | 0 .../test/integration/validate}/main.ml | 25 ++- .../manager_operation_helpers.ml | 103 +++++---- ...t_batched_manager_operation_validation.ml} | 44 ++-- .../test_manager_operation_validation.ml} | 208 +++++++++--------- 16 files changed, 437 insertions(+), 401 deletions(-) rename src/proto_014_PtKathma/lib_protocol/test/integration/{precheck => validate}/dune (100%) rename src/{proto_alpha/lib_protocol/test/integration/precheck => proto_014_PtKathma/lib_protocol/test/integration/validate}/main.ml (71%) rename src/proto_014_PtKathma/lib_protocol/test/integration/{precheck => validate}/manager_operation_helpers.ml (90%) rename src/proto_014_PtKathma/lib_protocol/test/integration/{precheck/test_batched_manager_operation_precheck.ml => validate/test_batched_manager_operation_validation.ml} (92%) rename src/{proto_alpha/lib_protocol/test/integration/precheck/test_manager_operation_precheck.ml => proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml} (73%) rename src/proto_alpha/lib_protocol/test/integration/{precheck => validate}/dune (100%) rename src/{proto_014_PtKathma/lib_protocol/test/integration/precheck => proto_alpha/lib_protocol/test/integration/validate}/main.ml (73%) rename src/proto_alpha/lib_protocol/test/integration/{precheck => validate}/manager_operation_helpers.ml (90%) rename src/proto_alpha/lib_protocol/test/integration/{precheck/test_batched_manager_operation_precheck.ml => validate/test_batched_manager_operation_validation.ml} (92%) rename src/{proto_014_PtKathma/lib_protocol/test/integration/precheck/test_manager_operation_precheck.ml => proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml} (73%) diff --git a/.gitlab/ci/test/unit.yml b/.gitlab/ci/test/unit.yml index b5610f258d31..112d90221cee 100644 --- a/.gitlab/ci/test/unit.yml +++ b/.gitlab/ci/test/unit.yml @@ -119,7 +119,7 @@ unit:014_PtKathma: proto_014_PtKathma__lib_protocol__2: > @src/proto_014_PtKathma/lib_protocol/test/integration/michelson/runtest @src/proto_014_PtKathma/lib_protocol/test/integration/operations/runtest - @src/proto_014_PtKathma/lib_protocol/test/integration/precheck/runtest + @src/proto_014_PtKathma/lib_protocol/test/integration/validate/runtest proto_014_PtKathma__lib_protocol__3: > @src/proto_014_PtKathma/lib_protocol/test/pbt/runtest @src/proto_014_PtKathma/lib_protocol/test/unit/runtest @@ -152,7 +152,7 @@ unit:alpha: proto_alpha__lib_protocol__2: > @src/proto_alpha/lib_protocol/test/integration/michelson/runtest @src/proto_alpha/lib_protocol/test/integration/operations/runtest - @src/proto_alpha/lib_protocol/test/integration/precheck/runtest + @src/proto_alpha/lib_protocol/test/integration/validate/runtest proto_alpha__lib_protocol__3: > @src/proto_alpha/lib_protocol/test/pbt/runtest @src/proto_alpha/lib_protocol/test/unit/runtest diff --git a/manifest/main.ml b/manifest/main.ml index da049abec0c2..4b42f76b9faa 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -3256,11 +3256,11 @@ end = struct octez_base_test_helpers |> open_; ] in - let _integration_precheck = + let _integration_validate = only_if N.(number >= 014) @@ fun () -> test "main" - ~path:(path // "lib_protocol/test/integration/precheck") + ~path:(path // "lib_protocol/test/integration/validate") ~opam:(sf "tezos-protocol-%s-tests" name_dash) ~deps: [ diff --git a/src/proto_014_PtKathma/lib_protocol/test/helpers/incremental.ml b/src/proto_014_PtKathma/lib_protocol/test/helpers/incremental.ml index 7c03e9c1d9ba..3d9ee379a617 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/helpers/incremental.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/helpers/incremental.ml @@ -170,10 +170,10 @@ let apply_operation ?(check_size = true) st op = Constants_repr.max_operation_data_length))) ; apply_operation st.state op >|= Environment.wrap_tzresult -let precheck_operation ?expect_failure ?check_size st op = +let validate_operation ?expect_failure ?check_size st op = apply_operation ?check_size st op >>= fun result -> match (expect_failure, result) with - | Some _, Ok _ -> failwith "Error expected while prechecking operation" + | Some _, Ok _ -> failwith "Error expected while validating operation" | Some f, Error err -> f err >|=? fun () -> st | None, Error err -> failwith "Error %a was not expected" pp_print_trace err | None, Ok (state, (Operation_metadata _ as metadata)) diff --git a/src/proto_014_PtKathma/lib_protocol/test/helpers/incremental.mli b/src/proto_014_PtKathma/lib_protocol/test/helpers/incremental.mli index 53a824fde6b5..804a282f813d 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/helpers/incremental.mli +++ b/src/proto_014_PtKathma/lib_protocol/test/helpers/incremental.mli @@ -57,23 +57,23 @@ val begin_construction : Block.t -> incremental tzresult Lwt.t -(** [precheck_operation ?expect_failure ?check_size i op] tries to - precheck [op] in the validation state of [i]. If the precheck +(** [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 precheck. Otherwise raise the - error from the prechecking of [op]. + 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)]: - precheck of [op] is expected to fail and [expect_failure] should - handle the error. In case precheck does not fail and an - [expect_failure] is provided, [precheck_operation] fails.} + 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 precheck_operation : +val validate_operation : ?expect_failure:(error list -> unit tzresult Lwt.t) -> ?check_size:bool -> incremental -> @@ -82,16 +82,16 @@ val precheck_operation : (** [add_operation ?expect_failure ?expect_apply_failure ?check_size i op] tries to apply [op] in the validation state of [i]. If the - precheck of [op] succeeds, the function returns the incremental + 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 prechecking of [op]. + [op]. 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)]: - precheck of [op] is expected to fail and [expect_failure] should - handle the error. In case precheck does not fail and - [expect_failure] is provided, [precheck_operation] fails.} + 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.} {ul {li [?expect_apply_failure:(error list -> unit tzresult Lwt.t)]: application of [op] is expected to fail and diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/dune b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/dune similarity index 100% rename from src/proto_014_PtKathma/lib_protocol/test/integration/precheck/dune rename to src/proto_014_PtKathma/lib_protocol/test/integration/validate/dune diff --git a/src/proto_alpha/lib_protocol/test/integration/precheck/main.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml similarity index 71% rename from src/proto_alpha/lib_protocol/test/integration/precheck/main.ml rename to src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml index 9e58c8ee0a29..445200746450 100644 --- a/src/proto_alpha/lib_protocol/test/integration/precheck/main.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml @@ -26,22 +26,25 @@ (** Testing ------- Component: Protocol - Invocation: dune runtest src/proto_alpha/lib_protocol/test/integration/precheck - Subject: Integration > Precheck + Invocation: dune runtest src/proto_014_PtKathma/lib_protocol/test/integration/validate + Subject: Integration > Validate *) let () = Alcotest_lwt.run - "protocol > integration > precheck" + "protocol > integration > validate" [ - ("sanity checks", Test_manager_operation_precheck.sanity_tests); - ("Single: gas checks", Test_manager_operation_precheck.gas_tests); - ("Single: storage checks", Test_manager_operation_precheck.storage_tests); - ("Single: fees checks", Test_manager_operation_precheck.fee_tests); - ("Single: contract checks", Test_manager_operation_precheck.contract_tests); + ("sanity checks", Test_manager_operation_validation.sanity_tests); + ("Single: gas checks", Test_manager_operation_validation.gas_tests); + ("Single: storage checks", Test_manager_operation_validation.storage_tests); + ("Single: fees checks", Test_manager_operation_validation.fee_tests); + ( "Single: contract checks", + Test_manager_operation_validation.contract_tests ); ( "Batched: contract checks", - Test_batched_manager_operation_precheck.contract_tests ); - ("Batched: gas checks", Test_batched_manager_operation_precheck.gas_tests); - ("Batched: fees checks", Test_batched_manager_operation_precheck.fee_tests); + Test_batched_manager_operation_validation.contract_tests ); + ( "Batched: gas checks", + Test_batched_manager_operation_validation.gas_tests ); + ( "Batched: fees checks", + Test_batched_manager_operation_validation.fee_tests ); ] |> Lwt_main.run diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/manager_operation_helpers.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml similarity index 90% rename from src/proto_014_PtKathma/lib_protocol/test/integration/precheck/manager_operation_helpers.ml rename to src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml index 2be78e4339b5..5beb5314851a 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/manager_operation_helpers.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -27,11 +27,15 @@ open Protocol open Alpha_context open Test_tez -(* Hard gas limit *) +(** {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) +(** {2 Context} *) + type infos = { block : Block.t; account1 : Account.t; @@ -45,8 +49,8 @@ type infos = { sc_rollup : Sc_rollup.t; } -(* Initialize an [infos] record with a context enabling tx and sc - rollup, funded accounts, tx_rollup, sc_rollup *) +(** Initialize an [infos] record with a context enabling tx and sc + rollup, funded accounts, tx_rollup, sc_rollup. *) let init_context ?hard_gas_limit_per_block () = let open Lwt_result_syntax in let* b, bootstrap_contract = @@ -60,7 +64,7 @@ let init_context ?hard_gas_limit_per_block () = () in (* Set a gas_limit to avoid the default gas_limit of the helpers - ([hard_gas_limit_per_operation]) *) + ([hard_gas_limit_per_operation]). *) let gas_limit = Op.Custom_gas (Gas.Arith.integral_of_int_exn 10_000) in (* Create and fund an account use for originate a Tx and a Sc rollup *) @@ -135,10 +139,12 @@ let init_context ?hard_gas_limit_per_block () = contract3 Tez.one in + let counter = Z.succ counter in let* create_contract_hash, contract_hash = Op.contract_origination_hash (B b) - contract3 + ~counter + bootstrap_contract ~fee:Tez.zero ~script:Op.dummy_script in @@ -162,7 +168,7 @@ let init_context ?hard_gas_limit_per_block () = sc_rollup; } -(* Same as [init_context] but [contract1] delegate to [contract2] *) +(** Same as [init_context] but [contract1] delegate to [contract2]. *) let init_delegated_implicit () = let open Lwt_result_syntax in let* infos = init_context () in @@ -196,7 +202,7 @@ let init_delegated_implicit () = let+ _ = Assert.equal_pkh ~loc:__LOC__ del infos.account2.pkh in {infos with block} -(* Same as [init_context] but [contract1] self delegate. *) +(** Same as [init_context] but [contract1] self delegate. *) let init_self_delegated_implicit () = let open Lwt_result_syntax in let* infos = init_context () in @@ -222,9 +228,9 @@ let init_self_delegated_implicit () = let+ _ = Assert.equal_pkh ~loc:__LOC__ del infos.account1.pkh in {infos with block} -(* Local helpers for generating all kind of manager operations. *) +(** {2 Local helpers for generating all kind of manager operations.} *) -(* Create a fresh account used for empty implicit account tests. *) +(** Create a fresh account used for empty implicit account tests. *) let mk_fresh_contract () = Contract.Implicit Account.(new_account ()).pkh let get_pkh source = Context.Contract.pkh source @@ -606,7 +612,7 @@ let mk_sc_rollup_add_messages ?counter ?fee ?gas_limit ?storage_limit (B infos.block) source infos.sc_rollup - [] + [""] let mk_sc_rollup_timeout ?counter ?fee ?gas_limit ?storage_limit ?force_reveal ~source (infos : infos) = @@ -633,10 +639,10 @@ let mk_sc_rollup_execute_outbox_message ?counter ?fee ?gas_limit ?storage_limit source infos.sc_rollup (Sc_rollup.Commitment.hash sc_dummy_commitment) - ~outbox_level:Raw_level.root + ~outbox_level:(Raw_level.of_int32_exn 0l) ~message_index:0 - ~inclusion_proof:"" - ~message:"" + ~inclusion_proof:"xyz" + ~message:"xyz" let mk_sc_rollup_return_bond ?counter ?fee ?gas_limit ?storage_limit ?force_reveal ~source (infos : infos) = @@ -678,9 +684,13 @@ let mk_dal_publish_slot_header ?counter ?fee ?gas_limit ?storage_limit source slot -(* Helpers for generation of generic check tests by manager operation. *) -(* This type should be extended for each new manager_operation kind - added in the protocol. *) +(** {2 Helpers for generation of generic check tests by manager operation.} *) + +(** 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 @@ -739,7 +749,7 @@ let select_op = function | K_Sc_rollup_recover_bond -> mk_sc_rollup_return_bond | K_Dal_publish_slot_header -> mk_dal_publish_slot_header -let string_of_kind = function +let kind_to_string = function | K_Transaction -> "Transaction" | K_Delegation -> "Delegation" | K_Undelegation -> "Undelegation" @@ -765,12 +775,12 @@ let string_of_kind = function | 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_return_bond" + | K_Sc_rollup_recover_bond -> "Sc_rollup_recover_bond" | K_Dal_publish_slot_header -> "Dal_publish_slot_header" let create_Tztest ?hd_msg test tests_msg operations = let hd_msg k = - let sk = string_of_kind k in + let sk = kind_to_string k in match hd_msg with | None -> sk | Some hd -> Format.sprintf "Batch: %s, %s" hd sk @@ -784,7 +794,7 @@ let create_Tztest ?hd_msg test tests_msg operations = operations let rec create_Tztest_batches test tests_msg operations = - let hdmsg k = Format.sprintf "%s" (string_of_kind k) in + let hdmsg k = Format.sprintf "%s" (kind_to_string k) in let aux hd_msg test operations = create_Tztest ~hd_msg test tests_msg operations in @@ -793,12 +803,13 @@ let rec create_Tztest_batches test tests_msg operations = | kop :: kops as ops -> aux (hdmsg kop) (test kop) ops @ create_Tztest_batches test tests_msg kops -(* Diagnostic helpers. *) -(* The purpose of diagnostic helpers is to state the correct observation - according to the precheck result of a test. *) +(** {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 precheck success. Its source, fees (sum for a batch), gas_limit +(** 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 = { @@ -823,26 +834,26 @@ let rec contents_infos : 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. *) +(** 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 - | _ -> assert false + | _ -> failwith "Should only handle manager operation" -(* [observe] asserts the success of precheck only. +(** [observe] asserts the success of validate only. Given on one side, a [contract], its initial balance [b_in], its initial - counter [c_in] and potentially the initial gas [g_in] before its prechecking; - and, on the other side, its [probes] and the context after its precheck [i]; - if precheck succeeds then we observe in [i] that: - - [contract] balance decreases by [probes.fee] when [only_precheck] marks that only the precheck + counter [c_in] and potentially the initial gas [g_in] before its validation; + and, on the other side, its [probes] and the context after its validate [i]; + if validate succeeds then we observe in [i] that: + - [contract] balance decreases by [probes.fee] when [only_validate] marks that only the validate succeeds - - [contract] balance decreases at least by [probes.fee] when ![only_precheck] marks + - [contract] balance decreases at least by [probes.fee] when [not only_validate] marks that the application has succeeded, - its counter [c_in] increases by [probes.nb_counter], and - the available gas in the block in [i] decreases by [g_in].*) -let observe ~only_precheck contract b_in c_in g_in probes i = +let observe ~only_validate contract b_in c_in g_in probes i = let open Lwt_result_syntax in let* b_out = Context.Contract.balance (I i) contract in let g_out = Gas.block_level (Incremental.alpha_ctxt i) in @@ -851,7 +862,7 @@ let observe ~only_precheck contract b_in c_in g_in probes i = let b_cmp = Assert.equal ~loc:__LOC__ - (if only_precheck then Tez.( = ) else Tez.( <= )) + (if only_validate then Tez.( = ) else Tez.( <= )) "Balance update" Tez.pp in @@ -875,7 +886,7 @@ let observe ~only_precheck contract b_in c_in g_in probes i = g_out g_expected -let precheck_with_diagnostic ~only_precheck (infos : infos) op = +let validate_with_diagnostic ~only_validate (infos : infos) op = let open Lwt_result_syntax in let* i = Incremental.begin_construction infos.block in let* prbs = manager_content_infos op in @@ -883,38 +894,38 @@ let precheck_with_diagnostic ~only_precheck (infos : infos) op = let* b_in = Context.Contract.balance (I i) contract in let* c_in = Context.Contract.counter (I i) contract in let g_in = Gas.block_level (Incremental.alpha_ctxt i) in - let* i = Incremental.precheck_operation i op in + let* i = Incremental.validate_operation i op in let* _ = Incremental.finalize_block i in - observe ~only_precheck contract b_in c_in g_in prbs i + observe ~only_validate contract b_in c_in g_in prbs i -(* If only the precheck of an operation succeed; e.g. the rest +(** If only the validate of an operation succeed; e.g. the rest of the application failed: - the fees must be paid, - the block gas consumption should be decreased, and - the counter of operation should be incremented - as defined by [observe] with [only_precheck]. *) -let only_precheck_diagnostic (infos : infos) op = - precheck_with_diagnostic ~only_precheck:true infos op + as defined by [observe] with [only_validate]. *) +let only_validate_diagnostic (infos : infos) op = + validate_with_diagnostic ~only_validate:true infos op -(* If an manager operation application succeed, the precheck +(** If an manager operation application succeed, the validate effects must be observed: - the fees must be paid, - the block gas consumption should be decreased, and - the counter of operation should be incremented - as defined by [observe] with ![only_precheck]. *) -let precheck_diagnostic (infos : infos) op = - precheck_with_diagnostic ~only_precheck:false infos op + as defined by [observe] with [not only_validate]. *) +let validate_diagnostic (infos : infos) op = + validate_with_diagnostic ~only_validate:false infos op -(* [precheck_ko_diagnostic] wraps the [expect_failure] when [op] precheck - failed. It is used in test that expects precheck [op] to fail. *) -let precheck_ko_diagnostic ?(mempool_mode = false) (infos : infos) op +(** [validate_ko_diagnostic] wraps the [expect_failure] when [op] validate + failed. It is used in test that expects validate [op] to fail. *) +let validate_ko_diagnostic ?(mempool_mode = false) (infos : infos) op expect_failure = let open Lwt_result_syntax in let* i = Incremental.begin_construction infos.block ~mempool_mode in let* _ = Incremental.add_operation ~expect_failure i op in return_unit -(* List of operation kind that must run on generic tests. This list +(** List of operation kind that must run on generic tests. This list should be extended for each new manager_operation kind. *) let subjects = [ @@ -961,7 +972,7 @@ let is_consumer = function | K_Tx_rollup_dispatch_tickets | K_Transfer_ticket -> true -let gas_consumer_in_precheck_subjects, not_gas_consumer_in_precheck_subjects = +let gas_consumer_in_validate_subjects, not_gas_consumer_in_validate_subjects = List.partition is_consumer subjects let revealed_subjects = diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/test_batched_manager_operation_precheck.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml similarity index 92% rename from src/proto_014_PtKathma/lib_protocol/test/integration/precheck/test_batched_manager_operation_precheck.ml rename to src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml index 28bcc3c6fb29..90dc2a88fdac 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/test_batched_manager_operation_precheck.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml @@ -25,20 +25,20 @@ (** Testing ------- - Component: Protocol (precheck manager) + Component: Protocol (validate manager) Invocation: dune exec \ - src/proto_alpha/lib_protocol/test/integration/precheck/main.exe \ + src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.exe \ -- test "^Batched" - Subject: Precheck manager operation. + Subject: Validation of batched manager operation. *) open Protocol open Alpha_context open Manager_operation_helpers -(* Tests on operation batches. *) +(** {2 Tests on operation batches} *) -(* Revelation should not occur elsewhere than in first position +(** 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 = @@ -54,7 +54,7 @@ let batch_reveal_in_the_middle_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_batch_reveal_in_the_middle kind1 kind2 () = let open Lwt_result_syntax in @@ -84,10 +84,10 @@ let test_batch_reveal_in_the_middle kind1 kind2 () = let generate_batches_reveal_in_the_middle () = create_Tztest_batches test_batch_reveal_in_the_middle - "reveal should occur only at the beginning of a batch." + "Reveal should only occur at the beginning of a batch." revealed_subjects -(* A batch of manager operation contains at most one Revelation.*) +(** 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 @@ -102,7 +102,7 @@ let batch_two_reveals_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expected_failure + validate_ko_diagnostic infos op expected_failure let test_batch_two_reveals kind () = let open Lwt_result_syntax in @@ -133,7 +133,7 @@ let generate_tests_batches_two_reveals () = "Only one revelation per batch." revealed_subjects -(* Every manager operation in a batch concerns the same source.*) +(** 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 @@ -147,7 +147,7 @@ let batch_two_sources_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_batch_two_sources kind1 kind2 () = let open Lwt_result_syntax in @@ -175,7 +175,7 @@ let generate_batches_two_sources () = "Only one source per batch." revealed_subjects -(* Counters in a batch should be a sequence from the successor of +(** Counters in a batch should be a sequence from the successor of the stored counter associated to source in the initial context. *) let test_batch_inconsistent_counters kind1 kind2 () = let open Lwt_result_syntax in @@ -266,7 +266,7 @@ let generate_batches_inconsistent_counters () = "Counters in a batch should be a sequence." revealed_subjects -(* A batch that consumes all the balance for fees can only face the total +(** A batch that consumes all the balance for fees can only face the total consumption at the end of the batch. *) let test_batch_emptying_balance_in_the_middle kind1 kind2 () = let open Lwt_result_syntax in @@ -314,7 +314,7 @@ let generate_batches_emptying_balance_in_the_middle () = "Fee payment emptying balance should occurs at the end of the batch." revealed_subjects -(* A batch of manager operation must not exceed the initial available gas in the block. *) +(** A batch of manager operation must not exceed the initial available gas in the block. *) let test_batch_exceeding_block_gas ~mempool_mode kind1 kind2 () = let open Lwt_result_syntax in let* infos = init_context ~hard_gas_limit_per_block:gb_limit () in @@ -408,8 +408,8 @@ let generate_batches_exceeding_block_gas_mp_mode () = "Too much gas consumption in mempool mode." revealed_subjects -(* A batch that consumes all the balance for fees only at the end of - the batch passes precheck.*) +(** A batch that consumes all the balance for fees only at the end of + the batch passes validate.*) let test_batch_balance_just_enough kind1 kind2 () = let open Lwt_result_syntax in let* infos = init_context () in @@ -445,16 +445,16 @@ let test_batch_balance_just_enough kind1 kind2 () = (Context.B infos.block) [reveal; op_case2; op2_case2] in - let* _ = precheck_diagnostic infos case2 in - precheck_diagnostic infos case3 + let* _ = validate_diagnostic infos case2 in + validate_diagnostic infos case3 let generate_batches_balance_just_enough () = create_Tztest_batches test_batch_balance_just_enough - "(Positive test) Fee payment emptying balance in a batch." + "Fee payment emptying balance in a batch." revealed_subjects -(* Simple reveal followed by a transaction. *) +(** Simple reveal followed by a transaction. *) let test_batch_reveal_transaction_ok () = let open Lwt_result_syntax in let* infos = init_context () in @@ -475,7 +475,7 @@ let test_batch_reveal_transaction_ok () = [reveal; transaction] in let* _i = Incremental.begin_construction infos.block in - precheck_diagnostic infos batch + validate_diagnostic infos batch let contract_tests = generate_batches_reveal_in_the_middle () @@ -484,7 +484,7 @@ let contract_tests = @ generate_batches_inconsistent_counters () @ [ Tztest.tztest - "Prechecked a batch with a reveal and a transaction." + "Validate a batch with a reveal and a transaction." `Quick test_batch_reveal_transaction_ok; ] diff --git a/src/proto_alpha/lib_protocol/test/integration/precheck/test_manager_operation_precheck.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml similarity index 73% rename from src/proto_alpha/lib_protocol/test/integration/precheck/test_manager_operation_precheck.ml rename to src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml index 79831ff4c608..a78782a5e204 100644 --- a/src/proto_alpha/lib_protocol/test/integration/precheck/test_manager_operation_precheck.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml @@ -25,27 +25,27 @@ (** Testing ------- - Component: Protocol (precheck manager) + Component: Protocol (validate manager) Invocation: dune exec \ - src/proto_alpha/lib_protocol/test/integration/precheck/main.exe \ - -- test "^Single$" - Subject: Precheck manager operation. + src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.exe \ + -- test "^Single" + Subject: Validation of manager 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 +(** 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 precheck test on the new manager - operation kind. *) + 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 kind infos ~force_reveal:false ~source:infos.contract1 in @@ -108,15 +108,15 @@ let test_ensure_manager_operation_coverage () = `Quick (fun () -> ensure_manager_operation_coverage ()) -(* Negative tests assert the case where precheck must fail. *) +(** {2 Negative tests assert the case where validate must fail} *) -(* Precheck fails if the gas limit is too low. +(** Validate fails if the gas limit is too low. - This test asserts that the precheck of a manager's operation - with a too low gas limit fails at precheck with an - [Gas_quota_exceeded_init_deserialize] error. - This test applies on manager operations that do not - consume gas in their specific part of precheck. *) + 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 @@ -132,7 +132,7 @@ let low_gas_limit_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_low_gas_limit kind () = let open Lwt_result_syntax in @@ -147,13 +147,13 @@ let generate_low_gas_limit () = create_Tztest test_low_gas_limit "Gas_limit too low." - gas_consumer_in_precheck_subjects + gas_consumer_in_validate_subjects -(* Precheck fails if the gas limit is too high. +(** Validate fails if the gas limit is too high. - This test asserts that the precheck of a manager operation with - a gas limit too high fails at precheck with an [Gas_limit_too_high] - error. It applies on every kind of manager operation. *) + 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 @@ -164,7 +164,7 @@ let high_gas_limit_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_high_gas_limit kind () = let open Lwt_result_syntax in @@ -178,11 +178,11 @@ let test_high_gas_limit kind () = let generate_high_gas_limit () = create_Tztest test_high_gas_limit "Gas_limit too high." subjects -(* Precheck fails if the storage limit is too high. +(** Validate fails if the storage limit is too high. - This test asserts that a manager operation with a storage limit - too high fails at precheck with [Storage_limit_too_high] error. - It applies to every kind of manager operation. *) + 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 @@ -194,7 +194,7 @@ let high_storage_limit_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_high_storage_limit kind () = let open Lwt_result_syntax in @@ -213,12 +213,13 @@ let test_high_storage_limit kind () = let generate_high_storage_limit () = create_Tztest test_high_gas_limit "Storage_limit too high." subjects -(* Precheck fails if the counter is in the future. +(** Validate fails if the counter is in the future. - This test asserts that a manager operation with a counter in the - future -- aka greater than the successor of the manager's counter - stored in the current context -- fails with [Counter_in_the_future] error. - It applies to every kind of manager operation. *) + 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 @@ -230,7 +231,7 @@ let high_counter_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_high_counter kind () = let open Lwt_result_syntax in @@ -244,12 +245,13 @@ let test_high_counter kind () = let generate_high_counter () = create_Tztest test_high_counter "Counter too high." subjects -(* Precheck fails if the counter is in the past. +(** Validate fails if the counter is in the past. - This test asserts that a manager operation with a counter in the past -- aka - smaller than the successor of the manager's counter stored in the current - context -- fails with [Counter_in_the_past] error. - It applies to every kind of manager operation. *) + 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 @@ -261,7 +263,7 @@ let low_counter_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_low_counter kind () = let open Lwt_result_syntax in @@ -278,11 +280,12 @@ let test_low_counter kind () = let generate_low_counter () = create_Tztest test_low_counter "Counter too low." subjects -(* Precheck fails if the source is not allocated. +(** Validate fails if the source is not allocated. - This test asserts that a manager operation which manager's contract - is not allocated fails with [Empty_implicit_contract] error. - It applies on every kind of manager operation. *) + 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 @@ -295,7 +298,7 @@ let not_allocated_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_not_allocated kind () = let open Lwt_result_syntax in @@ -306,13 +309,13 @@ let test_not_allocated kind () = not_allocated_diagnostic infos op let generate_not_allocated () = - create_Tztest test_not_allocated "not allocated source." subjects + create_Tztest test_not_allocated "Not allocated source." subjects -(* Precheck fails if the source is unrevealed. +(** Validate fails if the source is unrevealed. - This test asserts that a manager operation with an unrevealed source's - contract fails at precheck with [Unrevealed_manager_key]. - It applies on every kind of manager operation except [Revelation]. *) + 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 @@ -327,7 +330,7 @@ let unrevealed_key_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_unrevealed_key kind () = let open Lwt_result_syntax in @@ -338,14 +341,14 @@ let test_unrevealed_key kind () = let generate_unrevealed_key () = create_Tztest test_unrevealed_key - "unrevealed source (find_manager_public_key)." + "Unrevealed source (find_manager_public_key)." revealed_subjects -(* Precheck fails if the source's balance is not enough to pay the fees. +(** Validate fails if the source balance is not enough to pay the fees. - This test asserts that precheck of a manager operation fails if the - source's balance is lesser than the manager operation's fee. - It applies on every kind of manager operation. *) + 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 @@ -360,7 +363,7 @@ let high_fee_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_high_fee kind () = let open Lwt_result_syntax in @@ -372,16 +375,16 @@ let test_high_fee kind () = high_fee_diagnostic infos op let generate_tests_high_fee () = - create_Tztest test_high_fee "not enough for fee payment." subjects + create_Tztest test_high_fee "Balance too low for fee payment." subjects -(* Precheck fails if the fee payment empties the balance of a - delegated implicit contract. +(** 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, precheck fails with [Empty_implicit_delegated_contract] error. - It applies to every kind of manager operation except [Revelation].*) + 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 @@ -396,7 +399,7 @@ let emptying_delegated_implicit_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_emptying_delegated_implicit kind () = let open Lwt_result_syntax in @@ -410,16 +413,16 @@ let test_emptying_delegated_implicit kind () = let generate_tests_emptying_delegated_implicit () = create_Tztest test_emptying_delegated_implicit - "just enough funds to empty a delegated source." + "Just enough funds to empty a delegated source." revealed_subjects -(* Precheck fails if there is not enough available gas in the block. +(** Validate fails if there is not enough available gas in the block. - This test asserts that precheck fails with: + 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. *) + - [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 ~mempool_mode (infos : infos) op = let expect_failure errs = match errs with @@ -443,7 +446,7 @@ let exceeding_block_gas_diagnostic ~mempool_mode (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure ~mempool_mode + validate_ko_diagnostic infos op expect_failure ~mempool_mode let test_exceeding_block_gas ~mempool_mode kind () = let open Lwt_result_syntax in @@ -459,21 +462,21 @@ let test_exceeding_block_gas ~mempool_mode kind () = let generate_tests_exceeding_block_gas () = create_Tztest (test_exceeding_block_gas ~mempool_mode:false) - "too much gas consumption." + "Too much gas consumption." subjects let generate_tests_exceeding_block_gas_mp_mode () = create_Tztest (test_exceeding_block_gas ~mempool_mode:true) - "too much gas consumption in mempool mode." + "Too much gas consumption in mempool mode." subjects -(* Positive tests. +(** {2 Positive tests} *) - Tests that precheck succeeds when: - - it empties the balance of a self_delegated implicit source, - - it empties the balance of an undelegated implicit source, and - - in case: +(** 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, @@ -481,18 +484,19 @@ let generate_tests_exceeding_block_gas_mp_mode () = - 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 the first two only precheck succeeds while in the last case, - the full application also succeeds. - In the first 2 case, we observe in the output context that: + + Notice that in the first two cases only validate succeeds while + in the last case, the full application also succeeds. + In the first 2 case, we observe in the output context that: - the counter is the successor of the one stored in the initial context, - the balance decreased by fee, - the available gas in the block decreased by gas limit. - In the last case, we observe in the output context that: + In the last case, 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 by gas limit. *) -(* Fee payment that emptying a self_delegated implicit. *) +(** Fee payment that emptying a self_delegated implicit. *) let test_emptying_self_delegated_implicit kind () = let open Lwt_result_syntax in let* infos = init_self_delegated_implicit () in @@ -500,25 +504,25 @@ let test_emptying_self_delegated_implicit kind () = let* op = select_op ~fee ~force_reveal:false ~source:infos.contract1 kind infos in - only_precheck_diagnostic infos op + only_validate_diagnostic infos op let generate_tests_emptying_self_delegated_implicit () = create_Tztest test_emptying_self_delegated_implicit - "passes precheck and empties a self-delegated source." + "Validate and empties a self-delegated source." subjects -(* Minimum gas cost to pass the precheck: +(** Minimum gas cost to pass the validation: - cost_of_manager_operation for the generic part - 100 (empiric) for the specific part (script decoding or hash costs) *) -let empiric_minimal_gas_cost_for_precheck = +let empiric_minimal_gas_cost_for_validate = Gas.Arith.integral_of_int_exn (Michelson_v1_gas.Internal_for_tests.int_cost_of_manager_operation + 100) let test_emptying_undelegated_implicit kind () = let open Lwt_result_syntax in let* infos = init_context () in - let gas_limit = Op.Custom_gas empiric_minimal_gas_cost_for_precheck in + let gas_limit = Op.Custom_gas empiric_minimal_gas_cost_for_validate in let* fee = Context.Contract.balance (B infos.block) infos.contract1 in let* op = select_op @@ -529,28 +533,28 @@ let test_emptying_undelegated_implicit kind () = kind infos in - only_precheck_diagnostic infos op + only_validate_diagnostic infos op let generate_tests_emptying_undelegated_implicit () = create_Tztest test_emptying_undelegated_implicit - "passes precheck and empties an undelegated source." + "Validate and empties an undelegated source." subjects -(* Fee payment.*) -let test_precheck kind () = +(** Fee payment.*) +let test_validate kind () = let open Lwt_result_syntax in let* infos = init_context () in let* counter = Context.Contract.counter (B infos.block) infos.contract1 in let source = infos.contract1 in let* operation = select_op ~counter ~force_reveal:true ~source kind infos in - precheck_diagnostic infos operation + validate_diagnostic infos operation -let generate_tests_precheck () = - create_Tztest test_precheck "passes precheck." subjects +let generate_tests_validate () = + create_Tztest test_validate "Validate." subjects let sanity_tests = - test_ensure_manager_operation_coverage () :: generate_tests_precheck () + test_ensure_manager_operation_coverage () :: generate_tests_validate () let gas_tests = generate_low_gas_limit () @ generate_high_gas_limit () diff --git a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml index 195e94ff58fb..6d2ad1339282 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml @@ -169,10 +169,10 @@ let apply_operation ?(check_size = true) st op = Constants_repr.max_operation_data_length))) ; apply_operation st.state op >|= Environment.wrap_tzresult -let precheck_operation ?expect_failure ?check_size st op = +let validate_operation ?expect_failure ?check_size st op = apply_operation ?check_size st op >>= fun result -> match (expect_failure, result) with - | Some _, Ok _ -> failwith "Error expected while prechecking operation" + | Some _, Ok _ -> failwith "Error expected while validating operation" | Some f, Error err -> f err >|=? fun () -> st | None, Error err -> failwith "Error %a was not expected" pp_print_trace err | None, Ok (state, (Operation_metadata _ as metadata)) diff --git a/src/proto_alpha/lib_protocol/test/helpers/incremental.mli b/src/proto_alpha/lib_protocol/test/helpers/incremental.mli index 53a824fde6b5..804a282f813d 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/incremental.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/incremental.mli @@ -57,23 +57,23 @@ val begin_construction : Block.t -> incremental tzresult Lwt.t -(** [precheck_operation ?expect_failure ?check_size i op] tries to - precheck [op] in the validation state of [i]. If the precheck +(** [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 precheck. Otherwise raise the - error from the prechecking of [op]. + 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)]: - precheck of [op] is expected to fail and [expect_failure] should - handle the error. In case precheck does not fail and an - [expect_failure] is provided, [precheck_operation] fails.} + 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 precheck_operation : +val validate_operation : ?expect_failure:(error list -> unit tzresult Lwt.t) -> ?check_size:bool -> incremental -> @@ -82,16 +82,16 @@ val precheck_operation : (** [add_operation ?expect_failure ?expect_apply_failure ?check_size i op] tries to apply [op] in the validation state of [i]. If the - precheck of [op] succeeds, the function returns the incremental + 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 prechecking of [op]. + [op]. 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)]: - precheck of [op] is expected to fail and [expect_failure] should - handle the error. In case precheck does not fail and - [expect_failure] is provided, [precheck_operation] fails.} + 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.} {ul {li [?expect_apply_failure:(error list -> unit tzresult Lwt.t)]: application of [op] is expected to fail and diff --git a/src/proto_alpha/lib_protocol/test/integration/precheck/dune b/src/proto_alpha/lib_protocol/test/integration/validate/dune similarity index 100% rename from src/proto_alpha/lib_protocol/test/integration/precheck/dune rename to src/proto_alpha/lib_protocol/test/integration/validate/dune diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/main.ml b/src/proto_alpha/lib_protocol/test/integration/validate/main.ml similarity index 73% rename from src/proto_014_PtKathma/lib_protocol/test/integration/precheck/main.ml rename to src/proto_alpha/lib_protocol/test/integration/validate/main.ml index 9e58c8ee0a29..f7dd004ffd5e 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/main.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/main.ml @@ -26,22 +26,25 @@ (** Testing ------- Component: Protocol - Invocation: dune runtest src/proto_alpha/lib_protocol/test/integration/precheck - Subject: Integration > Precheck + Invocation: dune runtest src/proto_alpha/lib_protocol/test/integration/validate + Subject: Integration > Validate *) let () = Alcotest_lwt.run - "protocol > integration > precheck" + "protocol > integration > validate" [ - ("sanity checks", Test_manager_operation_precheck.sanity_tests); - ("Single: gas checks", Test_manager_operation_precheck.gas_tests); - ("Single: storage checks", Test_manager_operation_precheck.storage_tests); - ("Single: fees checks", Test_manager_operation_precheck.fee_tests); - ("Single: contract checks", Test_manager_operation_precheck.contract_tests); + ("sanity checks", Test_manager_operation_validation.sanity_tests); + ("Single: gas checks", Test_manager_operation_validation.gas_tests); + ("Single: storage checks", Test_manager_operation_validation.storage_tests); + ("Single: fees checks", Test_manager_operation_validation.fee_tests); + ( "Single: contract checks", + Test_manager_operation_validation.contract_tests ); ( "Batched: contract checks", - Test_batched_manager_operation_precheck.contract_tests ); - ("Batched: gas checks", Test_batched_manager_operation_precheck.gas_tests); - ("Batched: fees checks", Test_batched_manager_operation_precheck.fee_tests); + Test_batched_manager_operation_validation.contract_tests ); + ( "Batched: gas checks", + Test_batched_manager_operation_validation.gas_tests ); + ( "Batched: fees checks", + Test_batched_manager_operation_validation.fee_tests ); ] |> Lwt_main.run diff --git a/src/proto_alpha/lib_protocol/test/integration/precheck/manager_operation_helpers.ml b/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml similarity index 90% rename from src/proto_alpha/lib_protocol/test/integration/precheck/manager_operation_helpers.ml rename to src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml index 8da4b8410453..222edf4b7f6e 100644 --- a/src/proto_alpha/lib_protocol/test/integration/precheck/manager_operation_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -27,11 +27,15 @@ open Protocol open Alpha_context open Test_tez -(* Hard gas limit *) +(** {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) +(** {2 Context} *) + type infos = { block : Block.t; account1 : Account.t; @@ -45,7 +49,7 @@ type infos = { sc_rollup : Sc_rollup.t; } -(* Initialize an [infos] record with a context enabling tx and sc +(** Initialize an [infos] record with a context enabling tx and sc rollup, funded accounts, tx_rollup, sc_rollup *) let init_context ?hard_gas_limit_per_block () = let open Lwt_result_syntax in @@ -135,10 +139,12 @@ let init_context ?hard_gas_limit_per_block () = contract3 Tez.one in + let counter = Z.succ counter in let* create_contract_hash, contract_hash = Op.contract_origination_hash (B b) - contract3 + ~counter + bootstrap_contract ~fee:Tez.zero ~script:Op.dummy_script in @@ -162,7 +168,7 @@ let init_context ?hard_gas_limit_per_block () = sc_rollup; } -(* Same as [init_context] but [contract1] delegate to [contract2] *) +(** Same as [init_context] but [contract1] delegate to [contract2]. *) let init_delegated_implicit () = let open Lwt_result_syntax in let* infos = init_context () in @@ -196,7 +202,7 @@ let init_delegated_implicit () = let+ _ = Assert.equal_pkh ~loc:__LOC__ del infos.account2.pkh in {infos with block} -(* Same as [init_context] but [contract1] self delegate. *) +(** Same as [init_context] but [contract1] self delegate. *) let init_self_delegated_implicit () = let open Lwt_result_syntax in let* infos = init_context () in @@ -222,9 +228,9 @@ let init_self_delegated_implicit () = let+ _ = Assert.equal_pkh ~loc:__LOC__ del infos.account1.pkh in {infos with block} -(* Local helpers for generating all kind of manager operations. *) +(** {2 Local helpers for generating all kind of manager operations} *) -(* Create a fresh account used for empty implicit account tests. *) +(** Create a fresh account used for empty implicit account tests. *) let mk_fresh_contract () = Contract.Implicit Account.(new_account ()).pkh let get_pkh source = Context.Contract.pkh source @@ -599,7 +605,7 @@ let mk_sc_rollup_add_messages ?counter ?fee ?gas_limit ?storage_limit (B infos.block) source infos.sc_rollup - [] + [""] let mk_sc_rollup_timeout ?counter ?fee ?gas_limit ?storage_limit ?force_reveal ~source (infos : infos) = @@ -668,9 +674,13 @@ let mk_dal_publish_slot_header ?counter ?fee ?gas_limit ?storage_limit source slot -(* Helpers for generation of generic check tests by manager operation. *) -(* This type should be extended for each new manager_operation kind - added in the protocol. *) +(** {2 Helpers for generation of generic check tests by manager operation.} *) + +(** 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 @@ -729,7 +739,7 @@ let select_op = function | K_Sc_rollup_recover_bond -> mk_sc_rollup_return_bond | K_Dal_publish_slot_header -> mk_dal_publish_slot_header -let string_of_kind = function +let kind_to_string = function | K_Transaction -> "Transaction" | K_Delegation -> "Delegation" | K_Undelegation -> "Undelegation" @@ -755,12 +765,12 @@ let string_of_kind = function | 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_return_bond" + | K_Sc_rollup_recover_bond -> "Sc_rollup_recover_bond" | K_Dal_publish_slot_header -> "Dal_publish_slot_header" let create_Tztest ?hd_msg test tests_msg operations = let hd_msg k = - let sk = string_of_kind k in + let sk = kind_to_string k in match hd_msg with | None -> sk | Some hd -> Format.sprintf "Batch: %s, %s" hd sk @@ -774,7 +784,7 @@ let create_Tztest ?hd_msg test tests_msg operations = operations let rec create_Tztest_batches test tests_msg operations = - let hdmsg k = Format.sprintf "%s" (string_of_kind k) in + let hdmsg k = Format.sprintf "%s" (kind_to_string k) in let aux hd_msg test operations = create_Tztest ~hd_msg test tests_msg operations in @@ -783,12 +793,13 @@ let rec create_Tztest_batches test tests_msg operations = | kop :: kops as ops -> aux (hdmsg kop) (test kop) ops @ create_Tztest_batches test tests_msg kops -(* Diagnostic helpers. *) -(* The purpose of diagnostic helpers is to state the correct observation - according to the precheck result of a test. *) +(** {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 precheck success. Its source, fees (sum for a batch), gas_limit +(** 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 = { @@ -813,26 +824,26 @@ let rec contents_infos : 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. *) +(** 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 - | _ -> assert false + | _ -> failwith "Should only handle manager operation" -(* [observe] asserts the success of precheck only. +(** [observe] asserts the success of validate only. Given on one side, a [contract], its initial balance [b_in], its initial - counter [c_in] and potentially the initial gas [g_in] before its prechecking; - and, on the other side, its [probes] and the context after its precheck [i]; - if precheck succeeds then we observe in [i] that: - - [contract] balance decreases by [probes.fee] when [only_precheck] marks that only the precheck + counter [c_in] and potentially the initial gas [g_in] before its validation; + and, on the other side, its [probes] and the context after its validate [i]; + if validate succeeds then we observe in [i] that: + - [contract] balance decreases by [probes.fee] when [only_validate] marks that only the validate succeeds - - [contract] balance decreases at least by [probes.fee] when ![only_precheck] marks + - [contract] balance decreases at least by [probes.fee] when [not only_validate] marks that the application has succeeded, - its counter [c_in] increases by [probes.nb_counter], and - the available gas in the block in [i] decreases by [g_in].*) -let observe ~only_precheck contract b_in c_in g_in probes i = +let observe ~only_validate contract b_in c_in g_in probes i = let open Lwt_result_syntax in let* b_out = Context.Contract.balance (I i) contract in let g_out = Gas.block_level (Incremental.alpha_ctxt i) in @@ -841,7 +852,7 @@ let observe ~only_precheck contract b_in c_in g_in probes i = let b_cmp = Assert.equal ~loc:__LOC__ - (if only_precheck then Tez.( = ) else Tez.( <= )) + (if only_validate then Tez.( = ) else Tez.( <= )) "Balance update" Tez.pp in @@ -865,7 +876,7 @@ let observe ~only_precheck contract b_in c_in g_in probes i = g_out g_expected -let precheck_with_diagnostic ~only_precheck (infos : infos) op = +let validate_with_diagnostic ~only_validate (infos : infos) op = let open Lwt_result_syntax in let* i = Incremental.begin_construction infos.block in let* prbs = manager_content_infos op in @@ -873,38 +884,38 @@ let precheck_with_diagnostic ~only_precheck (infos : infos) op = let* b_in = Context.Contract.balance (I i) contract in let* c_in = Context.Contract.counter (I i) contract in let g_in = Gas.block_level (Incremental.alpha_ctxt i) in - let* i = Incremental.precheck_operation i op in + let* i = Incremental.validate_operation i op in let* _ = Incremental.finalize_block i in - observe ~only_precheck contract b_in c_in g_in prbs i + observe ~only_validate contract b_in c_in g_in prbs i -(* If only the precheck of an operation succeed; e.g. the rest +(** If only the validate of an operation succeed; e.g. the rest of the application failed: - the fees must be paid, - the block gas consumption should be decreased, and - the counter of operation should be incremented - as defined by [observe] with [only_precheck]. *) -let only_precheck_diagnostic (infos : infos) op = - precheck_with_diagnostic ~only_precheck:true infos op + as defined by [observe] with [only_validate]. *) +let only_validate_diagnostic (infos : infos) op = + validate_with_diagnostic ~only_validate:true infos op -(* If an manager operation application succeed, the precheck +(** If an manager operation application succeed, the validate effects must be observed: - the fees must be paid, - the block gas consumption should be decreased, and - the counter of operation should be incremented - as defined by [observe] with ![only_precheck]. *) -let precheck_diagnostic (infos : infos) op = - precheck_with_diagnostic ~only_precheck:false infos op + as defined by [observe] with [not only_validate]. *) +let validate_diagnostic (infos : infos) op = + validate_with_diagnostic ~only_validate:false infos op -(* [precheck_ko_diagnostic] wraps the [expect_failure] when [op] precheck - failed. It is used in test that expects precheck [op] to fail. *) -let precheck_ko_diagnostic ?(mempool_mode = false) (infos : infos) op +(** [validate_ko_diagnostic] wraps the [expect_failure] when [op] validate + failed. It is used in test that expects validate [op] to fail. *) +let validate_ko_diagnostic ?(mempool_mode = false) (infos : infos) op expect_failure = let open Lwt_result_syntax in let* i = Incremental.begin_construction infos.block ~mempool_mode in let* _ = Incremental.add_operation ~expect_failure i op in return_unit -(* List of operation kind that must run on generic tests. This list +(** List of operation kinds that must run on generic tests. This list should be extended for each new manager_operation kind. *) let subjects = [ @@ -951,7 +962,7 @@ let is_consumer = function | K_Tx_rollup_dispatch_tickets | K_Transfer_ticket -> true -let gas_consumer_in_precheck_subjects, not_gas_consumer_in_precheck_subjects = +let gas_consumer_in_validate_subjects, not_gas_consumer_in_validate_subjects = List.partition is_consumer subjects let revealed_subjects = diff --git a/src/proto_alpha/lib_protocol/test/integration/precheck/test_batched_manager_operation_precheck.ml b/src/proto_alpha/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml similarity index 92% rename from src/proto_alpha/lib_protocol/test/integration/precheck/test_batched_manager_operation_precheck.ml rename to src/proto_alpha/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml index 28bcc3c6fb29..15aec152ef94 100644 --- a/src/proto_alpha/lib_protocol/test/integration/precheck/test_batched_manager_operation_precheck.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml @@ -25,20 +25,20 @@ (** Testing ------- - Component: Protocol (precheck manager) + Component: Protocol (validate manager) Invocation: dune exec \ - src/proto_alpha/lib_protocol/test/integration/precheck/main.exe \ + src/proto_alpha/lib_protocol/test/integration/validate/main.exe \ -- test "^Batched" - Subject: Precheck manager operation. + Subject: Validation of batched manager operation. *) open Protocol open Alpha_context open Manager_operation_helpers -(* Tests on operation batches. *) +(** {2 Tests on operation batches} *) -(* Revelation should not occur elsewhere than in first position +(** 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 = @@ -54,7 +54,7 @@ let batch_reveal_in_the_middle_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_batch_reveal_in_the_middle kind1 kind2 () = let open Lwt_result_syntax in @@ -84,10 +84,10 @@ let test_batch_reveal_in_the_middle kind1 kind2 () = let generate_batches_reveal_in_the_middle () = create_Tztest_batches test_batch_reveal_in_the_middle - "reveal should occur only at the beginning of a batch." + "Reveal should only occur at the beginning of a batch." revealed_subjects -(* A batch of manager operation contains at most one Revelation.*) +(** 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 @@ -102,7 +102,7 @@ let batch_two_reveals_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expected_failure + validate_ko_diagnostic infos op expected_failure let test_batch_two_reveals kind () = let open Lwt_result_syntax in @@ -133,7 +133,7 @@ let generate_tests_batches_two_reveals () = "Only one revelation per batch." revealed_subjects -(* Every manager operation in a batch concerns the same source.*) +(** 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 @@ -147,7 +147,7 @@ let batch_two_sources_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_batch_two_sources kind1 kind2 () = let open Lwt_result_syntax in @@ -175,7 +175,7 @@ let generate_batches_two_sources () = "Only one source per batch." revealed_subjects -(* Counters in a batch should be a sequence from the successor of +(** Counters in a batch should be a sequence from the successor of the stored counter associated to source in the initial context. *) let test_batch_inconsistent_counters kind1 kind2 () = let open Lwt_result_syntax in @@ -266,7 +266,7 @@ let generate_batches_inconsistent_counters () = "Counters in a batch should be a sequence." revealed_subjects -(* A batch that consumes all the balance for fees can only face the total +(** A batch that consumes all the balance for fees can only face the total consumption at the end of the batch. *) let test_batch_emptying_balance_in_the_middle kind1 kind2 () = let open Lwt_result_syntax in @@ -314,7 +314,7 @@ let generate_batches_emptying_balance_in_the_middle () = "Fee payment emptying balance should occurs at the end of the batch." revealed_subjects -(* A batch of manager operation must not exceed the initial available gas in the block. *) +(** A batch of manager operation must not exceed the initial available gas in the block. *) let test_batch_exceeding_block_gas ~mempool_mode kind1 kind2 () = let open Lwt_result_syntax in let* infos = init_context ~hard_gas_limit_per_block:gb_limit () in @@ -408,8 +408,8 @@ let generate_batches_exceeding_block_gas_mp_mode () = "Too much gas consumption in mempool mode." revealed_subjects -(* A batch that consumes all the balance for fees only at the end of - the batch passes precheck.*) +(** A batch that consumes all the balance for fees only at the end of + the batch passes validate.*) let test_batch_balance_just_enough kind1 kind2 () = let open Lwt_result_syntax in let* infos = init_context () in @@ -445,16 +445,16 @@ let test_batch_balance_just_enough kind1 kind2 () = (Context.B infos.block) [reveal; op_case2; op2_case2] in - let* _ = precheck_diagnostic infos case2 in - precheck_diagnostic infos case3 + let* _ = validate_diagnostic infos case2 in + validate_diagnostic infos case3 let generate_batches_balance_just_enough () = create_Tztest_batches test_batch_balance_just_enough - "(Positive test) Fee payment emptying balance in a batch." + "Fee payment emptying balance in a batch." revealed_subjects -(* Simple reveal followed by a transaction. *) +(** Simple reveal followed by a transaction. *) let test_batch_reveal_transaction_ok () = let open Lwt_result_syntax in let* infos = init_context () in @@ -475,7 +475,7 @@ let test_batch_reveal_transaction_ok () = [reveal; transaction] in let* _i = Incremental.begin_construction infos.block in - precheck_diagnostic infos batch + validate_diagnostic infos batch let contract_tests = generate_batches_reveal_in_the_middle () @@ -484,7 +484,7 @@ let contract_tests = @ generate_batches_inconsistent_counters () @ [ Tztest.tztest - "Prechecked a batch with a reveal and a transaction." + "Validate a batch with a reveal and a transaction." `Quick test_batch_reveal_transaction_ok; ] diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/test_manager_operation_precheck.ml b/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml similarity index 73% rename from src/proto_014_PtKathma/lib_protocol/test/integration/precheck/test_manager_operation_precheck.ml rename to src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml index 79831ff4c608..5428ef1d1259 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/test_manager_operation_precheck.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml @@ -25,26 +25,26 @@ (** Testing ------- - Component: Protocol (precheck manager) + Component: Protocol (validate manager) Invocation: dune exec \ - src/proto_alpha/lib_protocol/test/integration/precheck/main.exe \ - -- test "^Single$" - Subject: Precheck manager operation. + src/proto_alpha/lib_protocol/test/integration/validate/main.exe \ + -- test "^Single" + Subject: Validation of manager operation. *) open Protocol open Alpha_context open Manager_operation_helpers -(* The goal of this test is to ensure that [select_op] generate the +(** 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, + 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 precheck test on the new manager + 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 @@ -108,15 +108,15 @@ let test_ensure_manager_operation_coverage () = `Quick (fun () -> ensure_manager_operation_coverage ()) -(* Negative tests assert the case where precheck must fail. *) +(** {2 Negative tests assert the case where validate must fail} *) -(* Precheck fails if the gas limit is too low. +(** Validate fails if the gas limit is too low. - This test asserts that the precheck of a manager's operation - with a too low gas limit fails at precheck with an - [Gas_quota_exceeded_init_deserialize] error. - This test applies on manager operations that do not - consume gas in their specific part of precheck. *) + 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 @@ -132,7 +132,7 @@ let low_gas_limit_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_low_gas_limit kind () = let open Lwt_result_syntax in @@ -147,13 +147,13 @@ let generate_low_gas_limit () = create_Tztest test_low_gas_limit "Gas_limit too low." - gas_consumer_in_precheck_subjects + gas_consumer_in_validate_subjects -(* Precheck fails if the gas limit is too high. +(** Validate fails if the gas limit is too high. - This test asserts that the precheck of a manager operation with - a gas limit too high fails at precheck with an [Gas_limit_too_high] - error. It applies on every kind of manager operation. *) + 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 @@ -164,7 +164,7 @@ let high_gas_limit_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_high_gas_limit kind () = let open Lwt_result_syntax in @@ -178,11 +178,11 @@ let test_high_gas_limit kind () = let generate_high_gas_limit () = create_Tztest test_high_gas_limit "Gas_limit too high." subjects -(* Precheck fails if the storage limit is too high. +(** Validate fails if the storage limit is too high. - This test asserts that a manager operation with a storage limit - too high fails at precheck with [Storage_limit_too_high] error. - It applies to every kind of manager operation. *) + 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 @@ -194,7 +194,7 @@ let high_storage_limit_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_high_storage_limit kind () = let open Lwt_result_syntax in @@ -213,12 +213,13 @@ let test_high_storage_limit kind () = let generate_high_storage_limit () = create_Tztest test_high_gas_limit "Storage_limit too high." subjects -(* Precheck fails if the counter is in the future. +(** Validate fails if the counter is in the future. - This test asserts that a manager operation with a counter in the - future -- aka greater than the successor of the manager's counter - stored in the current context -- fails with [Counter_in_the_future] error. - It applies to every kind of manager operation. *) + 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 @@ -230,7 +231,7 @@ let high_counter_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_high_counter kind () = let open Lwt_result_syntax in @@ -244,12 +245,13 @@ let test_high_counter kind () = let generate_high_counter () = create_Tztest test_high_counter "Counter too high." subjects -(* Precheck fails if the counter is in the past. +(** Validate fails if the counter is in the past. - This test asserts that a manager operation with a counter in the past -- aka - smaller than the successor of the manager's counter stored in the current - context -- fails with [Counter_in_the_past] error. - It applies to every kind of manager operation. *) + 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 @@ -261,7 +263,7 @@ let low_counter_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_low_counter kind () = let open Lwt_result_syntax in @@ -278,11 +280,12 @@ let test_low_counter kind () = let generate_low_counter () = create_Tztest test_low_counter "Counter too low." subjects -(* Precheck fails if the source is not allocated. +(** Validate fails if the source is not allocated. - This test asserts that a manager operation which manager's contract - is not allocated fails with [Empty_implicit_contract] error. - It applies on every kind of manager operation. *) + 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 @@ -295,7 +298,7 @@ let not_allocated_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_not_allocated kind () = let open Lwt_result_syntax in @@ -306,13 +309,13 @@ let test_not_allocated kind () = not_allocated_diagnostic infos op let generate_not_allocated () = - create_Tztest test_not_allocated "not allocated source." subjects + create_Tztest test_not_allocated "Not allocated source." subjects -(* Precheck fails if the source is unrevealed. +(** Validate fails if the source is unrevealed. - This test asserts that a manager operation with an unrevealed source's - contract fails at precheck with [Unrevealed_manager_key]. - It applies on every kind of manager operation except [Revelation]. *) + 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 @@ -327,7 +330,7 @@ let unrevealed_key_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_unrevealed_key kind () = let open Lwt_result_syntax in @@ -338,14 +341,14 @@ let test_unrevealed_key kind () = let generate_unrevealed_key () = create_Tztest test_unrevealed_key - "unrevealed source (find_manager_public_key)." + "Unrevealed source (find_manager_public_key)." revealed_subjects -(* Precheck fails if the source's balance is not enough to pay the fees. +(** Validate fails if the source balance is not enough to pay the fees. - This test asserts that precheck of a manager operation fails if the - source's balance is lesser than the manager operation's fee. - It applies on every kind of manager operation. *) + 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 @@ -360,7 +363,7 @@ let high_fee_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_high_fee kind () = let open Lwt_result_syntax in @@ -372,16 +375,16 @@ let test_high_fee kind () = high_fee_diagnostic infos op let generate_tests_high_fee () = - create_Tztest test_high_fee "not enough for fee payment." subjects + create_Tztest test_high_fee "Balance too low for fee payment." subjects -(* Precheck fails if the fee payment empties the balance of a - delegated implicit contract. +(** 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, precheck fails with [Empty_implicit_delegated_contract] error. - It applies to every kind of manager operation except [Revelation].*) + 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 @@ -396,7 +399,7 @@ let emptying_delegated_implicit_diagnostic (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure + validate_ko_diagnostic infos op expect_failure let test_emptying_delegated_implicit kind () = let open Lwt_result_syntax in @@ -410,16 +413,16 @@ let test_emptying_delegated_implicit kind () = let generate_tests_emptying_delegated_implicit () = create_Tztest test_emptying_delegated_implicit - "just enough funds to empty a delegated source." + "Just enough funds to empty a delegated source." revealed_subjects -(* Precheck fails if there is not enough available gas in the block. +(** Validate fails if there is not enough available gas in the block. - This test asserts that precheck fails with: + 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. *) + - [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 ~mempool_mode (infos : infos) op = let expect_failure errs = match errs with @@ -443,7 +446,7 @@ let exceeding_block_gas_diagnostic ~mempool_mode (infos : infos) op = Error_monad.pp_print_trace err in - precheck_ko_diagnostic infos op expect_failure ~mempool_mode + validate_ko_diagnostic infos op expect_failure ~mempool_mode let test_exceeding_block_gas ~mempool_mode kind () = let open Lwt_result_syntax in @@ -459,40 +462,41 @@ let test_exceeding_block_gas ~mempool_mode kind () = let generate_tests_exceeding_block_gas () = create_Tztest (test_exceeding_block_gas ~mempool_mode:false) - "too much gas consumption." + "Too much gas consumption." subjects let generate_tests_exceeding_block_gas_mp_mode () = create_Tztest (test_exceeding_block_gas ~mempool_mode:true) - "too much gas consumption in mempool mode." + "Too much gas consumption in mempool mode." subjects -(* Positive tests. +(** {2 Positive tests} *) - Tests that precheck 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: +(** 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 the first two only precheck succeeds while in the last case, - the full application also succeeds. - In the first 2 case, we observe in the output context that: + + Notice that in the first two cases only validate succeeds while + in the last case, the full application also succeeds. + In the first 2 case, we observe in the output context that: - the counter is the successor of the one stored in the initial context, - the balance decreased by fee, - the available gas in the block decreased by gas limit. - In the last case, we observe in the output context that: + In the last case, 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 by gas limit. *) -(* Fee payment that emptying a self_delegated implicit. *) +(** Fee payment that emptying a self_delegated implicit. *) let test_emptying_self_delegated_implicit kind () = let open Lwt_result_syntax in let* infos = init_self_delegated_implicit () in @@ -500,25 +504,25 @@ let test_emptying_self_delegated_implicit kind () = let* op = select_op ~fee ~force_reveal:false ~source:infos.contract1 kind infos in - only_precheck_diagnostic infos op + only_validate_diagnostic infos op let generate_tests_emptying_self_delegated_implicit () = create_Tztest test_emptying_self_delegated_implicit - "passes precheck and empties a self-delegated source." + "Validate and empties a self-delegated source." subjects -(* Minimum gas cost to pass the precheck: - - cost_of_manager_operation for the generic part - - 100 (empiric) for the specific part (script decoding or hash costs) *) -let empiric_minimal_gas_cost_for_precheck = +(** Minimum gas cost to pass the validation: + - cost_of_manager_operation for the generic part + - 100 (empiric) for the specific part (script decoding or hash costs) *) +let empiric_minimal_gas_cost_for_validate = Gas.Arith.integral_of_int_exn (Michelson_v1_gas.Internal_for_tests.int_cost_of_manager_operation + 100) let test_emptying_undelegated_implicit kind () = let open Lwt_result_syntax in let* infos = init_context () in - let gas_limit = Op.Custom_gas empiric_minimal_gas_cost_for_precheck in + let gas_limit = Op.Custom_gas empiric_minimal_gas_cost_for_validate in let* fee = Context.Contract.balance (B infos.block) infos.contract1 in let* op = select_op @@ -529,28 +533,28 @@ let test_emptying_undelegated_implicit kind () = kind infos in - only_precheck_diagnostic infos op + only_validate_diagnostic infos op let generate_tests_emptying_undelegated_implicit () = create_Tztest test_emptying_undelegated_implicit - "passes precheck and empties an undelegated source." + "Validate and empties an undelegated source." subjects -(* Fee payment.*) -let test_precheck kind () = +(** Fee payment.*) +let test_validate kind () = let open Lwt_result_syntax in let* infos = init_context () in let* counter = Context.Contract.counter (B infos.block) infos.contract1 in let source = infos.contract1 in let* operation = select_op ~counter ~force_reveal:true ~source kind infos in - precheck_diagnostic infos operation + validate_diagnostic infos operation -let generate_tests_precheck () = - create_Tztest test_precheck "passes precheck." subjects +let generate_tests_validate () = + create_Tztest test_validate "Validate." subjects let sanity_tests = - test_ensure_manager_operation_coverage () :: generate_tests_precheck () + test_ensure_manager_operation_coverage () :: generate_tests_validate () let gas_tests = generate_low_gas_limit () @ generate_high_gas_limit () -- GitLab From 48edbc38d5ec2ce85c58c31b9d22102336aafe25 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Mon, 27 Jun 2022 15:35:28 +0200 Subject: [PATCH 03/11] Proto/test: add test valid no gas consumer with minimal gas limit Co-authored-by: Zaynah Dargaye --- .../validate/manager_operation_helpers.ml | 32 ++++++++++++------- .../test_manager_operation_validation.ml | 18 +++++++++++ .../validate/manager_operation_helpers.ml | 32 ++++++++++++------- .../test_manager_operation_validation.ml | 18 +++++++++++ 4 files changed, 78 insertions(+), 22 deletions(-) diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml index 5beb5314851a..994f51144605 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -853,7 +853,7 @@ let manager_content_infos op = that the application has succeeded, - its counter [c_in] increases by [probes.nb_counter], and - the available gas in the block in [i] decreases by [g_in].*) -let observe ~only_validate contract b_in c_in g_in probes i = +let observe ~only_validate ~mode contract b_in c_in g_in probes i = let open Lwt_result_syntax in let* b_out = Context.Contract.balance (I i) contract in let g_out = Gas.block_level (Incremental.alpha_ctxt i) in @@ -863,7 +863,7 @@ let observe ~only_validate contract b_in c_in g_in probes i = Assert.equal ~loc:__LOC__ (if only_validate then Tez.( = ) else Tez.( <= )) - "Balance update" + (if only_validate then "Balance update (=)" else "Balance update (<=)") Tez.pp in let* _ = b_cmp b_out b_expected in @@ -877,14 +877,23 @@ let observe ~only_validate contract b_in c_in g_in probes i = c_out c_expected in - let g_expected = Gas.Arith.sub g_in (Gas.Arith.fp probes.gas_limit) in - Assert.equal - ~loc:__LOC__ - Gas.Arith.equal - "Gas consumption" - Gas.Arith.pp - g_out - g_expected + let* g_expected = + match mode with + | Validate_operation.Block -> + return (Gas.Arith.sub g_in (Gas.Arith.fp probes.gas_limit)) + | Validate_operation.Mempool -> + Context.get_constants (I i) >>=? fun c -> + return + (Gas.Arith.sub + (Gas.Arith.fp c.parametric.hard_gas_limit_per_block) + (Gas.Arith.fp probes.gas_limit)) + in + let g_msg = + match mode with + | Validate_operation.Block -> "Gas consumption (block)" + | Validate_operation.Mempool -> "Gas consumption (mempool)" + in + Assert.equal ~loc:__LOC__ Gas.Arith.equal g_msg Gas.Arith.pp g_out g_expected let validate_with_diagnostic ~only_validate (infos : infos) op = let open Lwt_result_syntax in @@ -896,7 +905,8 @@ let validate_with_diagnostic ~only_validate (infos : infos) op = let g_in = Gas.block_level (Incremental.alpha_ctxt i) in let* i = Incremental.validate_operation i op in let* _ = Incremental.finalize_block i in - observe ~only_validate contract b_in c_in g_in prbs i + let mode = Validate_operation.Block in + observe ~only_validate ~mode contract b_in c_in g_in prbs i (** If only the validate of an operation succeed; e.g. the rest of the application failed: diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml index a78782a5e204..cef8397931ac 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml @@ -541,6 +541,23 @@ let generate_tests_emptying_undelegated_implicit () = "Validate and empties an undelegated source." subjects +(** No gas consumer with the minimal gas limit for manager operations + passes validate. *) +let test_low_gas_limit_no_consumer kind () = + let open Lwt_result_syntax in + let* infos = init_context () in + let gas_limit = Op.Low in + let* op = + select_op ~gas_limit ~force_reveal:true ~source:infos.contract1 kind infos + in + validate_diagnostic infos op + +let generate_low_gas_limit_no_consumer () = + create_Tztest + test_low_gas_limit + "passes validate with minimal gas limit for manager operations." + gas_consumer_in_validate_subjects + (** Fee payment.*) let test_validate kind () = let open Lwt_result_syntax in @@ -560,6 +577,7 @@ let gas_tests = generate_low_gas_limit () @ generate_high_gas_limit () @ generate_tests_exceeding_block_gas () @ generate_tests_exceeding_block_gas_mp_mode () + @ generate_low_gas_limit_no_consumer () let storage_tests = generate_high_storage_limit () diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml b/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml index 222edf4b7f6e..01503a4b920b 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -843,7 +843,7 @@ let manager_content_infos op = that the application has succeeded, - its counter [c_in] increases by [probes.nb_counter], and - the available gas in the block in [i] decreases by [g_in].*) -let observe ~only_validate contract b_in c_in g_in probes i = +let observe ~only_validate ~mode contract b_in c_in g_in probes i = let open Lwt_result_syntax in let* b_out = Context.Contract.balance (I i) contract in let g_out = Gas.block_level (Incremental.alpha_ctxt i) in @@ -853,7 +853,7 @@ let observe ~only_validate contract b_in c_in g_in probes i = Assert.equal ~loc:__LOC__ (if only_validate then Tez.( = ) else Tez.( <= )) - "Balance update" + (if only_validate then "Balance update (=)" else "Balance update (<=)") Tez.pp in let* _ = b_cmp b_out b_expected in @@ -867,14 +867,23 @@ let observe ~only_validate contract b_in c_in g_in probes i = c_out c_expected in - let g_expected = Gas.Arith.sub g_in (Gas.Arith.fp probes.gas_limit) in - Assert.equal - ~loc:__LOC__ - Gas.Arith.equal - "Gas consumption" - Gas.Arith.pp - g_out - g_expected + let* g_expected = + match mode with + | Validate_operation.Block -> + return (Gas.Arith.sub g_in (Gas.Arith.fp probes.gas_limit)) + | Validate_operation.Mempool -> + Context.get_constants (I i) >>=? fun c -> + return + (Gas.Arith.sub + (Gas.Arith.fp c.parametric.hard_gas_limit_per_block) + (Gas.Arith.fp probes.gas_limit)) + in + let g_msg = + match mode with + | Validate_operation.Block -> "Gas consumption (block)" + | Validate_operation.Mempool -> "Gas consumption (mempool)" + in + Assert.equal ~loc:__LOC__ Gas.Arith.equal g_msg Gas.Arith.pp g_out g_expected let validate_with_diagnostic ~only_validate (infos : infos) op = let open Lwt_result_syntax in @@ -886,7 +895,8 @@ let validate_with_diagnostic ~only_validate (infos : infos) op = let g_in = Gas.block_level (Incremental.alpha_ctxt i) in let* i = Incremental.validate_operation i op in let* _ = Incremental.finalize_block i in - observe ~only_validate contract b_in c_in g_in prbs i + let mode = Validate_operation.Block in + observe ~only_validate ~mode contract b_in c_in g_in prbs i (** If only the validate of an operation succeed; e.g. the rest of the application failed: diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml b/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml index 5428ef1d1259..6cfee688277c 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml @@ -541,6 +541,23 @@ let generate_tests_emptying_undelegated_implicit () = "Validate and empties an undelegated source." subjects +(** No gas consumer with the minimal gas limit for manager operations + passes validate. *) +let test_low_gas_limit_no_consumer kind () = + let open Lwt_result_syntax in + let* infos = init_context () in + let gas_limit = Op.Low in + let* op = + select_op ~gas_limit ~force_reveal:true ~source:infos.contract1 kind infos + in + validate_diagnostic infos op + +let generate_low_gas_limit_no_consumer () = + create_Tztest + test_low_gas_limit + "passes validate with minimal gas limit for manager operations." + gas_consumer_in_validate_subjects + (** Fee payment.*) let test_validate kind () = let open Lwt_result_syntax in @@ -560,6 +577,7 @@ let gas_tests = generate_low_gas_limit () @ generate_high_gas_limit () @ generate_tests_exceeding_block_gas () @ generate_tests_exceeding_block_gas_mp_mode () + @ generate_low_gas_limit_no_consumer () let storage_tests = generate_high_storage_limit () -- GitLab From de8ac7b3de4ae92e306c279e9313f80cc6b3d049 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Mon, 27 Jun 2022 15:36:18 +0200 Subject: [PATCH 04/11] Proto/test: provide 1M and validate tests Co-authored-by: Zaynah Dargaye --- .../test/integration/validate/main.ml | 1 + .../validate/test_1m_restriction.ml | 292 ++++++++++++++++++ .../test/integration/validate/main.ml | 1 + .../validate/test_1m_restriction.ml | 292 ++++++++++++++++++ 4 files changed, 586 insertions(+) create mode 100644 src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml create mode 100644 src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml index 445200746450..d47ce8f6969a 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml @@ -46,5 +46,6 @@ let () = Test_batched_manager_operation_validation.gas_tests ); ( "Batched: fees checks", Test_batched_manager_operation_validation.fee_tests ); + ("1M: 1m restriction", Test_1m_restriction.tests); ] |> Lwt_main.run diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml new file mode 100644 index 000000000000..ef15beabe732 --- /dev/null +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml @@ -0,0 +1,292 @@ +(*****************************************************************************) +(* *) +(* 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_014_PtKathma/lib_protocol/test/integration/validate/main.exe \ + -- test "^1M" + Subject: 1M restriction in validation of manager operation. +*) + +open Protocol +open Alpha_context +open Manager_operation_helpers + +(* Temporary local helpers to be clean up. *) +let create_Tztest ?hd_msg test tests_msg = + let hd_msg k = + let sk = kind_to_string k in + match hd_msg with + | None -> sk + | Some hd -> Format.sprintf "Batch: %s, %s" hd sk + in + let kind = K_Register_global_constant in + Tztest.tztest + (Format.sprintf "%s: %s" (hd_msg kind) tests_msg) + `Quick + (fun () -> test kind ()) + +let generate_op ~fee ~reverse:_ kind infos = + let open Lwt_result_syntax in + let* counter = Context.Contract.counter (B infos.block) infos.contract1 in + let source = infos.contract1 in + let* operation = + select_op ~fee ~counter ~force_reveal:true ~source kind infos + in + let counter = Z.succ (Z.succ counter) in + let+ operation2 = + select_op ~fee ~counter ~force_reveal:false ~source kind infos + in + (operation, operation2) + +let generate_op_diff_man ~fee ~reverse:_ kind infos = + let open Lwt_result_syntax in + let* counter = Context.Contract.counter (B infos.block) infos.contract1 in + let source = infos.contract1 in + let* operation = + select_op ~fee ~counter ~force_reveal:true ~source kind infos + in + let* counter = Context.Contract.counter (B infos.block) infos.contract2 in + let source = infos.contract2 in + let+ operation2 = + select_op ~fee ~counter ~force_reveal:true ~source kind infos + in + (operation, operation2) + +(* Helpers that should be included or replace existing helpers for + validate tests.*) +let witness inc source = + let open Lwt_result_syntax in + let* b_in = Context.Contract.balance (I inc) source in + let+ c_in = Context.Contract.counter (I inc) source in + let g_in = Gas.block_level (Incremental.alpha_ctxt inc) in + (b_in, c_in, g_in) + +let observe ~mode inc_pre inc_post op = + let open Lwt_result_syntax in + let* prbs = manager_content_infos op in + let source = Contract.Implicit prbs.source in + let* b_in, c_in, g_in = witness inc_pre source in + observe ~only_validate:false ~mode source b_in c_in g_in prbs inc_post + +(** 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 test_two_op_with_same_manager ~mempool_mode kind () = + let open Lwt_result_syntax in + let* infos = init_context () in + let* op1, op2 = generate_op ~fee:Tez.zero ~reverse:false kind infos in + let* inc = Incremental.begin_construction ~mempool_mode infos.block in + let* inc = Incremental.validate_operation inc op1 in + let* _inc = + Incremental.validate_operation + inc + ~expect_failure:(function + | [ + Environment.Ecoproto_error + (Validate_operation.Manager.Manager_restriction _); + ] -> + return_unit + | err -> + failwith + "Error trace:@,\ + \ %a does not match the \ + [Validate_operation.Manager.Manager_restriction]" + Error_monad.pp_print_trace + err) + op2 + in + return_unit + +(** Under 1M restriction, a batch of two operations cannot be replaced + by two single operations. *) +let test_batch_of_two_not_be_two_singles ~mempool_mode kind () = + let open Lwt_result_syntax in + let mode = + if mempool_mode then Validate_operation.Mempool + else Validate_operation.Block + in + let* infos = init_context () in + let* inc = Incremental.begin_construction ~mempool_mode infos.block in + let* op1, op2 = generate_op ~fee:Tez.one_mutez ~reverse:false kind infos in + let* batch = + Op.batch_operations ~source:infos.contract1 (B infos.block) [op1; op2] + in + let* inc_batch = Incremental.validate_operation inc batch in + let* () = observe ~mode inc inc_batch batch in + let* inc1 = Incremental.validate_operation inc op1 in + let* () = observe ~mode inc inc1 op1 in + let* _inc2 = + Incremental.validate_operation + ~expect_failure:(fun _ -> return_unit) + inc + op2 + in + let* b1 = Incremental.finalize_block inc1 in + let* inc1' = Incremental.begin_construction ~mempool_mode b1 in + let* inc1_op2 = Incremental.validate_operation inc1' op2 in + let* () = observe ~mode inc1' inc1_op2 op2 in + return_unit + +(** The application of a valid operation succeeds, at least, to perform + the fee payment. *) +let valid_validate ~mempool_mode kind () = + let open Lwt_result_syntax in + let* infos = init_context () in + let* inc = Incremental.begin_construction ~mempool_mode infos.block in + let* op, _ = generate_op ~fee:Tez.one_mutez ~reverse:false kind infos in + let {shell; protocol_data = Operation_data protocol_data} = op in + let operation : _ Alpha_context.operation = {shell; protocol_data} in + let oph = Alpha_context.Operation.hash operation in + let init_infos, init_state = + Validate_operation.init_info_and_state + (Incremental.alpha_ctxt inc) + Validate_operation.Mempool + Chain_id.zero + in + let _res1 = + Validate_operation.validate_operation init_infos init_state oph operation + in + let* _ = Incremental.validate_operation inc op in + return_unit + +(** The applications of two covalid operations in a certain context + succeed, at least, to perform the fee payment of both, in whatever + application order. + + The application of a manager operation has two step: the fees + payment guarded by the validation and the rest of its application. + Two manager operations that are valid in a context, will succeed to + pass the first step of their application -- aka fee payment -- in + whatever application order. + + By construction they have distinct manager thanks to + [generate_op_diff_man]. *) +let valid_context_free ~mempool_mode kind () = + let open Lwt_result_syntax in + let mode = + if mempool_mode then Validate_operation.Mempool + else Validate_operation.Block + in + let* infos = init_context () in + let* inc = Incremental.begin_construction ~mempool_mode infos.block in + let* op1, op2 = + generate_op_diff_man ~fee:Tez.one_mutez ~reverse:false kind infos + in + let {shell; protocol_data = Operation_data protocol_data} = op1 in + let operation1 : _ Alpha_context.operation = {shell; protocol_data} in + let oph1 = Alpha_context.Operation.hash operation1 in + let {shell; protocol_data = Operation_data protocol_data} = op2 in + let operation2 : _ Alpha_context.operation = {shell; protocol_data} in + let oph2 = Alpha_context.Operation.hash operation2 in + let init_infos, init_state = + Validate_operation.init_info_and_state + (Incremental.alpha_ctxt inc) + Validate_operation.Mempool + Chain_id.zero + in + let* _res1 = + let*! res = + Validate_operation.validate_operation + init_infos + init_state + oph1 + operation1 + in + Lwt.return (Environment.wrap_tzresult res) + in + let* _res2 = + let*! res = + Validate_operation.validate_operation + init_infos + init_state + oph2 + operation2 + in + Lwt.return (Environment.wrap_tzresult res) + in + let* inc1 = Incremental.validate_operation inc op1 in + let* () = observe ~mode inc inc1 op1 in + let* inc1' = Incremental.validate_operation inc1 op2 in + let* () = observe ~mode inc1 inc1' op2 in + let* inc2 = Incremental.validate_operation inc op2 in + let* () = observe ~mode inc inc2 op2 in + let* inc2' = Incremental.validate_operation inc2 op1 in + let* () = observe ~mode inc2 inc2' op1 in + return_unit + +let generate_1m_conflit_mempool_mode () = + create_Tztest + (test_two_op_with_same_manager ~mempool_mode:true) + "1M restriction fails in mempool mode" + +let generate_1m_conflit_construction_mode () = + create_Tztest + (test_two_op_with_same_manager ~mempool_mode:false) + "1M restriction fails in construction mode" + +let generate_batch_of_two_not_be_two_singles_construction_mode () = + create_Tztest + (test_batch_of_two_not_be_two_singles ~mempool_mode:false) + "1M restriction fails in construction mode" + +let generate_batch_of_two_not_be_two_singles_mempool_mode () = + create_Tztest + (test_batch_of_two_not_be_two_singles ~mempool_mode:true) + "1M restriction fails in mempool mode" + +let generate_valid_precheck_mempool_mode () = + create_Tztest + (valid_validate ~mempool_mode:true) + "valid so fee payment in mempool mode" + +let generate_valid_precheck_construction_mode () = + create_Tztest + (valid_validate ~mempool_mode:false) + "valid so fee payment in construction mode" + +let generate_valid_context_free_mempool_mode () = + create_Tztest + (valid_context_free ~mempool_mode:true) + "two covalid so both pay fees commute under 1M in mempool mode" + +let generate_valid_context_free_construction_mode () = + create_Tztest + (valid_context_free ~mempool_mode:false) + "two covalid so both pay fees commute under 1M in construction mode" + +let tests = + [ + generate_1m_conflit_construction_mode (); + generate_batch_of_two_not_be_two_singles_construction_mode (); + generate_valid_precheck_construction_mode (); + generate_valid_context_free_construction_mode (); + generate_1m_conflit_mempool_mode (); + generate_batch_of_two_not_be_two_singles_mempool_mode (); + generate_valid_precheck_mempool_mode (); + generate_valid_context_free_mempool_mode (); + ] diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/main.ml b/src/proto_alpha/lib_protocol/test/integration/validate/main.ml index f7dd004ffd5e..3e64e87b8bfb 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/main.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/main.ml @@ -46,5 +46,6 @@ let () = Test_batched_manager_operation_validation.gas_tests ); ( "Batched: fees checks", Test_batched_manager_operation_validation.fee_tests ); + ("1M: 1m restriction", Test_1m_restriction.tests); ] |> Lwt_main.run diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml b/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml new file mode 100644 index 000000000000..c807a0470d3e --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml @@ -0,0 +1,292 @@ +(*****************************************************************************) +(* *) +(* 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_alpha/lib_protocol/test/integration/validate/main.exe \ + -- test "^1M" + Subject: 1M restriction in validation of manager operation. +*) + +open Protocol +open Alpha_context +open Manager_operation_helpers + +(* Temporary local helpers to be clean up. *) +let create_Tztest ?hd_msg test tests_msg = + let hd_msg k = + let sk = kind_to_string k in + match hd_msg with + | None -> sk + | Some hd -> Format.sprintf "Batch: %s, %s" hd sk + in + let kind = K_Register_global_constant in + Tztest.tztest + (Format.sprintf "%s: %s" (hd_msg kind) tests_msg) + `Quick + (fun () -> test kind ()) + +let generate_op ~fee ~reverse:_ kind infos = + let open Lwt_result_syntax in + let* counter = Context.Contract.counter (B infos.block) infos.contract1 in + let source = infos.contract1 in + let* operation = + select_op ~fee ~counter ~force_reveal:true ~source kind infos + in + let counter = Z.succ (Z.succ counter) in + let+ operation2 = + select_op ~fee ~counter ~force_reveal:false ~source kind infos + in + (operation, operation2) + +let generate_op_diff_man ~fee ~reverse:_ kind infos = + let open Lwt_result_syntax in + let* counter = Context.Contract.counter (B infos.block) infos.contract1 in + let source = infos.contract1 in + let* operation = + select_op ~fee ~counter ~force_reveal:true ~source kind infos + in + let* counter = Context.Contract.counter (B infos.block) infos.contract2 in + let source = infos.contract2 in + let+ operation2 = + select_op ~fee ~counter ~force_reveal:true ~source kind infos + in + (operation, operation2) + +(* Helpers that should be included or replace existing helpers for + validate tests.*) +let witness inc source = + let open Lwt_result_syntax in + let* b_in = Context.Contract.balance (I inc) source in + let+ c_in = Context.Contract.counter (I inc) source in + let g_in = Gas.block_level (Incremental.alpha_ctxt inc) in + (b_in, c_in, g_in) + +let observe ~mode inc_pre inc_post op = + let open Lwt_result_syntax in + let* prbs = manager_content_infos op in + let source = Contract.Implicit prbs.source in + let* b_in, c_in, g_in = witness inc_pre source in + observe ~only_validate:false ~mode source b_in c_in g_in prbs inc_post + +(** 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 test_two_op_with_same_manager ~mempool_mode kind () = + let open Lwt_result_syntax in + let* infos = init_context () in + let* op1, op2 = generate_op ~fee:Tez.zero ~reverse:false kind infos in + let* inc = Incremental.begin_construction ~mempool_mode infos.block in + let* inc = Incremental.validate_operation inc op1 in + let* _inc = + Incremental.validate_operation + inc + ~expect_failure:(function + | [ + Environment.Ecoproto_error + (Validate_operation.Manager.Manager_restriction _); + ] -> + return_unit + | err -> + failwith + "Error trace:@,\ + \ %a does not match the \ + [Validate_operation.Manager.Manager_restriction]" + Error_monad.pp_print_trace + err) + op2 + in + return_unit + +(** Under 1M restriction, a batch of two operations cannot be replaced + by two single operations. *) +let test_batch_of_two_not_be_two_singles ~mempool_mode kind () = + let open Lwt_result_syntax in + let mode = + if mempool_mode then Validate_operation.Mempool + else Validate_operation.Block + in + let* infos = init_context () in + let* inc = Incremental.begin_construction ~mempool_mode infos.block in + let* op1, op2 = generate_op ~fee:Tez.one_mutez ~reverse:false kind infos in + let* batch = + Op.batch_operations ~source:infos.contract1 (B infos.block) [op1; op2] + in + let* inc_batch = Incremental.validate_operation inc batch in + let* () = observe ~mode inc inc_batch batch in + let* inc1 = Incremental.validate_operation inc op1 in + let* () = observe ~mode inc inc1 op1 in + let* _inc2 = + Incremental.validate_operation + ~expect_failure:(fun _ -> return_unit) + inc + op2 + in + let* b1 = Incremental.finalize_block inc1 in + let* inc1' = Incremental.begin_construction ~mempool_mode b1 in + let* inc1_op2 = Incremental.validate_operation inc1' op2 in + let* () = observe ~mode inc1' inc1_op2 op2 in + return_unit + +(** The application of a valid operation succeeds, at least, to perform + the fee payment. *) +let valid_validate ~mempool_mode kind () = + let open Lwt_result_syntax in + let* infos = init_context () in + let* inc = Incremental.begin_construction ~mempool_mode infos.block in + let* op, _ = generate_op ~fee:Tez.one_mutez ~reverse:false kind infos in + let {shell; protocol_data = Operation_data protocol_data} = op in + let operation : _ Alpha_context.operation = {shell; protocol_data} in + let oph = Alpha_context.Operation.hash operation in + let init_infos, init_state = + Validate_operation.init_info_and_state + (Incremental.alpha_ctxt inc) + Validate_operation.Mempool + Chain_id.zero + in + let _res1 = + Validate_operation.validate_operation init_infos init_state oph operation + in + let* _ = Incremental.validate_operation inc op in + return_unit + +(** The applications of two covalid operations in a certain context + succeed, at least, to perform the fee payment of both, in whatever + application order. + + The application of a manager operation has two step: the fees + payment guarded by the validation and the rest of its application. + Two manager operations that are valid in a context, will succeed to + pass the first step of their application -- aka fee payment -- in + whatever application order. + + By construction they have distinct manager thanks to + [generate_op_diff_man]. *) +let valid_context_free ~mempool_mode kind () = + let open Lwt_result_syntax in + let mode = + if mempool_mode then Validate_operation.Mempool + else Validate_operation.Block + in + let* infos = init_context () in + let* inc = Incremental.begin_construction ~mempool_mode infos.block in + let* op1, op2 = + generate_op_diff_man ~fee:Tez.one_mutez ~reverse:false kind infos + in + let {shell; protocol_data = Operation_data protocol_data} = op1 in + let operation1 : _ Alpha_context.operation = {shell; protocol_data} in + let oph1 = Alpha_context.Operation.hash operation1 in + let {shell; protocol_data = Operation_data protocol_data} = op2 in + let operation2 : _ Alpha_context.operation = {shell; protocol_data} in + let oph2 = Alpha_context.Operation.hash operation2 in + let init_infos, init_state = + Validate_operation.init_info_and_state + (Incremental.alpha_ctxt inc) + Validate_operation.Mempool + Chain_id.zero + in + let* _res1 = + let*! res = + Validate_operation.validate_operation + init_infos + init_state + oph1 + operation1 + in + Lwt.return (Environment.wrap_tzresult res) + in + let* _res2 = + let*! res = + Validate_operation.validate_operation + init_infos + init_state + oph2 + operation2 + in + Lwt.return (Environment.wrap_tzresult res) + in + let* inc1 = Incremental.validate_operation inc op1 in + let* () = observe ~mode inc inc1 op1 in + let* inc1' = Incremental.validate_operation inc1 op2 in + let* () = observe ~mode inc1 inc1' op2 in + let* inc2 = Incremental.validate_operation inc op2 in + let* () = observe ~mode inc inc2 op2 in + let* inc2' = Incremental.validate_operation inc2 op1 in + let* () = observe ~mode inc2 inc2' op1 in + return_unit + +let generate_1m_conflit_mempool_mode () = + create_Tztest + (test_two_op_with_same_manager ~mempool_mode:true) + "1M restriction fails in mempool mode" + +let generate_1m_conflit_construction_mode () = + create_Tztest + (test_two_op_with_same_manager ~mempool_mode:false) + "1M restriction fails in construction mode" + +let generate_batch_of_two_not_be_two_singles_construction_mode () = + create_Tztest + (test_batch_of_two_not_be_two_singles ~mempool_mode:false) + "1M restriction fails in construction mode" + +let generate_batch_of_two_not_be_two_singles_mempool_mode () = + create_Tztest + (test_batch_of_two_not_be_two_singles ~mempool_mode:true) + "1M restriction fails in mempool mode" + +let generate_valid_precheck_mempool_mode () = + create_Tztest + (valid_validate ~mempool_mode:true) + "valid so fee payment in mempool mode" + +let generate_valid_precheck_construction_mode () = + create_Tztest + (valid_validate ~mempool_mode:false) + "valid so fee payment in construction mode" + +let generate_valid_context_free_mempool_mode () = + create_Tztest + (valid_context_free ~mempool_mode:true) + "two covalid so both pay fees commute under 1M in mempool mode" + +let generate_valid_context_free_construction_mode () = + create_Tztest + (valid_context_free ~mempool_mode:false) + "two covalid so both pay fees commute under 1M in construction mode" + +let tests = + [ + generate_1m_conflit_construction_mode (); + generate_batch_of_two_not_be_two_singles_construction_mode (); + generate_valid_precheck_construction_mode (); + generate_valid_context_free_construction_mode (); + generate_1m_conflit_mempool_mode (); + generate_batch_of_two_not_be_two_singles_mempool_mode (); + generate_valid_precheck_mempool_mode (); + generate_valid_context_free_mempool_mode (); + ] -- GitLab From bc0e32df2553f93924978102a8b53fb123e0df23 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Mon, 27 Jun 2022 16:00:32 +0200 Subject: [PATCH 05/11] Proto/tests: generalize manager operations helpers Co-authored-by: Zaynah Dargaye --- .../validate/manager_operation_helpers.ml | 1447 ++++++++++------- .../validate/test_1m_restriction.ml | 147 +- ...st_batched_manager_operation_validation.ml | 302 +++- .../test_manager_operation_validation.ml | 254 ++- .../validate/manager_operation_helpers.ml | 1446 +++++++++------- .../validate/test_1m_restriction.ml | 147 +- ...st_batched_manager_operation_validation.ml | 302 +++- .../test_manager_operation_validation.ml | 254 ++- 8 files changed, 2661 insertions(+), 1638 deletions(-) diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml index 994f51144605..4a55cda23778 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -30,354 +30,488 @@ 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) -(** {2 Context} *) +(** {2 Datatypes} *) -type infos = { +(** Context abstraction in a test. *) +type ctxt = { block : Block.t; - account1 : Account.t; - contract1 : Contract.t; - account2 : Account.t; - contract2 : Contract.t; - account3 : Account.t; - contract3 : Contract.t; - contract_hash : Contract_hash.t; - tx_rollup : Tx_rollup.t; - sc_rollup : Sc_rollup.t; + originated_contract : Contract_hash.t; + tx_rollup : Tx_rollup.t option; + sc_rollup : Sc_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 smart contructors of operations, 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 = { + source : Account.t; + dest : Account.t option; + del : Account.t option; + tx : Account.t option; + sc : Account.t option; +} + +(** Infos describes the information of the setting for a test: the + context and used accounts. *) +type infos = {ctxt : ctxt; accounts : accounts} + +(** 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_Reveal + | K_Increase_paid_storage + | K_Tx_rollup_origination + | K_Tx_rollup_submit_batch + | K_Tx_rollup_commit + | K_Tx_rollup_return_bond + | K_Tx_rollup_finalize + | K_Tx_rollup_remove_commitment + | K_Tx_rollup_dispatch_tickets + | K_Transfer_ticket + | K_Tx_rollup_reject + | 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 + +(** The requirements for a tested manager operation. *) +type operation_req = { + kind : manager_operation_kind; + counter : counter option; + fee : Tez.t option; + gas_limit : Op.gas_limit option; + storage_limit : counter option; + force_reveal : bool option; + amount : Tez.t option; } -(** Initialize an [infos] record with a context enabling tx and sc - rollup, funded accounts, tx_rollup, sc_rollup. *) -let init_context ?hard_gas_limit_per_block () = +(** 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; + fund_tx : Tez.t option; + fund_sc : Tez.t option; +} + +(** 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 ctxt_req_default = + { + hard_gas_limit_per_block = None; + fund_src = Some Tez.one; + fund_dest = Some Tez.one; + fund_del = Some Tez.one; + fund_tx = Some Tez.one; + fund_sc = Some Tez.one; + } + +let operation_req_default kind = + { + kind; + counter = None; + fee = None; + gas_limit = None; + storage_limit = None; + force_reveal = None; + amount = None; + } + +(** {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* b, bootstrap_contract = - Context.init1 - ~consensus_threshold:0 - ?hard_gas_limit_per_block - ~tx_rollup_enable:true - ~tx_rollup_sunset_level:Int32.max_int - ~sc_rollup_enable:true - ~dal_enable:true - () + 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 - (* Set a gas_limit to avoid the default gas_limit of the helpers - ([hard_gas_limit_per_operation]). *) - let gas_limit = Op.Custom_gas (Gas.Arith.integral_of_int_exn 10_000) in - (* Create and fund an account use for originate a Tx and a Sc - rollup *) - let rollup_account = Account.new_account () in - let rollup_contract = Contract.Implicit rollup_account.pkh in - let counter = Z.zero in - let* fund_rollup_account = - Op.transaction + 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 delegator delegate = + let open Lwt_result_syntax in + let delegate_pkh = delegate.Account.pkh in + let contract_delegator = contract_of delegator in + let contract_delegate = contract_of delegate in + let* operation = + Op.delegation ~force_reveal:true - ~counter - ~gas_limit - (B b) - bootstrap_contract - rollup_contract - Tez.one + (B block) + contract_delegate + (Some delegate_pkh) in - let* b = Block.bake ~operation:fund_rollup_account b in - let counter2 = Z.succ counter in - let* rollup_origination, tx_rollup = - Op.tx_rollup_origination + let* block = Block.bake block ~operation in + let* operation = + Op.delegation ~force_reveal:true - ~counter:counter2 - ~gas_limit - (B b) - rollup_contract + (B block) + contract_delegator + (Some delegate_pkh) + in + let* block = Block.bake block ~operation in + let* del_opt_new = + Context.Contract.delegate_opt (B block) contract_delegator + in + let* del = Assert.get_some ~loc:__LOC__ del_opt_new in + let+ _ = Assert.equal_pkh ~loc:__LOC__ del delegate_pkh in + block + +let originate_tx_rollup block rollup_account = + let open Lwt_result_syntax in + let rollup_contract = contract_of rollup_account in + let* rollup_origination, tx_rollup = + Op.tx_rollup_origination ~force_reveal:true (B block) rollup_contract in - let* _, sc_rollup = + let+ block = Block.bake ~operation:rollup_origination block in + (block, tx_rollup) + +let originate_sc_rollup block rollup_account = + let open Lwt_result_syntax in + let rollup_contract = contract_of rollup_account in + let* rollup_origination, sc_rollup = Op.sc_rollup_origination - ~counter:counter2 - ~gas_limit - (B b) + ~force_reveal:true + (B block) rollup_contract Sc_rollup.Kind.Example_arith "" (Script.lazy_expr (Expr.from_string "1")) in - let* b = Block.bake ~operation:rollup_origination b in - (* Create and fund three accounts *) - let account1 = Account.new_account () in - let contract1 = Contract.Implicit account1.pkh in - let counter = Z.succ counter in - let* fund_account1 = - Op.transaction - ~counter - ~gas_limit - (B b) - bootstrap_contract - contract1 - Tez.one - in - let account2 = Account.new_account () in - let contract2 = Contract.Implicit account2.pkh in - let counter = Z.succ counter in - let* fund_account2 = - Op.transaction - ~counter - ~gas_limit - (B b) - bootstrap_contract - contract2 - Tez.one - in - let account3 = Account.new_account () in - let contract3 = Contract.Implicit account3.pkh in - let counter = Z.succ counter in - let* fund_account3 = - Op.transaction - ~counter - ~gas_limit - (B b) - bootstrap_contract - contract3 - Tez.one - in - let counter = Z.succ counter in - let* create_contract_hash, contract_hash = - Op.contract_origination_hash - (B b) - ~counter - bootstrap_contract - ~fee:Tez.zero - ~script:Op.dummy_script + let+ block = Block.bake ~operation:rollup_origination block in + (block, sc_rollup) + +(** {2 Setting's context construction} *) + +let fund_account block bootstrap account fund = + let open Lwt_result_syntax in + let* counter = Context.Contract.counter (B block) bootstrap 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* operation = - Op.batch_operations - ~source:bootstrap_contract - (B b) - [fund_account1; fund_account2; fund_account3; create_contract_hash] + Op.transaction + ~counter + ~gas_limit:Op.High + (B block) + bootstrap + (Contract.Implicit account) + fund in - let+ block = Block.bake ~operation b in - { - block; - account1; - contract1; - account2; - contract2; - account3; - contract3; - contract_hash; - tx_rollup; - sc_rollup; - } + let*! b = Block.bake ~operation block in + match b with Error _ -> failwith "Funding account error" | Ok b -> return b -(** Same as [init_context] but [contract1] delegate to [contract2]. *) -let init_delegated_implicit () = +(** 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 {hard_gas_limit_per_block; fund_src; fund_dest; fund_del; fund_tx; fund_sc} -> let open Lwt_result_syntax in - let* infos = init_context () in - let* del_opt = - Context.Contract.delegate_opt (B infos.block) infos.contract1 + 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 + (block, Some account, rollup) in - let* _ = - Assert.is_none - ~loc:__LOC__ - ~pp:(fun fmt _ -> Format.fprintf fmt "should not be delegated") - del_opt + let* block, bootstraps = + Context.init_n + 6 + ~consensus_threshold:0 + ?hard_gas_limit_per_block + ~tx_rollup_enable:true + ~tx_rollup_sunset_level:Int32.max_int + ~sc_rollup_enable:true + ~dal_enable:true + () in - let* operation = - Op.delegation - ~force_reveal:true - (B infos.block) - infos.contract2 - (Some (Context.Contract.pkh infos.contract2)) + let get_bootstrap bootstraps n = 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 = Block.bake infos.block ~operation in - let* operation = - Op.delegation - ~force_reveal:true - (B block) - infos.contract1 - (Some infos.account2.pkh) + let* block, dest, _ = + create_and_fund block (get_bootstrap bootstraps 1) fund_dest in - let* block = Block.bake block ~operation in - let* del_opt_new = Context.Contract.delegate_opt (B block) infos.contract1 in - let* del = Assert.get_some ~loc:__LOC__ del_opt_new in - let+ _ = Assert.equal_pkh ~loc:__LOC__ del infos.account2.pkh in - {infos with block} - -(** Same as [init_context] but [contract1] self delegate. *) -let init_self_delegated_implicit () = - let open Lwt_result_syntax in - let* infos = init_context () in - let* del_opt = - Context.Contract.delegate_opt (B infos.block) infos.contract1 + let* block, del, _ = + create_and_fund block (get_bootstrap bootstraps 2) fund_del in - let* _ = - Assert.is_none - ~loc:__LOC__ - ~pp:(fun fmt _ -> Format.fprintf fmt "should not be delegated") - del_opt + let* block, tx, tx_rollup = + create_and_fund + ~originate_rollup:(fun infos account -> originate_tx_rollup infos account) + block + (get_bootstrap bootstraps 3) + fund_tx in - let* operation = - Op.delegation - ~force_reveal:true - (B infos.block) - infos.contract1 - (Some infos.account1.pkh) + let* block, sc, sc_rollup = + create_and_fund + ~originate_rollup:(fun infos account -> originate_sc_rollup infos account) + block + (get_bootstrap bootstraps 4) + fund_sc in - let* block = Block.bake infos.block ~operation in - let* del_opt_new = Context.Contract.delegate_opt (B block) infos.contract1 in - let* del = Assert.get_some ~loc:__LOC__ del_opt_new in - let+ _ = Assert.equal_pkh ~loc:__LOC__ del infos.account1.pkh in - {infos with block} + let* create_contract_hash, originated_contract = + Op.contract_origination_hash + (B block) + (get_bootstrap bootstraps 5) + ~fee:Tez.zero + ~script:Op.dummy_script + in + let+ block = Block.bake ~operation:create_contract_hash block in + let ctxt = {block; originated_contract; tx_rollup; sc_rollup} in + {ctxt; accounts = {source; dest; del; tx; sc}} -(** {2 Local helpers for generating all kind of manager operations.} *) +(** In addition of building up a context according to a context + requirement, source is self-delegated. -(** Create a fresh account used for empty implicit account tests. *) -let mk_fresh_contract () = Contract.Implicit Account.(new_account ()).pkh + 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 infos.accounts.source.pkh in + let ctxt = {infos.ctxt with block} in + {infos with ctxt} -let get_pkh source = Context.Contract.pkh source +(** In addition of building up a context accordning to a context + requirement, source delegates to del. -let get_pk infos source = + See [init_ctxt] description. *) +let ctxt_with_delegation : ctxt_req -> infos tzresult Lwt.t = + fun ctxt_req -> let open Lwt_result_syntax in - let+ account = Context.Contract.manager infos source in - account.pk + 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 infos.accounts.source delegate in + let ctxt = {infos.ctxt with block} in + {infos with ctxt} + +let default_init_ctxt () = init_ctxt ctxt_req_default + +let default_ctxt_with_self_delegation () = + ctxt_with_self_delegation ctxt_req_default + +let default_ctxt_with_delegation () = ctxt_with_delegation ctxt_req_default -let mk_transaction ?counter ?fee ?gas_limit ?storage_limit ?force_reveal ~source - (infos : infos) = +(** {2 Smart constructors} *) + +(** Smart contructors to forge manager operations according to + operation requirements in a test setting. *) + +let mk_transaction (oinfos : operation_req) (infos : infos) = Op.transaction - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - (B infos.block) - source - infos.contract2 - Tez.one - -let mk_delegation ?counter ?fee ?gas_limit ?storage_limit ?force_reveal ~source - (infos : infos) = + ?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 infos.accounts.source) + (contract_of + (match infos.accounts.dest with + | None -> infos.accounts.source + | 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 - ?fee - ?gas_limit - ?counter - ?storage_limit - (B infos.block) - source - (Some infos.account2.pkh) - -let mk_undelegation ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = + ?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 infos.accounts.source) + (Some + (match infos.accounts.del with + | None -> infos.accounts.source.pkh + | Some delegate -> delegate.pkh)) + +let mk_undelegation (oinfos : operation_req) (infos : infos) = Op.delegation - ?force_reveal - ?fee - ?gas_limit - ?counter - ?storage_limit - (B infos.block) - source + ?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 infos.accounts.source) None -let mk_self_delegation ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = +let mk_self_delegation (oinfos : operation_req) (infos : infos) = Op.delegation - ?force_reveal - ?fee - ?gas_limit - ?counter - ?storage_limit - (B infos.block) - source - (Some (get_pkh source)) - -let mk_origination ?counter ?fee ?gas_limit ?storage_limit ?force_reveal ~source - (infos : infos) = + ?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 infos.accounts.source) + (Some infos.accounts.source.pkh) + +let mk_origination (oinfos : operation_req) (infos : infos) = let open Lwt_result_syntax in let+ op, _ = Op.contract_origination - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit + ?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.block) - source + (B infos.ctxt.block) + (contract_of infos.accounts.source) in op -let mk_register_global_constant ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = +let mk_register_global_constant (oinfos : operation_req) (infos : infos) = Op.register_global_constant - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - (B infos.block) - ~source + ?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 infos.accounts.source) ~value:(Script_repr.lazy_expr (Expr.from_string "Pair 1 2")) -let mk_set_deposits_limit ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = +let mk_set_deposits_limit (oinfos : operation_req) (infos : infos) = Op.set_deposits_limit - ?force_reveal - ?fee - ?gas_limit - ?storage_limit - ?counter - (B infos.block) - source + ?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 infos.accounts.source) None -let mk_increase_paid_storage ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = +let mk_increase_paid_storage (oinfos : operation_req) (infos : infos) = Op.increase_paid_storage - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - (B infos.block) - ~source - ~destination:infos.contract_hash + ?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 infos.accounts.source) + ~destination:infos.ctxt.originated_contract Z.one -let mk_reveal ?counter ?fee ?gas_limit ?storage_limit ?force_reveal:_ ~source - (infos : infos) = +let mk_reveal (oinfos : operation_req) (infos : infos) = let open Lwt_result_syntax in - let* pk = get_pk (B infos.block) source in - Op.revelation ?fee ?gas_limit ?counter ?storage_limit (B infos.block) pk + let* pk = get_pk (B infos.ctxt.block) (contract_of infos.accounts.source) 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 mk_tx_rollup_origination ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = +let mk_tx_rollup_origination (oinfos : operation_req) (infos : infos) = let open Lwt_result_syntax in let+ op, _rollup = Op.tx_rollup_origination - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source + ?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 infos.accounts.source) in op -let mk_tx_rollup_submit_batch ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = +let tx_rollup_of = function + | Some tx_rollup -> return tx_rollup + | None -> failwith "Tx_rollup not created in this context" + +let sc_rollup_of = function + | Some sc_rollup -> return sc_rollup + | None -> failwith "Sc_rollup not created in this context" + +let mk_tx_rollup_submit_batch (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in Op.tx_rollup_submit_batch - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup + ?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 infos.accounts.source) + tx_rollup "batch" -let mk_tx_rollup_commit ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = +let mk_tx_rollup_commit (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in let commitement : Tx_rollup_commitment.Full.t = { level = Tx_rollup_level.root; @@ -387,54 +521,58 @@ let mk_tx_rollup_commit ?counter ?fee ?gas_limit ?storage_limit ?force_reveal } in Op.tx_rollup_commit - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup + ?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 infos.accounts.source) + tx_rollup commitement -let mk_tx_rollup_return_bond ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = +let mk_tx_rollup_return_bond (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in Op.tx_rollup_return_bond - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - -let mk_tx_rollup_finalize ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = + ?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 infos.accounts.source) + tx_rollup + +let mk_tx_rollup_finalize (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in Op.tx_rollup_finalize - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - -let mk_tx_rollup_remove_commitment ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = + ?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 infos.accounts.source) + tx_rollup + +let mk_tx_rollup_remove_commitment (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in Op.tx_rollup_remove_commitment - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - -let mk_tx_rollup_reject ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = + ?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 infos.accounts.source) + tx_rollup + +let mk_tx_rollup_reject (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in let message, _ = Tx_rollup_message.make_batch "" in let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in let message_path = @@ -457,14 +595,14 @@ let mk_tx_rollup_reject ?counter ?fee ?gas_limit ?storage_limit ?force_reveal } in Op.tx_rollup_reject - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup + ?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 infos.accounts.source) + tx_rollup Tx_rollup_level.root message ~message_position:0 @@ -475,62 +613,76 @@ let mk_tx_rollup_reject ?counter ?fee ?gas_limit ?storage_limit ?force_reveal ~previous_message_result ~previous_message_result_path:Tx_rollup_commitment.Merkle.dummy_path -let mk_transfer_ticket ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = +let mk_transfer_ticket (oinfos : operation_req) (infos : infos) = Op.transfer_ticket - ?fee - ?force_reveal - ?counter - ?gas_limit - ?storage_limit - (B infos.block) - ~source + ?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 infos.accounts.source) ~contents:(Script.lazy_expr (Expr.from_string "1")) ~ty:(Script.lazy_expr (Expr.from_string "nat")) - ~ticketer:infos.contract3 + ~ticketer: + (contract_of + (match infos.accounts.tx with + | None -> infos.accounts.source + | Some tx -> tx)) Z.zero - ~destination:infos.contract2 + ~destination: + (contract_of + (match infos.accounts.dest with + | None -> infos.accounts.source + | Some dest -> dest)) Entrypoint.default -let mk_tx_rollup_dispacth_ticket ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = +let mk_tx_rollup_dispacth_ticket (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in let reveal = Tx_rollup_reveal. { contents = Script.lazy_expr (Expr.from_string "1"); ty = Script.lazy_expr (Expr.from_string "nat"); - ticketer = infos.contract2; + ticketer = + contract_of + (match infos.accounts.dest with + | None -> infos.accounts.source + | Some dest -> dest); amount = Tx_rollup_l2_qty.of_int64_exn 10L; - claimer = infos.account3.pkh; + claimer = + (match infos.accounts.dest with + | None -> infos.accounts.source.pkh + | Some dest -> dest.pkh); } in Op.tx_rollup_dispatch_tickets - ?fee - ?force_reveal - ?counter - ?gas_limit - ?storage_limit - (B infos.block) - ~source + ?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 infos.accounts.source) ~message_index:0 ~message_result_path:Tx_rollup_commitment.Merkle.dummy_path - infos.tx_rollup + tx_rollup Tx_rollup_level.root Context_hash.zero [reveal] -let mk_sc_rollup_origination ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = +let mk_sc_rollup_origination (oinfos : operation_req) (infos : infos) = let open Lwt_result_syntax in let+ op, _ = Op.sc_rollup_origination - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source + ?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 infos.accounts.source) Sc_rollup.Kind.Example_arith "" (Script.lazy_expr (Expr.from_string "1")) @@ -557,107 +709,120 @@ let sc_dummy_commitment = compressed_state = Sc_rollup.State_hash.zero; } -let mk_sc_rollup_publish ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = +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 - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup + ?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 infos.accounts.source) + sc_rollup sc_dummy_commitment -let mk_sc_rollup_cement ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = +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 - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup + ?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 infos.accounts.source) + sc_rollup (Sc_rollup.Commitment.hash sc_dummy_commitment) -let mk_sc_rollup_refute ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = +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 = {choice = Sc_rollup.Tick.initial; step = Dissection []} in Op.sc_rollup_refute - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - infos.account2.pkh + ?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 infos.accounts.source) + sc_rollup + (match infos.accounts.dest with + | None -> infos.accounts.source.pkh + | Some dest -> dest.pkh) refutation false -let mk_sc_rollup_add_messages ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = +let mk_sc_rollup_add_messages (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_add_messages - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup + ?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 infos.accounts.source) + sc_rollup [""] -let mk_sc_rollup_timeout ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : 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 - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - (Sc_rollup.Game.Index.make infos.account2.pkh infos.account3.pkh) - -let mk_sc_rollup_execute_outbox_message ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = + ?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 infos.accounts.source) + sc_rollup + (Sc_rollup.Game.Index.make + infos.accounts.source.pkh + (match infos.accounts.dest with + | None -> infos.accounts.source.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 - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup + ?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 infos.accounts.source) + sc_rollup (Sc_rollup.Commitment.hash sc_dummy_commitment) ~outbox_level:(Raw_level.of_int32_exn 0l) ~message_index:0 ~inclusion_proof:"xyz" ~message:"xyz" -let mk_sc_rollup_return_bond ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = +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 Op.sc_rollup_recover_bond - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - -let mk_dal_publish_slot_header ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = + ?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 infos.accounts.source) + sc_rollup + +let mk_dal_publish_slot_header (oinfos : operation_req) (infos : infos) = let open Lwt_result_syntax in let level = 0 in let index = 0 in @@ -675,79 +840,16 @@ let mk_dal_publish_slot_header ?counter ?fee ?gas_limit ?storage_limit in let slot = Data_encoding.Json.destruct Dal.Slot.encoding json_slot in Op.dal_publish_slot_header - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source + ?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 infos.accounts.source) slot -(** {2 Helpers for generation of generic check tests by manager operation.} *) - -(** 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_Increase_paid_storage - | K_Reveal - | K_Tx_rollup_origination - | K_Tx_rollup_submit_batch - | K_Tx_rollup_commit - | K_Tx_rollup_return_bond - | K_Tx_rollup_finalize - | K_Tx_rollup_remove_commitment - | K_Tx_rollup_dispatch_tickets - | K_Transfer_ticket - | K_Tx_rollup_reject - | 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 - -let select_op = function - | 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_Increase_paid_storage -> mk_increase_paid_storage - | K_Reveal -> mk_reveal - | K_Tx_rollup_origination -> mk_tx_rollup_origination - | K_Tx_rollup_submit_batch -> mk_tx_rollup_submit_batch - | K_Tx_rollup_commit -> mk_tx_rollup_commit - | K_Tx_rollup_return_bond -> mk_tx_rollup_return_bond - | K_Tx_rollup_finalize -> mk_tx_rollup_finalize - | K_Tx_rollup_remove_commitment -> mk_tx_rollup_remove_commitment - | K_Tx_rollup_reject -> mk_tx_rollup_reject - | K_Transfer_ticket -> mk_transfer_ticket - | K_Tx_rollup_dispatch_tickets -> mk_tx_rollup_dispacth_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 +(** {2 Helpers for generation of generic check tests by manager operation} *) let kind_to_string = function | K_Transaction -> "Transaction" @@ -778,6 +880,41 @@ let kind_to_string = function | K_Sc_rollup_recover_bond -> "Sc_rollup_recover_bond" | K_Dal_publish_slot_header -> "Dal_publish_slot_header" +(** 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_Reveal -> mk_reveal + | K_Increase_paid_storage -> mk_increase_paid_storage + | K_Tx_rollup_origination -> mk_tx_rollup_origination + | K_Tx_rollup_submit_batch -> mk_tx_rollup_submit_batch + | K_Tx_rollup_commit -> mk_tx_rollup_commit + | K_Tx_rollup_return_bond -> mk_tx_rollup_return_bond + | K_Tx_rollup_finalize -> mk_tx_rollup_finalize + | K_Tx_rollup_remove_commitment -> mk_tx_rollup_remove_commitment + | K_Tx_rollup_reject -> mk_tx_rollup_reject + | K_Transfer_ticket -> mk_transfer_ticket + | K_Tx_rollup_dispatch_tickets -> mk_tx_rollup_dispacth_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 + in + mk_op op_req infos + let create_Tztest ?hd_msg test tests_msg operations = let hd_msg k = let sk = kind_to_string k in @@ -805,13 +942,14 @@ let rec create_Tztest_batches test tests_msg operations = (** {2 Diagnostic helpers.} *) -(** The purpose of diagnostic helpers is to state the correct observation - according to the validate result of a test. *) +(** 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. *) +(** 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; @@ -842,23 +980,93 @@ let manager_content_infos op = | Cons (Manager_operation _, _) as op -> contents_infos op | _ -> failwith "Should only handle manager operation" -(** [observe] asserts the success of validate only. - Given on one side, a [contract], its initial balance [b_in], its initial - counter [c_in] and potentially the initial gas [g_in] before its validation; - and, on the other side, its [probes] and the context after its validate [i]; - if validate succeeds then we observe in [i] that: - - [contract] balance decreases by [probes.fee] when [only_validate] marks that only the validate - succeeds - - [contract] balance decreases at least by [probes.fee] when [not only_validate] marks - that the application has succeeded, - - its counter [c_in] increases by [probes.nb_counter], and - - the available gas in the block in [i] decreases by [g_in].*) -let observe ~only_validate ~mode contract b_in c_in g_in probes i = - let open Lwt_result_syntax in - let* b_out = Context.Contract.balance (I i) contract in - let g_out = Gas.block_level (Incremental.alpha_ctxt i) in - let* c_out = Context.Contract.counter (I i) contract in +(** 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 + (b_in, c_in, g_in) + +(** According to the witness in pre-state and the probes, computes the + expected outputs. In any mode 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 = Z.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 + (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). 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 then we observe in the + post-state: + + The balance of source decreases by the fee of probes when + [only_validate] marks that only the validate succeeds. + + The balance of source decreases at least by fee of probes when + [not only_validate] marks that 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 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 ~only_validate ~mode ctxt_pre ctxt_post op = + let open Lwt_result_syntax in + let* probes = manager_content_infos op in + let contract = Contract.Implicit probes.source in + 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__ @@ -867,7 +1075,6 @@ let observe ~only_validate ~mode contract b_in c_in g_in probes i = Tez.pp in let* _ = b_cmp b_out b_expected in - let c_expected = Z.add c_in probes.nb_counter in let _ = Assert.equal Z.equal @@ -877,63 +1084,137 @@ let observe ~only_validate ~mode contract b_in c_in g_in probes i = c_out c_expected in - let* g_expected = - match mode with - | Validate_operation.Block -> - return (Gas.Arith.sub g_in (Gas.Arith.fp probes.gas_limit)) - | Validate_operation.Mempool -> - Context.get_constants (I i) >>=? fun c -> - return - (Gas.Arith.sub - (Gas.Arith.fp c.parametric.hard_gas_limit_per_block) - (Gas.Arith.fp probes.gas_limit)) - in let g_msg = match mode with - | Validate_operation.Block -> "Gas consumption (block)" - | Validate_operation.Mempool -> "Gas consumption (mempool)" - in - Assert.equal ~loc:__LOC__ Gas.Arith.equal g_msg Gas.Arith.pp g_out g_expected - -let validate_with_diagnostic ~only_validate (infos : infos) op = - let open Lwt_result_syntax in - let* i = Incremental.begin_construction infos.block in - let* prbs = manager_content_infos op in - let contract = Contract.Implicit prbs.source in - let* b_in = Context.Contract.balance (I i) contract in - let* c_in = Context.Contract.counter (I i) contract in - let g_in = Gas.block_level (Incremental.alpha_ctxt i) in - let* i = Incremental.validate_operation i op in - let* _ = Incremental.finalize_block i in - let mode = Validate_operation.Block in - observe ~only_validate ~mode contract b_in c_in g_in prbs i - -(** If only the validate of an operation succeed; e.g. the rest - of the application failed: - - the fees must be paid, - - the block gas consumption should be decreased, and - - the counter of operation should be incremented - as defined by [observe] with [only_validate]. *) -let only_validate_diagnostic (infos : infos) op = - validate_with_diagnostic ~only_validate:true infos op - -(** If an manager operation application succeed, the validate - effects must be observed: - - the fees must be paid, - - the block gas consumption should be decreased, and - - the counter of operation should be incremented - as defined by [observe] with [not only_validate]. *) -let validate_diagnostic (infos : infos) op = - validate_with_diagnostic ~only_validate:false infos op - -(** [validate_ko_diagnostic] wraps the [expect_failure] when [op] validate - failed. It is used in test that expects validate [op] to fail. *) -let validate_ko_diagnostic ?(mempool_mode = false) (infos : infos) op + | 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.equal + g_msg + Gas.Arith.pp + g_out + g_expected + +let observe_list ~only_validate ~mode ctxt_pre ctxt_post ops = + List.iter + (fun op -> + let _ = observe ~only_validate ~mode ctxt_pre ctxt_post op in + ()) + ops + +let validate_operations inc_in ops = + let open Lwt_result_syntax in + List.fold_left_es + (fun inc op -> + let* inc_out = Incremental.validate_operation 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 + 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 ~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 inc_pre ops in + let+ block = Incremental.finalize_block inc_post in + (Context.I inc_post, {infos with ctxt = {infos.ctxt with block}}) + | Application, Context.B b -> + let+ block = Block.bake ~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 only_validate status for each operation. + + See [observe] for more details on the observational validation. *) +let validate_with_diagnostic ~only_validate ~mode (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 ~only_validate ~mode ctxt_pre ctxt_post ops in + return infos + +(** If only the operation validation succeeds; e.g. the rest of the + application failed then [only_validate] must be set for the + observation validation. + + Default mode is [Construction]. See [observe] for more details. *) +let only_validate_diagnostic ?(mode = Construction) (infos : infos) ops = + validate_with_diagnostic ~only_validate:true ~mode infos ops + +(** If the whole operation application succeeds; e.g. the fee + payment and the full application succeed then [not only_validate] + must be set. + + Default mode is [Construction]. *) +let validate_diagnostic ?(mode = Construction) (infos : infos) ops = + validate_with_diagnostic ~only_validate:false ~mode infos ops + +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 - let* i = Incremental.begin_construction infos.block ~mempool_mode in - let* _ = Incremental.add_operation ~expect_failure i op in - return_unit + match mode with + | Construction | Mempool -> + let* i = + Incremental.begin_construction + infos.ctxt.block + ~mempool_mode:(mempool_mode_of mode) + in + let* _ = add_operations ~expect_failure i ops in + return_unit + | Application -> ( + let*! res = + Block.bake ~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 kind that must run on generic tests. This list should be extended for each new manager_operation kind. *) diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml index ef15beabe732..943e8f554b96 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml @@ -40,67 +40,82 @@ open Manager_operation_helpers let create_Tztest ?hd_msg test tests_msg = let hd_msg k = let sk = kind_to_string k in - match hd_msg with - | None -> sk - | Some hd -> Format.sprintf "Batch: %s, %s" hd sk + match hd_msg with None -> sk | Some hd -> Format.sprintf "%s, %s" sk hd in let kind = K_Register_global_constant in Tztest.tztest - (Format.sprintf "%s: %s" (hd_msg kind) tests_msg) + (Format.sprintf "%s [%s]" tests_msg (hd_msg kind)) `Quick (fun () -> test kind ()) let generate_op ~fee ~reverse:_ kind infos = let open Lwt_result_syntax in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let source = infos.contract1 in + let* counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in let* operation = - select_op ~fee ~counter ~force_reveal:true ~source kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + fee = Some fee; + counter = Some counter; + } + infos in - let counter = Z.succ (Z.succ counter) in let+ operation2 = - select_op ~fee ~counter ~force_reveal:false ~source kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some false; + fee = Some fee; + counter = Some (Z.succ (Z.succ counter)); + } + infos in (operation, operation2) let generate_op_diff_man ~fee ~reverse:_ kind infos = let open Lwt_result_syntax in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let source = infos.contract1 in + let source = contract_of infos.accounts.source in + let source2_account = + match infos.accounts.del with None -> assert false | Some s -> s + in + let source2 = contract_of source2_account in + let* counter = Context.Contract.counter (B infos.ctxt.block) source in let* operation = - select_op ~fee ~counter ~force_reveal:true ~source kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + fee = Some fee; + counter = Some counter; + } + infos in - let* counter = Context.Contract.counter (B infos.block) infos.contract2 in - let source = infos.contract2 in + let* counter = Context.Contract.counter (B infos.ctxt.block) source2 in let+ operation2 = - select_op ~fee ~counter ~force_reveal:true ~source kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + fee = Some fee; + counter = Some counter; + } + {infos with accounts = {infos.accounts with source = source2_account}} in (operation, operation2) -(* Helpers that should be included or replace existing helpers for - validate tests.*) -let witness inc source = - let open Lwt_result_syntax in - let* b_in = Context.Contract.balance (I inc) source in - let+ c_in = Context.Contract.counter (I inc) source in - let g_in = Gas.block_level (Incremental.alpha_ctxt inc) in - (b_in, c_in, g_in) - -let observe ~mode inc_pre inc_post op = - let open Lwt_result_syntax in - let* prbs = manager_content_infos op in - let source = Contract.Implicit prbs.source in - let* b_in, c_in, g_in = witness inc_pre source in - observe ~only_validate:false ~mode source b_in c_in g_in prbs inc_post - (** 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 test_two_op_with_same_manager ~mempool_mode kind () = let open Lwt_result_syntax in - let* infos = init_context () in + let* infos = default_init_ctxt () in let* op1, op2 = generate_op ~fee:Tez.zero ~reverse:false kind infos in - let* inc = Incremental.begin_construction ~mempool_mode infos.block in + let* inc = Incremental.begin_construction ~mempool_mode infos.ctxt.block in let* inc = Incremental.validate_operation inc op1 in let* _inc = Incremental.validate_operation @@ -126,20 +141,16 @@ let test_two_op_with_same_manager ~mempool_mode kind () = by two single operations. *) let test_batch_of_two_not_be_two_singles ~mempool_mode kind () = let open Lwt_result_syntax in - let mode = - if mempool_mode then Validate_operation.Mempool - else Validate_operation.Block - in - let* infos = init_context () in - let* inc = Incremental.begin_construction ~mempool_mode infos.block in + let mode = if mempool_mode then Mempool else Construction in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source in + let* inc = Incremental.begin_construction ~mempool_mode infos.ctxt.block in let* op1, op2 = generate_op ~fee:Tez.one_mutez ~reverse:false kind infos in - let* batch = - Op.batch_operations ~source:infos.contract1 (B infos.block) [op1; op2] - in + let* batch = Op.batch_operations ~source (B infos.ctxt.block) [op1; op2] in let* inc_batch = Incremental.validate_operation inc batch in - let* () = observe ~mode inc inc_batch batch in + let* () = observe ~only_validate:false ~mode (I inc) (I inc_batch) batch in let* inc1 = Incremental.validate_operation inc op1 in - let* () = observe ~mode inc inc1 op1 in + let* () = observe ~only_validate:false ~mode (I inc) (I inc1) op1 in let* _inc2 = Incremental.validate_operation ~expect_failure:(fun _ -> return_unit) @@ -149,15 +160,15 @@ let test_batch_of_two_not_be_two_singles ~mempool_mode kind () = let* b1 = Incremental.finalize_block inc1 in let* inc1' = Incremental.begin_construction ~mempool_mode b1 in let* inc1_op2 = Incremental.validate_operation inc1' op2 in - let* () = observe ~mode inc1' inc1_op2 op2 in + let* () = observe ~only_validate:false ~mode (I inc1') (I inc1_op2) op2 in return_unit (** The application of a valid operation succeeds, at least, to perform the fee payment. *) let valid_validate ~mempool_mode kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let* inc = Incremental.begin_construction ~mempool_mode infos.block in + let* infos = default_init_ctxt () in + let* inc = Incremental.begin_construction ~mempool_mode infos.ctxt.block in let* op, _ = generate_op ~fee:Tez.one_mutez ~reverse:false kind infos in let {shell; protocol_data = Operation_data protocol_data} = op in let operation : _ Alpha_context.operation = {shell; protocol_data} in @@ -188,12 +199,10 @@ let valid_validate ~mempool_mode kind () = [generate_op_diff_man]. *) let valid_context_free ~mempool_mode kind () = let open Lwt_result_syntax in - let mode = - if mempool_mode then Validate_operation.Mempool - else Validate_operation.Block - in - let* infos = init_context () in - let* inc = Incremental.begin_construction ~mempool_mode infos.block in + let mode = if mempool_mode then Mempool else Construction in + + let* infos = default_init_ctxt () in + let* inc = Incremental.begin_construction ~mempool_mode infos.ctxt.block in let* op1, op2 = generate_op_diff_man ~fee:Tez.one_mutez ~reverse:false kind infos in @@ -230,63 +239,63 @@ let valid_context_free ~mempool_mode kind () = Lwt.return (Environment.wrap_tzresult res) in let* inc1 = Incremental.validate_operation inc op1 in - let* () = observe ~mode inc inc1 op1 in + let* () = observe ~only_validate:false ~mode (I inc) (I inc1) op1 in let* inc1' = Incremental.validate_operation inc1 op2 in - let* () = observe ~mode inc1 inc1' op2 in + let* () = observe ~only_validate:false ~mode (I inc1) (I inc1') op2 in let* inc2 = Incremental.validate_operation inc op2 in - let* () = observe ~mode inc inc2 op2 in + let* () = observe ~only_validate:false ~mode (I inc) (I inc2) op2 in let* inc2' = Incremental.validate_operation inc2 op1 in - let* () = observe ~mode inc2 inc2' op1 in + let* () = observe ~only_validate:false ~mode (I inc2) (I inc2') op1 in return_unit let generate_1m_conflit_mempool_mode () = create_Tztest (test_two_op_with_same_manager ~mempool_mode:true) - "1M restriction fails in mempool mode" + "At most one operation per manager in mempool mode" let generate_1m_conflit_construction_mode () = create_Tztest (test_two_op_with_same_manager ~mempool_mode:false) - "1M restriction fails in construction mode" + "At most one operation per manager in construction mode" let generate_batch_of_two_not_be_two_singles_construction_mode () = create_Tztest (test_batch_of_two_not_be_two_singles ~mempool_mode:false) - "1M restriction fails in construction mode" + "A batch differs from a sequence in construction mode" let generate_batch_of_two_not_be_two_singles_mempool_mode () = create_Tztest (test_batch_of_two_not_be_two_singles ~mempool_mode:true) - "1M restriction fails in mempool mode" + "A batch differs from a sequence in mempool mode" -let generate_valid_precheck_mempool_mode () = +let generate_valid_validate_mempool_mode () = create_Tztest (valid_validate ~mempool_mode:true) - "valid so fee payment in mempool mode" + "Valid implies fee payment in mempool mode" -let generate_valid_precheck_construction_mode () = +let generate_valid_validate_construction_mode () = create_Tztest (valid_validate ~mempool_mode:false) - "valid so fee payment in construction mode" + "Valid implies fee payment in construction mode" let generate_valid_context_free_mempool_mode () = create_Tztest (valid_context_free ~mempool_mode:true) - "two covalid so both pay fees commute under 1M in mempool mode" + "Fee payment of two covalid operations commute in mempool mode" let generate_valid_context_free_construction_mode () = create_Tztest (valid_context_free ~mempool_mode:false) - "two covalid so both pay fees commute under 1M in construction mode" + "Fee payment of two covalid operations commute in construction mode" let tests = [ generate_1m_conflit_construction_mode (); generate_batch_of_two_not_be_two_singles_construction_mode (); - generate_valid_precheck_construction_mode (); + generate_valid_validate_construction_mode (); generate_valid_context_free_construction_mode (); generate_1m_conflit_mempool_mode (); generate_batch_of_two_not_be_two_singles_mempool_mode (); - generate_valid_precheck_mempool_mode (); + generate_valid_validate_mempool_mode (); generate_valid_context_free_mempool_mode (); ] diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml index 90dc2a88fdac..12f3dc3df4db 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml @@ -58,28 +58,50 @@ let batch_reveal_in_the_middle_diagnostic (infos : infos) op = let test_batch_reveal_in_the_middle kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let counter = counter in - let fee = Tez.one_mutez in + let* infos = default_init_ctxt () in + let* counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in let counter = Z.succ counter in let* operation1 = - select_op ~counter ~force_reveal:false ~source:infos.contract1 kind1 infos + select_op + { + (operation_req_default kind1) with + force_reveal = Some false; + counter = Some counter; + } + infos in let counter = Z.succ counter in - let* reveal = mk_reveal ~fee ~counter ~source:infos.contract1 infos in + let* reveal = + mk_reveal + { + (operation_req_default K_Reveal) with + fee = Some Tez.one_mutez; + counter = Some counter; + } + infos + in let counter = Z.succ counter in let* operation2 = - select_op ~counter ~force_reveal:false ~source:infos.contract1 kind2 infos + 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:infos.contract1 - (Context.B infos.block) + ~source:(contract_of infos.accounts.source) + (Context.B infos.ctxt.block) [operation1; reveal; operation2] in - batch_reveal_in_the_middle_diagnostic infos batch + batch_reveal_in_the_middle_diagnostic infos [batch] let generate_batches_reveal_in_the_middle () = create_Tztest_batches @@ -106,26 +128,50 @@ let batch_two_reveals_diagnostic (infos : infos) op = let test_batch_two_reveals kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let counter = counter in - let fee = Tez.one_mutez in + let* infos = default_init_ctxt () in + let* counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in let counter = Z.succ counter in - let* reveal = mk_reveal ~fee ~counter ~source:infos.contract1 infos in + let* reveal = + mk_reveal + { + (operation_req_default K_Reveal) with + fee = Some Tez.one_mutez; + counter = Some counter; + } + infos + in let counter = Z.succ counter in - let* reveal1 = mk_reveal ~fee ~counter ~source:infos.contract1 infos in + let* reveal1 = + mk_reveal + { + (operation_req_default K_Reveal) with + fee = Some Tez.one_mutez; + counter = Some counter; + } + infos + in let counter = Z.succ counter in let* operation = - select_op ~counter ~force_reveal:false ~source:infos.contract1 kind infos + 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:infos.contract1 - (Context.B infos.block) + ~source:(contract_of infos.accounts.source) + (Context.B infos.ctxt.block) [reveal; reveal1; operation] in - batch_two_reveals_diagnostic infos batch + batch_two_reveals_diagnostic infos [batch] let generate_tests_batches_two_reveals () = create_Tztest @@ -151,23 +197,38 @@ let batch_two_sources_diagnostic (infos : infos) op = let test_batch_two_sources kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source in + let* counter = Context.Contract.counter (B infos.ctxt.block) source in let counter = Z.succ counter in let* operation1 = - select_op ~counter ~force_reveal:true ~source:infos.contract1 kind1 infos + 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 source = source2}} in let* operation2 = - select_op ~force_reveal:false ~source:infos.contract2 kind2 infos + select_op + {(operation_req_default kind2) with force_reveal = Some false} + infos in let* batch = Op.batch_operations ~recompute_counters:false - ~source:infos.contract1 - (Context.B infos.block) + ~source + (Context.B infos.ctxt.block) [operation1; operation2] in - batch_two_sources_diagnostic infos batch + batch_two_sources_diagnostic infos [batch] let generate_batches_two_sources () = create_Tztest_batches @@ -179,17 +240,25 @@ let generate_batches_two_sources () = the stored counter associated to source in the initial context. *) let test_batch_inconsistent_counters kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let fee = Tez.one_mutez in - let* reveal = mk_reveal ~fee ~counter ~source:infos.contract1 infos in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source 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 = Z.succ counter in let counter2 = Z.succ counter in let counter3 = Z.succ counter2 in - let source = infos.contract1 in let operation counter kind = - select_op ~counter ~force_reveal:false ~source kind infos + 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 @@ -201,7 +270,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op1; op2] in let* op1 = op_counter2 kind1 in @@ -210,7 +279,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op1; op2] in let* op1 = op_counter kind1 in @@ -219,7 +288,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op1; op2] in let* op1 = op_counter2 kind1 in @@ -228,7 +297,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op1; op2] in let* op1 = op_counter0 kind1 in @@ -237,7 +306,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op1; op2] in let expect_failure errs = @@ -252,7 +321,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Error_monad.pp_print_trace err in - let* i = Incremental.begin_construction infos.block in + let* i = Incremental.begin_construction infos.ctxt.block in let* _ = Incremental.add_operation ~expect_failure i batch_same in let* _ = Incremental.add_operation ~expect_failure i batch_in_the_future in let* _ = Incremental.add_operation ~expect_failure i batch_missing_one in @@ -270,19 +339,37 @@ let generate_batches_inconsistent_counters () = consumption at the end of the batch. *) let test_batch_emptying_balance_in_the_middle kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let* init_bal = Context.Contract.balance (B infos.block) infos.contract1 in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source 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 source = infos.contract1 in - let* reveal = mk_reveal ~counter ~source infos in + let* reveal = + mk_reveal + {(operation_req_default K_Reveal) with counter = Some counter} + infos + in let counter = Z.succ counter in let operation fee = - select_op ~fee ~counter ~force_reveal:false ~source kind1 infos + select_op + { + (operation_req_default kind1) with + force_reveal = Some false; + counter = Some counter; + fee = Some fee; + } + infos in let counter = Z.succ counter in let operation2 fee = - select_op ~fee ~counter ~force_reveal:false ~source kind2 infos + 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 @@ -290,10 +377,10 @@ let test_batch_emptying_balance_in_the_middle kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case1; op2_case1] in - let* i = Incremental.begin_construction infos.block 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 _)] @@ -317,33 +404,41 @@ let generate_batches_emptying_balance_in_the_middle () = (** A batch of manager operation must not exceed the initial available gas in the block. *) let test_batch_exceeding_block_gas ~mempool_mode kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context ~hard_gas_limit_per_block:gb_limit () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in + let ctxt_req = + {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} + in + let* infos = init_ctxt ctxt_req in + let source = contract_of infos.accounts.source 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 counter = counter in - let source = infos.contract1 in - let* reveal = mk_reveal ~counter ~source infos in + let* reveal = + mk_reveal + {(operation_req_default K_Reveal) with counter = Some counter} + infos + in let counter = Z.succ counter in let operation gas_limit = select_op - ~gas_limit:(Custom_gas gas_limit) - ~counter - ~force_reveal:false - ~source - kind1 + { + (operation_req_default kind1) with + force_reveal = Some false; + counter = Some counter; + gas_limit = Some (Custom_gas gas_limit); + } infos in let counter = Z.succ counter in let operation2 gas_limit = select_op - ~gas_limit:(Custom_gas gas_limit) - ~counter - ~force_reveal:false - ~source - kind2 + { + (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 @@ -356,24 +451,24 @@ let test_batch_exceeding_block_gas ~mempool_mode kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case1; op2_case1] in let* case3 = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case3; op2_case3] in let* case2 = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case2; op2_case2] in - let* i = Incremental.begin_construction infos.block ~mempool_mode 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] @@ -412,20 +507,37 @@ let generate_batches_exceeding_block_gas_mp_mode () = the batch passes validate.*) let test_batch_balance_just_enough kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let* init_bal = Context.Contract.balance (B infos.block) infos.contract1 in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source 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 counter = counter in - let source = infos.contract1 in - let* reveal = mk_reveal ~counter ~source infos in + let* reveal = + mk_reveal + {(operation_req_default K_Reveal) with counter = Some counter} + infos + in let counter = Z.succ counter in let operation fee = - select_op ~fee ~counter ~force_reveal:false ~source kind1 infos + select_op + { + (operation_req_default kind1) with + force_reveal = Some false; + counter = Some counter; + fee = Some fee; + } + infos in let counter = Z.succ counter in let operation2 fee = - select_op ~fee ~counter ~force_reveal:false ~source kind2 infos + 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 @@ -435,18 +547,19 @@ let test_batch_balance_just_enough kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case3; op2_case3] in let* case2 = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case2; op2_case2] in - let* _ = validate_diagnostic infos case2 in - validate_diagnostic infos case3 + let* _ = validate_diagnostic infos [case2] in + let* _ = validate_diagnostic infos [case3] in + return_unit let generate_batches_balance_just_enough () = create_Tztest_batches @@ -457,25 +570,40 @@ let generate_batches_balance_just_enough () = (** Simple reveal followed by a transaction. *) let test_batch_reveal_transaction_ok () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source in + let* counter = Context.Contract.counter (B infos.ctxt.block) source in let counter = counter in let fee = Tez.one_mutez in - let source = infos.contract1 in - let* reveal = mk_reveal ~fee ~counter ~source infos in + let* reveal = + mk_reveal + { + (operation_req_default K_Reveal) with + fee = Some fee; + counter = Some counter; + } + infos + in let counter = Z.succ counter in let* transaction = - mk_transaction ~counter ~force_reveal:false ~source infos + 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.block) + (Context.B infos.ctxt.block) [reveal; transaction] in - let* _i = Incremental.begin_construction infos.block in - validate_diagnostic infos batch + let* _i = Incremental.begin_construction infos.ctxt.block in + let* _ = validate_diagnostic infos [batch] in + return_unit let contract_tests = generate_batches_reveal_in_the_middle () diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml index cef8397931ac..cb821688f6c6 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml @@ -48,7 +48,11 @@ open Manager_operation_helpers operation kind. *) let ensure_kind infos kind = let open Lwt_result_syntax in - let* op = select_op kind infos ~force_reveal:false ~source:infos.contract1 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; _}) -> ( @@ -99,7 +103,7 @@ let ensure_kind infos kind = let ensure_manager_operation_coverage () = let open Lwt_result_syntax in - let* infos = init_context () in + let* infos = default_init_ctxt () in List.iter_es (fun kind -> ensure_kind infos kind) subjects let test_ensure_manager_operation_coverage () = @@ -136,12 +140,17 @@ let low_gas_limit_diagnostic (infos : infos) op = let test_low_gas_limit kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let gas_limit = Op.Low in + let* infos = default_init_ctxt () in let* op = - select_op ~gas_limit ~force_reveal:true ~source:infos.contract1 kind infos + select_op + { + (operation_req_default kind) with + gas_limit = Some Op.Low; + force_reveal = Some true; + } + infos in - low_gas_limit_diagnostic infos op + low_gas_limit_diagnostic infos [op] let generate_low_gas_limit () = create_Tztest @@ -168,12 +177,18 @@ let high_gas_limit_diagnostic (infos : infos) op = let test_high_gas_limit kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let gas_limit = Op.Custom_gas (Gas.Arith.integral_of_int_exn 10_000_000) in + let* infos = default_init_ctxt () in let* op = - select_op ~gas_limit ~force_reveal:true ~source:infos.contract1 kind infos + 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 + high_gas_limit_diagnostic infos [op] let generate_high_gas_limit () = create_Tztest test_high_gas_limit "Gas_limit too high." subjects @@ -198,17 +213,17 @@ let high_storage_limit_diagnostic (infos : infos) op = let test_high_storage_limit kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let storage_limit = Z.of_int max_int in + let* infos = default_init_ctxt () in let* op = select_op - ~storage_limit - ~force_reveal:true - ~source:infos.contract1 - kind + { + (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 + high_storage_limit_diagnostic infos [op] let generate_high_storage_limit () = create_Tztest test_high_gas_limit "Storage_limit too high." subjects @@ -235,12 +250,17 @@ let high_counter_diagnostic (infos : infos) op = let test_high_counter kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let counter = Z.of_int max_int in + let* infos = default_init_ctxt () in let* op = - select_op ~counter ~force_reveal:true ~source:infos.contract1 kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + counter = Some (Z.of_int max_int); + } + infos in - high_counter_diagnostic infos op + high_counter_diagnostic infos [op] let generate_high_counter () = create_Tztest test_high_counter "Counter too high." subjects @@ -267,15 +287,22 @@ let low_counter_diagnostic (infos : infos) op = let test_low_counter kind () = let open Lwt_result_syntax in - let* infos = init_context () in + let* infos = default_init_ctxt () in let* current_counter = - Context.Contract.counter (B infos.block) infos.contract1 + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) in - let counter = Z.sub current_counter Z.one in let* op = - select_op ~counter ~force_reveal:true ~source:infos.contract1 kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + counter = Some (Z.sub current_counter Z.one); + } + infos in - low_counter_diagnostic infos op + low_counter_diagnostic infos [op] let generate_low_counter () = create_Tztest test_low_counter "Counter too low." subjects @@ -302,11 +329,16 @@ let not_allocated_diagnostic (infos : infos) op = let test_not_allocated kind () = let open Lwt_result_syntax in - let* infos = init_context () in + let* infos = default_init_ctxt () in let* op = - select_op ~force_reveal:false ~source:(mk_fresh_contract ()) kind infos + select_op + {(operation_req_default kind) with force_reveal = Some false} + { + infos with + accounts = {infos.accounts with source = Account.(new_account ())}; + } in - not_allocated_diagnostic infos op + not_allocated_diagnostic infos [op] let generate_not_allocated () = create_Tztest test_not_allocated "Not allocated source." subjects @@ -334,9 +366,13 @@ let unrevealed_key_diagnostic (infos : infos) op = let test_unrevealed_key kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let* op = select_op ~force_reveal:false ~source:infos.contract1 kind infos in - unrevealed_key_diagnostic infos op + let* infos = default_init_ctxt () in + let* op = + select_op + {(operation_req_default kind) with force_reveal = Some false} + infos + in + unrevealed_key_diagnostic infos [op] let generate_unrevealed_key () = create_Tztest @@ -367,12 +403,18 @@ let high_fee_diagnostic (infos : infos) op = let test_high_fee kind () = let open Lwt_result_syntax in - let* infos = init_context () in + let* infos = default_init_ctxt () in let*? fee = Tez.(one +? one) |> Environment.wrap_tzresult in let* op = - select_op ~fee ~force_reveal:true ~source:infos.contract1 kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + fee = Some fee; + } + infos in - high_fee_diagnostic infos op + high_fee_diagnostic infos [op] let generate_tests_high_fee () = create_Tztest test_high_fee "Balance too low for fee payment." subjects @@ -403,12 +445,22 @@ let emptying_delegated_implicit_diagnostic (infos : infos) op = let test_emptying_delegated_implicit kind () = let open Lwt_result_syntax in - let* infos = init_delegated_implicit () in - let* fee = Context.Contract.balance (B infos.block) infos.contract1 in + let* infos = default_ctxt_with_delegation () in + let* fee = + Context.Contract.balance + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in let* op = - select_op ~fee ~force_reveal:false ~source:infos.contract1 kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some false; + fee = Some fee; + } + infos in - emptying_delegated_implicit_diagnostic infos op + emptying_delegated_implicit_diagnostic infos [op] let generate_tests_emptying_delegated_implicit () = create_Tztest @@ -423,51 +475,60 @@ let generate_tests_emptying_delegated_implicit () = - [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 ~mempool_mode (infos : infos) op = +let exceeding_block_gas_diagnostic ~mode (infos : infos) op = let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Gas.Block_quota_exceeded] - when not mempool_mode -> + 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; - ] - when mempool_mode -> + | ( [ + 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 -> + | 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 ~mempool_mode + validate_ko_diagnostic infos op expect_failure ~mode -let test_exceeding_block_gas ~mempool_mode kind () = +let test_exceeding_block_gas ~mode kind () = let open Lwt_result_syntax in - let* infos = init_context ~hard_gas_limit_per_block:gb_limit () in - let gas_limit = - Op.Custom_gas (Gas.Arith.add gb_limit Gas.Arith.(integral_of_int_exn 1)) + let ctxt_req = + {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} in + let* infos = init_ctxt ctxt_req in let* operation = - select_op ~force_reveal:true ~source:infos.contract1 ~gas_limit kind infos + 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 ~mempool_mode infos operation + exceeding_block_gas_diagnostic ~mode infos [operation] let generate_tests_exceeding_block_gas () = create_Tztest - (test_exceeding_block_gas ~mempool_mode:false) + (test_exceeding_block_gas ~mode:Construction) "Too much gas consumption." subjects let generate_tests_exceeding_block_gas_mp_mode () = create_Tztest - (test_exceeding_block_gas ~mempool_mode:true) + (test_exceeding_block_gas ~mode:Mempool) "Too much gas consumption in mempool mode." subjects @@ -499,12 +560,23 @@ let generate_tests_exceeding_block_gas_mp_mode () = (** Fee payment that emptying a self_delegated implicit. *) let test_emptying_self_delegated_implicit kind () = let open Lwt_result_syntax in - let* infos = init_self_delegated_implicit () in - let* fee = Context.Contract.balance (B infos.block) infos.contract1 in + let* infos = default_ctxt_with_self_delegation () in + let* fee = + Context.Contract.balance + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in let* op = - select_op ~fee ~force_reveal:false ~source:infos.contract1 kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some false; + fee = Some fee; + } + infos in - only_validate_diagnostic infos op + let* _ = only_validate_diagnostic infos [op] in + return_unit let generate_tests_emptying_self_delegated_implicit () = create_Tztest @@ -521,19 +593,24 @@ let empiric_minimal_gas_cost_for_validate = let test_emptying_undelegated_implicit kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let gas_limit = Op.Custom_gas empiric_minimal_gas_cost_for_validate in - let* fee = Context.Contract.balance (B infos.block) infos.contract1 in + let* infos = default_init_ctxt () in + let* fee = + Context.Contract.balance + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in let* op = select_op - ~fee - ~gas_limit - ~force_reveal:true - ~source:infos.contract1 - kind + { + (operation_req_default kind) with + force_reveal = Some true; + fee = Some fee; + gas_limit = Some (Op.Custom_gas empiric_minimal_gas_cost_for_validate); + } infos in - only_validate_diagnostic infos op + let* _ = only_validate_diagnostic infos [op] in + return_unit let generate_tests_emptying_undelegated_implicit () = create_Tztest @@ -545,12 +622,17 @@ let generate_tests_emptying_undelegated_implicit () = passes validate. *) let test_low_gas_limit_no_consumer kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let gas_limit = Op.Low in + let* infos = default_init_ctxt () in let* op = - select_op ~gas_limit ~force_reveal:true ~source:infos.contract1 kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + gas_limit = Some Op.Low; + } + infos in - validate_diagnostic infos op + validate_diagnostic infos [op] let generate_low_gas_limit_no_consumer () = create_Tztest @@ -561,11 +643,23 @@ let generate_low_gas_limit_no_consumer () = (** Fee payment.*) let test_validate kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let source = infos.contract1 in - let* operation = select_op ~counter ~force_reveal:true ~source kind infos in - validate_diagnostic infos operation + let* infos = default_init_ctxt () in + let* counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + counter = Some counter; + } + infos + in + let* _ = validate_diagnostic infos [op] in + return_unit let generate_tests_validate () = create_Tztest test_validate "Validate." subjects diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml b/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml index 01503a4b920b..cf11000fb57d 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -30,354 +30,487 @@ 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) -(** {2 Context} *) +(** {2 Datatypes} *) -type infos = { +(** Context abstraction in a test. *) +type ctxt = { block : Block.t; - account1 : Account.t; - contract1 : Contract.t; - account2 : Account.t; - contract2 : Contract.t; - account3 : Account.t; - contract3 : Contract.t; - contract_hash : Contract_hash.t; - tx_rollup : Tx_rollup.t; - sc_rollup : Sc_rollup.t; + originated_contract : Contract_hash.t; + tx_rollup : Tx_rollup.t option; + sc_rollup : Sc_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 = { + source : Account.t; + dest : Account.t option; + del : Account.t option; + tx : Account.t option; + sc : Account.t option; } -(** Initialize an [infos] record with a context enabling tx and sc - rollup, funded accounts, tx_rollup, sc_rollup *) -let init_context ?hard_gas_limit_per_block () = +(** Infos describes the information of the setting for a test: the + context and used accounts. *) +type infos = {ctxt : ctxt; accounts : accounts} + +(** 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_Increase_paid_storage + | K_Reveal + | K_Tx_rollup_origination + | K_Tx_rollup_submit_batch + | K_Tx_rollup_commit + | K_Tx_rollup_return_bond + | K_Tx_rollup_finalize + | K_Tx_rollup_remove_commitment + | K_Tx_rollup_dispatch_tickets + | K_Transfer_ticket + | K_Tx_rollup_reject + | 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 + +(** The requirements for a tested manager operation. *) +type operation_req = { + kind : manager_operation_kind; + counter : counter option; + fee : Tez.t option; + gas_limit : Op.gas_limit option; + storage_limit : counter 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; + fund_tx : Tez.t option; + fund_sc : Tez.t option; +} + +(** 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 ctxt_req_default = + { + hard_gas_limit_per_block = None; + fund_src = Some Tez.one; + fund_dest = Some Tez.one; + fund_del = Some Tez.one; + fund_tx = Some Tez.one; + fund_sc = Some Tez.one; + } + +let operation_req_default kind = + { + kind; + counter = None; + fee = None; + gas_limit = None; + storage_limit = None; + force_reveal = None; + amount = None; + } + +(** {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* b, bootstrap_contract = - Context.init1 - ~consensus_threshold:0 - ?hard_gas_limit_per_block - ~tx_rollup_enable:true - ~tx_rollup_sunset_level:Int32.max_int - ~sc_rollup_enable:true - ~dal_enable:true - () + 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 - (* Set a gas_limit to avoid the default gas_limit of the helpers - ([hard_gas_limit_per_operation]) *) - let gas_limit = Op.Custom_gas (Gas.Arith.integral_of_int_exn 10_000) in - (* Create and fund an account use for originate a Tx and a Sc - rollup *) - let rollup_account = Account.new_account () in - let rollup_contract = Contract.Implicit rollup_account.pkh in - let counter = Z.zero in - let* fund_rollup_account = - Op.transaction + 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 delegator delegate = + let open Lwt_result_syntax in + let delegate_pkh = delegate.Account.pkh in + let contract_delegator = contract_of delegator in + let contract_delegate = contract_of delegate in + let* operation = + Op.delegation ~force_reveal:true - ~counter - ~gas_limit - (B b) - bootstrap_contract - rollup_contract - Tez.one + (B block) + contract_delegate + (Some delegate_pkh) in - let* b = Block.bake ~operation:fund_rollup_account b in - let counter2 = Z.succ counter in - let* rollup_origination, tx_rollup = - Op.tx_rollup_origination + let* block = Block.bake block ~operation in + let* operation = + Op.delegation ~force_reveal:true - ~counter:counter2 - ~gas_limit - (B b) - rollup_contract + (B block) + contract_delegator + (Some delegate_pkh) + in + let* block = Block.bake block ~operation in + let* del_opt_new = + Context.Contract.delegate_opt (B block) contract_delegator + in + let* del = Assert.get_some ~loc:__LOC__ del_opt_new in + let+ _ = Assert.equal_pkh ~loc:__LOC__ del delegate_pkh in + block + +let originate_tx_rollup block rollup_account = + let open Lwt_result_syntax in + let rollup_contract = contract_of rollup_account in + let* rollup_origination, tx_rollup = + Op.tx_rollup_origination ~force_reveal:true (B block) rollup_contract in - let* _, sc_rollup = + let+ block = Block.bake ~operation:rollup_origination block in + (block, tx_rollup) + +let originate_sc_rollup block rollup_account = + let open Lwt_result_syntax in + let rollup_contract = contract_of rollup_account in + let* rollup_origination, sc_rollup = Op.sc_rollup_origination - ~counter:counter2 - ~gas_limit - (B b) + ~force_reveal:true + (B block) rollup_contract Sc_rollup.Kind.Example_arith "" (Script.lazy_expr (Expr.from_string "1")) in - let* b = Block.bake ~operation:rollup_origination b in - (* Create and fund three accounts *) - let account1 = Account.new_account () in - let contract1 = Contract.Implicit account1.pkh in - let counter = Z.succ counter in - let* fund_account1 = - Op.transaction - ~counter - ~gas_limit - (B b) - bootstrap_contract - contract1 - Tez.one - in - let account2 = Account.new_account () in - let contract2 = Contract.Implicit account2.pkh in - let counter = Z.succ counter in - let* fund_account2 = - Op.transaction - ~counter - ~gas_limit - (B b) - bootstrap_contract - contract2 - Tez.one - in - let account3 = Account.new_account () in - let contract3 = Contract.Implicit account3.pkh in - let counter = Z.succ counter in - let* fund_account3 = - Op.transaction - ~counter - ~gas_limit - (B b) - bootstrap_contract - contract3 - Tez.one - in - let counter = Z.succ counter in - let* create_contract_hash, contract_hash = - Op.contract_origination_hash - (B b) - ~counter - bootstrap_contract - ~fee:Tez.zero - ~script:Op.dummy_script + let+ block = Block.bake ~operation:rollup_origination block in + (block, sc_rollup) + +(** {2 Setting's context construction} *) + +let fund_account block bootstrap account fund = + let open Lwt_result_syntax in + let* counter = Context.Contract.counter (B block) bootstrap 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* operation = - Op.batch_operations - ~source:bootstrap_contract - (B b) - [fund_account1; fund_account2; fund_account3; create_contract_hash] + Op.transaction + ~counter + ~gas_limit:Op.High + (B block) + bootstrap + (Contract.Implicit account) + fund in - let+ block = Block.bake ~operation b in - { - block; - account1; - contract1; - account2; - contract2; - account3; - contract3; - contract_hash; - tx_rollup; - sc_rollup; - } + let*! b = Block.bake ~operation block in + match b with Error _ -> failwith "Funding account error" | Ok b -> return b -(** Same as [init_context] but [contract1] delegate to [contract2]. *) -let init_delegated_implicit () = +(** 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 {hard_gas_limit_per_block; fund_src; fund_dest; fund_del; fund_tx; fund_sc} -> let open Lwt_result_syntax in - let* infos = init_context () in - let* del_opt = - Context.Contract.delegate_opt (B infos.block) infos.contract1 + 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 + (block, Some account, rollup) in - let* _ = - Assert.is_none - ~loc:__LOC__ - ~pp:(fun fmt _ -> Format.fprintf fmt "should not be delegated") - del_opt + let* block, bootstraps = + Context.init_n + 6 + ~consensus_threshold:0 + ?hard_gas_limit_per_block + ~tx_rollup_enable:true + ~tx_rollup_sunset_level:Int32.max_int + ~sc_rollup_enable:true + ~dal_enable:true + () in - let* operation = - Op.delegation - ~force_reveal:true - (B infos.block) - infos.contract2 - (Some (Context.Contract.pkh infos.contract2)) + let get_bootstrap bootstraps n = 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 = Block.bake infos.block ~operation in - let* operation = - Op.delegation - ~force_reveal:true - (B block) - infos.contract1 - (Some infos.account2.pkh) + let* block, dest, _ = + create_and_fund block (get_bootstrap bootstraps 1) fund_dest in - let* block = Block.bake block ~operation in - let* del_opt_new = Context.Contract.delegate_opt (B block) infos.contract1 in - let* del = Assert.get_some ~loc:__LOC__ del_opt_new in - let+ _ = Assert.equal_pkh ~loc:__LOC__ del infos.account2.pkh in - {infos with block} - -(** Same as [init_context] but [contract1] self delegate. *) -let init_self_delegated_implicit () = - let open Lwt_result_syntax in - let* infos = init_context () in - let* del_opt = - Context.Contract.delegate_opt (B infos.block) infos.contract1 + let* block, del, _ = + create_and_fund block (get_bootstrap bootstraps 2) fund_del in - let* _ = - Assert.is_none - ~loc:__LOC__ - ~pp:(fun fmt _ -> Format.fprintf fmt "should not be delegated") - del_opt + let* block, tx, tx_rollup = + create_and_fund + ~originate_rollup:(fun infos account -> originate_tx_rollup infos account) + block + (get_bootstrap bootstraps 3) + fund_tx in - let* operation = - Op.delegation - ~force_reveal:true - (B infos.block) - infos.contract1 - (Some infos.account1.pkh) + let* block, sc, sc_rollup = + create_and_fund + ~originate_rollup:(fun infos account -> originate_sc_rollup infos account) + block + (get_bootstrap bootstraps 4) + fund_sc in - let* block = Block.bake infos.block ~operation in - let* del_opt_new = Context.Contract.delegate_opt (B block) infos.contract1 in - let* del = Assert.get_some ~loc:__LOC__ del_opt_new in - let+ _ = Assert.equal_pkh ~loc:__LOC__ del infos.account1.pkh in - {infos with block} + let* create_contract_hash, originated_contract = + Op.contract_origination_hash + (B block) + (get_bootstrap bootstraps 5) + ~fee:Tez.zero + ~script:Op.dummy_script + in + let+ block = Block.bake ~operation:create_contract_hash block in + let ctxt = {block; originated_contract; tx_rollup; sc_rollup} in + {ctxt; accounts = {source; dest; del; tx; sc}} -(** {2 Local helpers for generating all kind of manager operations} *) +(** In addition of building up a context according to a context + requirement, source is self-delegated. -(** Create a fresh account used for empty implicit account tests. *) -let mk_fresh_contract () = Contract.Implicit Account.(new_account ()).pkh + 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 infos.accounts.source.pkh in + let ctxt = {infos.ctxt with block} in + {infos with ctxt} -let get_pkh source = Context.Contract.pkh source +(** In addition of building up a context accordning to a context + requirement, source delegates to del. -let get_pk infos source = + See [init_ctxt] description. *) +let ctxt_with_delegation : ctxt_req -> infos tzresult Lwt.t = + fun ctxt_req -> let open Lwt_result_syntax in - let+ account = Context.Contract.manager infos source in - account.pk + 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 infos.accounts.source delegate in + let ctxt = {infos.ctxt with block} in + {infos with ctxt} -let mk_transaction ?counter ?fee ?gas_limit ?storage_limit ?force_reveal ~source - (infos : infos) = +let default_init_ctxt () = init_ctxt ctxt_req_default + +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 - ?counter - ?fee - ?gas_limit - ?storage_limit - (B infos.block) - source - infos.contract2 - Tez.one - -let mk_delegation ?counter ?fee ?gas_limit ?storage_limit ?force_reveal ~source - (infos : infos) = + ?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 infos.accounts.source) + (contract_of + (match infos.accounts.dest with + | None -> infos.accounts.source + | 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 - ?fee - ?gas_limit - ?counter - ?storage_limit - (B infos.block) - source - (Some infos.account2.pkh) - -let mk_undelegation ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = + ?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 infos.accounts.source) + (Some + (match infos.accounts.del with + | None -> infos.accounts.source.pkh + | Some delegate -> delegate.pkh)) + +let mk_undelegation (oinfos : operation_req) (infos : infos) = Op.delegation - ?force_reveal - ?fee - ?gas_limit - ?counter - ?storage_limit - (B infos.block) - source + ?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 infos.accounts.source) None -let mk_self_delegation ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = +let mk_self_delegation (oinfos : operation_req) (infos : infos) = Op.delegation - ?force_reveal - ?fee - ?gas_limit - ?counter - ?storage_limit - (B infos.block) - source - (Some (get_pkh source)) - -let mk_origination ?counter ?fee ?gas_limit ?storage_limit ?force_reveal ~source - (infos : infos) = + ?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 infos.accounts.source) + (Some infos.accounts.source.pkh) + +let mk_origination (oinfos : operation_req) (infos : infos) = let open Lwt_result_syntax in let+ op, _ = Op.contract_origination - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit + ?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.block) - source + (B infos.ctxt.block) + (contract_of infos.accounts.source) in op -let mk_register_global_constant ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = +let mk_register_global_constant (oinfos : operation_req) (infos : infos) = Op.register_global_constant - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - (B infos.block) - ~source + ?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 infos.accounts.source) ~value:(Script_repr.lazy_expr (Expr.from_string "Pair 1 2")) -let mk_set_deposits_limit ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = +let mk_set_deposits_limit (oinfos : operation_req) (infos : infos) = Op.set_deposits_limit - ?force_reveal - ?fee - ?gas_limit - ?storage_limit - ?counter - (B infos.block) - source + ?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 infos.accounts.source) None -let mk_increase_paid_storage ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = +let mk_increase_paid_storage (oinfos : operation_req) (infos : infos) = Op.increase_paid_storage - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - (B infos.block) - ~source - ~destination:infos.contract_hash + ?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 infos.accounts.source) + ~destination:infos.ctxt.originated_contract Z.one -let mk_reveal ?counter ?fee ?gas_limit ?storage_limit ?force_reveal:_ ~source - (infos : infos) = +let mk_reveal (oinfos : operation_req) (infos : infos) = let open Lwt_result_syntax in - let* pk = get_pk (B infos.block) source in - Op.revelation ?fee ?gas_limit ?counter ?storage_limit (B infos.block) pk + let* pk = get_pk (B infos.ctxt.block) (contract_of infos.accounts.source) 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 mk_tx_rollup_origination ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = +let mk_tx_rollup_origination (oinfos : operation_req) (infos : infos) = let open Lwt_result_syntax in let+ op, _rollup = Op.tx_rollup_origination - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source + ?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 infos.accounts.source) in op -let mk_tx_rollup_submit_batch ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = +let tx_rollup_of = function + | Some tx_rollup -> return tx_rollup + | None -> failwith "Tx_rollup not created in this context" + +let sc_rollup_of = function + | Some sc_rollup -> return sc_rollup + | None -> failwith "Sc_rollup not created in this context" + +let mk_tx_rollup_submit_batch (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in + Op.tx_rollup_submit_batch - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup + ?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 infos.accounts.source) + tx_rollup "batch" -let mk_tx_rollup_commit ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = +let mk_tx_rollup_commit (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in let commitement : Tx_rollup_commitment.Full.t = { level = Tx_rollup_level.root; @@ -387,54 +520,58 @@ let mk_tx_rollup_commit ?counter ?fee ?gas_limit ?storage_limit ?force_reveal } in Op.tx_rollup_commit - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup + ?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 infos.accounts.source) + tx_rollup commitement -let mk_tx_rollup_return_bond ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = +let mk_tx_rollup_return_bond (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in Op.tx_rollup_return_bond - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - -let mk_tx_rollup_finalize ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = + ?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 infos.accounts.source) + tx_rollup + +let mk_tx_rollup_finalize (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in Op.tx_rollup_finalize - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - -let mk_tx_rollup_remove_commitment ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = + ?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 infos.accounts.source) + tx_rollup + +let mk_tx_rollup_remove_commitment (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in Op.tx_rollup_remove_commitment - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - -let mk_tx_rollup_reject ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = + ?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 infos.accounts.source) + tx_rollup + +let mk_tx_rollup_reject (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in let message, _ = Tx_rollup_message.make_batch "" in let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in let message_path = @@ -457,14 +594,14 @@ let mk_tx_rollup_reject ?counter ?fee ?gas_limit ?storage_limit ?force_reveal } in Op.tx_rollup_reject - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup + ?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 infos.accounts.source) + tx_rollup Tx_rollup_level.root message ~message_position:0 @@ -475,62 +612,76 @@ let mk_tx_rollup_reject ?counter ?fee ?gas_limit ?storage_limit ?force_reveal ~previous_message_result ~previous_message_result_path:Tx_rollup_commitment.Merkle.dummy_path -let mk_transfer_ticket ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = +let mk_transfer_ticket (oinfos : operation_req) (infos : infos) = Op.transfer_ticket - ?fee - ?force_reveal - ?counter - ?gas_limit - ?storage_limit - (B infos.block) - ~source + ?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 infos.accounts.source) ~contents:(Script.lazy_expr (Expr.from_string "1")) ~ty:(Script.lazy_expr (Expr.from_string "nat")) - ~ticketer:infos.contract3 + ~ticketer: + (contract_of + (match infos.accounts.tx with + | None -> infos.accounts.source + | Some tx -> tx)) Z.zero - ~destination:infos.contract2 + ~destination: + (contract_of + (match infos.accounts.dest with + | None -> infos.accounts.source + | Some dest -> dest)) Entrypoint.default -let mk_tx_rollup_dispacth_ticket ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = +let mk_tx_rollup_dispacth_ticket (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in let reveal = Tx_rollup_reveal. { contents = Script.lazy_expr (Expr.from_string "1"); ty = Script.lazy_expr (Expr.from_string "nat"); - ticketer = infos.contract2; + ticketer = + contract_of + (match infos.accounts.dest with + | None -> infos.accounts.source + | Some dest -> dest); amount = Tx_rollup_l2_qty.of_int64_exn 10L; - claimer = infos.account3.pkh; + claimer = + (match infos.accounts.dest with + | None -> infos.accounts.source.pkh + | Some dest -> dest.pkh); } in Op.tx_rollup_dispatch_tickets - ?fee - ?force_reveal - ?counter - ?gas_limit - ?storage_limit - (B infos.block) - ~source + ?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 infos.accounts.source) ~message_index:0 ~message_result_path:Tx_rollup_commitment.Merkle.dummy_path - infos.tx_rollup + tx_rollup Tx_rollup_level.root Context_hash.zero [reveal] -let mk_sc_rollup_origination ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = +let mk_sc_rollup_origination (oinfos : operation_req) (infos : infos) = let open Lwt_result_syntax in let+ op, _ = Op.sc_rollup_origination - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source + ?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 infos.accounts.source) Sc_rollup.Kind.Example_arith "" (Script.lazy_expr (Expr.from_string "1")) @@ -551,103 +702,116 @@ let sc_dummy_commitment = compressed_state = Sc_rollup.State_hash.zero; } -let mk_sc_rollup_publish ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = +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 - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup + ?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 infos.accounts.source) + sc_rollup sc_dummy_commitment -let mk_sc_rollup_cement ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = +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 - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup + ?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 infos.accounts.source) + sc_rollup (Sc_rollup.Commitment.hash sc_dummy_commitment) -let mk_sc_rollup_refute ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = +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 = {choice = Sc_rollup.Tick.initial; step = Dissection []} in Op.sc_rollup_refute - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - infos.account2.pkh + ?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 infos.accounts.source) + sc_rollup + (match infos.accounts.dest with + | None -> infos.accounts.source.pkh + | Some dest -> dest.pkh) (Some refutation) -let mk_sc_rollup_add_messages ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = +let mk_sc_rollup_add_messages (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_add_messages - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup + ?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 infos.accounts.source) + sc_rollup [""] -let mk_sc_rollup_timeout ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : 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 - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - (Sc_rollup.Game.Index.make infos.account2.pkh infos.account3.pkh) - -let mk_sc_rollup_execute_outbox_message ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = + ?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 infos.accounts.source) + sc_rollup + (Sc_rollup.Game.Index.make + infos.accounts.source.pkh + (match infos.accounts.dest with + | None -> infos.accounts.source.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 - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup + ?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 infos.accounts.source) + sc_rollup (Sc_rollup.Commitment.hash sc_dummy_commitment) ~output_proof:"" -let mk_sc_rollup_return_bond ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = +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 Op.sc_rollup_recover_bond - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - -let mk_dal_publish_slot_header ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = + ?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 infos.accounts.source) + sc_rollup + +let mk_dal_publish_slot_header (oinfos : operation_req) (infos : infos) = let open Lwt_result_syntax in let level = 0 in let index = 0 in @@ -665,79 +829,16 @@ let mk_dal_publish_slot_header ?counter ?fee ?gas_limit ?storage_limit in let slot = Data_encoding.Json.destruct Dal.Slot.encoding json_slot in Op.dal_publish_slot_header - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source + ?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 infos.accounts.source) slot -(** {2 Helpers for generation of generic check tests by manager operation.} *) - -(** 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_Increase_paid_storage - | K_Reveal - | K_Tx_rollup_origination - | K_Tx_rollup_submit_batch - | K_Tx_rollup_commit - | K_Tx_rollup_return_bond - | K_Tx_rollup_finalize - | K_Tx_rollup_remove_commitment - | K_Tx_rollup_dispatch_tickets - | K_Transfer_ticket - | K_Tx_rollup_reject - | 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 - -let select_op = function - | 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_Increase_paid_storage -> mk_increase_paid_storage - | K_Reveal -> mk_reveal - | K_Tx_rollup_origination -> mk_tx_rollup_origination - | K_Tx_rollup_submit_batch -> mk_tx_rollup_submit_batch - | K_Tx_rollup_commit -> mk_tx_rollup_commit - | K_Tx_rollup_return_bond -> mk_tx_rollup_return_bond - | K_Tx_rollup_finalize -> mk_tx_rollup_finalize - | K_Tx_rollup_remove_commitment -> mk_tx_rollup_remove_commitment - | K_Tx_rollup_reject -> mk_tx_rollup_reject - | K_Transfer_ticket -> mk_transfer_ticket - | K_Tx_rollup_dispatch_tickets -> mk_tx_rollup_dispacth_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 +(** {2 Helpers for generation of generic check tests by manager operation} *) let kind_to_string = function | K_Transaction -> "Transaction" @@ -768,6 +869,41 @@ let kind_to_string = function | K_Sc_rollup_recover_bond -> "Sc_rollup_recover_bond" | K_Dal_publish_slot_header -> "Dal_publish_slot_header" +(** 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_Increase_paid_storage -> mk_increase_paid_storage + | K_Reveal -> mk_reveal + | K_Tx_rollup_origination -> mk_tx_rollup_origination + | K_Tx_rollup_submit_batch -> mk_tx_rollup_submit_batch + | K_Tx_rollup_commit -> mk_tx_rollup_commit + | K_Tx_rollup_return_bond -> mk_tx_rollup_return_bond + | K_Tx_rollup_finalize -> mk_tx_rollup_finalize + | K_Tx_rollup_remove_commitment -> mk_tx_rollup_remove_commitment + | K_Tx_rollup_reject -> mk_tx_rollup_reject + | K_Transfer_ticket -> mk_transfer_ticket + | K_Tx_rollup_dispatch_tickets -> mk_tx_rollup_dispacth_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 + in + mk_op op_req infos + let create_Tztest ?hd_msg test tests_msg operations = let hd_msg k = let sk = kind_to_string k in @@ -795,13 +931,14 @@ let rec create_Tztest_batches test tests_msg operations = (** {2 Diagnostic helpers.} *) -(** The purpose of diagnostic helpers is to state the correct observation - according to the validate result of a test. *) +(** 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. *) +(** 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; @@ -832,23 +969,93 @@ let manager_content_infos op = | Cons (Manager_operation _, _) as op -> contents_infos op | _ -> failwith "Should only handle manager operation" -(** [observe] asserts the success of validate only. - Given on one side, a [contract], its initial balance [b_in], its initial - counter [c_in] and potentially the initial gas [g_in] before its validation; - and, on the other side, its [probes] and the context after its validate [i]; - if validate succeeds then we observe in [i] that: - - [contract] balance decreases by [probes.fee] when [only_validate] marks that only the validate - succeeds - - [contract] balance decreases at least by [probes.fee] when [not only_validate] marks - that the application has succeeded, - - its counter [c_in] increases by [probes.nb_counter], and - - the available gas in the block in [i] decreases by [g_in].*) -let observe ~only_validate ~mode contract b_in c_in g_in probes i = - let open Lwt_result_syntax in - let* b_out = Context.Contract.balance (I i) contract in - let g_out = Gas.block_level (Incremental.alpha_ctxt i) in - let* c_out = Context.Contract.counter (I i) contract in +(** 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 + (b_in, c_in, g_in) + +(** According to the witness in pre-state and the probes, computes the + expected outputs. In any mode 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 = Z.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 + (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). 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 then we observe in the + post-state: + + The balance of source decreases by the fee of probes when + [only_validate] marks that only the validate succeeds. + + The balance of source decreases at least by fee of probes when + [not only_validate] marks that 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 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 ~only_validate ~mode ctxt_pre ctxt_post op = + let open Lwt_result_syntax in + let* probes = manager_content_infos op in + let contract = Contract.Implicit probes.source in + 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__ @@ -857,7 +1064,6 @@ let observe ~only_validate ~mode contract b_in c_in g_in probes i = Tez.pp in let* _ = b_cmp b_out b_expected in - let c_expected = Z.add c_in probes.nb_counter in let _ = Assert.equal Z.equal @@ -867,63 +1073,137 @@ let observe ~only_validate ~mode contract b_in c_in g_in probes i = c_out c_expected in - let* g_expected = - match mode with - | Validate_operation.Block -> - return (Gas.Arith.sub g_in (Gas.Arith.fp probes.gas_limit)) - | Validate_operation.Mempool -> - Context.get_constants (I i) >>=? fun c -> - return - (Gas.Arith.sub - (Gas.Arith.fp c.parametric.hard_gas_limit_per_block) - (Gas.Arith.fp probes.gas_limit)) - in let g_msg = match mode with - | Validate_operation.Block -> "Gas consumption (block)" - | Validate_operation.Mempool -> "Gas consumption (mempool)" - in - Assert.equal ~loc:__LOC__ Gas.Arith.equal g_msg Gas.Arith.pp g_out g_expected - -let validate_with_diagnostic ~only_validate (infos : infos) op = - let open Lwt_result_syntax in - let* i = Incremental.begin_construction infos.block in - let* prbs = manager_content_infos op in - let contract = Contract.Implicit prbs.source in - let* b_in = Context.Contract.balance (I i) contract in - let* c_in = Context.Contract.counter (I i) contract in - let g_in = Gas.block_level (Incremental.alpha_ctxt i) in - let* i = Incremental.validate_operation i op in - let* _ = Incremental.finalize_block i in - let mode = Validate_operation.Block in - observe ~only_validate ~mode contract b_in c_in g_in prbs i - -(** If only the validate of an operation succeed; e.g. the rest - of the application failed: - - the fees must be paid, - - the block gas consumption should be decreased, and - - the counter of operation should be incremented - as defined by [observe] with [only_validate]. *) -let only_validate_diagnostic (infos : infos) op = - validate_with_diagnostic ~only_validate:true infos op - -(** If an manager operation application succeed, the validate - effects must be observed: - - the fees must be paid, - - the block gas consumption should be decreased, and - - the counter of operation should be incremented - as defined by [observe] with [not only_validate]. *) -let validate_diagnostic (infos : infos) op = - validate_with_diagnostic ~only_validate:false infos op - -(** [validate_ko_diagnostic] wraps the [expect_failure] when [op] validate - failed. It is used in test that expects validate [op] to fail. *) -let validate_ko_diagnostic ?(mempool_mode = false) (infos : infos) op + | 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.equal + g_msg + Gas.Arith.pp + g_out + g_expected + +let observe_list ~only_validate ~mode ctxt_pre ctxt_post ops = + List.iter + (fun op -> + let _ = observe ~only_validate ~mode ctxt_pre ctxt_post op in + ()) + ops + +let validate_operations inc_in ops = + let open Lwt_result_syntax in + List.fold_left_es + (fun inc op -> + let* inc_out = Incremental.validate_operation 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 + 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 ~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 inc_pre ops in + let+ block = Incremental.finalize_block inc_post in + (Context.I inc_post, {infos with ctxt = {infos.ctxt with block}}) + | Application, Context.B b -> + let+ block = Block.bake ~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 only_validate status for each operation. + + See [observe] for more details on the observational validation. *) +let validate_with_diagnostic ~only_validate ~mode (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 ~only_validate ~mode ctxt_pre ctxt_post ops in + return infos + +(** If only the operation validation succeeds; e.g. the rest of the + application failed then [only_validate] must be set for the + observation validation. + + Default mode is [Construction]. See [observe] for more details. *) +let only_validate_diagnostic ?(mode = Construction) (infos : infos) ops = + validate_with_diagnostic ~only_validate:true ~mode infos ops + +(** If the whole operation application succeeds; e.g. the fee + payment and the full application succeed then [not only_validate] + must be set. + + Default mode is [Construction]. *) +let validate_diagnostic ?(mode = Construction) (infos : infos) ops = + validate_with_diagnostic ~only_validate:false ~mode infos ops + +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 - let* i = Incremental.begin_construction infos.block ~mempool_mode in - let* _ = Incremental.add_operation ~expect_failure i op in - return_unit + match mode with + | Construction | Mempool -> + let* i = + Incremental.begin_construction + infos.ctxt.block + ~mempool_mode:(mempool_mode_of mode) + in + let* _ = add_operations ~expect_failure i ops in + return_unit + | Application -> ( + let*! res = + Block.bake ~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. *) diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml b/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml index c807a0470d3e..2feae36dfe82 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml @@ -40,67 +40,82 @@ open Manager_operation_helpers let create_Tztest ?hd_msg test tests_msg = let hd_msg k = let sk = kind_to_string k in - match hd_msg with - | None -> sk - | Some hd -> Format.sprintf "Batch: %s, %s" hd sk + match hd_msg with None -> sk | Some hd -> Format.sprintf "%s, %s" sk hd in let kind = K_Register_global_constant in Tztest.tztest - (Format.sprintf "%s: %s" (hd_msg kind) tests_msg) + (Format.sprintf "%s [%s]" tests_msg (hd_msg kind)) `Quick (fun () -> test kind ()) let generate_op ~fee ~reverse:_ kind infos = let open Lwt_result_syntax in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let source = infos.contract1 in + let* counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in let* operation = - select_op ~fee ~counter ~force_reveal:true ~source kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + fee = Some fee; + counter = Some counter; + } + infos in - let counter = Z.succ (Z.succ counter) in let+ operation2 = - select_op ~fee ~counter ~force_reveal:false ~source kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some false; + fee = Some fee; + counter = Some (Z.succ (Z.succ counter)); + } + infos in (operation, operation2) let generate_op_diff_man ~fee ~reverse:_ kind infos = let open Lwt_result_syntax in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let source = infos.contract1 in + let source = contract_of infos.accounts.source in + let source2_account = + match infos.accounts.del with None -> assert false | Some s -> s + in + let source2 = contract_of source2_account in + let* counter = Context.Contract.counter (B infos.ctxt.block) source in let* operation = - select_op ~fee ~counter ~force_reveal:true ~source kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + fee = Some fee; + counter = Some counter; + } + infos in - let* counter = Context.Contract.counter (B infos.block) infos.contract2 in - let source = infos.contract2 in + let* counter = Context.Contract.counter (B infos.ctxt.block) source2 in let+ operation2 = - select_op ~fee ~counter ~force_reveal:true ~source kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + fee = Some fee; + counter = Some counter; + } + {infos with accounts = {infos.accounts with source = source2_account}} in (operation, operation2) -(* Helpers that should be included or replace existing helpers for - validate tests.*) -let witness inc source = - let open Lwt_result_syntax in - let* b_in = Context.Contract.balance (I inc) source in - let+ c_in = Context.Contract.counter (I inc) source in - let g_in = Gas.block_level (Incremental.alpha_ctxt inc) in - (b_in, c_in, g_in) - -let observe ~mode inc_pre inc_post op = - let open Lwt_result_syntax in - let* prbs = manager_content_infos op in - let source = Contract.Implicit prbs.source in - let* b_in, c_in, g_in = witness inc_pre source in - observe ~only_validate:false ~mode source b_in c_in g_in prbs inc_post - (** 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 test_two_op_with_same_manager ~mempool_mode kind () = let open Lwt_result_syntax in - let* infos = init_context () in + let* infos = default_init_ctxt () in let* op1, op2 = generate_op ~fee:Tez.zero ~reverse:false kind infos in - let* inc = Incremental.begin_construction ~mempool_mode infos.block in + let* inc = Incremental.begin_construction ~mempool_mode infos.ctxt.block in let* inc = Incremental.validate_operation inc op1 in let* _inc = Incremental.validate_operation @@ -126,20 +141,16 @@ let test_two_op_with_same_manager ~mempool_mode kind () = by two single operations. *) let test_batch_of_two_not_be_two_singles ~mempool_mode kind () = let open Lwt_result_syntax in - let mode = - if mempool_mode then Validate_operation.Mempool - else Validate_operation.Block - in - let* infos = init_context () in - let* inc = Incremental.begin_construction ~mempool_mode infos.block in + let mode = if mempool_mode then Mempool else Construction in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source in + let* inc = Incremental.begin_construction ~mempool_mode infos.ctxt.block in let* op1, op2 = generate_op ~fee:Tez.one_mutez ~reverse:false kind infos in - let* batch = - Op.batch_operations ~source:infos.contract1 (B infos.block) [op1; op2] - in + let* batch = Op.batch_operations ~source (B infos.ctxt.block) [op1; op2] in let* inc_batch = Incremental.validate_operation inc batch in - let* () = observe ~mode inc inc_batch batch in + let* () = observe ~only_validate:false ~mode (I inc) (I inc_batch) batch in let* inc1 = Incremental.validate_operation inc op1 in - let* () = observe ~mode inc inc1 op1 in + let* () = observe ~only_validate:false ~mode (I inc) (I inc1) op1 in let* _inc2 = Incremental.validate_operation ~expect_failure:(fun _ -> return_unit) @@ -149,15 +160,15 @@ let test_batch_of_two_not_be_two_singles ~mempool_mode kind () = let* b1 = Incremental.finalize_block inc1 in let* inc1' = Incremental.begin_construction ~mempool_mode b1 in let* inc1_op2 = Incremental.validate_operation inc1' op2 in - let* () = observe ~mode inc1' inc1_op2 op2 in + let* () = observe ~only_validate:false ~mode (I inc1') (I inc1_op2) op2 in return_unit (** The application of a valid operation succeeds, at least, to perform the fee payment. *) let valid_validate ~mempool_mode kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let* inc = Incremental.begin_construction ~mempool_mode infos.block in + let* infos = default_init_ctxt () in + let* inc = Incremental.begin_construction ~mempool_mode infos.ctxt.block in let* op, _ = generate_op ~fee:Tez.one_mutez ~reverse:false kind infos in let {shell; protocol_data = Operation_data protocol_data} = op in let operation : _ Alpha_context.operation = {shell; protocol_data} in @@ -188,12 +199,10 @@ let valid_validate ~mempool_mode kind () = [generate_op_diff_man]. *) let valid_context_free ~mempool_mode kind () = let open Lwt_result_syntax in - let mode = - if mempool_mode then Validate_operation.Mempool - else Validate_operation.Block - in - let* infos = init_context () in - let* inc = Incremental.begin_construction ~mempool_mode infos.block in + let mode = if mempool_mode then Mempool else Construction in + + let* infos = default_init_ctxt () in + let* inc = Incremental.begin_construction ~mempool_mode infos.ctxt.block in let* op1, op2 = generate_op_diff_man ~fee:Tez.one_mutez ~reverse:false kind infos in @@ -230,63 +239,63 @@ let valid_context_free ~mempool_mode kind () = Lwt.return (Environment.wrap_tzresult res) in let* inc1 = Incremental.validate_operation inc op1 in - let* () = observe ~mode inc inc1 op1 in + let* () = observe ~only_validate:false ~mode (I inc) (I inc1) op1 in let* inc1' = Incremental.validate_operation inc1 op2 in - let* () = observe ~mode inc1 inc1' op2 in + let* () = observe ~only_validate:false ~mode (I inc1) (I inc1') op2 in let* inc2 = Incremental.validate_operation inc op2 in - let* () = observe ~mode inc inc2 op2 in + let* () = observe ~only_validate:false ~mode (I inc) (I inc2) op2 in let* inc2' = Incremental.validate_operation inc2 op1 in - let* () = observe ~mode inc2 inc2' op1 in + let* () = observe ~only_validate:false ~mode (I inc2) (I inc2') op1 in return_unit let generate_1m_conflit_mempool_mode () = create_Tztest (test_two_op_with_same_manager ~mempool_mode:true) - "1M restriction fails in mempool mode" + "At most one operation per manager in mempool mode" let generate_1m_conflit_construction_mode () = create_Tztest (test_two_op_with_same_manager ~mempool_mode:false) - "1M restriction fails in construction mode" + "At most one operation per manager in construction mode" let generate_batch_of_two_not_be_two_singles_construction_mode () = create_Tztest (test_batch_of_two_not_be_two_singles ~mempool_mode:false) - "1M restriction fails in construction mode" + "A batch differs from a sequence in construction mode" let generate_batch_of_two_not_be_two_singles_mempool_mode () = create_Tztest (test_batch_of_two_not_be_two_singles ~mempool_mode:true) - "1M restriction fails in mempool mode" + "A batch differs from a sequence in mempool mode" -let generate_valid_precheck_mempool_mode () = +let generate_valid_validate_mempool_mode () = create_Tztest (valid_validate ~mempool_mode:true) - "valid so fee payment in mempool mode" + "Valid implies fee payment in mempool mode" -let generate_valid_precheck_construction_mode () = +let generate_valid_validate_construction_mode () = create_Tztest (valid_validate ~mempool_mode:false) - "valid so fee payment in construction mode" + "Valid implies fee payment in construction mode" let generate_valid_context_free_mempool_mode () = create_Tztest (valid_context_free ~mempool_mode:true) - "two covalid so both pay fees commute under 1M in mempool mode" + "Fee payment of two covalid operations commute in mempool mode" let generate_valid_context_free_construction_mode () = create_Tztest (valid_context_free ~mempool_mode:false) - "two covalid so both pay fees commute under 1M in construction mode" + "Fee payment of two covalid operations commute in construction mode" let tests = [ generate_1m_conflit_construction_mode (); generate_batch_of_two_not_be_two_singles_construction_mode (); - generate_valid_precheck_construction_mode (); + generate_valid_validate_construction_mode (); generate_valid_context_free_construction_mode (); generate_1m_conflit_mempool_mode (); generate_batch_of_two_not_be_two_singles_mempool_mode (); - generate_valid_precheck_mempool_mode (); + generate_valid_validate_mempool_mode (); generate_valid_context_free_mempool_mode (); ] diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml b/src/proto_alpha/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml index 15aec152ef94..f53573b9eb1f 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml @@ -58,28 +58,50 @@ let batch_reveal_in_the_middle_diagnostic (infos : infos) op = let test_batch_reveal_in_the_middle kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let counter = counter in - let fee = Tez.one_mutez in + let* infos = default_init_ctxt () in + let* counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in let counter = Z.succ counter in let* operation1 = - select_op ~counter ~force_reveal:false ~source:infos.contract1 kind1 infos + select_op + { + (operation_req_default kind1) with + force_reveal = Some false; + counter = Some counter; + } + infos in let counter = Z.succ counter in - let* reveal = mk_reveal ~fee ~counter ~source:infos.contract1 infos in + let* reveal = + mk_reveal + { + (operation_req_default K_Reveal) with + fee = Some Tez.one_mutez; + counter = Some counter; + } + infos + in let counter = Z.succ counter in let* operation2 = - select_op ~counter ~force_reveal:false ~source:infos.contract1 kind2 infos + 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:infos.contract1 - (Context.B infos.block) + ~source:(contract_of infos.accounts.source) + (Context.B infos.ctxt.block) [operation1; reveal; operation2] in - batch_reveal_in_the_middle_diagnostic infos batch + batch_reveal_in_the_middle_diagnostic infos [batch] let generate_batches_reveal_in_the_middle () = create_Tztest_batches @@ -106,26 +128,50 @@ let batch_two_reveals_diagnostic (infos : infos) op = let test_batch_two_reveals kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let counter = counter in - let fee = Tez.one_mutez in + let* infos = default_init_ctxt () in + let* counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in let counter = Z.succ counter in - let* reveal = mk_reveal ~fee ~counter ~source:infos.contract1 infos in + let* reveal = + mk_reveal + { + (operation_req_default K_Reveal) with + fee = Some Tez.one_mutez; + counter = Some counter; + } + infos + in let counter = Z.succ counter in - let* reveal1 = mk_reveal ~fee ~counter ~source:infos.contract1 infos in + let* reveal1 = + mk_reveal + { + (operation_req_default K_Reveal) with + fee = Some Tez.one_mutez; + counter = Some counter; + } + infos + in let counter = Z.succ counter in let* operation = - select_op ~counter ~force_reveal:false ~source:infos.contract1 kind infos + 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:infos.contract1 - (Context.B infos.block) + ~source:(contract_of infos.accounts.source) + (Context.B infos.ctxt.block) [reveal; reveal1; operation] in - batch_two_reveals_diagnostic infos batch + batch_two_reveals_diagnostic infos [batch] let generate_tests_batches_two_reveals () = create_Tztest @@ -151,23 +197,38 @@ let batch_two_sources_diagnostic (infos : infos) op = let test_batch_two_sources kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source in + let* counter = Context.Contract.counter (B infos.ctxt.block) source in let counter = Z.succ counter in let* operation1 = - select_op ~counter ~force_reveal:true ~source:infos.contract1 kind1 infos + 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 source = source2}} in let* operation2 = - select_op ~force_reveal:false ~source:infos.contract2 kind2 infos + select_op + {(operation_req_default kind2) with force_reveal = Some false} + infos in let* batch = Op.batch_operations ~recompute_counters:false - ~source:infos.contract1 - (Context.B infos.block) + ~source + (Context.B infos.ctxt.block) [operation1; operation2] in - batch_two_sources_diagnostic infos batch + batch_two_sources_diagnostic infos [batch] let generate_batches_two_sources () = create_Tztest_batches @@ -179,17 +240,25 @@ let generate_batches_two_sources () = the stored counter associated to source in the initial context. *) let test_batch_inconsistent_counters kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let fee = Tez.one_mutez in - let* reveal = mk_reveal ~fee ~counter ~source:infos.contract1 infos in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source 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 = Z.succ counter in let counter2 = Z.succ counter in let counter3 = Z.succ counter2 in - let source = infos.contract1 in let operation counter kind = - select_op ~counter ~force_reveal:false ~source kind infos + 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 @@ -201,7 +270,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op1; op2] in let* op1 = op_counter2 kind1 in @@ -210,7 +279,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op1; op2] in let* op1 = op_counter kind1 in @@ -219,7 +288,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op1; op2] in let* op1 = op_counter2 kind1 in @@ -228,7 +297,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op1; op2] in let* op1 = op_counter0 kind1 in @@ -237,7 +306,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op1; op2] in let expect_failure errs = @@ -252,7 +321,7 @@ let test_batch_inconsistent_counters kind1 kind2 () = Error_monad.pp_print_trace err in - let* i = Incremental.begin_construction infos.block in + let* i = Incremental.begin_construction infos.ctxt.block in let* _ = Incremental.add_operation ~expect_failure i batch_same in let* _ = Incremental.add_operation ~expect_failure i batch_in_the_future in let* _ = Incremental.add_operation ~expect_failure i batch_missing_one in @@ -270,19 +339,37 @@ let generate_batches_inconsistent_counters () = consumption at the end of the batch. *) let test_batch_emptying_balance_in_the_middle kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let* init_bal = Context.Contract.balance (B infos.block) infos.contract1 in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source 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 source = infos.contract1 in - let* reveal = mk_reveal ~counter ~source infos in + let* reveal = + mk_reveal + {(operation_req_default K_Reveal) with counter = Some counter} + infos + in let counter = Z.succ counter in let operation fee = - select_op ~fee ~counter ~force_reveal:false ~source kind1 infos + select_op + { + (operation_req_default kind1) with + force_reveal = Some false; + counter = Some counter; + fee = Some fee; + } + infos in let counter = Z.succ counter in let operation2 fee = - select_op ~fee ~counter ~force_reveal:false ~source kind2 infos + 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 @@ -290,10 +377,10 @@ let test_batch_emptying_balance_in_the_middle kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case1; op2_case1] in - let* i = Incremental.begin_construction infos.block 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 _)] @@ -317,33 +404,41 @@ let generate_batches_emptying_balance_in_the_middle () = (** A batch of manager operation must not exceed the initial available gas in the block. *) let test_batch_exceeding_block_gas ~mempool_mode kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context ~hard_gas_limit_per_block:gb_limit () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in + let ctxt_req = + {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} + in + let* infos = init_ctxt ctxt_req in + let source = contract_of infos.accounts.source 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 counter = counter in - let source = infos.contract1 in - let* reveal = mk_reveal ~counter ~source infos in + let* reveal = + mk_reveal + {(operation_req_default K_Reveal) with counter = Some counter} + infos + in let counter = Z.succ counter in let operation gas_limit = select_op - ~gas_limit:(Custom_gas gas_limit) - ~counter - ~force_reveal:false - ~source - kind1 + { + (operation_req_default kind1) with + force_reveal = Some false; + counter = Some counter; + gas_limit = Some (Custom_gas gas_limit); + } infos in let counter = Z.succ counter in let operation2 gas_limit = select_op - ~gas_limit:(Custom_gas gas_limit) - ~counter - ~force_reveal:false - ~source - kind2 + { + (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 @@ -356,24 +451,24 @@ let test_batch_exceeding_block_gas ~mempool_mode kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case1; op2_case1] in let* case3 = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case3; op2_case3] in let* case2 = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case2; op2_case2] in - let* i = Incremental.begin_construction infos.block ~mempool_mode 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] @@ -412,20 +507,37 @@ let generate_batches_exceeding_block_gas_mp_mode () = the batch passes validate.*) let test_batch_balance_just_enough kind1 kind2 () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let* init_bal = Context.Contract.balance (B infos.block) infos.contract1 in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source 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 counter = counter in - let source = infos.contract1 in - let* reveal = mk_reveal ~counter ~source infos in + let* reveal = + mk_reveal + {(operation_req_default K_Reveal) with counter = Some counter} + infos + in let counter = Z.succ counter in let operation fee = - select_op ~fee ~counter ~force_reveal:false ~source kind1 infos + select_op + { + (operation_req_default kind1) with + force_reveal = Some false; + counter = Some counter; + fee = Some fee; + } + infos in let counter = Z.succ counter in let operation2 fee = - select_op ~fee ~counter ~force_reveal:false ~source kind2 infos + 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 @@ -435,18 +547,19 @@ let test_batch_balance_just_enough kind1 kind2 () = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case3; op2_case3] in let* case2 = Op.batch_operations ~recompute_counters:false ~source - (Context.B infos.block) + (Context.B infos.ctxt.block) [reveal; op_case2; op2_case2] in - let* _ = validate_diagnostic infos case2 in - validate_diagnostic infos case3 + let* _ = validate_diagnostic infos [case2] in + let* _ = validate_diagnostic infos [case3] in + return_unit let generate_batches_balance_just_enough () = create_Tztest_batches @@ -457,25 +570,40 @@ let generate_batches_balance_just_enough () = (** Simple reveal followed by a transaction. *) let test_batch_reveal_transaction_ok () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in + let* infos = default_init_ctxt () in + let source = contract_of infos.accounts.source in + let* counter = Context.Contract.counter (B infos.ctxt.block) source in let counter = counter in let fee = Tez.one_mutez in - let source = infos.contract1 in - let* reveal = mk_reveal ~fee ~counter ~source infos in + let* reveal = + mk_reveal + { + (operation_req_default K_Reveal) with + fee = Some fee; + counter = Some counter; + } + infos + in let counter = Z.succ counter in let* transaction = - mk_transaction ~counter ~force_reveal:false ~source infos + 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.block) + (Context.B infos.ctxt.block) [reveal; transaction] in - let* _i = Incremental.begin_construction infos.block in - validate_diagnostic infos batch + let* _i = Incremental.begin_construction infos.ctxt.block in + let* _ = validate_diagnostic infos [batch] in + return_unit let contract_tests = generate_batches_reveal_in_the_middle () diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml b/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml index 6cfee688277c..6b43a1883e92 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml @@ -48,7 +48,11 @@ open Manager_operation_helpers operation kind. *) let ensure_kind infos kind = let open Lwt_result_syntax in - let* op = select_op kind infos ~force_reveal:false ~source:infos.contract1 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; _}) -> ( @@ -99,7 +103,7 @@ let ensure_kind infos kind = let ensure_manager_operation_coverage () = let open Lwt_result_syntax in - let* infos = init_context () in + let* infos = default_init_ctxt () in List.iter_es (fun kind -> ensure_kind infos kind) subjects let test_ensure_manager_operation_coverage () = @@ -136,12 +140,17 @@ let low_gas_limit_diagnostic (infos : infos) op = let test_low_gas_limit kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let gas_limit = Op.Low in + let* infos = default_init_ctxt () in let* op = - select_op ~gas_limit ~force_reveal:true ~source:infos.contract1 kind infos + select_op + { + (operation_req_default kind) with + gas_limit = Some Op.Low; + force_reveal = Some true; + } + infos in - low_gas_limit_diagnostic infos op + low_gas_limit_diagnostic infos [op] let generate_low_gas_limit () = create_Tztest @@ -168,12 +177,18 @@ let high_gas_limit_diagnostic (infos : infos) op = let test_high_gas_limit kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let gas_limit = Op.Custom_gas (Gas.Arith.integral_of_int_exn 10_000_000) in + let* infos = default_init_ctxt () in let* op = - select_op ~gas_limit ~force_reveal:true ~source:infos.contract1 kind infos + 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 + high_gas_limit_diagnostic infos [op] let generate_high_gas_limit () = create_Tztest test_high_gas_limit "Gas_limit too high." subjects @@ -198,17 +213,17 @@ let high_storage_limit_diagnostic (infos : infos) op = let test_high_storage_limit kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let storage_limit = Z.of_int max_int in + let* infos = default_init_ctxt () in let* op = select_op - ~storage_limit - ~force_reveal:true - ~source:infos.contract1 - kind + { + (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 + high_storage_limit_diagnostic infos [op] let generate_high_storage_limit () = create_Tztest test_high_gas_limit "Storage_limit too high." subjects @@ -235,12 +250,17 @@ let high_counter_diagnostic (infos : infos) op = let test_high_counter kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let counter = Z.of_int max_int in + let* infos = default_init_ctxt () in let* op = - select_op ~counter ~force_reveal:true ~source:infos.contract1 kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + counter = Some (Z.of_int max_int); + } + infos in - high_counter_diagnostic infos op + high_counter_diagnostic infos [op] let generate_high_counter () = create_Tztest test_high_counter "Counter too high." subjects @@ -267,15 +287,22 @@ let low_counter_diagnostic (infos : infos) op = let test_low_counter kind () = let open Lwt_result_syntax in - let* infos = init_context () in + let* infos = default_init_ctxt () in let* current_counter = - Context.Contract.counter (B infos.block) infos.contract1 + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) in - let counter = Z.sub current_counter Z.one in let* op = - select_op ~counter ~force_reveal:true ~source:infos.contract1 kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + counter = Some (Z.sub current_counter Z.one); + } + infos in - low_counter_diagnostic infos op + low_counter_diagnostic infos [op] let generate_low_counter () = create_Tztest test_low_counter "Counter too low." subjects @@ -302,11 +329,16 @@ let not_allocated_diagnostic (infos : infos) op = let test_not_allocated kind () = let open Lwt_result_syntax in - let* infos = init_context () in + let* infos = default_init_ctxt () in let* op = - select_op ~force_reveal:false ~source:(mk_fresh_contract ()) kind infos + select_op + {(operation_req_default kind) with force_reveal = Some false} + { + infos with + accounts = {infos.accounts with source = Account.(new_account ())}; + } in - not_allocated_diagnostic infos op + not_allocated_diagnostic infos [op] let generate_not_allocated () = create_Tztest test_not_allocated "Not allocated source." subjects @@ -334,9 +366,13 @@ let unrevealed_key_diagnostic (infos : infos) op = let test_unrevealed_key kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let* op = select_op ~force_reveal:false ~source:infos.contract1 kind infos in - unrevealed_key_diagnostic infos op + let* infos = default_init_ctxt () in + let* op = + select_op + {(operation_req_default kind) with force_reveal = Some false} + infos + in + unrevealed_key_diagnostic infos [op] let generate_unrevealed_key () = create_Tztest @@ -367,12 +403,18 @@ let high_fee_diagnostic (infos : infos) op = let test_high_fee kind () = let open Lwt_result_syntax in - let* infos = init_context () in + let* infos = default_init_ctxt () in let*? fee = Tez.(one +? one) |> Environment.wrap_tzresult in let* op = - select_op ~fee ~force_reveal:true ~source:infos.contract1 kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + fee = Some fee; + } + infos in - high_fee_diagnostic infos op + high_fee_diagnostic infos [op] let generate_tests_high_fee () = create_Tztest test_high_fee "Balance too low for fee payment." subjects @@ -403,12 +445,22 @@ let emptying_delegated_implicit_diagnostic (infos : infos) op = let test_emptying_delegated_implicit kind () = let open Lwt_result_syntax in - let* infos = init_delegated_implicit () in - let* fee = Context.Contract.balance (B infos.block) infos.contract1 in + let* infos = default_ctxt_with_delegation () in + let* fee = + Context.Contract.balance + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in let* op = - select_op ~fee ~force_reveal:false ~source:infos.contract1 kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some false; + fee = Some fee; + } + infos in - emptying_delegated_implicit_diagnostic infos op + emptying_delegated_implicit_diagnostic infos [op] let generate_tests_emptying_delegated_implicit () = create_Tztest @@ -423,51 +475,60 @@ let generate_tests_emptying_delegated_implicit () = - [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 ~mempool_mode (infos : infos) op = +let exceeding_block_gas_diagnostic ~mode (infos : infos) op = let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Gas.Block_quota_exceeded] - when not mempool_mode -> + 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; - ] - when mempool_mode -> + | ( [ + 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 -> + | 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 ~mempool_mode + validate_ko_diagnostic infos op expect_failure ~mode -let test_exceeding_block_gas ~mempool_mode kind () = +let test_exceeding_block_gas ~mode kind () = let open Lwt_result_syntax in - let* infos = init_context ~hard_gas_limit_per_block:gb_limit () in - let gas_limit = - Op.Custom_gas (Gas.Arith.add gb_limit Gas.Arith.(integral_of_int_exn 1)) + let ctxt_req = + {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} in + let* infos = init_ctxt ctxt_req in let* operation = - select_op ~force_reveal:true ~source:infos.contract1 ~gas_limit kind infos + 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 ~mempool_mode infos operation + exceeding_block_gas_diagnostic ~mode infos [operation] let generate_tests_exceeding_block_gas () = create_Tztest - (test_exceeding_block_gas ~mempool_mode:false) + (test_exceeding_block_gas ~mode:Construction) "Too much gas consumption." subjects let generate_tests_exceeding_block_gas_mp_mode () = create_Tztest - (test_exceeding_block_gas ~mempool_mode:true) + (test_exceeding_block_gas ~mode:Mempool) "Too much gas consumption in mempool mode." subjects @@ -499,12 +560,23 @@ let generate_tests_exceeding_block_gas_mp_mode () = (** Fee payment that emptying a self_delegated implicit. *) let test_emptying_self_delegated_implicit kind () = let open Lwt_result_syntax in - let* infos = init_self_delegated_implicit () in - let* fee = Context.Contract.balance (B infos.block) infos.contract1 in + let* infos = default_ctxt_with_self_delegation () in + let* fee = + Context.Contract.balance + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in let* op = - select_op ~fee ~force_reveal:false ~source:infos.contract1 kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some false; + fee = Some fee; + } + infos in - only_validate_diagnostic infos op + let* _ = only_validate_diagnostic infos [op] in + return_unit let generate_tests_emptying_self_delegated_implicit () = create_Tztest @@ -521,19 +593,24 @@ let empiric_minimal_gas_cost_for_validate = let test_emptying_undelegated_implicit kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let gas_limit = Op.Custom_gas empiric_minimal_gas_cost_for_validate in - let* fee = Context.Contract.balance (B infos.block) infos.contract1 in + let* infos = default_init_ctxt () in + let* fee = + Context.Contract.balance + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in let* op = select_op - ~fee - ~gas_limit - ~force_reveal:true - ~source:infos.contract1 - kind + { + (operation_req_default kind) with + force_reveal = Some true; + fee = Some fee; + gas_limit = Some (Op.Custom_gas empiric_minimal_gas_cost_for_validate); + } infos in - only_validate_diagnostic infos op + let* _ = only_validate_diagnostic infos [op] in + return_unit let generate_tests_emptying_undelegated_implicit () = create_Tztest @@ -545,12 +622,17 @@ let generate_tests_emptying_undelegated_implicit () = passes validate. *) let test_low_gas_limit_no_consumer kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let gas_limit = Op.Low in + let* infos = default_init_ctxt () in let* op = - select_op ~gas_limit ~force_reveal:true ~source:infos.contract1 kind infos + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + gas_limit = Some Op.Low; + } + infos in - validate_diagnostic infos op + validate_diagnostic infos [op] let generate_low_gas_limit_no_consumer () = create_Tztest @@ -561,11 +643,23 @@ let generate_low_gas_limit_no_consumer () = (** Fee payment.*) let test_validate kind () = let open Lwt_result_syntax in - let* infos = init_context () in - let* counter = Context.Contract.counter (B infos.block) infos.contract1 in - let source = infos.contract1 in - let* operation = select_op ~counter ~force_reveal:true ~source kind infos in - validate_diagnostic infos operation + let* infos = default_init_ctxt () in + let* counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + counter = Some counter; + } + infos + in + let* _ = validate_diagnostic infos [op] in + return_unit let generate_tests_validate () = create_Tztest test_validate "Validate." subjects -- GitLab From 61315af2dd8af3da69883d38568e21b27c07afec Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Mon, 27 Jun 2022 16:00:52 +0200 Subject: [PATCH 06/11] Proto/tests: add pretty printer in validate helpers Co-authored-by: Zaynah Dargaye --- .../lib_protocol/test/helpers/op.ml | 9 ++ .../lib_protocol/test/helpers/op.mli | 3 + .../validate/manager_operation_helpers.ml | 131 +++++++++++++----- .../lib_protocol/test/helpers/op.ml | 9 ++ .../lib_protocol/test/helpers/op.mli | 3 + .../validate/manager_operation_helpers.ml | 130 ++++++++++++----- 6 files changed, 217 insertions(+), 68 deletions(-) diff --git a/src/proto_014_PtKathma/lib_protocol/test/helpers/op.ml b/src/proto_014_PtKathma/lib_protocol/test/helpers/op.ml index c3e183a50dfe..ccef199cec1e 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/helpers/op.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/helpers/op.ml @@ -170,6 +170,15 @@ let resolve_gas_limit ctxt = function | Zero -> return Gas.Arith.zero | Custom_gas x -> return x +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: %a" Gas.Arith.pp_integral default_low_gas_limit + | 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) ; diff --git a/src/proto_014_PtKathma/lib_protocol/test/helpers/op.mli b/src/proto_014_PtKathma/lib_protocol/test/helpers/op.mli index c2aa30bfd275..d4e2d7bf3fe6 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/helpers/op.mli +++ b/src/proto_014_PtKathma/lib_protocol/test/helpers/op.mli @@ -69,6 +69,9 @@ type gas_limit = | 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:Z.t -> diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml index 4a55cda23778..f78b55804060 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -149,6 +149,100 @@ let operation_req_default kind = amount = None; } +(** {2 String of datatypes} *) + +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_Origination -> "Origination" + | K_Register_global_constant -> "Register global constant" + | K_Reveal -> "Revelation" + | K_Increase_paid_storage -> "Increase paid storage" + | K_Tx_rollup_origination -> "Tx_rollup_origination" + | K_Tx_rollup_submit_batch -> "Tx_rollup_submit_batch" + | K_Tx_rollup_commit -> "Tx_rollup_commit" + | K_Tx_rollup_return_bond -> "Tx_rollup_return_bond" + | K_Tx_rollup_finalize -> "Tx_rollup_finalize" + | K_Tx_rollup_remove_commitment -> "Tx_rollup_remove_commitment" + | K_Tx_rollup_dispatch_tickets -> "Tx_rollup_dispatch_tickets" + | K_Tx_rollup_reject -> "Tx_rollup_reject" + | 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" + +(** {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 Z.pp_print) + 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_ctxt_req pp + {hard_gas_limit_per_block; fund_src; fund_dest; fund_del; fund_tx; fund_sc} + = + Format.fprintf + pp + "@[Ctxt_req:@,\ + hard_gas_limit_per_block:%a@,\ + fund_src: %a tz@,\ + fund_dest: %a tz@,\ + fund_del: %a tz@,\ + fund_tx: %a tz@,\ + fund_sc: %a tz@,\ + @]" + (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 + (pp_opt Tez.pp) + fund_tx + (pp_opt Tez.pp) + fund_sc + +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 @@ -851,35 +945,6 @@ let mk_dal_publish_slot_header (oinfos : operation_req) (infos : infos) = (** {2 Helpers for generation of generic check tests by manager operation} *) -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_Origination -> "Origination" - | K_Register_global_constant -> "Register global constant" - | K_Increase_paid_storage -> "Increase paid storage" - | K_Reveal -> "Revelation" - | K_Tx_rollup_origination -> "Tx_rollup_origination" - | K_Tx_rollup_submit_batch -> "Tx_rollup_submit_batch" - | K_Tx_rollup_commit -> "Tx_rollup_commit" - | K_Tx_rollup_return_bond -> "Tx_rollup_return_bond" - | K_Tx_rollup_finalize -> "Tx_rollup_finalize" - | K_Tx_rollup_remove_commitment -> "Tx_rollup_remove_commitment" - | K_Tx_rollup_dispatch_tickets -> "Tx_rollup_dispatch_tickets" - | K_Tx_rollup_reject -> "Tx_rollup_reject" - | 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" - (** 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) = @@ -916,16 +981,14 @@ let select_op (op_req : operation_req) (infos : infos) = mk_op op_req infos let create_Tztest ?hd_msg test tests_msg operations = - let hd_msg k = + let tl_msg k = let sk = kind_to_string k in - match hd_msg with - | None -> sk - | Some hd -> Format.sprintf "Batch: %s, %s" hd sk + match hd_msg with None -> sk | Some hd -> Format.sprintf "%s, %s" hd sk in List.map (fun kind -> Tztest.tztest - (Format.sprintf "%s with %s" (hd_msg kind) tests_msg) + (Format.sprintf "%s [%s]" tests_msg (tl_msg kind)) `Quick (fun () -> test kind ())) operations diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.ml b/src/proto_alpha/lib_protocol/test/helpers/op.ml index b06aa3c76c1a..ffc6e2daadfc 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/op.ml @@ -170,6 +170,15 @@ let resolve_gas_limit ctxt = function | Zero -> return Gas.Arith.zero | Custom_gas x -> return x +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: %a" Gas.Arith.pp_integral default_low_gas_limit + | 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) ; diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.mli b/src/proto_alpha/lib_protocol/test/helpers/op.mli index 951547cd2ab9..c96b2140df28 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/op.mli @@ -69,6 +69,9 @@ type gas_limit = | 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:Z.t -> diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml b/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml index cf11000fb57d..0b4ddb24c060 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -147,6 +147,99 @@ let operation_req_default kind = 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_Origination -> "Origination" + | K_Register_global_constant -> "Register global constant" + | K_Increase_paid_storage -> "Increase paid storage" + | K_Reveal -> "Revelation" + | K_Tx_rollup_origination -> "Tx_rollup_origination" + | K_Tx_rollup_submit_batch -> "Tx_rollup_submit_batch" + | K_Tx_rollup_commit -> "Tx_rollup_commit" + | K_Tx_rollup_return_bond -> "Tx_rollup_return_bond" + | K_Tx_rollup_finalize -> "Tx_rollup_finalize" + | K_Tx_rollup_remove_commitment -> "Tx_rollup_remove_commitment" + | K_Tx_rollup_dispatch_tickets -> "Tx_rollup_dispatch_tickets" + | K_Tx_rollup_reject -> "Tx_rollup_reject" + | 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" + +(** {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 Z.pp_print) + 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_ctxt_req pp + {hard_gas_limit_per_block; fund_src; fund_dest; fund_del; fund_tx; fund_sc} + = + Format.fprintf + pp + "@[Ctxt_req:@,\ + hard_gas_limit_per_block:%a@,\ + fund_src: %a tz@,\ + fund_dest: %a tz@,\ + fund_del: %a tz@,\ + fund_tx: %a tz@,\ + fund_sc: %a tz@,\ + @]" + (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 + (pp_opt Tez.pp) + fund_tx + (pp_opt Tez.pp) + fund_sc + +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 @@ -840,35 +933,6 @@ let mk_dal_publish_slot_header (oinfos : operation_req) (infos : infos) = (** {2 Helpers for generation of generic check tests by manager operation} *) -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_Origination -> "Origination" - | K_Register_global_constant -> "Register global constant" - | K_Increase_paid_storage -> "Increase paid storage" - | K_Reveal -> "Revelation" - | K_Tx_rollup_origination -> "Tx_rollup_origination" - | K_Tx_rollup_submit_batch -> "Tx_rollup_submit_batch" - | K_Tx_rollup_commit -> "Tx_rollup_commit" - | K_Tx_rollup_return_bond -> "Tx_rollup_return_bond" - | K_Tx_rollup_finalize -> "Tx_rollup_finalize" - | K_Tx_rollup_remove_commitment -> "Tx_rollup_remove_commitment" - | K_Tx_rollup_dispatch_tickets -> "Tx_rollup_dispatch_tickets" - | K_Tx_rollup_reject -> "Tx_rollup_reject" - | 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" - (** 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) = @@ -905,16 +969,14 @@ let select_op (op_req : operation_req) (infos : infos) = mk_op op_req infos let create_Tztest ?hd_msg test tests_msg operations = - let hd_msg k = + let tl_msg k = let sk = kind_to_string k in - match hd_msg with - | None -> sk - | Some hd -> Format.sprintf "Batch: %s, %s" hd sk + match hd_msg with None -> sk | Some hd -> Format.sprintf "%s, %s" hd sk in List.map (fun kind -> Tztest.tztest - (Format.sprintf "%s with %s" (hd_msg kind) tests_msg) + (Format.sprintf "%s [%s]" tests_msg (tl_msg kind)) `Quick (fun () -> test kind ())) operations -- GitLab From 7ed4ec09a9e4cc2b7b5b0444b3873407dfa7f78a Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 8 Jul 2022 11:55:21 +0200 Subject: [PATCH 07/11] lib_test: add qcheck_make_result in qcheck2_helpers --- src/lib_test/qcheck2_helpers.ml | 18 ++++++++++++++++++ src/lib_test/qcheck2_helpers.mli | 15 +++++++++++++++ 2 files changed, 33 insertions(+) diff --git a/src/lib_test/qcheck2_helpers.ml b/src/lib_test/qcheck2_helpers.ml index 285f9d595563..d78ca281a5e4 100644 --- a/src/lib_test/qcheck2_helpers.ml +++ b/src/lib_test/qcheck2_helpers.ml @@ -26,6 +26,24 @@ let qcheck_wrap ?verbose ?long ?rand = List.map (QCheck_alcotest.to_alcotest ?verbose ?long ?rand) +let qcheck_make_result ?count ?print ?pp_error ?check ~name + ~(gen : 'a QCheck2.Gen.t) (f : 'a -> (bool, 'b) result) = + let check = + match check with + | Some check -> check + | None -> ( + function + | Ok b -> b + | Error err -> ( + match pp_error with + | Some pp_error -> + QCheck2.Test.fail_reportf "Test failed:@,%a" pp_error err + | None -> + QCheck2.Test.fail_reportf + "Test failed but no pretty printer was provided.")) + in + QCheck2.Test.make ~name ?print ?count gen (fun x -> f x |> check) + let qcheck_eq ?pp ?cmp ?eq expected actual = let pass = match (eq, cmp) with diff --git a/src/lib_test/qcheck2_helpers.mli b/src/lib_test/qcheck2_helpers.mli index 879c13337ccd..05f411e6c8a7 100644 --- a/src/lib_test/qcheck2_helpers.mli +++ b/src/lib_test/qcheck2_helpers.mli @@ -31,6 +31,21 @@ val qcheck_wrap : QCheck2.Test.t list -> unit Alcotest.test_case list +(** [qcheck_make_result ?print ?pp_error ?count ?check ~name ~gen f] + is a wrapper around {!QCheck2.Test.make} where [f] returns a + result type. If [check] is not provided and if the result of [f] is + an error, {!Qcheck2.Test.fail_reportf} is called and the error is + shown if [pp_error] is provided. *) +val qcheck_make_result : + ?count:int -> + ?print:'a QCheck2.Print.t -> + ?pp_error:(Format.formatter -> 'b -> unit) -> + ?check:((bool, 'b) result -> bool) -> + name:string -> + gen:'a QCheck2.Gen.t -> + ('a -> (bool, 'b) result) -> + QCheck2.Test.t + (** [qcheck_eq_tests ~eq ~gen ~eq_name] returns three tests of [eq]: reflexivity, symmetry, and transitivity. -- GitLab From 90df77c10225437a20431e75b31bb81e6eed1405 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Mon, 27 Jun 2022 15:06:58 +0200 Subject: [PATCH 08/11] Proto/tests: provide generators for using qcheck2 Co-authored-by: Zaynah Dargaye --- manifest/main.ml | 1 + opam/tezos-protocol-014-PtKathma-tests.opam | 2 +- opam/tezos-protocol-alpha-tests.opam | 2 +- .../test/integration/validate/dune | 1 + .../test/integration/validate/generators.ml | 234 ++++++++++++++++++ .../validate/test_1m_restriction.ml | 59 +++++ .../test/integration/validate/dune | 1 + .../test/integration/validate/generators.ml | 234 ++++++++++++++++++ .../validate/test_1m_restriction.ml | 59 +++++ 9 files changed, 591 insertions(+), 2 deletions(-) create mode 100644 src/proto_014_PtKathma/lib_protocol/test/integration/validate/generators.ml create mode 100644 src/proto_alpha/lib_protocol/test/integration/validate/generators.ml diff --git a/manifest/main.ml b/manifest/main.ml index 4b42f76b9faa..f0ab1f97d4a3 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -3268,6 +3268,7 @@ end = struct octez_base |> open_ ~m:"TzPervasives" |> open_ ~m:"TzPervasives.Error_monad.Legacy_monad_globals"; main |> open_; + qcheck_alcotest; client |> if_some |> open_; test_helpers |> if_some |> open_; octez_base_test_helpers |> open_; diff --git a/opam/tezos-protocol-014-PtKathma-tests.opam b/opam/tezos-protocol-014-PtKathma-tests.opam index 5cf1b84e0072..133d4d2e2812 100644 --- a/opam/tezos-protocol-014-PtKathma-tests.opam +++ b/opam/tezos-protocol-014-PtKathma-tests.opam @@ -20,10 +20,10 @@ depends: [ "tezos-micheline" {with-test} "tezos-benchmark-014-PtKathma" {with-test} "tezos-benchmark-type-inference-014-PtKathma" {with-test} + "qcheck-alcotest" { with-test & >= "0.18" } "tezos-context" {with-test} "tezos-test-helpers" {with-test} "alcotest" { with-test & >= "1.5.0" } - "qcheck-alcotest" { with-test & >= "0.18" } "tezos-client-base" {with-test} "tezos-protocol-environment" {with-test} "tezos-stdlib-unix" {with-test} diff --git a/opam/tezos-protocol-alpha-tests.opam b/opam/tezos-protocol-alpha-tests.opam index 576a88839805..495c0121aa9a 100644 --- a/opam/tezos-protocol-alpha-tests.opam +++ b/opam/tezos-protocol-alpha-tests.opam @@ -20,10 +20,10 @@ depends: [ "tezos-micheline" {with-test} "tezos-benchmark-alpha" {with-test} "tezos-benchmark-type-inference-alpha" {with-test} + "qcheck-alcotest" { with-test & >= "0.18" } "tezos-context" {with-test} "tezos-test-helpers" {with-test} "alcotest" { with-test & >= "1.5.0" } - "qcheck-alcotest" { with-test & >= "0.18" } "tezos-client-base" {with-test} "tezos-protocol-environment" {with-test} "tezos-stdlib-unix" {with-test} diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/dune b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/dune index 0aab47b27e37..538f261f856a 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/dune +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/dune @@ -7,6 +7,7 @@ alcotest-lwt tezos-base tezos-protocol-014-PtKathma + qcheck-alcotest tezos-client-014-PtKathma tezos-014-PtKathma-test-helpers tezos-base-test-helpers) diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/generators.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/generators.ml new file mode 100644 index 000000000000..ccffc0de3011 --- /dev/null +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/generators.ml @@ -0,0 +1,234 @@ +(*****************************************************************************) +(* *) +(* 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; + tx_cstrs : cstrs; + sc_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; + tx_cstrs = default_cstrs; + sc_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 counter and 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 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_z 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 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; + tx_cstrs; + sc_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_tx = gen_tez tx_cstrs in + let+ fund_sc = gen_tez sc_cstrs in + {hard_gas_limit_per_block; fund_src; fund_dest; fund_del; fund_tx; fund_sc} + +(** {2 Wrappers} *) + +let wrap ~name ?print ?count ?check ~(gen : 'a QCheck2.Gen.t) + (f : 'a -> bool tzresult Lwt.t) = + Lib_test.Qcheck2_helpers.qcheck_make_result + ~name + ?print + ?count + ?check + ~pp_error:pp_print_trace + ~gen + (fun a -> Lwt_main.run (f a)) + +let wrap_mode infos op mode = validate_diagnostic ~mode infos op diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml index 943e8f554b96..61af81dce369 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml @@ -299,3 +299,62 @@ let tests = generate_valid_validate_mempool_mode (); generate_valid_context_free_mempool_mode (); ] + +open Generators + +let contract_of (account : Account.t) = Contract.Implicit account.pkh + +let positive_validated_op () = + let op_cstrs = + { + default_operation_cstrs with + fee = Range {min = 0; max = 1_000; origin = 1_000}; + force_reveal = Some true; + amount = Range {min = 0; max = 1_000; origin = 10_000}; + } + in + let ctxt_cstrs = + { + default_ctxt_cstrs with + src_cstrs = Greater {n = 15_000; origin = 15_000}; + dest_cstrs = Pure 15000; + del_cstrs = Pure 15000; + tx_cstrs = Pure 15000; + sc_cstrs = Pure 15000; + } + in + let gen = + QCheck2.Gen.triple + (Generators.gen_ctxt_req ctxt_cstrs) + (Generators.gen_operation_req op_cstrs subjects) + Generators.gen_mode + in + let print (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 + in + wrap + ~count:1000 + ~print + ~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) + +open Lib_test.Qcheck2_helpers + +let positive_tests () = qcheck_wrap [positive_validated_op ()] + +let qcheck_tests () = ("Positive tests", positive_tests ()) + +let () = Alcotest.run "1M QCheck" [qcheck_tests ()] diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/dune b/src/proto_alpha/lib_protocol/test/integration/validate/dune index ebb763391fb8..1482bc72589e 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/dune +++ b/src/proto_alpha/lib_protocol/test/integration/validate/dune @@ -7,6 +7,7 @@ alcotest-lwt tezos-base tezos-protocol-alpha + qcheck-alcotest tezos-client-alpha tezos-alpha-test-helpers tezos-base-test-helpers) diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml b/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml new file mode 100644 index 000000000000..ccffc0de3011 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml @@ -0,0 +1,234 @@ +(*****************************************************************************) +(* *) +(* 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; + tx_cstrs : cstrs; + sc_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; + tx_cstrs = default_cstrs; + sc_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 counter and 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 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_z 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 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; + tx_cstrs; + sc_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_tx = gen_tez tx_cstrs in + let+ fund_sc = gen_tez sc_cstrs in + {hard_gas_limit_per_block; fund_src; fund_dest; fund_del; fund_tx; fund_sc} + +(** {2 Wrappers} *) + +let wrap ~name ?print ?count ?check ~(gen : 'a QCheck2.Gen.t) + (f : 'a -> bool tzresult Lwt.t) = + Lib_test.Qcheck2_helpers.qcheck_make_result + ~name + ?print + ?count + ?check + ~pp_error:pp_print_trace + ~gen + (fun a -> Lwt_main.run (f a)) + +let wrap_mode infos op mode = validate_diagnostic ~mode infos op diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml b/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml index 2feae36dfe82..eb42336975a0 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml @@ -299,3 +299,62 @@ let tests = generate_valid_validate_mempool_mode (); generate_valid_context_free_mempool_mode (); ] + +open Generators + +let contract_of (account : Account.t) = Contract.Implicit account.pkh + +let positive_validated_op () = + let op_cstrs = + { + default_operation_cstrs with + fee = Range {min = 0; max = 1_000; origin = 1_000}; + force_reveal = Some true; + amount = Range {min = 0; max = 1_000; origin = 10_000}; + } + in + let ctxt_cstrs = + { + default_ctxt_cstrs with + src_cstrs = Greater {n = 15_000; origin = 15_000}; + dest_cstrs = Pure 15000; + del_cstrs = Pure 15000; + tx_cstrs = Pure 15000; + sc_cstrs = Pure 15000; + } + in + let gen = + QCheck2.Gen.triple + (Generators.gen_ctxt_req ctxt_cstrs) + (Generators.gen_operation_req op_cstrs subjects) + Generators.gen_mode + in + let print (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 + in + wrap + ~count:1000 + ~print + ~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) + +open Lib_test.Qcheck2_helpers + +let positive_tests () = qcheck_wrap [positive_validated_op ()] + +let qcheck_tests () = ("Positive tests", positive_tests ()) + +let () = Alcotest.run "1M QCheck" [qcheck_tests ()] -- GitLab From b4d2ff18f282bd4e61d6318661f2e2e726813cff Mon Sep 17 00:00:00 2001 From: Zaynah Dargaye Date: Mon, 27 Jun 2022 19:44:34 +0200 Subject: [PATCH 09/11] Proto/tests: replace 1m restriction unit tests by pbt tests Co-authored-by: Albin Coquereau --- manifest/main.ml | 4 +- .../test/integration/validate/dune | 9 +- .../test/integration/validate/generators.ml | 21 + .../test/integration/validate/main.ml | 1 - .../validate/manager_operation_helpers.ml | 9 + .../validate/test_1m_restriction.ml | 482 +++++++---------- .../test/integration/validate/dune | 9 +- .../test/integration/validate/generators.ml | 21 + .../test/integration/validate/main.ml | 1 - .../validate/manager_operation_helpers.ml | 9 + .../validate/test_1m_restriction.ml | 484 +++++++----------- 11 files changed, 441 insertions(+), 609 deletions(-) diff --git a/manifest/main.ml b/manifest/main.ml index f0ab1f97d4a3..ee2dbb45c8fc 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -3258,8 +3258,8 @@ end = struct in let _integration_validate = only_if N.(number >= 014) @@ fun () -> - test - "main" + tests + ["main"; "test_1m_restriction"] ~path:(path // "lib_protocol/test/integration/validate") ~opam:(sf "tezos-protocol-%s-tests" name_dash) ~deps: diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/dune b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/dune index 538f261f856a..9e56b2994a37 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/dune +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/dune @@ -1,8 +1,8 @@ ; This file was automatically generated, do not edit. ; Edit file manifest/main.ml instead. -(executable - (name main) +(executables + (names main test_1m_restriction) (libraries alcotest-lwt tezos-base @@ -24,3 +24,8 @@ (alias runtest) (package tezos-protocol-014-PtKathma-tests) (action (run %{dep:./main.exe}))) + +(rule + (alias runtest) + (package tezos-protocol-014-PtKathma-tests) + (action (run %{dep:./test_1m_restriction.exe}))) diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/generators.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/generators.ml index ccffc0de3011..4cd5f6bfacd9 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/generators.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/generators.ml @@ -199,6 +199,27 @@ let gen_operation_req : 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 -> Z.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 { diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml index d47ce8f6969a..445200746450 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml @@ -46,6 +46,5 @@ let () = Test_batched_manager_operation_validation.gas_tests ); ( "Batched: fees checks", Test_batched_manager_operation_validation.fee_tests ); - ("1M: 1m restriction", Test_1m_restriction.tests); ] |> Lwt_main.run diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml index f78b55804060..ba7a98813d51 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -212,6 +212,15 @@ let pp_operation_req pp (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; fund_tx; fund_sc} = diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml index 61af81dce369..6950d40876ae 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml @@ -27,334 +27,216 @@ ------- Component: Protocol (validate manager) Invocation: dune exec \ - src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.exe \ - -- test "^1M" + src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.exe Subject: 1M restriction in validation of manager operation. *) open Protocol -open Alpha_context open Manager_operation_helpers +open Generators -(* Temporary local helpers to be clean up. *) -let create_Tztest ?hd_msg test tests_msg = - let hd_msg k = - let sk = kind_to_string k in - match hd_msg with None -> sk | Some hd -> Format.sprintf "%s, %s" sk hd - in - let kind = K_Register_global_constant in - Tztest.tztest - (Format.sprintf "%s [%s]" tests_msg (hd_msg kind)) - `Quick - (fun () -> test kind ()) - -let generate_op ~fee ~reverse:_ kind infos = - let open Lwt_result_syntax in - let* counter = - Context.Contract.counter - (B infos.ctxt.block) - (contract_of infos.accounts.source) - in - let* operation = - select_op - { - (operation_req_default kind) with - force_reveal = Some true; - fee = Some fee; - counter = Some counter; - } - infos - in - let+ operation2 = - select_op - { - (operation_req_default kind) with - force_reveal = Some false; - fee = Some fee; - counter = Some (Z.succ (Z.succ counter)); - } - infos - in - (operation, operation2) +(** Local default values for the tests. *) +let ctxt_cstrs_default = + { + default_ctxt_cstrs with + src_cstrs = Greater {n = 15000; origin = 15000}; + dest_cstrs = Pure 15000; + del_cstrs = Pure 15000; + tx_cstrs = Pure 15000; + sc_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 -let generate_op_diff_man ~fee ~reverse:_ kind infos = - let open Lwt_result_syntax in - let source = contract_of infos.accounts.source in - let source2_account = - match infos.accounts.del with None -> assert false | Some s -> s - in - let source2 = contract_of source2_account in - let* counter = Context.Contract.counter (B infos.ctxt.block) source in - let* operation = - select_op - { - (operation_req_default kind) with - force_reveal = Some true; - fee = Some fee; - counter = Some counter; - } - infos - in - let* counter = Context.Contract.counter (B infos.ctxt.block) source2 in - let+ operation2 = - select_op - { - (operation_req_default kind) with - force_reveal = Some true; - fee = Some fee; - counter = Some counter; - } - {infos with accounts = {infos.accounts with source = source2_account}} +(** The application of a valid operation succeeds, at least, to perform + the fee payment. *) +let positive_validated_op = + 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 - (operation, operation2) + wrap + ~count:1000 + ~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 test_two_op_with_same_manager ~mempool_mode kind () = - let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let* op1, op2 = generate_op ~fee:Tez.zero ~reverse:false kind infos in - let* inc = Incremental.begin_construction ~mempool_mode infos.ctxt.block in - let* inc = Incremental.validate_operation inc op1 in - let* _inc = - Incremental.validate_operation - inc - ~expect_failure:(function - | [ - Environment.Ecoproto_error - (Validate_operation.Manager.Manager_restriction _); - ] -> - return_unit - | err -> - failwith - "Error trace:@,\ - \ %a does not match the \ - [Validate_operation.Manager.Manager_restriction]" - Error_monad.pp_print_trace - err) - op2 + pool should contain two operations with the same manager. It + raises a Manager_restriction error. *) +let negative_validated_two_ops_of_same_manager = + 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 - return_unit - -(** Under 1M restriction, a batch of two operations cannot be replaced - by two single operations. *) -let test_batch_of_two_not_be_two_singles ~mempool_mode kind () = - let open Lwt_result_syntax in - let mode = if mempool_mode then Mempool else Construction in - let* infos = default_init_ctxt () in - let source = contract_of infos.accounts.source in - let* inc = Incremental.begin_construction ~mempool_mode infos.ctxt.block in - let* op1, op2 = generate_op ~fee:Tez.one_mutez ~reverse:false kind infos in - let* batch = Op.batch_operations ~source (B infos.ctxt.block) [op1; op2] in - let* inc_batch = Incremental.validate_operation inc batch in - let* () = observe ~only_validate:false ~mode (I inc) (I inc_batch) batch in - let* inc1 = Incremental.validate_operation inc op1 in - let* () = observe ~only_validate:false ~mode (I inc) (I inc1) op1 in - let* _inc2 = - Incremental.validate_operation - ~expect_failure:(fun _ -> return_unit) - inc - op2 + let expect_failure = function + | [ + Environment.Ecoproto_error + (Validate_operation.Manager.Manager_restriction _); + ] -> + return_unit + | err -> + failwith + "Error trace:@,\ + \ %a does not match the \ + [Validate_operation.Manager.Manager_restriction] error" + Error_monad.pp_print_trace + err in - let* b1 = Incremental.finalize_block inc1 in - let* inc1' = Incremental.begin_construction ~mempool_mode b1 in - let* inc1_op2 = Incremental.validate_operation inc1' op2 in - let* () = observe ~only_validate:false ~mode (I inc1') (I inc1_op2) op2 in - return_unit + wrap + ~count:1000 + ~print:print_two_ops + ~name:"Negative -- 1M" + ~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) -(** The application of a valid operation succeeds, at least, to perform - the fee payment. *) -let valid_validate ~mempool_mode kind () = - let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let* inc = Incremental.begin_construction ~mempool_mode infos.ctxt.block in - let* op, _ = generate_op ~fee:Tez.one_mutez ~reverse:false kind infos in - let {shell; protocol_data = Operation_data protocol_data} = op in - let operation : _ Alpha_context.operation = {shell; protocol_data} in - let oph = Alpha_context.Operation.hash operation in - let init_infos, init_state = - Validate_operation.init_info_and_state - (Incremental.alpha_ctxt inc) - Validate_operation.Mempool - Chain_id.zero - in - let _res1 = - Validate_operation.validate_operation init_infos init_state oph operation +(** Under 1M restriction, a batch of two operations cannot be replaced + by two single operations. *) +let negative_batch_of_two_is_not_two_single = + 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* _ = Incremental.validate_operation inc op in - return_unit + let expect_failure _ = return_unit in + wrap + ~count:1000 + ~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 infos.accounts.source in + let* batch = + Op.batch_operations ~source (B infos.ctxt.block) [op1; op2] + in + let* _ = 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. - - The application of a manager operation has two step: the fees - payment guarded by the validation and the rest of its application. - Two manager operations that are valid in a context, will succeed to - pass the first step of their application -- aka fee payment -- in - whatever application order. - - By construction they have distinct manager thanks to - [generate_op_diff_man]. *) -let valid_context_free ~mempool_mode kind () = - let open Lwt_result_syntax in - let mode = if mempool_mode then Mempool else Construction in - - let* infos = default_init_ctxt () in - let* inc = Incremental.begin_construction ~mempool_mode infos.ctxt.block in - let* op1, op2 = - generate_op_diff_man ~fee:Tez.one_mutez ~reverse:false kind infos - in - let {shell; protocol_data = Operation_data protocol_data} = op1 in - let operation1 : _ Alpha_context.operation = {shell; protocol_data} in - let oph1 = Alpha_context.Operation.hash operation1 in - let {shell; protocol_data = Operation_data protocol_data} = op2 in - let operation2 : _ Alpha_context.operation = {shell; protocol_data} in - let oph2 = Alpha_context.Operation.hash operation2 in - let init_infos, init_state = - Validate_operation.init_info_and_state - (Incremental.alpha_ctxt inc) - Validate_operation.Mempool - Chain_id.zero - in - let* _res1 = - let*! res = - Validate_operation.validate_operation - init_infos - init_state - oph1 - operation1 - in - Lwt.return (Environment.wrap_tzresult res) - in - let* _res2 = - let*! res = - Validate_operation.validate_operation - init_infos - init_state - oph2 - operation2 - in - Lwt.return (Environment.wrap_tzresult res) - in - let* inc1 = Incremental.validate_operation inc op1 in - let* () = observe ~only_validate:false ~mode (I inc) (I inc1) op1 in - let* inc1' = Incremental.validate_operation inc1 op2 in - let* () = observe ~only_validate:false ~mode (I inc1) (I inc1') op2 in - let* inc2 = Incremental.validate_operation inc op2 in - let* () = observe ~only_validate:false ~mode (I inc) (I inc2) op2 in - let* inc2' = Incremental.validate_operation inc2 op1 in - let* () = observe ~only_validate:false ~mode (I inc2) (I inc2') op1 in - return_unit - -let generate_1m_conflit_mempool_mode () = - create_Tztest - (test_two_op_with_same_manager ~mempool_mode:true) - "At most one operation per manager in mempool mode" - -let generate_1m_conflit_construction_mode () = - create_Tztest - (test_two_op_with_same_manager ~mempool_mode:false) - "At most one operation per manager in construction mode" - -let generate_batch_of_two_not_be_two_singles_construction_mode () = - create_Tztest - (test_batch_of_two_not_be_two_singles ~mempool_mode:false) - "A batch differs from a sequence in construction mode" - -let generate_batch_of_two_not_be_two_singles_mempool_mode () = - create_Tztest - (test_batch_of_two_not_be_two_singles ~mempool_mode:true) - "A batch differs from a sequence in mempool mode" - -let generate_valid_validate_mempool_mode () = - create_Tztest - (valid_validate ~mempool_mode:true) - "Valid implies fee payment in mempool mode" - -let generate_valid_validate_construction_mode () = - create_Tztest - (valid_validate ~mempool_mode:false) - "Valid implies fee payment in construction mode" - -let generate_valid_context_free_mempool_mode () = - create_Tztest - (valid_context_free ~mempool_mode:true) - "Fee payment of two covalid operations commute in mempool mode" - -let generate_valid_context_free_construction_mode () = - create_Tztest - (valid_context_free ~mempool_mode:false) - "Fee payment of two covalid operations commute in construction mode" - -let tests = - [ - generate_1m_conflit_construction_mode (); - generate_batch_of_two_not_be_two_singles_construction_mode (); - generate_valid_validate_construction_mode (); - generate_valid_context_free_construction_mode (); - generate_1m_conflit_mempool_mode (); - generate_batch_of_two_not_be_two_singles_mempool_mode (); - generate_valid_validate_mempool_mode (); - generate_valid_context_free_mempool_mode (); - ] - -open Generators - -let contract_of (account : Account.t) = Contract.Implicit account.pkh - -let positive_validated_op () = - let op_cstrs = - { - default_operation_cstrs with - fee = Range {min = 0; max = 1_000; origin = 1_000}; - force_reveal = Some true; - amount = Range {min = 0; max = 1_000; origin = 10_000}; - } - in - let ctxt_cstrs = - { - default_ctxt_cstrs with - src_cstrs = Greater {n = 15_000; origin = 15_000}; - dest_cstrs = Pure 15000; - del_cstrs = Pure 15000; - tx_cstrs = Pure 15000; - sc_cstrs = Pure 15000; - } - in + application order. *) +let valid_context_free = let gen = - QCheck2.Gen.triple - (Generators.gen_ctxt_req ctxt_cstrs) - (Generators.gen_operation_req op_cstrs subjects) + 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 - let print (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 - in wrap ~count:1000 - ~print - ~name:"Positive validated op" + ~print:print_two_ops + ~name:"Under 1M, co-valid ops commute" ~gen - (fun (ctxt_req, operation_req, mode) -> + (fun (ctxt_req, operation_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 + let* op1 = select_op operation_req infos in + let infos2 = + { + infos with + accounts = + { + infos.accounts with + source = + (match infos.accounts.del with + | None -> assert false + | Some s -> s); + }; + } + in + let* op2 = select_op operation_req' infos2 in + let* _ = validate_diagnostic ~mode infos [op1; op2] in + let* _ = validate_diagnostic ~mode infos [op2; op1] in return_true) open Lib_test.Qcheck2_helpers -let positive_tests () = qcheck_wrap [positive_validated_op ()] +let positive_tests = qcheck_wrap [positive_validated_op] + +let two_op_from_same_manager_tests = + qcheck_wrap [negative_validated_two_ops_of_same_manager] + +let batch_is_not_singles_tests = + qcheck_wrap [negative_batch_of_two_is_not_two_single] + +let conflict_free_tests = qcheck_wrap [valid_context_free] + +let qcheck_tests = ("Positive tests", positive_tests) + +let qcheck_tests2 = + ("Only one manager op per manager", two_op_from_same_manager_tests) + +let qcheck_tests3 = + ("A batch differs from a sequence", batch_is_not_singles_tests) -let qcheck_tests () = ("Positive tests", positive_tests ()) +let qcheck_tests4 = + ("Fee payment of two covalid operations commute", conflict_free_tests) -let () = Alcotest.run "1M QCheck" [qcheck_tests ()] +let () = + Alcotest.run + "1M QCheck" + [qcheck_tests; qcheck_tests2; qcheck_tests3; qcheck_tests4] diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/dune b/src/proto_alpha/lib_protocol/test/integration/validate/dune index 1482bc72589e..fe89647675a8 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/dune +++ b/src/proto_alpha/lib_protocol/test/integration/validate/dune @@ -1,8 +1,8 @@ ; This file was automatically generated, do not edit. ; Edit file manifest/main.ml instead. -(executable - (name main) +(executables + (names main test_1m_restriction) (libraries alcotest-lwt tezos-base @@ -24,3 +24,8 @@ (alias runtest) (package tezos-protocol-alpha-tests) (action (run %{dep:./main.exe}))) + +(rule + (alias runtest) + (package tezos-protocol-alpha-tests) + (action (run %{dep:./test_1m_restriction.exe}))) diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml b/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml index ccffc0de3011..4cd5f6bfacd9 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml @@ -199,6 +199,27 @@ let gen_operation_req : 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 -> Z.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 { diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/main.ml b/src/proto_alpha/lib_protocol/test/integration/validate/main.ml index 3e64e87b8bfb..f7dd004ffd5e 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/main.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/main.ml @@ -46,6 +46,5 @@ let () = Test_batched_manager_operation_validation.gas_tests ); ( "Batched: fees checks", Test_batched_manager_operation_validation.fee_tests ); - ("1M: 1m restriction", Test_1m_restriction.tests); ] |> Lwt_main.run diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml b/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml index 0b4ddb24c060..449c6023a14e 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -209,6 +209,15 @@ let pp_operation_req pp (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; fund_tx; fund_sc} = diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml b/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml index eb42336975a0..18c261fb070d 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml @@ -27,334 +27,216 @@ ------- Component: Protocol (validate manager) Invocation: dune exec \ - src/proto_alpha/lib_protocol/test/integration/validate/main.exe \ - -- test "^1M" + src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.exe Subject: 1M restriction in validation of manager operation. *) open Protocol -open Alpha_context open Manager_operation_helpers +open Generators -(* Temporary local helpers to be clean up. *) -let create_Tztest ?hd_msg test tests_msg = - let hd_msg k = - let sk = kind_to_string k in - match hd_msg with None -> sk | Some hd -> Format.sprintf "%s, %s" sk hd - in - let kind = K_Register_global_constant in - Tztest.tztest - (Format.sprintf "%s [%s]" tests_msg (hd_msg kind)) - `Quick - (fun () -> test kind ()) - -let generate_op ~fee ~reverse:_ kind infos = - let open Lwt_result_syntax in - let* counter = - Context.Contract.counter - (B infos.ctxt.block) - (contract_of infos.accounts.source) - in - let* operation = - select_op - { - (operation_req_default kind) with - force_reveal = Some true; - fee = Some fee; - counter = Some counter; - } - infos - in - let+ operation2 = - select_op - { - (operation_req_default kind) with - force_reveal = Some false; - fee = Some fee; - counter = Some (Z.succ (Z.succ counter)); - } - infos - in - (operation, operation2) +(** Local default values for the tests. *) +let ctxt_cstrs_default = + { + default_ctxt_cstrs with + src_cstrs = Greater {n = 15000; origin = 15000}; + dest_cstrs = Pure 15000; + del_cstrs = Pure 15000; + tx_cstrs = Pure 15000; + sc_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 -let generate_op_diff_man ~fee ~reverse:_ kind infos = - let open Lwt_result_syntax in - let source = contract_of infos.accounts.source in - let source2_account = - match infos.accounts.del with None -> assert false | Some s -> s - in - let source2 = contract_of source2_account in - let* counter = Context.Contract.counter (B infos.ctxt.block) source in - let* operation = - select_op - { - (operation_req_default kind) with - force_reveal = Some true; - fee = Some fee; - counter = Some counter; - } - infos - in - let* counter = Context.Contract.counter (B infos.ctxt.block) source2 in - let+ operation2 = - select_op - { - (operation_req_default kind) with - force_reveal = Some true; - fee = Some fee; - counter = Some counter; - } - {infos with accounts = {infos.accounts with source = source2_account}} +(** The application of a valid operation succeeds, at least, to perform + the fee payment. *) +let positive_validated_op = + 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 - (operation, operation2) + wrap + ~count:1000 + ~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 test_two_op_with_same_manager ~mempool_mode kind () = - let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let* op1, op2 = generate_op ~fee:Tez.zero ~reverse:false kind infos in - let* inc = Incremental.begin_construction ~mempool_mode infos.ctxt.block in - let* inc = Incremental.validate_operation inc op1 in - let* _inc = - Incremental.validate_operation - inc - ~expect_failure:(function - | [ - Environment.Ecoproto_error - (Validate_operation.Manager.Manager_restriction _); - ] -> - return_unit - | err -> - failwith - "Error trace:@,\ - \ %a does not match the \ - [Validate_operation.Manager.Manager_restriction]" - Error_monad.pp_print_trace - err) - op2 + pool should contain two operations with the same manager. It + raises a Manager_restriction error. *) +let negative_validated_two_ops_of_same_manager = + 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 - return_unit - -(** Under 1M restriction, a batch of two operations cannot be replaced - by two single operations. *) -let test_batch_of_two_not_be_two_singles ~mempool_mode kind () = - let open Lwt_result_syntax in - let mode = if mempool_mode then Mempool else Construction in - let* infos = default_init_ctxt () in - let source = contract_of infos.accounts.source in - let* inc = Incremental.begin_construction ~mempool_mode infos.ctxt.block in - let* op1, op2 = generate_op ~fee:Tez.one_mutez ~reverse:false kind infos in - let* batch = Op.batch_operations ~source (B infos.ctxt.block) [op1; op2] in - let* inc_batch = Incremental.validate_operation inc batch in - let* () = observe ~only_validate:false ~mode (I inc) (I inc_batch) batch in - let* inc1 = Incremental.validate_operation inc op1 in - let* () = observe ~only_validate:false ~mode (I inc) (I inc1) op1 in - let* _inc2 = - Incremental.validate_operation - ~expect_failure:(fun _ -> return_unit) - inc - op2 + let expect_failure = function + | [ + Environment.Ecoproto_error + (Validate_operation.Manager.Manager_restriction _); + ] -> + return_unit + | err -> + failwith + "Error trace:@,\ + \ %a does not match the \ + [Validate_operation.Manager.Manager_restriction] error" + Error_monad.pp_print_trace + err in - let* b1 = Incremental.finalize_block inc1 in - let* inc1' = Incremental.begin_construction ~mempool_mode b1 in - let* inc1_op2 = Incremental.validate_operation inc1' op2 in - let* () = observe ~only_validate:false ~mode (I inc1') (I inc1_op2) op2 in - return_unit + wrap + ~count:1000 + ~print:print_two_ops + ~name:"Negative -- 1M" + ~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) -(** The application of a valid operation succeeds, at least, to perform - the fee payment. *) -let valid_validate ~mempool_mode kind () = - let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let* inc = Incremental.begin_construction ~mempool_mode infos.ctxt.block in - let* op, _ = generate_op ~fee:Tez.one_mutez ~reverse:false kind infos in - let {shell; protocol_data = Operation_data protocol_data} = op in - let operation : _ Alpha_context.operation = {shell; protocol_data} in - let oph = Alpha_context.Operation.hash operation in - let init_infos, init_state = - Validate_operation.init_info_and_state - (Incremental.alpha_ctxt inc) - Validate_operation.Mempool - Chain_id.zero - in - let _res1 = - Validate_operation.validate_operation init_infos init_state oph operation +(** Under 1M restriction, a batch of two operations cannot be replaced + by two single operations. *) +let negative_batch_of_two_is_not_two_single = + 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* _ = Incremental.validate_operation inc op in - return_unit + let expect_failure _ = return_unit in + wrap + ~count:1000 + ~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 infos.accounts.source in + let* batch = + Op.batch_operations ~source (B infos.ctxt.block) [op1; op2] + in + let* _ = 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. - - The application of a manager operation has two step: the fees - payment guarded by the validation and the rest of its application. - Two manager operations that are valid in a context, will succeed to - pass the first step of their application -- aka fee payment -- in - whatever application order. - - By construction they have distinct manager thanks to - [generate_op_diff_man]. *) -let valid_context_free ~mempool_mode kind () = - let open Lwt_result_syntax in - let mode = if mempool_mode then Mempool else Construction in - - let* infos = default_init_ctxt () in - let* inc = Incremental.begin_construction ~mempool_mode infos.ctxt.block in - let* op1, op2 = - generate_op_diff_man ~fee:Tez.one_mutez ~reverse:false kind infos - in - let {shell; protocol_data = Operation_data protocol_data} = op1 in - let operation1 : _ Alpha_context.operation = {shell; protocol_data} in - let oph1 = Alpha_context.Operation.hash operation1 in - let {shell; protocol_data = Operation_data protocol_data} = op2 in - let operation2 : _ Alpha_context.operation = {shell; protocol_data} in - let oph2 = Alpha_context.Operation.hash operation2 in - let init_infos, init_state = - Validate_operation.init_info_and_state - (Incremental.alpha_ctxt inc) - Validate_operation.Mempool - Chain_id.zero - in - let* _res1 = - let*! res = - Validate_operation.validate_operation - init_infos - init_state - oph1 - operation1 - in - Lwt.return (Environment.wrap_tzresult res) - in - let* _res2 = - let*! res = - Validate_operation.validate_operation - init_infos - init_state - oph2 - operation2 - in - Lwt.return (Environment.wrap_tzresult res) - in - let* inc1 = Incremental.validate_operation inc op1 in - let* () = observe ~only_validate:false ~mode (I inc) (I inc1) op1 in - let* inc1' = Incremental.validate_operation inc1 op2 in - let* () = observe ~only_validate:false ~mode (I inc1) (I inc1') op2 in - let* inc2 = Incremental.validate_operation inc op2 in - let* () = observe ~only_validate:false ~mode (I inc) (I inc2) op2 in - let* inc2' = Incremental.validate_operation inc2 op1 in - let* () = observe ~only_validate:false ~mode (I inc2) (I inc2') op1 in - return_unit - -let generate_1m_conflit_mempool_mode () = - create_Tztest - (test_two_op_with_same_manager ~mempool_mode:true) - "At most one operation per manager in mempool mode" - -let generate_1m_conflit_construction_mode () = - create_Tztest - (test_two_op_with_same_manager ~mempool_mode:false) - "At most one operation per manager in construction mode" - -let generate_batch_of_two_not_be_two_singles_construction_mode () = - create_Tztest - (test_batch_of_two_not_be_two_singles ~mempool_mode:false) - "A batch differs from a sequence in construction mode" - -let generate_batch_of_two_not_be_two_singles_mempool_mode () = - create_Tztest - (test_batch_of_two_not_be_two_singles ~mempool_mode:true) - "A batch differs from a sequence in mempool mode" - -let generate_valid_validate_mempool_mode () = - create_Tztest - (valid_validate ~mempool_mode:true) - "Valid implies fee payment in mempool mode" - -let generate_valid_validate_construction_mode () = - create_Tztest - (valid_validate ~mempool_mode:false) - "Valid implies fee payment in construction mode" - -let generate_valid_context_free_mempool_mode () = - create_Tztest - (valid_context_free ~mempool_mode:true) - "Fee payment of two covalid operations commute in mempool mode" - -let generate_valid_context_free_construction_mode () = - create_Tztest - (valid_context_free ~mempool_mode:false) - "Fee payment of two covalid operations commute in construction mode" - -let tests = - [ - generate_1m_conflit_construction_mode (); - generate_batch_of_two_not_be_two_singles_construction_mode (); - generate_valid_validate_construction_mode (); - generate_valid_context_free_construction_mode (); - generate_1m_conflit_mempool_mode (); - generate_batch_of_two_not_be_two_singles_mempool_mode (); - generate_valid_validate_mempool_mode (); - generate_valid_context_free_mempool_mode (); - ] - -open Generators - -let contract_of (account : Account.t) = Contract.Implicit account.pkh - -let positive_validated_op () = - let op_cstrs = - { - default_operation_cstrs with - fee = Range {min = 0; max = 1_000; origin = 1_000}; - force_reveal = Some true; - amount = Range {min = 0; max = 1_000; origin = 10_000}; - } - in - let ctxt_cstrs = - { - default_ctxt_cstrs with - src_cstrs = Greater {n = 15_000; origin = 15_000}; - dest_cstrs = Pure 15000; - del_cstrs = Pure 15000; - tx_cstrs = Pure 15000; - sc_cstrs = Pure 15000; - } - in + succeed, at least, to perform the fee payment of both, in whatever + application order. *) +let valid_context_free = let gen = - QCheck2.Gen.triple - (Generators.gen_ctxt_req ctxt_cstrs) - (Generators.gen_operation_req op_cstrs subjects) + 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 - let print (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 - in wrap ~count:1000 - ~print - ~name:"Positive validated op" + ~print:print_two_ops + ~name:"Under 1M, co-valid ops commute" ~gen - (fun (ctxt_req, operation_req, mode) -> + (fun (ctxt_req, operation_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 + let* op1 = select_op operation_req infos in + let infos2 = + { + infos with + accounts = + { + infos.accounts with + source = + (match infos.accounts.del with + | None -> assert false + | Some s -> s); + }; + } + in + let* op2 = select_op operation_req' infos2 in + let* _ = validate_diagnostic ~mode infos [op1; op2] in + let* _ = validate_diagnostic ~mode infos [op2; op1] in return_true) open Lib_test.Qcheck2_helpers -let positive_tests () = qcheck_wrap [positive_validated_op ()] +let positive_tests = qcheck_wrap [positive_validated_op] + +let two_op_from_same_manager_tests = + qcheck_wrap [negative_validated_two_ops_of_same_manager] + +let batch_is_not_singles_tests = + qcheck_wrap [negative_batch_of_two_is_not_two_single] + +let conflict_free_tests = qcheck_wrap [valid_context_free] + +let qcheck_tests = ("Positive tests", positive_tests) + +let qcheck_tests2 = + ("Only one manager op per manager", two_op_from_same_manager_tests) + +let qcheck_tests3 = + ("A batch differs from a sequence", batch_is_not_singles_tests) -let qcheck_tests () = ("Positive tests", positive_tests ()) +let qcheck_tests4 = + ("Fee payment of two covalid operations commute", conflict_free_tests) -let () = Alcotest.run "1M QCheck" [qcheck_tests ()] +let () = + Alcotest.run + "1M QCheck" + [qcheck_tests; qcheck_tests2; qcheck_tests3; qcheck_tests4] -- GitLab From 54685b89e8b8e1af98b4d1a2792600db96abef18 Mon Sep 17 00:00:00 2001 From: Zaynah Dargaye Date: Mon, 4 Jul 2022 15:33:18 +0200 Subject: [PATCH 10/11] Proto/test: provide feature flag tests for validate Co-authored-by: Albin Coquereau --- .../test/integration/validate/generators.ml | 10 +- .../test/integration/validate/main.ml | 2 + .../validate/manager_operation_helpers.ml | 97 ++++++++++++++---- .../test_manager_operation_validation.ml | 94 ++++++++++++++++++ .../test/integration/validate/generators.ml | 10 +- .../test/integration/validate/main.ml | 2 + .../validate/manager_operation_helpers.ml | 99 +++++++++++++++---- .../test_manager_operation_validation.ml | 94 ++++++++++++++++++ 8 files changed, 371 insertions(+), 37 deletions(-) diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/generators.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/generators.ml index 4cd5f6bfacd9..dd40f8c10039 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/generators.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/generators.ml @@ -237,7 +237,15 @@ let gen_ctxt_req : ctxt_cstrs -> ctxt_req QCheck2.Gen.t = let* fund_del = gen_tez del_cstrs in let* fund_tx = gen_tez tx_cstrs in let+ fund_sc = gen_tez sc_cstrs in - {hard_gas_limit_per_block; fund_src; fund_dest; fund_del; fund_tx; fund_sc} + { + hard_gas_limit_per_block; + fund_src; + fund_dest; + fund_del; + fund_tx; + fund_sc; + flags = all_enabled; + } (** {2 Wrappers} *) diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml index 445200746450..1f6fca58d06a 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml @@ -46,5 +46,7 @@ let () = Test_batched_manager_operation_validation.gas_tests ); ( "Batched: fees checks", Test_batched_manager_operation_validation.fee_tests ); + ( "Flags: feature flag checks", + Test_manager_operation_validation.flags_tests ); ] |> Lwt_main.run diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml index ba7a98813d51..25fb7cac301f 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -109,6 +109,9 @@ type operation_req = { amount : Tez.t option; } +(** Feature flags requirements for a context setting for a test. *) +type feature_flags = {dal : bool; scoru : bool; toru : bool} + (** The requirements for a context setting for a test. *) type ctxt_req = { hard_gas_limit_per_block : Gas.Arith.integral option; @@ -117,6 +120,7 @@ type ctxt_req = { fund_del : Tez.t option; fund_tx : Tez.t option; fund_sc : Tez.t option; + flags : feature_flags; } (** Validation mode. @@ -128,7 +132,15 @@ type ctxt_req = { type mode = Construction | Mempool | Application (** {2 Default values} *) -let ctxt_req_default = +let all_enabled = {dal = true; scoru = true; toru = 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 ctxt_req_default_to_flag flags = { hard_gas_limit_per_block = None; fund_src = Some Tez.one; @@ -136,8 +148,11 @@ let ctxt_req_default = fund_del = Some Tez.one; fund_tx = Some Tez.one; fund_sc = Some Tez.one; + flags; } +let ctxt_req_default = ctxt_req_default_to_flag all_enabled + let operation_req_default kind = { kind; @@ -222,8 +237,15 @@ let pp_2_operation_req pp (op_req1, op_req2) = op_req2 let pp_ctxt_req pp - {hard_gas_limit_per_block; fund_src; fund_dest; fund_del; fund_tx; fund_sc} - = + { + hard_gas_limit_per_block; + fund_src; + fund_dest; + fund_del; + fund_tx; + fund_sc; + flags; + } = Format.fprintf pp "@[Ctxt_req:@,\ @@ -233,6 +255,9 @@ let pp_ctxt_req pp fund_del: %a tz@,\ fund_tx: %a tz@,\ fund_sc: %a tz@,\ + dal_flag: %a@,\ + scoru_flag: %a@,\ + toru_flag: %a@,\ @]" (pp_opt Gas.Arith.pp_integral) hard_gas_limit_per_block @@ -246,6 +271,12 @@ let pp_ctxt_req pp fund_tx (pp_opt Tez.pp) fund_sc + Format.pp_print_bool + flags.dal + Format.pp_print_bool + flags.scoru + Format.pp_print_bool + flags.toru let pp_mode pp = function | Construction -> Format.fprintf pp "Construction" @@ -360,7 +391,15 @@ let fund_account block bootstrap account fund = have been created and funded according to the context requirements.*) let init_ctxt : ctxt_req -> infos tzresult Lwt.t = - fun {hard_gas_limit_per_block; fund_src; fund_dest; fund_del; fund_tx; fund_sc} -> + fun { + hard_gas_limit_per_block; + fund_src; + fund_dest; + fund_del; + fund_tx; + fund_sc; + flags; + } -> let open Lwt_result_syntax in let create_and_fund ?originate_rollup block bootstrap fund = match fund with @@ -382,10 +421,10 @@ let init_ctxt : ctxt_req -> infos tzresult Lwt.t = 6 ~consensus_threshold:0 ?hard_gas_limit_per_block - ~tx_rollup_enable:true + ~tx_rollup_enable:flags.toru ~tx_rollup_sunset_level:Int32.max_int - ~sc_rollup_enable:true - ~dal_enable:true + ~sc_rollup_enable:flags.scoru + ~dal_enable:flags.dal () in let get_bootstrap bootstraps n = Stdlib.List.nth bootstraps n in @@ -400,18 +439,24 @@ let init_ctxt : ctxt_req -> infos tzresult Lwt.t = create_and_fund block (get_bootstrap bootstraps 2) fund_del in let* block, tx, tx_rollup = - create_and_fund - ~originate_rollup:(fun infos account -> originate_tx_rollup infos account) - block - (get_bootstrap bootstraps 3) - fund_tx + if flags.toru then + create_and_fund + ~originate_rollup:(fun infos account -> + originate_tx_rollup infos account) + block + (get_bootstrap bootstraps 3) + fund_tx + else return (block, None, None) in let* block, sc, sc_rollup = - create_and_fund - ~originate_rollup:(fun infos account -> originate_sc_rollup infos account) - block - (get_bootstrap bootstraps 4) - fund_sc + if flags.scoru then + create_and_fund + ~originate_rollup:(fun infos account -> + originate_sc_rollup infos account) + block + (get_bootstrap bootstraps 4) + fund_sc + else return (block, None, None) in let* create_contract_hash, originated_contract = Op.contract_origination_hash @@ -455,6 +500,8 @@ let ctxt_with_delegation : ctxt_req -> infos tzresult Lwt.t = 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 @@ -1340,3 +1387,19 @@ let gas_consumer_in_validate_subjects, not_gas_consumer_in_validate_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_Reveal + | K_Increase_paid_storage -> + false + | K_Tx_rollup_origination | K_Tx_rollup_submit_batch | K_Tx_rollup_commit + | K_Tx_rollup_return_bond | K_Tx_rollup_finalize + | K_Tx_rollup_remove_commitment | K_Tx_rollup_dispatch_tickets + | K_Transfer_ticket | K_Tx_rollup_reject -> + flags.toru = 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 diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml index cb821688f6c6..ed3c312e9b6f 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml @@ -664,6 +664,97 @@ let test_validate kind () = let generate_tests_validate () = create_Tztest test_validate "Validate." subjects +(* 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_operation.Manager.Sc_rollup_feature_disabled; + ] + when flags.scoru = false -> + return_unit + | [ + Environment.Ecoproto_error + Validate_operation.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 + | 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 flags kind () = + 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 + tx_rollup = infos_op.ctxt.tx_rollup; + sc_rollup = infos_op.ctxt.sc_rollup; + }; + } + in + let* counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + let* op = + select_op + { + {(operation_req_default kind) with force_reveal = Some true} with + counter = Some counter; + } + infos + in + let* _ = + if is_disabled flags kind then + validate_ko_diagnostic infos [op] (flag_expect_failure flags) + else + let* _ = validate_diagnostic infos [op] in + return_unit + in + return_unit + +let generate_dal_flag () = + create_Tztest + (test_feature_flags disabled_dal) + "Validate with dal disabled." + subjects + +let generate_scoru_flag () = + create_Tztest + (test_feature_flags disabled_scoru) + "Validate with scoru disabled." + subjects + +let generate_toru_flag () = + create_Tztest + (test_feature_flags disabled_toru) + "Validate with toru disabled." + subjects + let sanity_tests = test_ensure_manager_operation_coverage () :: generate_tests_validate () @@ -684,3 +775,6 @@ let fee_tests = let contract_tests = generate_high_counter () @ generate_low_counter () @ generate_not_allocated () @ generate_unrevealed_key () + +let flags_tests = + generate_dal_flag () @ generate_toru_flag () @ generate_scoru_flag () diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml b/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml index 4cd5f6bfacd9..dd40f8c10039 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml @@ -237,7 +237,15 @@ let gen_ctxt_req : ctxt_cstrs -> ctxt_req QCheck2.Gen.t = let* fund_del = gen_tez del_cstrs in let* fund_tx = gen_tez tx_cstrs in let+ fund_sc = gen_tez sc_cstrs in - {hard_gas_limit_per_block; fund_src; fund_dest; fund_del; fund_tx; fund_sc} + { + hard_gas_limit_per_block; + fund_src; + fund_dest; + fund_del; + fund_tx; + fund_sc; + flags = all_enabled; + } (** {2 Wrappers} *) diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/main.ml b/src/proto_alpha/lib_protocol/test/integration/validate/main.ml index f7dd004ffd5e..5613c918c335 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/main.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/main.ml @@ -46,5 +46,7 @@ let () = Test_batched_manager_operation_validation.gas_tests ); ( "Batched: fees checks", Test_batched_manager_operation_validation.fee_tests ); + ( "Flags: feature flag checks", + Test_manager_operation_validation.flags_tests ); ] |> Lwt_main.run diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml b/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml index 449c6023a14e..2f5f15ffc874 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -107,6 +107,9 @@ type operation_req = { amount : Tez.t option; } +(** Feature flags requirements for a context setting for a test. *) +type feature_flags = {dal : bool; scoru : bool; toru : bool} + (** The requirements for a context setting for a test. *) type ctxt_req = { hard_gas_limit_per_block : Gas.Arith.integral option; @@ -115,9 +118,10 @@ type ctxt_req = { fund_del : Tez.t option; fund_tx : Tez.t option; fund_sc : Tez.t option; + flags : feature_flags; } -(** Validation mode. +(** Validation mode. FIXME: https://gitlab.com/tezos/tezos/-/issues/3365 This type should be replaced by the one defined @@ -126,7 +130,15 @@ type ctxt_req = { type mode = Construction | Mempool | Application (** {2 Default values} *) -let ctxt_req_default = +let all_enabled = {dal = true; scoru = true; toru = 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 ctxt_req_default_to_flag flags = { hard_gas_limit_per_block = None; fund_src = Some Tez.one; @@ -134,8 +146,11 @@ let ctxt_req_default = fund_del = Some Tez.one; fund_tx = Some Tez.one; fund_sc = Some Tez.one; + flags; } +let ctxt_req_default = ctxt_req_default_to_flag all_enabled + let operation_req_default kind = { kind; @@ -219,8 +234,15 @@ let pp_2_operation_req pp (op_req1, op_req2) = op_req2 let pp_ctxt_req pp - {hard_gas_limit_per_block; fund_src; fund_dest; fund_del; fund_tx; fund_sc} - = + { + hard_gas_limit_per_block; + fund_src; + fund_dest; + fund_del; + fund_tx; + fund_sc; + flags; + } = Format.fprintf pp "@[Ctxt_req:@,\ @@ -230,6 +252,9 @@ let pp_ctxt_req pp fund_del: %a tz@,\ fund_tx: %a tz@,\ fund_sc: %a tz@,\ + dal_flag: %a@,\ + scoru_flag: %a@,\ + toru_flag: %a@,\ @]" (pp_opt Gas.Arith.pp_integral) hard_gas_limit_per_block @@ -243,6 +268,12 @@ let pp_ctxt_req pp fund_tx (pp_opt Tez.pp) fund_sc + Format.pp_print_bool + flags.dal + Format.pp_print_bool + flags.scoru + Format.pp_print_bool + flags.toru let pp_mode pp = function | Construction -> Format.fprintf pp "Construction" @@ -357,7 +388,15 @@ let fund_account block bootstrap account fund = have been created and funded according to the context requirements.*) let init_ctxt : ctxt_req -> infos tzresult Lwt.t = - fun {hard_gas_limit_per_block; fund_src; fund_dest; fund_del; fund_tx; fund_sc} -> + fun { + hard_gas_limit_per_block; + fund_src; + fund_dest; + fund_del; + fund_tx; + fund_sc; + flags; + } -> let open Lwt_result_syntax in let create_and_fund ?originate_rollup block bootstrap fund = match fund with @@ -379,10 +418,10 @@ let init_ctxt : ctxt_req -> infos tzresult Lwt.t = 6 ~consensus_threshold:0 ?hard_gas_limit_per_block - ~tx_rollup_enable:true + ~tx_rollup_enable:flags.toru ~tx_rollup_sunset_level:Int32.max_int - ~sc_rollup_enable:true - ~dal_enable:true + ~sc_rollup_enable:flags.scoru + ~dal_enable:flags.dal () in let get_bootstrap bootstraps n = Stdlib.List.nth bootstraps n in @@ -397,18 +436,24 @@ let init_ctxt : ctxt_req -> infos tzresult Lwt.t = create_and_fund block (get_bootstrap bootstraps 2) fund_del in let* block, tx, tx_rollup = - create_and_fund - ~originate_rollup:(fun infos account -> originate_tx_rollup infos account) - block - (get_bootstrap bootstraps 3) - fund_tx + if flags.toru then + create_and_fund + ~originate_rollup:(fun infos account -> + originate_tx_rollup infos account) + block + (get_bootstrap bootstraps 3) + fund_tx + else return (block, None, None) in let* block, sc, sc_rollup = - create_and_fund - ~originate_rollup:(fun infos account -> originate_sc_rollup infos account) - block - (get_bootstrap bootstraps 4) - fund_sc + if flags.scoru then + create_and_fund + ~originate_rollup:(fun infos account -> + originate_sc_rollup infos account) + block + (get_bootstrap bootstraps 4) + fund_sc + else return (block, None, None) in let* create_contract_hash, originated_contract = Op.contract_origination_hash @@ -452,6 +497,8 @@ let ctxt_with_delegation : ctxt_req -> infos tzresult Lwt.t = 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 @@ -1328,3 +1375,19 @@ let gas_consumer_in_validate_subjects, not_gas_consumer_in_validate_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_Increase_paid_storage | K_Reveal -> + false + | K_Tx_rollup_origination | K_Tx_rollup_submit_batch | K_Tx_rollup_commit + | K_Tx_rollup_return_bond | K_Tx_rollup_finalize + | K_Tx_rollup_remove_commitment | K_Tx_rollup_dispatch_tickets + | K_Transfer_ticket | K_Tx_rollup_reject -> + flags.toru = 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 diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml b/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml index 6b43a1883e92..83108d0de5d6 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml @@ -664,6 +664,97 @@ let test_validate kind () = let generate_tests_validate () = create_Tztest test_validate "Validate." subjects +(* 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_operation.Manager.Sc_rollup_feature_disabled; + ] + when flags.scoru = false -> + return_unit + | [ + Environment.Ecoproto_error + Validate_operation.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 + | 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 flags kind () = + 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 + tx_rollup = infos_op.ctxt.tx_rollup; + sc_rollup = infos_op.ctxt.sc_rollup; + }; + } + in + let* counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + let* op = + select_op + { + {(operation_req_default kind) with force_reveal = Some true} with + counter = Some counter; + } + infos + in + let* _ = + if is_disabled flags kind then + validate_ko_diagnostic infos [op] (flag_expect_failure flags) + else + let* _ = validate_diagnostic infos [op] in + return_unit + in + return_unit + +let generate_dal_flag () = + create_Tztest + (test_feature_flags disabled_dal) + "Validate with dal disabled." + subjects + +let generate_scoru_flag () = + create_Tztest + (test_feature_flags disabled_scoru) + "Validate with scoru disabled." + subjects + +let generate_toru_flag () = + create_Tztest + (test_feature_flags disabled_toru) + "Validate with toru disabled." + subjects + let sanity_tests = test_ensure_manager_operation_coverage () :: generate_tests_validate () @@ -684,3 +775,6 @@ let fee_tests = let contract_tests = generate_high_counter () @ generate_low_counter () @ generate_not_allocated () @ generate_unrevealed_key () + +let flags_tests = + generate_dal_flag () @ generate_toru_flag () @ generate_scoru_flag () -- GitLab From d687f8c8e28cae309570146c03b40ca30afd26bc Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Tue, 12 Jul 2022 20:01:28 +0200 Subject: [PATCH 11/11] Tezt: check that 1M restriction is checked even when the node does not use the manager operation precheck from the plugin --- tezt/tests/main.ml | 1 + tezt/tests/operation_validation.ml | 89 ++++++++++++++++++++++++++++++ 2 files changed, 90 insertions(+) create mode 100644 tezt/tests/operation_validation.ml diff --git a/tezt/tests/main.ml b/tezt/tests/main.ml index 6830576dd540..3ac2b72a3f41 100644 --- a/tezt/tests/main.ml +++ b/tezt/tests/main.ml @@ -141,6 +141,7 @@ let register_K_plus_tests () = Events.register ~protocols:[Alpha] ; Ghostnet_dictator_migration.register ~protocols:[Alpha] ; Increase_paid_storage.register ~protocols ; + Operation_validation.register ~protocols ; Sc_rollup.register ~protocols:[Alpha] ; Test_contract_bls12_381.register ~protocols:[Alpha] ; Testnet_dictator.register ~protocols:[Alpha] ; diff --git a/tezt/tests/operation_validation.ml b/tezt/tests/operation_validation.ml new file mode 100644 index 000000000000..df5176675624 --- /dev/null +++ b/tezt/tests/operation_validation.ml @@ -0,0 +1,89 @@ +(*****************************************************************************) +(* *) +(* 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: Validation components + Invocation: dune exec tezt/tests/main.exe -- --file "op_validation.ml" + Subject: Checks the validation of operations +*) + +(** This test checks that from `Kathmandu`, the 1M restriction is + checked with and without the precheck manager operation enable in + the plugin's node. *) +let check_validate_1m_restriction_node = + Protocol.register_test + ~__FILE__ + ~supports:(Protocol.From_protocol 14) + ~title:"Check 1M restriction with and without precheck in the plugin" + ~tags:["1m"; "manager"; "plugin"; "restriction"] + @@ fun protocol -> + let inject_two_manager_operations_and_check_error ~disable_operations_precheck + error = + Log.info + "Initialize a client %s operation precheck in the plugin." + (if disable_operations_precheck then "without" else "with") ; + let* _node, client = + Client.init_with_protocol + ~nodes_args: + ((if disable_operations_precheck then + [Node.Disable_operations_precheck] + else []) + @ [Synchronisation_threshold 0]) + ~protocol + `Client + () + in + + Log.info "Inject a first transfer." ; + let op1 = + Operation.Manager.make (Operation.Manager.transfer ~amount:1 ()) + in + let* (`OpHash _s) = Operation.Manager.inject [op1] client in + + Log.info + "Inject a second transfer with the same manager and check that the \ + injection fails with the following message:\n\ + %s" + (show_rex error) ; + let op2 = + Operation.Manager.make (Operation.Manager.transfer ~amount:2 ()) + in + let* (`OpHash _) = + Operation.Manager.inject ~error ~request:`Inject [op2] client + in + unit + in + + let* () = + inject_two_manager_operations_and_check_error + ~disable_operations_precheck:false + (rex "Only one manager operation per manager per block allowed") + in + inject_two_manager_operations_and_check_error + ~disable_operations_precheck:true + (rex "Manager.*already has the operation.*in the current block.") + +let register ~protocols = check_validate_1m_restriction_node protocols -- GitLab