diff --git a/.gitlab/ci/test/unit.yml b/.gitlab/ci/test/unit.yml index 0dfb65e5aa50e9e43d5d0d093d0cf6c8b369f5b1..112d90221ceede1b4c57e438418dca75136c5c65 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/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 @@ -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/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 da049abec0c208b65b2617af6e31d0cce5c0a369..ee2dbb45c8fc3169bce26350c15a39b2fc400b14 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") + tests + ["main"; "test_1m_restriction"] + ~path:(path // "lib_protocol/test/integration/validate") ~opam:(sf "tezos-protocol-%s-tests" name_dash) ~deps: [ @@ -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 5cf1b84e0072d4c836e0f6a0d01beee1c90a7591..133d4d2e28121cca63e5805da93aa432c9935b7d 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 576a888398053aa08acb41a7287863949685b815..495c0121aa9ada1a8212972639d5db2979b2037f 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/lib_test/qcheck2_helpers.ml b/src/lib_test/qcheck2_helpers.ml index 285f9d595563823450b2fc35f969dce370c847b2..d78ca281a5e4d4cc6dbdab05027da7d83dad3a69 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 879c13337ccdf141bcc3183616cd0d9cf8173894..05f411e6c8a71bd9caa81b32ccfdb45ab8e3e5bd 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. 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 7c03e9c1d9ba13f55e73ad78ef1a9ecf5a7f91a7..3d9ee379a6171c46e745c6670e4162f898cced2f 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 53a824fde6b5df853bb3ebc7410fbbc3d527f17e..804a282f813d7a5ec1634e6a8d4dfcbbd388c955 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/helpers/op.ml b/src/proto_014_PtKathma/lib_protocol/test/helpers/op.ml index c3e183a50dfeda7fc12732af45634e14de996d47..ccef199cec1ea3a6bddc67964b75b8bededbde3b 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 c2aa30bfd275075366549d9f012871c824a5f07a..d4e2d7bf3fe656590fc32676f9f3fcceb6bc7723 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/precheck/manager_operation_helpers.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/manager_operation_helpers.ml deleted file mode 100644 index 2be78e4339b58c22c7a739cdfcf2e9841be01ca7..0000000000000000000000000000000000000000 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/manager_operation_helpers.ml +++ /dev/null @@ -1,968 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic-Labs. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Protocol -open Alpha_context -open Test_tez - -(* 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) - -type infos = { - 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; -} - -(* 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 = - 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 - () - 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 - ~force_reveal:true - ~counter - ~gas_limit - (B b) - bootstrap_contract - rollup_contract - Tez.one - 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 - ~force_reveal:true - ~counter:counter2 - ~gas_limit - (B b) - rollup_contract - in - let* _, sc_rollup = - Op.sc_rollup_origination - ~counter:counter2 - ~gas_limit - (B b) - 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* create_contract_hash, contract_hash = - Op.contract_origination_hash - (B b) - contract3 - ~fee:Tez.zero - ~script:Op.dummy_script - in - let* operation = - Op.batch_operations - ~source:bootstrap_contract - (B b) - [fund_account1; fund_account2; fund_account3; create_contract_hash] - in - let+ block = Block.bake ~operation b in - { - block; - account1; - contract1; - account2; - contract2; - account3; - contract3; - contract_hash; - tx_rollup; - sc_rollup; - } - -(* Same as [init_context] but [contract1] delegate to [contract2] *) -let init_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 - in - let* _ = - Assert.is_none - ~loc:__LOC__ - ~pp:(fun fmt _ -> Format.fprintf fmt "should not be delegated") - del_opt - in - let* operation = - Op.delegation - ~force_reveal:true - (B infos.block) - infos.contract2 - (Some (Context.Contract.pkh infos.contract2)) - in - let* block = Block.bake infos.block ~operation in - let* operation = - Op.delegation - ~force_reveal:true - (B block) - infos.contract1 - (Some infos.account2.pkh) - 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 - in - let* _ = - Assert.is_none - ~loc:__LOC__ - ~pp:(fun fmt _ -> Format.fprintf fmt "should not be delegated") - del_opt - in - let* operation = - Op.delegation - ~force_reveal:true - (B infos.block) - infos.contract1 - (Some infos.account1.pkh) - 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} - -(* Local helpers for generating all kind of manager operations. *) - -(* 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 - -let get_pk infos source = - let open Lwt_result_syntax in - let+ account = Context.Contract.manager infos source in - account.pk - -let mk_transaction ?counter ?fee ?gas_limit ?storage_limit ?force_reveal ~source - (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) = - 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) = - Op.delegation - ?force_reveal - ?fee - ?gas_limit - ?counter - ?storage_limit - (B infos.block) - source - None - -let mk_self_delegation ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (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) = - let open Lwt_result_syntax in - let+ op, _ = - Op.contract_origination - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ~script:Op.dummy_script - (B infos.block) - source - in - op - -let mk_register_global_constant ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.register_global_constant - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - (B infos.block) - ~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) = - Op.set_deposits_limit - ?force_reveal - ?fee - ?gas_limit - ?storage_limit - ?counter - (B infos.block) - source - None - -let mk_increase_paid_storage ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.increase_paid_storage - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - (B infos.block) - ~source - ~destination:infos.contract_hash - Z.one - -let mk_reveal ?counter ?fee ?gas_limit ?storage_limit ?force_reveal:_ ~source - (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 mk_tx_rollup_origination ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (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 - in - op - -let mk_tx_rollup_submit_batch ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.tx_rollup_submit_batch - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - "batch" - -let mk_tx_rollup_commit ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - let commitement : Tx_rollup_commitment.Full.t = - { - level = Tx_rollup_level.root; - messages = []; - predecessor = None; - inbox_merkle_root = Tx_rollup_inbox.Merkle.merklize_list []; - } - in - Op.tx_rollup_commit - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - commitement - -let mk_tx_rollup_return_bond ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - 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) = - 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) = - 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) = - let message, _ = Tx_rollup_message.make_batch "" in - let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in - let message_path = - match Tx_rollup_inbox.Merkle.compute_path [message_hash] 0 with - | Ok message_path -> message_path - | _ -> raise (Invalid_argument "Single_message_inbox.message_path") - in - let proof : Tx_rollup_l2_proof.t = - { - version = 1; - before = `Value Tx_rollup_message_result.empty_l2_context_hash; - after = `Value Context_hash.zero; - state = Seq.empty; - } - in - let previous_message_result : Tx_rollup_message_result.t = - { - context_hash = Tx_rollup_message_result.empty_l2_context_hash; - withdraw_list_hash = Tx_rollup_withdraw_list_hash.empty; - } - in - Op.tx_rollup_reject - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - Tx_rollup_level.root - message - ~message_position:0 - ~message_path - ~message_result_hash:Tx_rollup_message_result_hash.zero - ~message_result_path:Tx_rollup_commitment.Merkle.dummy_path - ~proof - ~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) = - Op.transfer_ticket - ?fee - ?force_reveal - ?counter - ?gas_limit - ?storage_limit - (B infos.block) - ~source - ~contents:(Script.lazy_expr (Expr.from_string "1")) - ~ty:(Script.lazy_expr (Expr.from_string "nat")) - ~ticketer:infos.contract3 - Z.zero - ~destination:infos.contract2 - Entrypoint.default - -let mk_tx_rollup_dispacth_ticket ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - let reveal = - Tx_rollup_reveal. - { - contents = Script.lazy_expr (Expr.from_string "1"); - ty = Script.lazy_expr (Expr.from_string "nat"); - ticketer = infos.contract2; - amount = Tx_rollup_l2_qty.of_int64_exn 10L; - claimer = infos.account3.pkh; - } - in - Op.tx_rollup_dispatch_tickets - ?fee - ?force_reveal - ?counter - ?gas_limit - ?storage_limit - (B infos.block) - ~source - ~message_index:0 - ~message_result_path:Tx_rollup_commitment.Merkle.dummy_path - infos.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 open Lwt_result_syntax in - let+ op, _ = - Op.sc_rollup_origination - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - Sc_rollup.Kind.Example_arith - "" - (Script.lazy_expr (Expr.from_string "1")) - in - op - -let sc_dummy_commitment = - let number_of_messages = - match Sc_rollup.Number_of_messages.of_int32 3l with - | None -> assert false - | Some x -> x - in - let number_of_ticks = - match Sc_rollup.Number_of_ticks.of_int32 3000l with - | None -> assert false - | Some x -> x - in - Sc_rollup.Commitment. - { - predecessor = Sc_rollup.Commitment.Hash.zero; - inbox_level = Raw_level.of_int32_exn Int32.zero; - number_of_messages; - number_of_ticks; - compressed_state = Sc_rollup.State_hash.zero; - } - -let mk_sc_rollup_publish ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - Op.sc_rollup_publish - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - sc_dummy_commitment - -let mk_sc_rollup_cement ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - Op.sc_rollup_cement - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.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 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 - refutation - false - -let mk_sc_rollup_add_messages ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.sc_rollup_add_messages - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - [] - -let mk_sc_rollup_timeout ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - 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) = - Op.sc_rollup_execute_outbox_message - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - (Sc_rollup.Commitment.hash sc_dummy_commitment) - ~outbox_level:Raw_level.root - ~message_index:0 - ~inclusion_proof:"" - ~message:"" - -let mk_sc_rollup_return_bond ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - 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) = - let open Lwt_result_syntax in - let level = 0 in - let index = 0 in - let header = 0 in - let json_slot = - Data_encoding.Json.from_string - (Format.asprintf - {|{"level":%d,"index":%d,"header":%d}|} - level - index - header) - in - let* json_slot = - match json_slot with Error s -> failwith "%s" s | Ok slot -> return slot - 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 - 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. *) -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 - -let string_of_kind = 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_return_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 - match hd_msg with - | None -> sk - | Some hd -> Format.sprintf "Batch: %s, %s" hd sk - in - List.map - (fun kind -> - Tztest.tztest - (Format.sprintf "%s with %s" (hd_msg kind) tests_msg) - `Quick - (fun () -> test kind ())) - operations - -let rec create_Tztest_batches test tests_msg operations = - let hdmsg k = Format.sprintf "%s" (string_of_kind k) in - let aux hd_msg test operations = - create_Tztest ~hd_msg test tests_msg operations - in - match operations with - | [] -> [] - | 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. *) - -(* For a manager operation a [probes] contains the values required for observing - its precheck success. Its source, fees (sum for a batch), gas_limit - (sum of gas_limit of the batch), and the increment of the counters aka 1 for - a single operation, n for a batch of n manager operations. *) -type probes = { - source : Signature.Public_key_hash.t; - fee : Tez.tez; - gas_limit : Gas.Arith.integral; - nb_counter : Z.t; -} - -let rec contents_infos : - type kind. kind Kind.manager contents_list -> probes tzresult Lwt.t = - fun op -> - let open Lwt_result_syntax in - match op with - | Single (Manager_operation {source; fee; gas_limit; _}) -> - return {source; fee; gas_limit; nb_counter = Z.one} - | Cons (Manager_operation manop, manops) -> - let* probes = contents_infos manops in - let*? fee = manop.fee +? probes.fee in - let gas_limit = Gas.Arith.add probes.gas_limit manop.gas_limit in - let nb_counter = Z.succ probes.nb_counter in - let _ = Assert.equal_pkh ~loc:__LOC__ manop.source probes.source in - return {fee; source = probes.source; gas_limit; nb_counter} - -(* Computes a [probes] from a list of manager contents. *) -let manager_content_infos op = - let (Operation_data {contents; _}) = op.protocol_data in - match contents with - | Single (Manager_operation _) as op -> contents_infos op - | Cons (Manager_operation _, _) as op -> contents_infos op - | _ -> assert false - -(* [observe] asserts the success of precheck 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 - succeeds - - [contract] balance decreases at least by [probes.fee] when ![only_precheck] 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 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 - let*? b_expected = b_in -? probes.fee in - let b_cmp = - Assert.equal - ~loc:__LOC__ - (if only_precheck then Tez.( = ) else Tez.( <= )) - "Balance update" - 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 - ~loc:__LOC__ - "Counter incrementation" - Z.pp_print - 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 precheck_with_diagnostic ~only_precheck (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.precheck_operation i op in - let* _ = Incremental.finalize_block i in - observe ~only_precheck contract b_in c_in g_in prbs i - -(* If only the precheck 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 - -(* If an manager operation application succeed, the precheck - 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 - -(* [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 - 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 - should be extended for each new manager_operation kind. *) -let subjects = - [ - K_Transaction; - K_Origination; - K_Register_global_constant; - K_Delegation; - K_Undelegation; - K_Self_delegation; - K_Set_deposits_limit; - K_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 is_consumer = function - | K_Set_deposits_limit | K_Increase_paid_storage | K_Reveal - | K_Self_delegation | K_Delegation | K_Undelegation | K_Tx_rollup_origination - | K_Tx_rollup_submit_batch | K_Tx_rollup_finalize | K_Tx_rollup_commit - | K_Tx_rollup_return_bond | K_Tx_rollup_remove_commitment | K_Tx_rollup_reject - | K_Sc_rollup_add_messages | K_Sc_rollup_origination | K_Sc_rollup_refute - | K_Sc_rollup_timeout | K_Sc_rollup_cement | K_Sc_rollup_publish - | K_Sc_rollup_execute_outbox_message | K_Sc_rollup_recover_bond - | K_Dal_publish_slot_header -> - false - | K_Transaction | K_Origination | K_Register_global_constant - | K_Tx_rollup_dispatch_tickets | K_Transfer_ticket -> - true - -let gas_consumer_in_precheck_subjects, not_gas_consumer_in_precheck_subjects = - List.partition is_consumer subjects - -let revealed_subjects = - List.filter (function K_Reveal -> false | _ -> true) subjects diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/test_manager_operation_precheck.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/test_manager_operation_precheck.ml deleted file mode 100644 index 79831ff4c6082933472274884967fcabfde6bcb4..0000000000000000000000000000000000000000 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/test_manager_operation_precheck.ml +++ /dev/null @@ -1,570 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic-Labs. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (precheck manager) - Invocation: dune exec \ - src/proto_alpha/lib_protocol/test/integration/precheck/main.exe \ - -- test "^Single$" - Subject: Precheck 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 - - 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. *) -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 (Operation_data {contents; _}) = op.protocol_data in - match contents with - | Single (Manager_operation {operation; _}) -> ( - match (operation, kind) with - | Transaction _, K_Transaction - | Reveal _, K_Reveal - | Origination _, K_Origination - | Delegation _, K_Delegation - | Delegation _, K_Undelegation - | Delegation _, K_Self_delegation - | Register_global_constant _, K_Register_global_constant - | Set_deposits_limit _, K_Set_deposits_limit - | Increase_paid_storage _, K_Increase_paid_storage - | Tx_rollup_origination, K_Tx_rollup_origination - | Tx_rollup_submit_batch _, K_Tx_rollup_submit_batch - | Tx_rollup_commit _, K_Tx_rollup_commit - | Tx_rollup_return_bond _, K_Tx_rollup_return_bond - | Tx_rollup_finalize_commitment _, K_Tx_rollup_finalize - | Tx_rollup_remove_commitment _, K_Tx_rollup_remove_commitment - | Tx_rollup_rejection _, K_Tx_rollup_reject - | Tx_rollup_dispatch_tickets _, K_Tx_rollup_dispatch_tickets - | Transfer_ticket _, K_Transfer_ticket - | Sc_rollup_originate _, K_Sc_rollup_origination - | Sc_rollup_add_messages _, K_Sc_rollup_add_messages - | Sc_rollup_cement _, K_Sc_rollup_cement - | Sc_rollup_publish _, K_Sc_rollup_publish - | Sc_rollup_refute _, K_Sc_rollup_refute - | Sc_rollup_timeout _, K_Sc_rollup_timeout - | Sc_rollup_execute_outbox_message _, K_Sc_rollup_execute_outbox_message - | Sc_rollup_recover_bond _, K_Sc_rollup_recover_bond - | Dal_publish_slot_header _, K_Dal_publish_slot_header -> - return_unit - | ( ( Transaction _ | Origination _ | Register_global_constant _ - | Delegation _ | Set_deposits_limit _ | Increase_paid_storage _ - | Reveal _ | Tx_rollup_origination | Tx_rollup_submit_batch _ - | Tx_rollup_commit _ | Tx_rollup_return_bond _ - | Tx_rollup_finalize_commitment _ | Tx_rollup_remove_commitment _ - | Tx_rollup_dispatch_tickets _ | Transfer_ticket _ - | Tx_rollup_rejection _ | Sc_rollup_originate _ | Sc_rollup_publish _ - | Sc_rollup_cement _ | Sc_rollup_add_messages _ | Sc_rollup_refute _ - | Sc_rollup_timeout _ | Sc_rollup_execute_outbox_message _ - | Sc_rollup_recover_bond _ | Dal_publish_slot_header _ - | Sc_rollup_dal_slot_subscribe _ ), - _ ) -> - assert false) - | Single _ -> assert false - | Cons _ -> assert false - -let ensure_manager_operation_coverage () = - let open Lwt_result_syntax in - let* infos = init_context () in - List.iter_es (fun kind -> ensure_kind infos kind) subjects - -let test_ensure_manager_operation_coverage () = - Tztest.tztest - (Format.sprintf "Ensure manager_operation coverage") - `Quick - (fun () -> ensure_manager_operation_coverage ()) - -(* Negative tests assert the case where precheck must fail. *) - -(* Precheck 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. *) -let low_gas_limit_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error - Validate_operation.Manager.Gas_quota_exceeded_init_deserialize; - Environment.Ecoproto_error Raw_context.Operation_quota_exceeded; - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_low_gas_limit 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 - low_gas_limit_diagnostic infos op - -let generate_low_gas_limit () = - create_Tztest - test_low_gas_limit - "Gas_limit too low." - gas_consumer_in_precheck_subjects - -(* Precheck 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. *) -let high_gas_limit_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Gas.Gas_limit_too_high] -> return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -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* op = - select_op ~gas_limit ~force_reveal:true ~source:infos.contract1 kind infos - in - high_gas_limit_diagnostic infos op - -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. - - 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. *) -let high_storage_limit_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Fees_storage.Storage_limit_too_high] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -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* op = - select_op - ~storage_limit - ~force_reveal:true - ~source:infos.contract1 - kind - infos - in - high_storage_limit_diagnostic infos op - -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. - - 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. *) -let high_counter_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error (Contract_storage.Counter_in_the_future _)] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -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* op = - select_op ~counter ~force_reveal:true ~source:infos.contract1 kind infos - in - high_counter_diagnostic infos op - -let generate_high_counter () = - create_Tztest test_high_counter "Counter too high." subjects - -(* Precheck 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. *) -let low_counter_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error (Contract_storage.Counter_in_the_past _)] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_low_counter kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let* current_counter = - Context.Contract.counter (B infos.block) infos.contract1 - in - let counter = Z.sub current_counter Z.one in - let* op = - select_op ~counter ~force_reveal:true ~source:infos.contract1 kind infos - in - low_counter_diagnostic infos op - -let generate_low_counter () = - create_Tztest test_low_counter "Counter too low." subjects - -(* Precheck 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. *) -let not_allocated_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error (Contract_storage.Empty_implicit_contract _)] - -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_not_allocated kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let* op = - select_op ~force_reveal:false ~source:(mk_fresh_contract ()) kind infos - in - not_allocated_diagnostic infos op - -let generate_not_allocated () = - create_Tztest test_not_allocated "not allocated source." subjects - -(* Precheck 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]. *) -let unrevealed_key_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error - (Contract_manager_storage.Unrevealed_manager_key _); - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -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 generate_unrevealed_key () = - create_Tztest - test_unrevealed_key - "unrevealed source (find_manager_public_key)." - revealed_subjects - -(* Precheck fails if the source's 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. *) -let high_fee_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error (Contract_storage.Balance_too_low _); - Environment.Ecoproto_error (Tez_repr.Subtraction_underflow _); - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_high_fee kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let*? fee = Tez.(one +? one) |> Environment.wrap_tzresult in - let* op = - select_op ~fee ~force_reveal:true ~source:infos.contract1 kind infos - in - high_fee_diagnostic infos op - -let generate_tests_high_fee () = - create_Tztest test_high_fee "not enough for fee payment." subjects - -(* Precheck 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].*) -let emptying_delegated_implicit_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error - (Contract_storage.Empty_implicit_delegated_contract _); - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -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* op = - select_op ~fee ~force_reveal:false ~source:infos.contract1 kind infos - in - emptying_delegated_implicit_diagnostic infos op - -let generate_tests_emptying_delegated_implicit () = - create_Tztest - test_emptying_delegated_implicit - "just enough funds to empty a delegated source." - revealed_subjects - -(* Precheck fails if there is not enough available gas in the block. - - This test asserts that precheck fails with: - - [Gas_limit_too_high;Block_quota_exceeded] in mempool mode, - | [Block_quota_exceeded] in other mode - with gas limit exceeds the available gas in the block. - It applies to every kind of manager operation. *) -let exceeding_block_gas_diagnostic ~mempool_mode (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Gas.Block_quota_exceeded] - when not mempool_mode -> - return_unit - | [ - Environment.Ecoproto_error Gas.Gas_limit_too_high; - Environment.Ecoproto_error Gas.Block_quota_exceeded; - ] - when mempool_mode -> - (* In mempool_mode, batch that exceed [operation_gas_limit] needs - to be refused. [Gas.Block_quota_exceeded] only return a - temporary error. [Gas.Gas_limit_too_high], which is a - permanent error, is added to the error trace to ensure that - the batch is refused. *) - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure ~mempool_mode - -let test_exceeding_block_gas ~mempool_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)) - in - let* operation = - select_op ~force_reveal:true ~source:infos.contract1 ~gas_limit kind infos - in - exceeding_block_gas_diagnostic ~mempool_mode infos operation - -let generate_tests_exceeding_block_gas () = - create_Tztest - (test_exceeding_block_gas ~mempool_mode:false) - "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." - subjects - -(* 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: - - 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: - - 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: - - 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. *) -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* op = - select_op ~fee ~force_reveal:false ~source:infos.contract1 kind infos - in - only_precheck_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." - 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 = - 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* fee = Context.Contract.balance (B infos.block) infos.contract1 in - let* op = - select_op - ~fee - ~gas_limit - ~force_reveal:true - ~source:infos.contract1 - kind - infos - in - only_precheck_diagnostic infos op - -let generate_tests_emptying_undelegated_implicit () = - create_Tztest - test_emptying_undelegated_implicit - "passes precheck and empties an undelegated source." - subjects - -(* Fee payment.*) -let test_precheck 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 - -let generate_tests_precheck () = - create_Tztest test_precheck "passes precheck." subjects - -let sanity_tests = - test_ensure_manager_operation_coverage () :: generate_tests_precheck () - -let gas_tests = - generate_low_gas_limit () @ generate_high_gas_limit () - @ generate_tests_exceeding_block_gas () - @ generate_tests_exceeding_block_gas_mp_mode () - -let storage_tests = generate_high_storage_limit () - -let fee_tests = - generate_tests_high_fee () - @ generate_tests_emptying_delegated_implicit () - @ generate_tests_emptying_self_delegated_implicit () - @ generate_tests_emptying_undelegated_implicit () - -let contract_tests = - generate_high_counter () @ generate_low_counter () @ generate_not_allocated () - @ generate_unrevealed_key () 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 77% rename from src/proto_014_PtKathma/lib_protocol/test/integration/precheck/dune rename to src/proto_014_PtKathma/lib_protocol/test/integration/validate/dune index 0aab47b27e377d06c26e46f4f89dd3ac836a5d58..9e56b2994a37280604b29ba4365b31f710a8ce2a 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/dune +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/dune @@ -1,12 +1,13 @@ ; 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 tezos-protocol-014-PtKathma + qcheck-alcotest tezos-client-014-PtKathma tezos-014-PtKathma-test-helpers tezos-base-test-helpers) @@ -23,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 new file mode 100644 index 0000000000000000000000000000000000000000..dd40f8c10039719726fa31e63a3c2592ca785ec0 --- /dev/null +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/generators.ml @@ -0,0 +1,263 @@ +(*****************************************************************************) +(* *) +(* 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 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 { + 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; + flags = all_enabled; + } + +(** {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/precheck/main.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml similarity index 69% rename from src/proto_014_PtKathma/lib_protocol/test/integration/precheck/main.ml rename to src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml index 9e58c8ee0a29d40a59b7ffd8ee1f32ee950b930d..1f6fca58d06a9fc3ef1887bec073a0f513d9cf51 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/precheck/main.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml @@ -26,22 +26,27 @@ (** 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 ); + ( "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 new file mode 100644 index 0000000000000000000000000000000000000000..25fb7cac301f3448fab69d82b3e810223484b957 --- /dev/null +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -0,0 +1,1405 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic-Labs. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context +open Test_tez + +(** {2 Constants} *) + +(** Hard gas limit *) + +let gb_limit = Gas.Arith.(integral_of_int_exn 100_000) + +let half_gb_limit = Gas.Arith.(integral_of_int_exn 50_000) + +(** {2 Datatypes} *) + +(** Context abstraction in a test. *) +type ctxt = { + block : Block.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; +} + +(** 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; + 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; + flags : feature_flags; +} + +(** Validation mode. + + FIXME: https://gitlab.com/tezos/tezos/-/issues/3365 + This type should be replaced by the one defined + in validation, type mode in `validate_operation`, when it would + include the distinction between Contruction and Application. *) +type mode = Construction | Mempool | Application + +(** {2 Default values} *) +let all_enabled = {dal = true; scoru = true; toru = true} + +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; + fund_dest = Some Tez.one; + 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; + counter = None; + fee = None; + gas_limit = None; + storage_limit = None; + force_reveal = None; + 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_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; + flags; + } = + 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@,\ + dal_flag: %a@,\ + scoru_flag: %a@,\ + toru_flag: %a@,\ + @]" + (pp_opt Gas.Arith.pp_integral) + hard_gas_limit_per_block + (pp_opt Tez.pp) + fund_src + (pp_opt Tez.pp) + fund_dest + (pp_opt Tez.pp) + fund_del + (pp_opt Tez.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" + | Mempool -> Format.fprintf pp "Mempool" + | Application -> Format.fprintf pp "Block" + +(** {2 Short-cuts} *) +let contract_of (account : Account.t) = Contract.Implicit account.pkh + +(** Make a [mempool_mode], aka a boolean, as used in incremental from + a [mode]. *) +let mempool_mode_of = function Mempool -> true | _ -> false + +let get_pk infos source = + let open Lwt_result_syntax in + let+ account = Context.Contract.manager infos source in + account.pk + +(** Operation for specific context. *) +let self_delegate block pkh = + let open Lwt_result_syntax in + let contract = Contract.Implicit pkh in + let* operation = + Op.delegation ~force_reveal:true (B block) contract (Some pkh) + in + let* block = Block.bake block ~operation in + let* del_opt_new = Context.Contract.delegate_opt (B block) contract in + let* del = Assert.get_some ~loc:__LOC__ del_opt_new in + let+ _ = Assert.equal_pkh ~loc:__LOC__ del pkh in + block + +let delegation block 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 + (B block) + contract_delegate + (Some delegate_pkh) + in + let* block = Block.bake block ~operation in + let* operation = + Op.delegation + ~force_reveal:true + (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+ 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 + ~force_reveal:true + (B block) + rollup_contract + Sc_rollup.Kind.Example_arith + "" + (Script.lazy_expr (Expr.from_string "1")) + in + 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.transaction + ~counter + ~gas_limit:Op.High + (B block) + bootstrap + (Contract.Implicit account) + fund + in + let*! b = Block.bake ~operation block in + match b with Error _ -> failwith "Funding account error" | Ok b -> return b + +(** 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; + flags; + } -> + let open Lwt_result_syntax in + let create_and_fund ?originate_rollup block bootstrap fund = + match fund with + | None -> return (block, None, None) + | Some _ -> + let account = Account.new_account () in + let* block = fund_account block bootstrap account.pkh fund in + let+ block, rollup = + match originate_rollup with + | None -> return (block, None) + | Some f -> + let+ block, rollup = f block account in + (block, Some rollup) + in + (block, Some account, rollup) + in + let* block, bootstraps = + Context.init_n + 6 + ~consensus_threshold:0 + ?hard_gas_limit_per_block + ~tx_rollup_enable:flags.toru + ~tx_rollup_sunset_level:Int32.max_int + ~sc_rollup_enable:flags.scoru + ~dal_enable:flags.dal + () + in + 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, dest, _ = + create_and_fund block (get_bootstrap bootstraps 1) fund_dest + in + let* block, del, _ = + create_and_fund block (get_bootstrap bootstraps 2) fund_del + in + let* block, tx, tx_rollup = + 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 = + 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 + (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}} + +(** In addition of building up a context according to a context + requirement, source is self-delegated. + + See [init_ctxt] description. *) +let ctxt_with_self_delegation : ctxt_req -> infos tzresult Lwt.t = + fun ctxt_req -> + let open Lwt_result_syntax in + let* infos = init_ctxt ctxt_req in + let+ block = self_delegate infos.ctxt.block infos.accounts.source.pkh in + let ctxt = {infos.ctxt with block} in + {infos with ctxt} + +(** In addition of building up a context accordning to a context + requirement, source delegates to del. + + See [init_ctxt] description. *) +let ctxt_with_delegation : ctxt_req -> infos tzresult Lwt.t = + fun ctxt_req -> + let open Lwt_result_syntax in + let* infos = init_ctxt ctxt_req in + let* delegate = + match infos.accounts.del with + | None -> failwith "Delegate account should be funded" + | Some a -> return a + in + let+ block = delegation infos.ctxt.block 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_init_with_flags flags = init_ctxt (ctxt_req_default_to_flag flags) + +let default_ctxt_with_self_delegation () = + ctxt_with_self_delegation ctxt_req_default + +let default_ctxt_with_delegation () = ctxt_with_delegation ctxt_req_default + +(** {2 Smart constructors} *) + +(** Smart 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: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: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: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 (oinfos : operation_req) (infos : infos) = + Op.delegation + ?force_reveal:oinfos.force_reveal + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + (contract_of 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:oinfos.force_reveal + ?counter:oinfos.counter + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + ~script:Op.dummy_script + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + op + +let mk_register_global_constant (oinfos : operation_req) (infos : infos) = + Op.register_global_constant + ?force_reveal:oinfos.force_reveal + ?counter:oinfos.counter + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + ~source:(contract_of infos.accounts.source) + ~value:(Script_repr.lazy_expr (Expr.from_string "Pair 1 2")) + +let mk_set_deposits_limit (oinfos : operation_req) (infos : infos) = + Op.set_deposits_limit + ?force_reveal:oinfos.force_reveal + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + ?counter:oinfos.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + None + +let mk_increase_paid_storage (oinfos : operation_req) (infos : infos) = + Op.increase_paid_storage + ?force_reveal:oinfos.force_reveal + ?counter:oinfos.counter + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + ~source:(contract_of infos.accounts.source) + ~destination:infos.ctxt.originated_contract + Z.one + +let mk_reveal (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* pk = get_pk (B infos.ctxt.block) (contract_of 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 (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let+ op, _rollup = + Op.tx_rollup_origination + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + op + +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: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 (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; + messages = []; + predecessor = None; + inbox_merkle_root = Tx_rollup_inbox.Merkle.merklize_list []; + } + in + Op.tx_rollup_commit + ?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 (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: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: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: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 = + match Tx_rollup_inbox.Merkle.compute_path [message_hash] 0 with + | Ok message_path -> message_path + | _ -> raise (Invalid_argument "Single_message_inbox.message_path") + in + let proof : Tx_rollup_l2_proof.t = + { + version = 1; + before = `Value Tx_rollup_message_result.empty_l2_context_hash; + after = `Value Context_hash.zero; + state = Seq.empty; + } + in + let previous_message_result : Tx_rollup_message_result.t = + { + context_hash = Tx_rollup_message_result.empty_l2_context_hash; + withdraw_list_hash = Tx_rollup_withdraw_list_hash.empty; + } + in + Op.tx_rollup_reject + ?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 + ~message_path + ~message_result_hash:Tx_rollup_message_result_hash.zero + ~message_result_path:Tx_rollup_commitment.Merkle.dummy_path + ~proof + ~previous_message_result + ~previous_message_result_path:Tx_rollup_commitment.Merkle.dummy_path + +let mk_transfer_ticket (oinfos : operation_req) (infos : infos) = + Op.transfer_ticket + ?fee:oinfos.fee + ?force_reveal:oinfos.force_reveal + ?counter:oinfos.counter + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + ~source:(contract_of infos.accounts.source) + ~contents:(Script.lazy_expr (Expr.from_string "1")) + ~ty:(Script.lazy_expr (Expr.from_string "nat")) + ~ticketer: + (contract_of + (match infos.accounts.tx with + | None -> infos.accounts.source + | Some tx -> tx)) + Z.zero + ~destination: + (contract_of + (match infos.accounts.dest with + | None -> infos.accounts.source + | Some dest -> dest)) + Entrypoint.default + +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 = + contract_of + (match infos.accounts.dest with + | None -> infos.accounts.source + | Some dest -> dest); + amount = Tx_rollup_l2_qty.of_int64_exn 10L; + claimer = + (match infos.accounts.dest with + | None -> infos.accounts.source.pkh + | Some dest -> dest.pkh); + } + in + Op.tx_rollup_dispatch_tickets + ?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 + tx_rollup + Tx_rollup_level.root + Context_hash.zero + [reveal] + +let mk_sc_rollup_origination (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let+ op, _ = + Op.sc_rollup_origination + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + Sc_rollup.Kind.Example_arith + "" + (Script.lazy_expr (Expr.from_string "1")) + in + op + +let sc_dummy_commitment = + let number_of_messages = + match Sc_rollup.Number_of_messages.of_int32 3l with + | None -> assert false + | Some x -> x + in + let number_of_ticks = + match Sc_rollup.Number_of_ticks.of_int32 3000l with + | None -> assert false + | Some x -> x + in + Sc_rollup.Commitment. + { + predecessor = Sc_rollup.Commitment.Hash.zero; + inbox_level = Raw_level.of_int32_exn Int32.zero; + number_of_messages; + number_of_ticks; + compressed_state = Sc_rollup.State_hash.zero; + } + +let mk_sc_rollup_publish (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + Op.sc_rollup_publish + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + sc_rollup + sc_dummy_commitment + +let mk_sc_rollup_cement (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + Op.sc_rollup_cement + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + sc_rollup + (Sc_rollup.Commitment.hash sc_dummy_commitment) + +let mk_sc_rollup_refute (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + let refutation : Sc_rollup.Game.refutation = + {choice = Sc_rollup.Tick.initial; step = Dissection []} + in + Op.sc_rollup_refute + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of 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 (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: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 (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + Op.sc_rollup_timeout + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of 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: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 (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: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 + let header = 0 in + let json_slot = + Data_encoding.Json.from_string + (Format.asprintf + {|{"level":%d,"index":%d,"header":%d}|} + level + index + header) + in + let* json_slot = + match json_slot with Error s -> failwith "%s" s | Ok slot -> return slot + in + let slot = Data_encoding.Json.destruct Dal.Slot.encoding json_slot in + Op.dal_publish_slot_header + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + slot + +(** {2 Helpers for generation of generic check tests by manager operation} *) + +(** Generic forge for any kind of manager operation according to + operation requirements in a specific test setting. *) +let select_op (op_req : operation_req) (infos : infos) = + let mk_op = + match op_req.kind with + | K_Transaction -> mk_transaction + | K_Origination -> mk_origination + | K_Register_global_constant -> mk_register_global_constant + | K_Delegation -> mk_delegation + | K_Undelegation -> mk_undelegation + | K_Self_delegation -> mk_self_delegation + | K_Set_deposits_limit -> mk_set_deposits_limit + | K_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 tl_msg k = + let sk = kind_to_string k in + match hd_msg with None -> sk | Some hd -> Format.sprintf "%s, %s" hd sk + in + List.map + (fun kind -> + Tztest.tztest + (Format.sprintf "%s [%s]" tests_msg (tl_msg kind)) + `Quick + (fun () -> test kind ())) + operations + +let rec create_Tztest_batches test tests_msg operations = + 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 + match operations with + | [] -> [] + | kop :: kops as ops -> + aux (hdmsg kop) (test kop) ops @ create_Tztest_batches test tests_msg kops + +(** {2 Diagnostic helpers.} *) + +(** The purpose of diagnostic helpers is to state the correct + observation according to the validate result of a test. *) + +(** For a manager operation a [probes] contains the values required + for observing its validate success. Its source, fees (sum for a + batch), gas_limit (sum of gas_limit of the batch), and the + increment of the counters aka 1 for a single operation, n for a + batch of n manager operations. *) +type probes = { + source : Signature.Public_key_hash.t; + fee : Tez.tez; + gas_limit : Gas.Arith.integral; + nb_counter : Z.t; +} + +let rec contents_infos : + type kind. kind Kind.manager contents_list -> probes tzresult Lwt.t = + fun op -> + let open Lwt_result_syntax in + match op with + | Single (Manager_operation {source; fee; gas_limit; _}) -> + return {source; fee; gas_limit; nb_counter = Z.one} + | Cons (Manager_operation manop, manops) -> + let* probes = contents_infos manops in + let*? fee = manop.fee +? probes.fee in + let gas_limit = Gas.Arith.add probes.gas_limit manop.gas_limit in + let nb_counter = Z.succ probes.nb_counter in + let _ = Assert.equal_pkh ~loc:__LOC__ manop.source probes.source in + return {fee; source = probes.source; gas_limit; nb_counter} + +(** Computes a [probes] from a list of manager contents. *) +let manager_content_infos op = + let (Operation_data {contents; _}) = op.protocol_data in + match contents with + | Single (Manager_operation _) as op -> contents_infos op + | Cons (Manager_operation _, _) as op -> contents_infos op + | _ -> failwith "Should only handle manager operation" + +(** We need a way to get the available gas in a context of type + block. *) +let available_gas = function + | Context.I inc -> Some (Gas.block_level (Incremental.alpha_ctxt inc)) + | B _ -> None + +(** Computes the witness value in a state. The witness values are the + the initial balance of source, its initial counter and the + available gas in the state. The available gas is computed only + when the context is an incremental one. *) +let witness ctxt source = + let open Lwt_result_syntax in + let* b_in = Context.Contract.balance ctxt source in + let+ c_in = Context.Contract.counter ctxt source in + let g_in = available_gas ctxt in + (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__ + (if only_validate then Tez.( = ) else Tez.( <= )) + (if only_validate then "Balance update (=)" else "Balance update (<=)") + Tez.pp + in + let* _ = b_cmp b_out b_expected in + let _ = + Assert.equal + Z.equal + ~loc:__LOC__ + "Counter incrementation" + Z.pp_print + c_out + c_expected + in + let g_msg = + match mode with + | Application -> "Gas consumption (application)" + | Mempool -> "Gas consumption (mempool)" + | Construction -> "Gas consumption (construction)" + in + match g_expected with + | None -> Assert.is_none ~loc:__LOC__ ~pp:Gas.Arith.pp g_out + | Some g_expected -> + let* g_out = Assert.get_some ~loc:__LOC__ g_out in + Assert.equal + ~loc:__LOC__ + Gas.Arith.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 + 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. *) +let subjects = + [ + 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 is_consumer = function + | K_Set_deposits_limit | K_Increase_paid_storage | K_Reveal + | K_Self_delegation | K_Delegation | K_Undelegation | K_Tx_rollup_origination + | K_Tx_rollup_submit_batch | K_Tx_rollup_finalize | K_Tx_rollup_commit + | K_Tx_rollup_return_bond | K_Tx_rollup_remove_commitment | K_Tx_rollup_reject + | K_Sc_rollup_add_messages | K_Sc_rollup_origination | K_Sc_rollup_refute + | K_Sc_rollup_timeout | K_Sc_rollup_cement | K_Sc_rollup_publish + | K_Sc_rollup_execute_outbox_message | K_Sc_rollup_recover_bond + | K_Dal_publish_slot_header -> + false + | K_Transaction | K_Origination | K_Register_global_constant + | K_Tx_rollup_dispatch_tickets | K_Transfer_ticket -> + true + +let gas_consumer_in_validate_subjects, not_gas_consumer_in_validate_subjects = + List.partition is_consumer subjects + +let revealed_subjects = + List.filter (function K_Reveal -> false | _ -> true) subjects + +let is_disabled flags = function + | K_Transaction | K_Origination | K_Register_global_constant | K_Delegation + | K_Undelegation | K_Self_delegation | K_Set_deposits_limit | K_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_1m_restriction.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml new file mode 100644 index 0000000000000000000000000000000000000000..6950d40876aee3466bf60230798264bdfabb3dc6 --- /dev/null +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml @@ -0,0 +1,242 @@ +(*****************************************************************************) +(* *) +(* 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/test_1m_restriction.exe + Subject: 1M restriction in validation of manager operation. +*) + +open Protocol +open Manager_operation_helpers +open Generators + +(** 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 + +(** 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 + 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 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 + 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 + 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) + +(** 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 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. *) +let valid_context_free = + let gen = + QCheck2.Gen.quad + (Generators.gen_ctxt_req ctxt_cstrs_default) + (Generators.gen_operation_req (op_cstrs_default true) revealed_subjects) + (Generators.gen_operation_req (op_cstrs_default true) revealed_subjects) + Generators.gen_mode + in + wrap + ~count:1000 + ~print:print_two_ops + ~name:"Under 1M, co-valid ops commute" + ~gen + (fun (ctxt_req, operation_req, operation_req', mode) -> + let open Lwt_result_syntax in + let* infos = init_ctxt ctxt_req in + let* op1 = select_op operation_req infos in + let infos2 = + { + infos with + accounts = + { + infos.accounts with + 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 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_tests4 = + ("Fee payment of two covalid operations commute", conflict_free_tests) + +let () = + Alcotest.run + "1M QCheck" + [qcheck_tests; qcheck_tests2; qcheck_tests3; qcheck_tests4] 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 61% 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 28bcc3c6fb299a816383446b6a6b54d11a765a5b..12f3dc3df4db96b505c3455729cda3a76ed1d2c3 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,40 +54,62 @@ 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 - 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 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,30 +124,54 @@ 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 - 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 @@ -133,7 +179,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,27 +193,42 @@ 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 - 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 @@ -175,21 +236,29 @@ 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 - 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 @@ -266,23 +335,41 @@ 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 - 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 _)] @@ -314,36 +401,44 @@ 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 - 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] @@ -408,24 +503,41 @@ 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 - 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,47 +547,63 @@ 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* _ = precheck_diagnostic infos case2 in - precheck_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 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 - 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 - precheck_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 () @@ -484,7 +612,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/validate/test_manager_operation_validation.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml new file mode 100644 index 0000000000000000000000000000000000000000..ed3c312e9b6fec50b6f2f167fc1356d2f7415bbd --- /dev/null +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml @@ -0,0 +1,780 @@ +(*****************************************************************************) +(* *) +(* 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 "^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 + + Note: if a new manager operation kind is added in the protocol, + [Manager_operation_helpers.manager_operation_kind] should be + extended. You will also have to extend + [Manager_operation_helpers.select_op] with a new `mk` for this new + operation. Finally the list [Manager_operation_helpers.subjects] + should also be extended to run the validate test on the new manager + operation kind. *) +let ensure_kind infos kind = + let open Lwt_result_syntax in + let* op = + select_op + {(operation_req_default kind) with force_reveal = Some false} + infos + in + let (Operation_data {contents; _}) = op.protocol_data in + match contents with + | Single (Manager_operation {operation; _}) -> ( + match (operation, kind) with + | Transaction _, K_Transaction + | Reveal _, K_Reveal + | Origination _, K_Origination + | Delegation _, K_Delegation + | Delegation _, K_Undelegation + | Delegation _, K_Self_delegation + | Register_global_constant _, K_Register_global_constant + | Set_deposits_limit _, K_Set_deposits_limit + | Increase_paid_storage _, K_Increase_paid_storage + | Tx_rollup_origination, K_Tx_rollup_origination + | Tx_rollup_submit_batch _, K_Tx_rollup_submit_batch + | Tx_rollup_commit _, K_Tx_rollup_commit + | Tx_rollup_return_bond _, K_Tx_rollup_return_bond + | Tx_rollup_finalize_commitment _, K_Tx_rollup_finalize + | Tx_rollup_remove_commitment _, K_Tx_rollup_remove_commitment + | Tx_rollup_rejection _, K_Tx_rollup_reject + | Tx_rollup_dispatch_tickets _, K_Tx_rollup_dispatch_tickets + | Transfer_ticket _, K_Transfer_ticket + | Sc_rollup_originate _, K_Sc_rollup_origination + | Sc_rollup_add_messages _, K_Sc_rollup_add_messages + | Sc_rollup_cement _, K_Sc_rollup_cement + | Sc_rollup_publish _, K_Sc_rollup_publish + | Sc_rollup_refute _, K_Sc_rollup_refute + | Sc_rollup_timeout _, K_Sc_rollup_timeout + | Sc_rollup_execute_outbox_message _, K_Sc_rollup_execute_outbox_message + | Sc_rollup_recover_bond _, K_Sc_rollup_recover_bond + | Dal_publish_slot_header _, K_Dal_publish_slot_header -> + return_unit + | ( ( Transaction _ | Origination _ | Register_global_constant _ + | Delegation _ | Set_deposits_limit _ | Increase_paid_storage _ + | Reveal _ | Tx_rollup_origination | Tx_rollup_submit_batch _ + | Tx_rollup_commit _ | Tx_rollup_return_bond _ + | Tx_rollup_finalize_commitment _ | Tx_rollup_remove_commitment _ + | Tx_rollup_dispatch_tickets _ | Transfer_ticket _ + | Tx_rollup_rejection _ | Sc_rollup_originate _ | Sc_rollup_publish _ + | Sc_rollup_cement _ | Sc_rollup_add_messages _ | Sc_rollup_refute _ + | Sc_rollup_timeout _ | Sc_rollup_execute_outbox_message _ + | Sc_rollup_recover_bond _ | Dal_publish_slot_header _ + | Sc_rollup_dal_slot_subscribe _ ), + _ ) -> + assert false) + | Single _ -> assert false + | Cons _ -> assert false + +let ensure_manager_operation_coverage () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + List.iter_es (fun kind -> ensure_kind infos kind) subjects + +let test_ensure_manager_operation_coverage () = + Tztest.tztest + (Format.sprintf "Ensure manager_operation coverage") + `Quick + (fun () -> ensure_manager_operation_coverage ()) + +(** {2 Negative tests assert the case where validate must fail} *) + +(** Validate fails if the gas limit is too low. + + This test asserts that the validation of a manager operation + with a too low gas limit fails at validate with an + [Gas_quota_exceeded_init_deserialize] error. + This test applies on manager operations that do not + consume gas in their specific part of validate. *) +let low_gas_limit_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [ + Environment.Ecoproto_error + Validate_operation.Manager.Gas_quota_exceeded_init_deserialize; + Environment.Ecoproto_error Raw_context.Operation_quota_exceeded; + ] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_low_gas_limit kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + select_op + { + (operation_req_default kind) with + gas_limit = Some Op.Low; + force_reveal = Some true; + } + infos + in + low_gas_limit_diagnostic infos [op] + +let generate_low_gas_limit () = + create_Tztest + test_low_gas_limit + "Gas_limit too low." + gas_consumer_in_validate_subjects + +(** Validate fails if the gas limit is too high. + + This test asserts that the validation of a manager operation with + a gas limit too high fails at validate with an [Gas_limit_too_high] + error. It applies on every kind of manager operation. *) +let high_gas_limit_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error Gas.Gas_limit_too_high] -> return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_high_gas_limit kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + gas_limit = + Some (Op.Custom_gas (Gas.Arith.integral_of_int_exn 10_000_000)); + } + infos + in + high_gas_limit_diagnostic infos [op] + +let generate_high_gas_limit () = + create_Tztest test_high_gas_limit "Gas_limit too high." subjects + +(** Validate fails if the storage limit is too high. + + This test asserts that a manager operation with a storage limit + too high fails at validation with [Storage_limit_too_high] error. + It applies to every kind of manager operation. *) +let high_storage_limit_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error Fees_storage.Storage_limit_too_high] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_high_storage_limit kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + storage_limit = Some (Z.of_int max_int); + } + infos + in + high_storage_limit_diagnostic infos [op] + +let generate_high_storage_limit () = + create_Tztest test_high_gas_limit "Storage_limit too high." subjects + +(** Validate fails if the counter is in the future. + + This test asserts that the validation of + a manager operation with a counter in the + future -- aka greater than the successor of the manager counter + stored in the current context -- fails with [Counter_in_the_future] error. + It applies to every kind of manager operation. *) +let high_counter_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error (Contract_storage.Counter_in_the_future _)] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_high_counter kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + 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] + +let generate_high_counter () = + create_Tztest test_high_counter "Counter too high." subjects + +(** Validate fails if the counter is in the past. + + This test asserts that the validation of a manager operation with a + counter in the past -- aka smaller than the successor of the + manager counter stored in the current context -- fails with + [Counter_in_the_past] error. It applies to every kind of manager + operation. *) +let low_counter_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error (Contract_storage.Counter_in_the_past _)] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_low_counter kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* current_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 (Z.sub current_counter Z.one); + } + infos + in + low_counter_diagnostic infos [op] + +let generate_low_counter () = + create_Tztest test_low_counter "Counter too low." subjects + +(** Validate fails if the source is not allocated. + + This test asserts that the validation of a manager operation which + manager contract is not allocated fails with + [Empty_implicit_contract] error. It applies on every kind of + manager operation. *) +let not_allocated_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error (Contract_storage.Empty_implicit_contract _)] + -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_not_allocated kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + 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] + +let generate_not_allocated () = + create_Tztest test_not_allocated "Not allocated source." subjects + +(** Validate fails if the source is unrevealed. + + This test asserts that a manager operation with an unrevealed source + contract fails at validation with [Unrevealed_manager_key]. + It applies on every kind of manager operation except [Revelation]. *) +let unrevealed_key_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [ + Environment.Ecoproto_error + (Contract_manager_storage.Unrevealed_manager_key _); + ] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_unrevealed_key kind () = + let open Lwt_result_syntax in + 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 + test_unrevealed_key + "Unrevealed source (find_manager_public_key)." + revealed_subjects + +(** Validate fails if the source balance is not enough to pay the fees. + + This test asserts that validation of a manager operation fails if the + source balance is lesser than the manager operation fee. + It applies on every kind of manager operation. *) +let high_fee_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [ + Environment.Ecoproto_error (Contract_storage.Balance_too_low _); + Environment.Ecoproto_error (Tez_repr.Subtraction_underflow _); + ] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_high_fee kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let*? fee = Tez.(one +? one) |> Environment.wrap_tzresult in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + fee = Some fee; + } + infos + in + high_fee_diagnostic infos [op] + +let generate_tests_high_fee () = + create_Tztest test_high_fee "Balance too low for fee payment." subjects + +(** Validate fails if the fee payment empties the balance of a + delegated implicit contract. + + This test asserts that in case that: + - the source is a delegated implicit contract, and + - the fee is the exact balance of source. + then, validate fails with [Empty_implicit_delegated_contract] error. + It applies to every kind of manager operation except [Revelation].*) +let emptying_delegated_implicit_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [ + Environment.Ecoproto_error + (Contract_storage.Empty_implicit_delegated_contract _); + ] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_emptying_delegated_implicit kind () = + let open Lwt_result_syntax 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 + { + (operation_req_default kind) with + force_reveal = Some false; + fee = Some fee; + } + infos + in + emptying_delegated_implicit_diagnostic infos [op] + +let generate_tests_emptying_delegated_implicit () = + create_Tztest + test_emptying_delegated_implicit + "Just enough funds to empty a delegated source." + revealed_subjects + +(** Validate fails if there is not enough available gas in the block. + + This test asserts that validate fails with: + - [Gas_limit_too_high;Block_quota_exceeded] in mempool mode, + - [Block_quota_exceeded] in other mode + with gas limit exceeds the available gas in the block. + It applies to every kind of manager operation. *) +let exceeding_block_gas_diagnostic ~mode (infos : infos) op = + let expect_failure errs = + match (errs, mode) with + | ( [Environment.Ecoproto_error Gas.Block_quota_exceeded], + (Construction | Application) ) -> + return_unit + | ( [ + Environment.Ecoproto_error Gas.Gas_limit_too_high; + Environment.Ecoproto_error Gas.Block_quota_exceeded; + ], + Mempool ) -> + (* In mempool_mode, batch that exceed [operation_gas_limit] needs + to be refused. [Gas.Block_quota_exceeded] only return a + temporary error. [Gas.Gas_limit_too_high], which is a + permanent error, is added to the error trace to ensure that + the batch is refused. *) + return_unit + | err, _ -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure ~mode + +let test_exceeding_block_gas ~mode kind () = + let open Lwt_result_syntax 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* operation = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + gas_limit = + Some + (Op.Custom_gas + (Gas.Arith.add gb_limit Gas.Arith.(integral_of_int_exn 1))); + } + infos + in + exceeding_block_gas_diagnostic ~mode infos [operation] + +let generate_tests_exceeding_block_gas () = + create_Tztest + (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 ~mode:Mempool) + "Too much gas consumption in mempool mode." + subjects + +(** {2 Positive tests} *) + +(** Tests that validate succeeds when: + - it empties the balance of a self_delegated implicit source, + - it empties the balance of an undelegated implicit source, and + - in case: + - the counter is the successor of the one stored in the context, + - the fee is lesser than the balance, + - the storage limit is lesser than the maximum authorized storage, + - the gas limit is: + - lesser than the available gas in the block, + - less than the maximum gas consumable by an operation, and + - greater than the minimum gas consumable by an operation. + + Notice that in the first two cases only validate succeeds while + in the last case, the full application also succeeds. + In the 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: + - 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. *) +let test_emptying_self_delegated_implicit kind () = + let open Lwt_result_syntax 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 + { + (operation_req_default kind) with + force_reveal = Some false; + fee = Some fee; + } + infos + in + let* _ = only_validate_diagnostic infos [op] in + return_unit + +let generate_tests_emptying_self_delegated_implicit () = + create_Tztest + test_emptying_self_delegated_implicit + "Validate and empties a self-delegated source." + subjects + +(** 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 = default_init_ctxt () in + let* fee = + Context.Contract.balance + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + let* op = + select_op + { + (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 + let* _ = only_validate_diagnostic infos [op] in + return_unit + +let generate_tests_emptying_undelegated_implicit () = + create_Tztest + test_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 = default_init_ctxt () in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + gas_limit = Some Op.Low; + } + 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 + 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 + +(* 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 () + +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 () + +let fee_tests = + generate_tests_high_fee () + @ generate_tests_emptying_delegated_implicit () + @ generate_tests_emptying_self_delegated_implicit () + @ generate_tests_emptying_undelegated_implicit () + +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/helpers/incremental.ml b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml index 195e94ff58fb9f05fd82941c0c93cdcf7435c44c..6d2ad1339282d58eba1e2c14cfb63016656464d8 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 53a824fde6b5df853bb3ebc7410fbbc3d527f17e..804a282f813d7a5ec1634e6a8d4dfcbbd388c955 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/helpers/op.ml b/src/proto_alpha/lib_protocol/test/helpers/op.ml index b06aa3c76c1ad4244e2a6c0bca4f2150a13e3e4d..ffc6e2daadfcceb70530c60c8c3d0e48417ca512 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 951547cd2ab9595a04c08e9d0b40bbdd72c021fd..c96b2140df28512518319788e983b53831c13cf6 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/precheck/manager_operation_helpers.ml b/src/proto_alpha/lib_protocol/test/integration/precheck/manager_operation_helpers.ml deleted file mode 100644 index 8da4b841045325615952fa3838d3e223ec1d54a5..0000000000000000000000000000000000000000 --- a/src/proto_alpha/lib_protocol/test/integration/precheck/manager_operation_helpers.ml +++ /dev/null @@ -1,958 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic-Labs. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Protocol -open Alpha_context -open Test_tez - -(* 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) - -type infos = { - 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; -} - -(* 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 = - 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 - () - 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 - ~force_reveal:true - ~counter - ~gas_limit - (B b) - bootstrap_contract - rollup_contract - Tez.one - 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 - ~force_reveal:true - ~counter:counter2 - ~gas_limit - (B b) - rollup_contract - in - let* _, sc_rollup = - Op.sc_rollup_origination - ~counter:counter2 - ~gas_limit - (B b) - 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* create_contract_hash, contract_hash = - Op.contract_origination_hash - (B b) - contract3 - ~fee:Tez.zero - ~script:Op.dummy_script - in - let* operation = - Op.batch_operations - ~source:bootstrap_contract - (B b) - [fund_account1; fund_account2; fund_account3; create_contract_hash] - in - let+ block = Block.bake ~operation b in - { - block; - account1; - contract1; - account2; - contract2; - account3; - contract3; - contract_hash; - tx_rollup; - sc_rollup; - } - -(* Same as [init_context] but [contract1] delegate to [contract2] *) -let init_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 - in - let* _ = - Assert.is_none - ~loc:__LOC__ - ~pp:(fun fmt _ -> Format.fprintf fmt "should not be delegated") - del_opt - in - let* operation = - Op.delegation - ~force_reveal:true - (B infos.block) - infos.contract2 - (Some (Context.Contract.pkh infos.contract2)) - in - let* block = Block.bake infos.block ~operation in - let* operation = - Op.delegation - ~force_reveal:true - (B block) - infos.contract1 - (Some infos.account2.pkh) - 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 - in - let* _ = - Assert.is_none - ~loc:__LOC__ - ~pp:(fun fmt _ -> Format.fprintf fmt "should not be delegated") - del_opt - in - let* operation = - Op.delegation - ~force_reveal:true - (B infos.block) - infos.contract1 - (Some infos.account1.pkh) - 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} - -(* Local helpers for generating all kind of manager operations. *) - -(* 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 - -let get_pk infos source = - let open Lwt_result_syntax in - let+ account = Context.Contract.manager infos source in - account.pk - -let mk_transaction ?counter ?fee ?gas_limit ?storage_limit ?force_reveal ~source - (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) = - 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) = - Op.delegation - ?force_reveal - ?fee - ?gas_limit - ?counter - ?storage_limit - (B infos.block) - source - None - -let mk_self_delegation ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (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) = - let open Lwt_result_syntax in - let+ op, _ = - Op.contract_origination - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - ~script:Op.dummy_script - (B infos.block) - source - in - op - -let mk_register_global_constant ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.register_global_constant - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - (B infos.block) - ~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) = - Op.set_deposits_limit - ?force_reveal - ?fee - ?gas_limit - ?storage_limit - ?counter - (B infos.block) - source - None - -let mk_increase_paid_storage ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.increase_paid_storage - ?force_reveal - ?counter - ?fee - ?gas_limit - ?storage_limit - (B infos.block) - ~source - ~destination:infos.contract_hash - Z.one - -let mk_reveal ?counter ?fee ?gas_limit ?storage_limit ?force_reveal:_ ~source - (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 mk_tx_rollup_origination ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (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 - in - op - -let mk_tx_rollup_submit_batch ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.tx_rollup_submit_batch - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - "batch" - -let mk_tx_rollup_commit ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - let commitement : Tx_rollup_commitment.Full.t = - { - level = Tx_rollup_level.root; - messages = []; - predecessor = None; - inbox_merkle_root = Tx_rollup_inbox.Merkle.merklize_list []; - } - in - Op.tx_rollup_commit - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - commitement - -let mk_tx_rollup_return_bond ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - 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) = - 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) = - 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) = - let message, _ = Tx_rollup_message.make_batch "" in - let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in - let message_path = - match Tx_rollup_inbox.Merkle.compute_path [message_hash] 0 with - | Ok message_path -> message_path - | _ -> raise (Invalid_argument "Single_message_inbox.message_path") - in - let proof : Tx_rollup_l2_proof.t = - { - version = 1; - before = `Value Tx_rollup_message_result.empty_l2_context_hash; - after = `Value Context_hash.zero; - state = Seq.empty; - } - in - let previous_message_result : Tx_rollup_message_result.t = - { - context_hash = Tx_rollup_message_result.empty_l2_context_hash; - withdraw_list_hash = Tx_rollup_withdraw_list_hash.empty; - } - in - Op.tx_rollup_reject - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.tx_rollup - Tx_rollup_level.root - message - ~message_position:0 - ~message_path - ~message_result_hash:Tx_rollup_message_result_hash.zero - ~message_result_path:Tx_rollup_commitment.Merkle.dummy_path - ~proof - ~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) = - Op.transfer_ticket - ?fee - ?force_reveal - ?counter - ?gas_limit - ?storage_limit - (B infos.block) - ~source - ~contents:(Script.lazy_expr (Expr.from_string "1")) - ~ty:(Script.lazy_expr (Expr.from_string "nat")) - ~ticketer:infos.contract3 - Z.zero - ~destination:infos.contract2 - Entrypoint.default - -let mk_tx_rollup_dispacth_ticket ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - let reveal = - Tx_rollup_reveal. - { - contents = Script.lazy_expr (Expr.from_string "1"); - ty = Script.lazy_expr (Expr.from_string "nat"); - ticketer = infos.contract2; - amount = Tx_rollup_l2_qty.of_int64_exn 10L; - claimer = infos.account3.pkh; - } - in - Op.tx_rollup_dispatch_tickets - ?fee - ?force_reveal - ?counter - ?gas_limit - ?storage_limit - (B infos.block) - ~source - ~message_index:0 - ~message_result_path:Tx_rollup_commitment.Merkle.dummy_path - infos.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 open Lwt_result_syntax in - let+ op, _ = - Op.sc_rollup_origination - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - Sc_rollup.Kind.Example_arith - "" - (Script.lazy_expr (Expr.from_string "1")) - in - op - -let sc_dummy_commitment = - let number_of_ticks = - match Sc_rollup.Number_of_ticks.of_int32 3000l with - | None -> assert false - | Some x -> x - in - Sc_rollup.Commitment. - { - predecessor = Sc_rollup.Commitment.Hash.zero; - inbox_level = Raw_level.of_int32_exn Int32.zero; - number_of_ticks; - compressed_state = Sc_rollup.State_hash.zero; - } - -let mk_sc_rollup_publish ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - Op.sc_rollup_publish - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - sc_dummy_commitment - -let mk_sc_rollup_cement ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - Op.sc_rollup_cement - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.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 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 - (Some refutation) - -let mk_sc_rollup_add_messages ?counter ?fee ?gas_limit ?storage_limit - ?force_reveal ~source (infos : infos) = - Op.sc_rollup_add_messages - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.sc_rollup - [] - -let mk_sc_rollup_timeout ?counter ?fee ?gas_limit ?storage_limit ?force_reveal - ~source (infos : infos) = - 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) = - Op.sc_rollup_execute_outbox_message - ?fee - ?gas_limit - ?counter - ?storage_limit - ?force_reveal - (B infos.block) - source - infos.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) = - 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) = - let open Lwt_result_syntax in - let level = 0 in - let index = 0 in - let header = 0 in - let json_slot = - Data_encoding.Json.from_string - (Format.asprintf - {|{"level":%d,"index":%d,"header":%d}|} - level - index - header) - in - let* json_slot = - match json_slot with Error s -> failwith "%s" s | Ok slot -> return slot - 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 - 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. *) -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 - -let string_of_kind = 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_return_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 - match hd_msg with - | None -> sk - | Some hd -> Format.sprintf "Batch: %s, %s" hd sk - in - List.map - (fun kind -> - Tztest.tztest - (Format.sprintf "%s with %s" (hd_msg kind) tests_msg) - `Quick - (fun () -> test kind ())) - operations - -let rec create_Tztest_batches test tests_msg operations = - let hdmsg k = Format.sprintf "%s" (string_of_kind k) in - let aux hd_msg test operations = - create_Tztest ~hd_msg test tests_msg operations - in - match operations with - | [] -> [] - | 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. *) - -(* For a manager operation a [probes] contains the values required for observing - its precheck success. Its source, fees (sum for a batch), gas_limit - (sum of gas_limit of the batch), and the increment of the counters aka 1 for - a single operation, n for a batch of n manager operations. *) -type probes = { - source : Signature.Public_key_hash.t; - fee : Tez.tez; - gas_limit : Gas.Arith.integral; - nb_counter : Z.t; -} - -let rec contents_infos : - type kind. kind Kind.manager contents_list -> probes tzresult Lwt.t = - fun op -> - let open Lwt_result_syntax in - match op with - | Single (Manager_operation {source; fee; gas_limit; _}) -> - return {source; fee; gas_limit; nb_counter = Z.one} - | Cons (Manager_operation manop, manops) -> - let* probes = contents_infos manops in - let*? fee = manop.fee +? probes.fee in - let gas_limit = Gas.Arith.add probes.gas_limit manop.gas_limit in - let nb_counter = Z.succ probes.nb_counter in - let _ = Assert.equal_pkh ~loc:__LOC__ manop.source probes.source in - return {fee; source = probes.source; gas_limit; nb_counter} - -(* Computes a [probes] from a list of manager contents. *) -let manager_content_infos op = - let (Operation_data {contents; _}) = op.protocol_data in - match contents with - | Single (Manager_operation _) as op -> contents_infos op - | Cons (Manager_operation _, _) as op -> contents_infos op - | _ -> assert false - -(* [observe] asserts the success of precheck 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 - succeeds - - [contract] balance decreases at least by [probes.fee] when ![only_precheck] 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 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 - let*? b_expected = b_in -? probes.fee in - let b_cmp = - Assert.equal - ~loc:__LOC__ - (if only_precheck then Tez.( = ) else Tez.( <= )) - "Balance update" - 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 - ~loc:__LOC__ - "Counter incrementation" - Z.pp_print - 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 precheck_with_diagnostic ~only_precheck (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.precheck_operation i op in - let* _ = Incremental.finalize_block i in - observe ~only_precheck contract b_in c_in g_in prbs i - -(* If only the precheck 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 - -(* If an manager operation application succeed, the precheck - 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 - -(* [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 - 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 - should be extended for each new manager_operation kind. *) -let subjects = - [ - K_Transaction; - K_Origination; - K_Register_global_constant; - K_Delegation; - K_Undelegation; - K_Self_delegation; - K_Set_deposits_limit; - K_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 is_consumer = function - | K_Set_deposits_limit | K_Increase_paid_storage | K_Reveal - | K_Self_delegation | K_Delegation | K_Undelegation | K_Tx_rollup_origination - | K_Tx_rollup_submit_batch | K_Tx_rollup_finalize | K_Tx_rollup_commit - | K_Tx_rollup_return_bond | K_Tx_rollup_remove_commitment | K_Tx_rollup_reject - | K_Sc_rollup_add_messages | K_Sc_rollup_origination | K_Sc_rollup_refute - | K_Sc_rollup_timeout | K_Sc_rollup_cement | K_Sc_rollup_publish - | K_Sc_rollup_execute_outbox_message | K_Sc_rollup_recover_bond - | K_Dal_publish_slot_header -> - false - | K_Transaction | K_Origination | K_Register_global_constant - | K_Tx_rollup_dispatch_tickets | K_Transfer_ticket -> - true - -let gas_consumer_in_precheck_subjects, not_gas_consumer_in_precheck_subjects = - List.partition is_consumer subjects - -let revealed_subjects = - List.filter (function K_Reveal -> false | _ -> true) subjects diff --git a/src/proto_alpha/lib_protocol/test/integration/precheck/test_manager_operation_precheck.ml b/src/proto_alpha/lib_protocol/test/integration/precheck/test_manager_operation_precheck.ml deleted file mode 100644 index 79831ff4c6082933472274884967fcabfde6bcb4..0000000000000000000000000000000000000000 --- a/src/proto_alpha/lib_protocol/test/integration/precheck/test_manager_operation_precheck.ml +++ /dev/null @@ -1,570 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic-Labs. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** Testing - ------- - Component: Protocol (precheck manager) - Invocation: dune exec \ - src/proto_alpha/lib_protocol/test/integration/precheck/main.exe \ - -- test "^Single$" - Subject: Precheck 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 - - 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. *) -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 (Operation_data {contents; _}) = op.protocol_data in - match contents with - | Single (Manager_operation {operation; _}) -> ( - match (operation, kind) with - | Transaction _, K_Transaction - | Reveal _, K_Reveal - | Origination _, K_Origination - | Delegation _, K_Delegation - | Delegation _, K_Undelegation - | Delegation _, K_Self_delegation - | Register_global_constant _, K_Register_global_constant - | Set_deposits_limit _, K_Set_deposits_limit - | Increase_paid_storage _, K_Increase_paid_storage - | Tx_rollup_origination, K_Tx_rollup_origination - | Tx_rollup_submit_batch _, K_Tx_rollup_submit_batch - | Tx_rollup_commit _, K_Tx_rollup_commit - | Tx_rollup_return_bond _, K_Tx_rollup_return_bond - | Tx_rollup_finalize_commitment _, K_Tx_rollup_finalize - | Tx_rollup_remove_commitment _, K_Tx_rollup_remove_commitment - | Tx_rollup_rejection _, K_Tx_rollup_reject - | Tx_rollup_dispatch_tickets _, K_Tx_rollup_dispatch_tickets - | Transfer_ticket _, K_Transfer_ticket - | Sc_rollup_originate _, K_Sc_rollup_origination - | Sc_rollup_add_messages _, K_Sc_rollup_add_messages - | Sc_rollup_cement _, K_Sc_rollup_cement - | Sc_rollup_publish _, K_Sc_rollup_publish - | Sc_rollup_refute _, K_Sc_rollup_refute - | Sc_rollup_timeout _, K_Sc_rollup_timeout - | Sc_rollup_execute_outbox_message _, K_Sc_rollup_execute_outbox_message - | Sc_rollup_recover_bond _, K_Sc_rollup_recover_bond - | Dal_publish_slot_header _, K_Dal_publish_slot_header -> - return_unit - | ( ( Transaction _ | Origination _ | Register_global_constant _ - | Delegation _ | Set_deposits_limit _ | Increase_paid_storage _ - | Reveal _ | Tx_rollup_origination | Tx_rollup_submit_batch _ - | Tx_rollup_commit _ | Tx_rollup_return_bond _ - | Tx_rollup_finalize_commitment _ | Tx_rollup_remove_commitment _ - | Tx_rollup_dispatch_tickets _ | Transfer_ticket _ - | Tx_rollup_rejection _ | Sc_rollup_originate _ | Sc_rollup_publish _ - | Sc_rollup_cement _ | Sc_rollup_add_messages _ | Sc_rollup_refute _ - | Sc_rollup_timeout _ | Sc_rollup_execute_outbox_message _ - | Sc_rollup_recover_bond _ | Dal_publish_slot_header _ - | Sc_rollup_dal_slot_subscribe _ ), - _ ) -> - assert false) - | Single _ -> assert false - | Cons _ -> assert false - -let ensure_manager_operation_coverage () = - let open Lwt_result_syntax in - let* infos = init_context () in - List.iter_es (fun kind -> ensure_kind infos kind) subjects - -let test_ensure_manager_operation_coverage () = - Tztest.tztest - (Format.sprintf "Ensure manager_operation coverage") - `Quick - (fun () -> ensure_manager_operation_coverage ()) - -(* Negative tests assert the case where precheck must fail. *) - -(* Precheck 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. *) -let low_gas_limit_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error - Validate_operation.Manager.Gas_quota_exceeded_init_deserialize; - Environment.Ecoproto_error Raw_context.Operation_quota_exceeded; - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_low_gas_limit 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 - low_gas_limit_diagnostic infos op - -let generate_low_gas_limit () = - create_Tztest - test_low_gas_limit - "Gas_limit too low." - gas_consumer_in_precheck_subjects - -(* Precheck 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. *) -let high_gas_limit_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Gas.Gas_limit_too_high] -> return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -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* op = - select_op ~gas_limit ~force_reveal:true ~source:infos.contract1 kind infos - in - high_gas_limit_diagnostic infos op - -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. - - 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. *) -let high_storage_limit_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Fees_storage.Storage_limit_too_high] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -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* op = - select_op - ~storage_limit - ~force_reveal:true - ~source:infos.contract1 - kind - infos - in - high_storage_limit_diagnostic infos op - -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. - - 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. *) -let high_counter_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error (Contract_storage.Counter_in_the_future _)] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -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* op = - select_op ~counter ~force_reveal:true ~source:infos.contract1 kind infos - in - high_counter_diagnostic infos op - -let generate_high_counter () = - create_Tztest test_high_counter "Counter too high." subjects - -(* Precheck 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. *) -let low_counter_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error (Contract_storage.Counter_in_the_past _)] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_low_counter kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let* current_counter = - Context.Contract.counter (B infos.block) infos.contract1 - in - let counter = Z.sub current_counter Z.one in - let* op = - select_op ~counter ~force_reveal:true ~source:infos.contract1 kind infos - in - low_counter_diagnostic infos op - -let generate_low_counter () = - create_Tztest test_low_counter "Counter too low." subjects - -(* Precheck 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. *) -let not_allocated_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error (Contract_storage.Empty_implicit_contract _)] - -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_not_allocated kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let* op = - select_op ~force_reveal:false ~source:(mk_fresh_contract ()) kind infos - in - not_allocated_diagnostic infos op - -let generate_not_allocated () = - create_Tztest test_not_allocated "not allocated source." subjects - -(* Precheck 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]. *) -let unrevealed_key_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error - (Contract_manager_storage.Unrevealed_manager_key _); - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -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 generate_unrevealed_key () = - create_Tztest - test_unrevealed_key - "unrevealed source (find_manager_public_key)." - revealed_subjects - -(* Precheck fails if the source's 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. *) -let high_fee_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error (Contract_storage.Balance_too_low _); - Environment.Ecoproto_error (Tez_repr.Subtraction_underflow _); - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -let test_high_fee kind () = - let open Lwt_result_syntax in - let* infos = init_context () in - let*? fee = Tez.(one +? one) |> Environment.wrap_tzresult in - let* op = - select_op ~fee ~force_reveal:true ~source:infos.contract1 kind infos - in - high_fee_diagnostic infos op - -let generate_tests_high_fee () = - create_Tztest test_high_fee "not enough for fee payment." subjects - -(* Precheck 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].*) -let emptying_delegated_implicit_diagnostic (infos : infos) op = - let expect_failure errs = - match errs with - | [ - Environment.Ecoproto_error - (Contract_storage.Empty_implicit_delegated_contract _); - ] -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure - -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* op = - select_op ~fee ~force_reveal:false ~source:infos.contract1 kind infos - in - emptying_delegated_implicit_diagnostic infos op - -let generate_tests_emptying_delegated_implicit () = - create_Tztest - test_emptying_delegated_implicit - "just enough funds to empty a delegated source." - revealed_subjects - -(* Precheck fails if there is not enough available gas in the block. - - This test asserts that precheck fails with: - - [Gas_limit_too_high;Block_quota_exceeded] in mempool mode, - | [Block_quota_exceeded] in other mode - with gas limit exceeds the available gas in the block. - It applies to every kind of manager operation. *) -let exceeding_block_gas_diagnostic ~mempool_mode (infos : infos) op = - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Gas.Block_quota_exceeded] - when not mempool_mode -> - return_unit - | [ - Environment.Ecoproto_error Gas.Gas_limit_too_high; - Environment.Ecoproto_error Gas.Block_quota_exceeded; - ] - when mempool_mode -> - (* In mempool_mode, batch that exceed [operation_gas_limit] needs - to be refused. [Gas.Block_quota_exceeded] only return a - temporary error. [Gas.Gas_limit_too_high], which is a - permanent error, is added to the error trace to ensure that - the batch is refused. *) - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - precheck_ko_diagnostic infos op expect_failure ~mempool_mode - -let test_exceeding_block_gas ~mempool_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)) - in - let* operation = - select_op ~force_reveal:true ~source:infos.contract1 ~gas_limit kind infos - in - exceeding_block_gas_diagnostic ~mempool_mode infos operation - -let generate_tests_exceeding_block_gas () = - create_Tztest - (test_exceeding_block_gas ~mempool_mode:false) - "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." - subjects - -(* 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: - - 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: - - 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: - - 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. *) -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* op = - select_op ~fee ~force_reveal:false ~source:infos.contract1 kind infos - in - only_precheck_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." - 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 = - 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* fee = Context.Contract.balance (B infos.block) infos.contract1 in - let* op = - select_op - ~fee - ~gas_limit - ~force_reveal:true - ~source:infos.contract1 - kind - infos - in - only_precheck_diagnostic infos op - -let generate_tests_emptying_undelegated_implicit () = - create_Tztest - test_emptying_undelegated_implicit - "passes precheck and empties an undelegated source." - subjects - -(* Fee payment.*) -let test_precheck 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 - -let generate_tests_precheck () = - create_Tztest test_precheck "passes precheck." subjects - -let sanity_tests = - test_ensure_manager_operation_coverage () :: generate_tests_precheck () - -let gas_tests = - generate_low_gas_limit () @ generate_high_gas_limit () - @ generate_tests_exceeding_block_gas () - @ generate_tests_exceeding_block_gas_mp_mode () - -let storage_tests = generate_high_storage_limit () - -let fee_tests = - generate_tests_high_fee () - @ generate_tests_emptying_delegated_implicit () - @ generate_tests_emptying_self_delegated_implicit () - @ generate_tests_emptying_undelegated_implicit () - -let contract_tests = - generate_high_counter () @ generate_low_counter () @ generate_not_allocated () - @ generate_unrevealed_key () diff --git a/src/proto_alpha/lib_protocol/test/integration/precheck/dune b/src/proto_alpha/lib_protocol/test/integration/validate/dune similarity index 76% rename from src/proto_alpha/lib_protocol/test/integration/precheck/dune rename to src/proto_alpha/lib_protocol/test/integration/validate/dune index ebb763391fb83ea01b8ce18e3910983a8a91989b..fe89647675a887147e163b4f6c0c254d5db0bf04 100644 --- a/src/proto_alpha/lib_protocol/test/integration/precheck/dune +++ b/src/proto_alpha/lib_protocol/test/integration/validate/dune @@ -1,12 +1,13 @@ ; 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 tezos-protocol-alpha + qcheck-alcotest tezos-client-alpha tezos-alpha-test-helpers tezos-base-test-helpers) @@ -23,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 new file mode 100644 index 0000000000000000000000000000000000000000..dd40f8c10039719726fa31e63a3c2592ca785ec0 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml @@ -0,0 +1,263 @@ +(*****************************************************************************) +(* *) +(* 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 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 { + 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; + flags = all_enabled; + } + +(** {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/precheck/main.ml b/src/proto_alpha/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_alpha/lib_protocol/test/integration/validate/main.ml index 9e58c8ee0a29d40a59b7ffd8ee1f32ee950b930d..5613c918c335d8287e8c3d41f401b3ec3d021094 100644 --- a/src/proto_alpha/lib_protocol/test/integration/precheck/main.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/main.ml @@ -26,22 +26,27 @@ (** 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 ); + ( "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 new file mode 100644 index 0000000000000000000000000000000000000000..2f5f15ffc87478a5358bb68c2bba5ea830f413d8 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -0,0 +1,1393 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic-Labs. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context +open Test_tez + +(** {2 Constants} *) + +(** Hard gas limit *) + +let gb_limit = Gas.Arith.(integral_of_int_exn 100_000) + +let half_gb_limit = Gas.Arith.(integral_of_int_exn 50_000) + +(** {2 Datatypes} *) + +(** Context abstraction in a test. *) +type ctxt = { + block : Block.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; +} + +(** 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; +} + +(** 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; + 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; + flags : feature_flags; +} + +(** Validation mode. + + FIXME: https://gitlab.com/tezos/tezos/-/issues/3365 + This type should be replaced by the one defined + in validation, type mode in `validate_operation`, when it would + include the distinction between Contruction and Application. *) +type mode = Construction | Mempool | Application + +(** {2 Default values} *) +let all_enabled = {dal = true; scoru = true; toru = true} + +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; + fund_dest = Some Tez.one; + 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; + counter = None; + fee = None; + gas_limit = None; + storage_limit = None; + force_reveal = None; + amount = None; + } + +(** {2 String_of data} *) +let kind_to_string = function + | K_Transaction -> "Transaction" + | K_Delegation -> "Delegation" + | K_Undelegation -> "Undelegation" + | K_Self_delegation -> "Self-delegation" + | K_Set_deposits_limit -> "Set deposits limit" + | K_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_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; + flags; + } = + 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@,\ + dal_flag: %a@,\ + scoru_flag: %a@,\ + toru_flag: %a@,\ + @]" + (pp_opt Gas.Arith.pp_integral) + hard_gas_limit_per_block + (pp_opt Tez.pp) + fund_src + (pp_opt Tez.pp) + fund_dest + (pp_opt Tez.pp) + fund_del + (pp_opt Tez.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" + | Mempool -> Format.fprintf pp "Mempool" + | Application -> Format.fprintf pp "Block" + +(** {2 Short-cuts} *) +let contract_of (account : Account.t) = Contract.Implicit account.pkh + +(** Make a [mempool_mode], aka a boolean, as used in incremental from + a [mode]. *) +let mempool_mode_of = function Mempool -> true | _ -> false + +let get_pk infos source = + let open Lwt_result_syntax in + let+ account = Context.Contract.manager infos source in + account.pk + +(** Operation for specific context. *) +let self_delegate block pkh = + let open Lwt_result_syntax in + let contract = Contract.Implicit pkh in + let* operation = + Op.delegation ~force_reveal:true (B block) contract (Some pkh) + in + let* block = Block.bake block ~operation in + let* del_opt_new = Context.Contract.delegate_opt (B block) contract in + let* del = Assert.get_some ~loc:__LOC__ del_opt_new in + let+ _ = Assert.equal_pkh ~loc:__LOC__ del pkh in + block + +let delegation block 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 + (B block) + contract_delegate + (Some delegate_pkh) + in + let* block = Block.bake block ~operation in + let* operation = + Op.delegation + ~force_reveal:true + (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+ 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 + ~force_reveal:true + (B block) + rollup_contract + Sc_rollup.Kind.Example_arith + "" + (Script.lazy_expr (Expr.from_string "1")) + in + 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.transaction + ~counter + ~gas_limit:Op.High + (B block) + bootstrap + (Contract.Implicit account) + fund + in + let*! b = Block.bake ~operation block in + match b with Error _ -> failwith "Funding account error" | Ok b -> return b + +(** 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; + flags; + } -> + let open Lwt_result_syntax in + let create_and_fund ?originate_rollup block bootstrap fund = + match fund with + | None -> return (block, None, None) + | Some _ -> + let account = Account.new_account () in + let* block = fund_account block bootstrap account.pkh fund in + let+ block, rollup = + match originate_rollup with + | None -> return (block, None) + | Some f -> + let+ block, rollup = f block account in + (block, Some rollup) + in + (block, Some account, rollup) + in + let* block, bootstraps = + Context.init_n + 6 + ~consensus_threshold:0 + ?hard_gas_limit_per_block + ~tx_rollup_enable:flags.toru + ~tx_rollup_sunset_level:Int32.max_int + ~sc_rollup_enable:flags.scoru + ~dal_enable:flags.dal + () + in + 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, dest, _ = + create_and_fund block (get_bootstrap bootstraps 1) fund_dest + in + let* block, del, _ = + create_and_fund block (get_bootstrap bootstraps 2) fund_del + in + let* block, tx, tx_rollup = + 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 = + 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 + (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}} + +(** In addition of building up a context according to a context + requirement, source is self-delegated. + + see [init_ctxt] description. *) +let ctxt_with_self_delegation : ctxt_req -> infos tzresult Lwt.t = + fun ctxt_req -> + let open Lwt_result_syntax in + let* infos = init_ctxt ctxt_req in + let+ block = self_delegate infos.ctxt.block infos.accounts.source.pkh in + let ctxt = {infos.ctxt with block} in + {infos with ctxt} + +(** In addition of building up a context accordning to a context + requirement, source delegates to del. + + See [init_ctxt] description. *) +let ctxt_with_delegation : ctxt_req -> infos tzresult Lwt.t = + fun ctxt_req -> + let open Lwt_result_syntax in + let* infos = init_ctxt ctxt_req in + let* delegate = + match infos.accounts.del with + | None -> failwith "Delegate account should be funded" + | Some a -> return a + in + let+ block = delegation infos.ctxt.block 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_init_with_flags flags = init_ctxt (ctxt_req_default_to_flag flags) + +let default_ctxt_with_self_delegation () = + ctxt_with_self_delegation ctxt_req_default + +let default_ctxt_with_delegation () = ctxt_with_delegation ctxt_req_default + +(** {2 Smart constructors} *) + +(** Smart constructors to forge manager operations according to + operation requirements in a test setting. *) + +let mk_transaction (oinfos : operation_req) (infos : infos) = + Op.transaction + ?force_reveal:oinfos.force_reveal + ?counter:oinfos.counter + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + (contract_of 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: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: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 (oinfos : operation_req) (infos : infos) = + Op.delegation + ?force_reveal:oinfos.force_reveal + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + (contract_of 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:oinfos.force_reveal + ?counter:oinfos.counter + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + ~script:Op.dummy_script + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + op + +let mk_register_global_constant (oinfos : operation_req) (infos : infos) = + Op.register_global_constant + ?force_reveal:oinfos.force_reveal + ?counter:oinfos.counter + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + ~source:(contract_of infos.accounts.source) + ~value:(Script_repr.lazy_expr (Expr.from_string "Pair 1 2")) + +let mk_set_deposits_limit (oinfos : operation_req) (infos : infos) = + Op.set_deposits_limit + ?force_reveal:oinfos.force_reveal + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + ?counter:oinfos.counter + (B infos.ctxt.block) + (contract_of infos.accounts.source) + None + +let mk_increase_paid_storage (oinfos : operation_req) (infos : infos) = + Op.increase_paid_storage + ?force_reveal:oinfos.force_reveal + ?counter:oinfos.counter + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + ~source:(contract_of infos.accounts.source) + ~destination:infos.ctxt.originated_contract + Z.one + +let mk_reveal (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* pk = get_pk (B infos.ctxt.block) (contract_of 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 (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let+ op, _rollup = + Op.tx_rollup_origination + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + op + +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: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 (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; + messages = []; + predecessor = None; + inbox_merkle_root = Tx_rollup_inbox.Merkle.merklize_list []; + } + in + Op.tx_rollup_commit + ?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 (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: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: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: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 = + match Tx_rollup_inbox.Merkle.compute_path [message_hash] 0 with + | Ok message_path -> message_path + | _ -> raise (Invalid_argument "Single_message_inbox.message_path") + in + let proof : Tx_rollup_l2_proof.t = + { + version = 1; + before = `Value Tx_rollup_message_result.empty_l2_context_hash; + after = `Value Context_hash.zero; + state = Seq.empty; + } + in + let previous_message_result : Tx_rollup_message_result.t = + { + context_hash = Tx_rollup_message_result.empty_l2_context_hash; + withdraw_list_hash = Tx_rollup_withdraw_list_hash.empty; + } + in + Op.tx_rollup_reject + ?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 + ~message_path + ~message_result_hash:Tx_rollup_message_result_hash.zero + ~message_result_path:Tx_rollup_commitment.Merkle.dummy_path + ~proof + ~previous_message_result + ~previous_message_result_path:Tx_rollup_commitment.Merkle.dummy_path + +let mk_transfer_ticket (oinfos : operation_req) (infos : infos) = + Op.transfer_ticket + ?fee:oinfos.fee + ?force_reveal:oinfos.force_reveal + ?counter:oinfos.counter + ?gas_limit:oinfos.gas_limit + ?storage_limit:oinfos.storage_limit + (B infos.ctxt.block) + ~source:(contract_of infos.accounts.source) + ~contents:(Script.lazy_expr (Expr.from_string "1")) + ~ty:(Script.lazy_expr (Expr.from_string "nat")) + ~ticketer: + (contract_of + (match infos.accounts.tx with + | None -> infos.accounts.source + | Some tx -> tx)) + Z.zero + ~destination: + (contract_of + (match infos.accounts.dest with + | None -> infos.accounts.source + | Some dest -> dest)) + Entrypoint.default + +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 = + contract_of + (match infos.accounts.dest with + | None -> infos.accounts.source + | Some dest -> dest); + amount = Tx_rollup_l2_qty.of_int64_exn 10L; + claimer = + (match infos.accounts.dest with + | None -> infos.accounts.source.pkh + | Some dest -> dest.pkh); + } + in + Op.tx_rollup_dispatch_tickets + ?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 + tx_rollup + Tx_rollup_level.root + Context_hash.zero + [reveal] + +let mk_sc_rollup_origination (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let+ op, _ = + Op.sc_rollup_origination + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + Sc_rollup.Kind.Example_arith + "" + (Script.lazy_expr (Expr.from_string "1")) + in + op + +let sc_dummy_commitment = + let number_of_ticks = + match Sc_rollup.Number_of_ticks.of_int32 3000l with + | None -> assert false + | Some x -> x + in + Sc_rollup.Commitment. + { + predecessor = Sc_rollup.Commitment.Hash.zero; + inbox_level = Raw_level.of_int32_exn Int32.zero; + number_of_ticks; + compressed_state = Sc_rollup.State_hash.zero; + } + +let mk_sc_rollup_publish (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + Op.sc_rollup_publish + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + sc_rollup + sc_dummy_commitment + +let mk_sc_rollup_cement (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + Op.sc_rollup_cement + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + sc_rollup + (Sc_rollup.Commitment.hash sc_dummy_commitment) + +let mk_sc_rollup_refute (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + let refutation : Sc_rollup.Game.refutation = + {choice = Sc_rollup.Tick.initial; step = Dissection []} + in + Op.sc_rollup_refute + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of 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 (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: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 (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* sc_rollup = sc_rollup_of infos.ctxt.sc_rollup in + Op.sc_rollup_timeout + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of 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: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 (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: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 + let header = 0 in + let json_slot = + Data_encoding.Json.from_string + (Format.asprintf + {|{"level":%d,"index":%d,"header":%d}|} + level + index + header) + in + let* json_slot = + match json_slot with Error s -> failwith "%s" s | Ok slot -> return slot + in + let slot = Data_encoding.Json.destruct Dal.Slot.encoding json_slot in + Op.dal_publish_slot_header + ?fee:oinfos.fee + ?gas_limit:oinfos.gas_limit + ?counter:oinfos.counter + ?storage_limit:oinfos.storage_limit + ?force_reveal:oinfos.force_reveal + (B infos.ctxt.block) + (contract_of infos.accounts.source) + slot + +(** {2 Helpers for generation of generic check tests by manager operation} *) + +(** Generic forge for any kind of manager operation according to + operation requirements in a specific test setting. *) +let select_op (op_req : operation_req) (infos : infos) = + let mk_op = + match op_req.kind with + | K_Transaction -> mk_transaction + | K_Origination -> mk_origination + | K_Register_global_constant -> mk_register_global_constant + | K_Delegation -> mk_delegation + | K_Undelegation -> mk_undelegation + | K_Self_delegation -> mk_self_delegation + | K_Set_deposits_limit -> mk_set_deposits_limit + | K_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 tl_msg k = + let sk = kind_to_string k in + match hd_msg with None -> sk | Some hd -> Format.sprintf "%s, %s" hd sk + in + List.map + (fun kind -> + Tztest.tztest + (Format.sprintf "%s [%s]" tests_msg (tl_msg kind)) + `Quick + (fun () -> test kind ())) + operations + +let rec create_Tztest_batches test tests_msg operations = + 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 + match operations with + | [] -> [] + | kop :: kops as ops -> + aux (hdmsg kop) (test kop) ops @ create_Tztest_batches test tests_msg kops + +(** {2 Diagnostic helpers.} *) + +(** The purpose of diagnostic helpers is to state the correct + observation according to the validate result of a test. *) + +(** For a manager operation a [probes] contains the values required + for observing its validate success. Its source, fees (sum for a + batch), gas_limit (sum of gas_limit of the batch), and the + increment of the counters aka 1 for a single operation, n for a + batch of n manager operations. *) +type probes = { + source : Signature.Public_key_hash.t; + fee : Tez.tez; + gas_limit : Gas.Arith.integral; + nb_counter : Z.t; +} + +let rec contents_infos : + type kind. kind Kind.manager contents_list -> probes tzresult Lwt.t = + fun op -> + let open Lwt_result_syntax in + match op with + | Single (Manager_operation {source; fee; gas_limit; _}) -> + return {source; fee; gas_limit; nb_counter = Z.one} + | Cons (Manager_operation manop, manops) -> + let* probes = contents_infos manops in + let*? fee = manop.fee +? probes.fee in + let gas_limit = Gas.Arith.add probes.gas_limit manop.gas_limit in + let nb_counter = Z.succ probes.nb_counter in + let _ = Assert.equal_pkh ~loc:__LOC__ manop.source probes.source in + return {fee; source = probes.source; gas_limit; nb_counter} + +(** Computes a [probes] from a list of manager contents. *) +let manager_content_infos op = + let (Operation_data {contents; _}) = op.protocol_data in + match contents with + | Single (Manager_operation _) as op -> contents_infos op + | Cons (Manager_operation _, _) as op -> contents_infos op + | _ -> failwith "Should only handle manager operation" + +(** We need a way to get the available gas in a context of type + block. *) +let available_gas = function + | Context.I inc -> Some (Gas.block_level (Incremental.alpha_ctxt inc)) + | B _ -> None + +(** Computes the witness value in a state. The witness values are the + the initial balance of source, its initial counter and the + available gas in the state. The available gas is computed only + when the context is an incremental one. *) +let witness ctxt source = + let open Lwt_result_syntax in + let* b_in = Context.Contract.balance ctxt source in + let+ c_in = Context.Contract.counter ctxt source in + let g_in = available_gas ctxt in + (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__ + (if only_validate then Tez.( = ) else Tez.( <= )) + (if only_validate then "Balance update (=)" else "Balance update (<=)") + Tez.pp + in + let* _ = b_cmp b_out b_expected in + let _ = + Assert.equal + Z.equal + ~loc:__LOC__ + "Counter incrementation" + Z.pp_print + c_out + c_expected + in + let g_msg = + match mode with + | Application -> "Gas consumption (application)" + | Mempool -> "Gas consumption (mempool)" + | Construction -> "Gas consumption (construction)" + in + match g_expected with + | None -> Assert.is_none ~loc:__LOC__ ~pp:Gas.Arith.pp g_out + | Some g_expected -> + let* g_out = Assert.get_some ~loc:__LOC__ g_out in + Assert.equal + ~loc:__LOC__ + Gas.Arith.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 + 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. *) +let subjects = + [ + 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 is_consumer = function + | K_Set_deposits_limit | K_Increase_paid_storage | K_Reveal + | K_Self_delegation | K_Delegation | K_Undelegation | K_Tx_rollup_origination + | K_Tx_rollup_submit_batch | K_Tx_rollup_finalize | K_Tx_rollup_commit + | K_Tx_rollup_return_bond | K_Tx_rollup_remove_commitment | K_Tx_rollup_reject + | K_Sc_rollup_add_messages | K_Sc_rollup_origination | K_Sc_rollup_refute + | K_Sc_rollup_timeout | K_Sc_rollup_cement | K_Sc_rollup_publish + | K_Sc_rollup_execute_outbox_message | K_Sc_rollup_recover_bond + | K_Dal_publish_slot_header -> + false + | K_Transaction | K_Origination | K_Register_global_constant + | K_Tx_rollup_dispatch_tickets | K_Transfer_ticket -> + true + +let gas_consumer_in_validate_subjects, not_gas_consumer_in_validate_subjects = + List.partition is_consumer subjects + +let revealed_subjects = + List.filter (function K_Reveal -> false | _ -> true) subjects + +let is_disabled flags = function + | K_Transaction | K_Origination | K_Register_global_constant | K_Delegation + | K_Undelegation | K_Self_delegation | K_Set_deposits_limit + | K_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_1m_restriction.ml b/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml new file mode 100644 index 0000000000000000000000000000000000000000..18c261fb070dd9052d1f9d5b437178b11db53a00 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml @@ -0,0 +1,242 @@ +(*****************************************************************************) +(* *) +(* 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/test_1m_restriction.exe + Subject: 1M restriction in validation of manager operation. +*) + +open Protocol +open Manager_operation_helpers +open Generators + +(** 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 + +(** 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 + 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 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 + 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 + 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) + +(** 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 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. *) +let valid_context_free = + let gen = + QCheck2.Gen.quad + (Generators.gen_ctxt_req ctxt_cstrs_default) + (Generators.gen_operation_req (op_cstrs_default true) revealed_subjects) + (Generators.gen_operation_req (op_cstrs_default true) revealed_subjects) + Generators.gen_mode + in + wrap + ~count:1000 + ~print:print_two_ops + ~name:"Under 1M, co-valid ops commute" + ~gen + (fun (ctxt_req, operation_req, operation_req', mode) -> + let open Lwt_result_syntax in + let* infos = init_ctxt ctxt_req in + let* op1 = select_op operation_req infos in + let infos2 = + { + infos with + accounts = + { + infos.accounts with + 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 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_tests4 = + ("Fee payment of two covalid operations commute", conflict_free_tests) + +let () = + Alcotest.run + "1M QCheck" + [qcheck_tests; qcheck_tests2; qcheck_tests3; qcheck_tests4] 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 61% 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 28bcc3c6fb299a816383446b6a6b54d11a765a5b..f53573b9eb1f139ea7e8d2982565eb2a8331e1f8 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,40 +54,62 @@ 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 - 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 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,30 +124,54 @@ 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 - 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 @@ -133,7 +179,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,27 +193,42 @@ 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 - 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 @@ -175,21 +236,29 @@ 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 - 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 @@ -266,23 +335,41 @@ 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 - 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 _)] @@ -314,36 +401,44 @@ 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 - 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] @@ -408,24 +503,41 @@ 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 - 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,47 +547,63 @@ 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* _ = precheck_diagnostic infos case2 in - precheck_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 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 - 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 - precheck_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 () @@ -484,7 +612,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/validate/test_manager_operation_validation.ml b/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml new file mode 100644 index 0000000000000000000000000000000000000000..83108d0de5d66d2fe6e8f333209461f5558b7b94 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml @@ -0,0 +1,780 @@ +(*****************************************************************************) +(* *) +(* 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 "^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 + + Note: if a new manager operation kind is added in the protocol, + [Manager_operation_helpers.manager_operation_kind] should be + extended. You will also have to extend + [Manager_operation_helpers.select_op] with a new `mk` for this new + operation. Finally the list [Manager_operation_helpers.subjects] + should also be extended to run the validate test on the new manager + operation kind. *) +let ensure_kind infos kind = + let open Lwt_result_syntax in + let* op = + select_op + {(operation_req_default kind) with force_reveal = Some false} + infos + in + let (Operation_data {contents; _}) = op.protocol_data in + match contents with + | Single (Manager_operation {operation; _}) -> ( + match (operation, kind) with + | Transaction _, K_Transaction + | Reveal _, K_Reveal + | Origination _, K_Origination + | Delegation _, K_Delegation + | Delegation _, K_Undelegation + | Delegation _, K_Self_delegation + | Register_global_constant _, K_Register_global_constant + | Set_deposits_limit _, K_Set_deposits_limit + | Increase_paid_storage _, K_Increase_paid_storage + | Tx_rollup_origination, K_Tx_rollup_origination + | Tx_rollup_submit_batch _, K_Tx_rollup_submit_batch + | Tx_rollup_commit _, K_Tx_rollup_commit + | Tx_rollup_return_bond _, K_Tx_rollup_return_bond + | Tx_rollup_finalize_commitment _, K_Tx_rollup_finalize + | Tx_rollup_remove_commitment _, K_Tx_rollup_remove_commitment + | Tx_rollup_rejection _, K_Tx_rollup_reject + | Tx_rollup_dispatch_tickets _, K_Tx_rollup_dispatch_tickets + | Transfer_ticket _, K_Transfer_ticket + | Sc_rollup_originate _, K_Sc_rollup_origination + | Sc_rollup_add_messages _, K_Sc_rollup_add_messages + | Sc_rollup_cement _, K_Sc_rollup_cement + | Sc_rollup_publish _, K_Sc_rollup_publish + | Sc_rollup_refute _, K_Sc_rollup_refute + | Sc_rollup_timeout _, K_Sc_rollup_timeout + | Sc_rollup_execute_outbox_message _, K_Sc_rollup_execute_outbox_message + | Sc_rollup_recover_bond _, K_Sc_rollup_recover_bond + | Dal_publish_slot_header _, K_Dal_publish_slot_header -> + return_unit + | ( ( Transaction _ | Origination _ | Register_global_constant _ + | Delegation _ | Set_deposits_limit _ | Increase_paid_storage _ + | Reveal _ | Tx_rollup_origination | Tx_rollup_submit_batch _ + | Tx_rollup_commit _ | Tx_rollup_return_bond _ + | Tx_rollup_finalize_commitment _ | Tx_rollup_remove_commitment _ + | Tx_rollup_dispatch_tickets _ | Transfer_ticket _ + | Tx_rollup_rejection _ | Sc_rollup_originate _ | Sc_rollup_publish _ + | Sc_rollup_cement _ | Sc_rollup_add_messages _ | Sc_rollup_refute _ + | Sc_rollup_timeout _ | Sc_rollup_execute_outbox_message _ + | Sc_rollup_recover_bond _ | Dal_publish_slot_header _ + | Sc_rollup_dal_slot_subscribe _ ), + _ ) -> + assert false) + | Single _ -> assert false + | Cons _ -> assert false + +let ensure_manager_operation_coverage () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + List.iter_es (fun kind -> ensure_kind infos kind) subjects + +let test_ensure_manager_operation_coverage () = + Tztest.tztest + (Format.sprintf "Ensure manager_operation coverage") + `Quick + (fun () -> ensure_manager_operation_coverage ()) + +(** {2 Negative tests assert the case where validate must fail} *) + +(** Validate fails if the gas limit is too low. + + This test asserts that the validation of a manager operation + with a too low gas limit fails at validate with an + [Gas_quota_exceeded_init_deserialize] error. + This test applies on manager operations that do not + consume gas in their specific part of validate. *) +let low_gas_limit_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [ + Environment.Ecoproto_error + Validate_operation.Manager.Gas_quota_exceeded_init_deserialize; + Environment.Ecoproto_error Raw_context.Operation_quota_exceeded; + ] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_low_gas_limit kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + select_op + { + (operation_req_default kind) with + gas_limit = Some Op.Low; + force_reveal = Some true; + } + infos + in + low_gas_limit_diagnostic infos [op] + +let generate_low_gas_limit () = + create_Tztest + test_low_gas_limit + "Gas_limit too low." + gas_consumer_in_validate_subjects + +(** Validate fails if the gas limit is too high. + + This test asserts that the validation of a manager operation with + a gas limit too high fails at validate with an [Gas_limit_too_high] + error. It applies on every kind of manager operation. *) +let high_gas_limit_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error Gas.Gas_limit_too_high] -> return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_high_gas_limit kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + gas_limit = + Some (Op.Custom_gas (Gas.Arith.integral_of_int_exn 10_000_000)); + } + infos + in + high_gas_limit_diagnostic infos [op] + +let generate_high_gas_limit () = + create_Tztest test_high_gas_limit "Gas_limit too high." subjects + +(** Validate fails if the storage limit is too high. + + This test asserts that a manager operation with a storage limit + too high fails at validation with [Storage_limit_too_high] error. + It applies to every kind of manager operation. *) +let high_storage_limit_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error Fees_storage.Storage_limit_too_high] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_high_storage_limit kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + storage_limit = Some (Z.of_int max_int); + } + infos + in + high_storage_limit_diagnostic infos [op] + +let generate_high_storage_limit () = + create_Tztest test_high_gas_limit "Storage_limit too high." subjects + +(** Validate fails if the counter is in the future. + + This test asserts that the validation of + a manager operation with a counter in the + future -- aka greater than the successor of the manager counter + stored in the current context -- fails with [Counter_in_the_future] error. + It applies to every kind of manager operation. *) +let high_counter_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error (Contract_storage.Counter_in_the_future _)] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_high_counter kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + 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] + +let generate_high_counter () = + create_Tztest test_high_counter "Counter too high." subjects + +(** Validate fails if the counter is in the past. + + This test asserts that the validation of a manager operation with a + counter in the past -- aka smaller than the successor of the + manager counter stored in the current context -- fails with + [Counter_in_the_past] error. It applies to every kind of manager + operation. *) +let low_counter_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error (Contract_storage.Counter_in_the_past _)] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_low_counter kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* current_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 (Z.sub current_counter Z.one); + } + infos + in + low_counter_diagnostic infos [op] + +let generate_low_counter () = + create_Tztest test_low_counter "Counter too low." subjects + +(** Validate fails if the source is not allocated. + + This test asserts that the validation of a manager operation which + manager contract is not allocated fails with + [Empty_implicit_contract] error. It applies on every kind of + manager operation. *) +let not_allocated_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error (Contract_storage.Empty_implicit_contract _)] + -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_not_allocated kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let* op = + 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] + +let generate_not_allocated () = + create_Tztest test_not_allocated "Not allocated source." subjects + +(** Validate fails if the source is unrevealed. + + This test asserts that a manager operation with an unrevealed source + contract fails at validation with [Unrevealed_manager_key]. + It applies on every kind of manager operation except [Revelation]. *) +let unrevealed_key_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [ + Environment.Ecoproto_error + (Contract_manager_storage.Unrevealed_manager_key _); + ] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_unrevealed_key kind () = + let open Lwt_result_syntax in + 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 + test_unrevealed_key + "Unrevealed source (find_manager_public_key)." + revealed_subjects + +(** Validate fails if the source balance is not enough to pay the fees. + + This test asserts that validation of a manager operation fails if the + source balance is lesser than the manager operation fee. + It applies on every kind of manager operation. *) +let high_fee_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [ + Environment.Ecoproto_error (Contract_storage.Balance_too_low _); + Environment.Ecoproto_error (Tez_repr.Subtraction_underflow _); + ] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_high_fee kind () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + let*? fee = Tez.(one +? one) |> Environment.wrap_tzresult in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + fee = Some fee; + } + infos + in + high_fee_diagnostic infos [op] + +let generate_tests_high_fee () = + create_Tztest test_high_fee "Balance too low for fee payment." subjects + +(** Validate fails if the fee payment empties the balance of a + delegated implicit contract. + + This test asserts that in case that: + - the source is a delegated implicit contract, and + - the fee is the exact balance of source. + then, validate fails with [Empty_implicit_delegated_contract] error. + It applies to every kind of manager operation except [Revelation].*) +let emptying_delegated_implicit_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [ + Environment.Ecoproto_error + (Contract_storage.Empty_implicit_delegated_contract _); + ] -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure + +let test_emptying_delegated_implicit kind () = + let open Lwt_result_syntax 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 + { + (operation_req_default kind) with + force_reveal = Some false; + fee = Some fee; + } + infos + in + emptying_delegated_implicit_diagnostic infos [op] + +let generate_tests_emptying_delegated_implicit () = + create_Tztest + test_emptying_delegated_implicit + "Just enough funds to empty a delegated source." + revealed_subjects + +(** Validate fails if there is not enough available gas in the block. + + This test asserts that validate fails with: + - [Gas_limit_too_high;Block_quota_exceeded] in mempool mode, + - [Block_quota_exceeded] in other mode + with gas limit exceeds the available gas in the block. + It applies to every kind of manager operation. *) +let exceeding_block_gas_diagnostic ~mode (infos : infos) op = + let expect_failure errs = + match (errs, mode) with + | ( [Environment.Ecoproto_error Gas.Block_quota_exceeded], + (Construction | Application) ) -> + return_unit + | ( [ + Environment.Ecoproto_error Gas.Gas_limit_too_high; + Environment.Ecoproto_error Gas.Block_quota_exceeded; + ], + Mempool ) -> + (* In mempool_mode, batch that exceed [operation_gas_limit] needs + to be refused. [Gas.Block_quota_exceeded] only return a + temporary error. [Gas.Gas_limit_too_high], which is a + permanent error, is added to the error trace to ensure that + the batch is refused. *) + return_unit + | err, _ -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + validate_ko_diagnostic infos op expect_failure ~mode + +let test_exceeding_block_gas ~mode kind () = + let open Lwt_result_syntax 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* operation = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + gas_limit = + Some + (Op.Custom_gas + (Gas.Arith.add gb_limit Gas.Arith.(integral_of_int_exn 1))); + } + infos + in + exceeding_block_gas_diagnostic ~mode infos [operation] + +let generate_tests_exceeding_block_gas () = + create_Tztest + (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 ~mode:Mempool) + "Too much gas consumption in mempool mode." + subjects + +(** {2 Positive tests} *) + +(** Tests that validate succeeds when: + - it empties the balance of a self_delegated implicit source, + - it empties the balance of an undelegated implicit source, and + - in case: + - the counter is the successor of the one stored in the context, + - the fee is lesser than the balance, + - the storage limit is lesser than the maximum authorized storage, + - the gas limit is: + - lesser than the available gas in the block, + - less than the maximum gas consumable by an operation, and + - greater than the minimum gas consumable by an operation. + + Notice that in the first two cases only validate succeeds while + in the last case, the full application also succeeds. + In the 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: + - 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. *) +let test_emptying_self_delegated_implicit kind () = + let open Lwt_result_syntax 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 + { + (operation_req_default kind) with + force_reveal = Some false; + fee = Some fee; + } + infos + in + let* _ = only_validate_diagnostic infos [op] in + return_unit + +let generate_tests_emptying_self_delegated_implicit () = + create_Tztest + test_emptying_self_delegated_implicit + "Validate and empties a self-delegated source." + subjects + +(** 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 = default_init_ctxt () in + let* fee = + Context.Contract.balance + (B infos.ctxt.block) + (contract_of infos.accounts.source) + in + let* op = + select_op + { + (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 + let* _ = only_validate_diagnostic infos [op] in + return_unit + +let generate_tests_emptying_undelegated_implicit () = + create_Tztest + test_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 = default_init_ctxt () in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + gas_limit = Some Op.Low; + } + 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 + 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 + +(* 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 () + +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 () + +let fee_tests = + generate_tests_high_fee () + @ generate_tests_emptying_delegated_implicit () + @ generate_tests_emptying_self_delegated_implicit () + @ generate_tests_emptying_undelegated_implicit () + +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/tezt/tests/main.ml b/tezt/tests/main.ml index 6830576dd540a4fd6407e6ac59a55f5028f41696..3ac2b72a3f419f495ac0a3baf6530c3146369f90 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 0000000000000000000000000000000000000000..df517667562490b686f196a9c72db22aff828290 --- /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