From 1f17409d46a5f8dc2aa7854a48c1d1e1dc6de6b8 Mon Sep 17 00:00:00 2001 From: Zaynah Dargaye Date: Fri, 3 Jun 2022 19:58:35 +0200 Subject: [PATCH 1/4] Proto_alpha: prepare for precheck tests Co-authored-by: Albin Coquereau Co-authored-by: Zaynah Dargaye --- src/proto_alpha/lib_protocol/apply.mli | 1 + .../lib_protocol/contract_storage.mli | 5 + .../lib_protocol/test/helpers/block.ml | 17 ++- .../lib_protocol/test/helpers/block.mli | 4 + .../lib_protocol/test/helpers/context.ml | 5 +- .../lib_protocol/test/helpers/context.mli | 2 + .../lib_protocol/test/helpers/op.ml | 106 ++++++++++++++++-- .../lib_protocol/test/helpers/op.mli | 87 ++++++++++++-- 8 files changed, 201 insertions(+), 26 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.mli b/src/proto_alpha/lib_protocol/apply.mli index d48cca5585b5..286a1014b992 100644 --- a/src/proto_alpha/lib_protocol/apply.mli +++ b/src/proto_alpha/lib_protocol/apply.mli @@ -45,6 +45,7 @@ type error += | Inconsistent_counters | Forbidden_zero_ticket_quantity | Incorrect_reveal_position + | Inconsistent_sources val begin_partial_construction : context -> diff --git a/src/proto_alpha/lib_protocol/contract_storage.mli b/src/proto_alpha/lib_protocol/contract_storage.mli index f15e68debbc1..ce29e7d68d9f 100644 --- a/src/proto_alpha/lib_protocol/contract_storage.mli +++ b/src/proto_alpha/lib_protocol/contract_storage.mli @@ -29,6 +29,8 @@ type error += | (* `Temporary *) Balance_too_low of Contract_repr.t * Tez_repr.t * Tez_repr.t + | (* `Temporary *) + Counter_in_the_past of Contract_repr.t * Z.t * Z.t | (* `Branch *) Counter_in_the_future of Contract_repr.t * Z.t * Z.t | (* `Temporary *) @@ -39,6 +41,9 @@ type error += | (* `Permanent *) Failure of string | (* `Branch *) Empty_implicit_contract of Signature.Public_key_hash.t + | (* `Branch *) + Empty_implicit_delegated_contract of + Signature.Public_key_hash.t (** [allocated ctxt contract] returns [true] if and only if the contract is stored in [Storage.Contract.Balance]. *) diff --git a/src/proto_alpha/lib_protocol/test/helpers/block.ml b/src/proto_alpha/lib_protocol/test/helpers/block.ml index 40a6328e330c..8d941c7d07a9 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/block.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/block.ml @@ -423,7 +423,7 @@ let prepare_initial_context_params ?consensus_threshold ?min_proposal_quorum ?baking_reward_bonus_per_slot ?baking_reward_fixed_portion ?origination_size ?blocks_per_cycle ?cycles_per_voting_period ?tx_rollup_enable ?tx_rollup_sunset_level ?tx_rollup_origination_size ?sc_rollup_enable - initial_accounts = + ?dal_enable ?hard_gas_limit_per_block initial_accounts = let open Tezos_protocol_alpha_parameters in let constants = Default_parameters.constants_test in let min_proposal_quorum = @@ -482,6 +482,14 @@ let prepare_initial_context_params ?consensus_threshold ?min_proposal_quorum let sc_rollup_enable = Option.value ~default:constants.sc_rollup.enable sc_rollup_enable in + let dal_enable = + Option.value ~default:constants.dal.feature_enable dal_enable + in + let hard_gas_limit_per_block = + Option.value + ~default:constants.hard_gas_limit_per_block + hard_gas_limit_per_block + in let constants = { constants with @@ -503,6 +511,8 @@ let prepare_initial_context_params ?consensus_threshold ?min_proposal_quorum origination_size = tx_rollup_origination_size; }; sc_rollup = {constants.sc_rollup with enable = sc_rollup_enable}; + dal = {constants.dal with feature_enable = dal_enable}; + hard_gas_limit_per_block; } in (* Check there is at least one roll *) @@ -550,7 +560,8 @@ let genesis ?commitments ?consensus_threshold ?min_proposal_quorum ?endorsing_reward_per_slot ?baking_reward_bonus_per_slot ?baking_reward_fixed_portion ?origination_size ?blocks_per_cycle ?cycles_per_voting_period ?tx_rollup_enable ?tx_rollup_sunset_level - ?tx_rollup_origination_size ?sc_rollup_enable + ?tx_rollup_origination_size ?sc_rollup_enable ?dal_enable + ?hard_gas_limit_per_block (initial_accounts : (Account.t * Tez.t * Signature.Public_key_hash.t option) list) = prepare_initial_context_params @@ -569,6 +580,8 @@ let genesis ?commitments ?consensus_threshold ?min_proposal_quorum ?tx_rollup_sunset_level ?tx_rollup_origination_size ?sc_rollup_enable + ?dal_enable + ?hard_gas_limit_per_block initial_accounts >>=? fun (constants, shell, hash) -> initial_context diff --git a/src/proto_alpha/lib_protocol/test/helpers/block.mli b/src/proto_alpha/lib_protocol/test/helpers/block.mli index d19bece55353..74ea23ec0fa2 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/block.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/block.mli @@ -125,6 +125,8 @@ val genesis : ?tx_rollup_sunset_level:int32 -> ?tx_rollup_origination_size:int -> ?sc_rollup_enable:bool -> + ?dal_enable:bool -> + ?hard_gas_limit_per_block:Gas.Arith.integral -> (Account.t * Tez.tez * Signature.Public_key_hash.t option) list -> block tzresult Lwt.t @@ -266,6 +268,8 @@ val prepare_initial_context_params : ?tx_rollup_sunset_level:int32 -> ?tx_rollup_origination_size:int -> ?sc_rollup_enable:bool -> + ?dal_enable:bool -> + ?hard_gas_limit_per_block:Gas.Arith.integral -> (Account.t * Tez.t * Signature.Public_key_hash.t option) list -> ( Constants.Parametric.t * Block_header.shell_header * Block_hash.t, tztrace ) diff --git a/src/proto_alpha/lib_protocol/test/helpers/context.ml b/src/proto_alpha/lib_protocol/test/helpers/context.ml index c5f7874c415c..83a69d9fb91b 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/context.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/context.ml @@ -400,7 +400,8 @@ let init_gen tup ?rng_state ?commitments ?(initial_balances = []) ?endorsing_reward_per_slot ?baking_reward_bonus_per_slot ?baking_reward_fixed_portion ?origination_size ?blocks_per_cycle ?cycles_per_voting_period ?tx_rollup_enable ?tx_rollup_sunset_level - ?tx_rollup_origination_size ?sc_rollup_enable () = + ?tx_rollup_origination_size ?sc_rollup_enable ?dal_enable + ?hard_gas_limit_per_block () = let n = tup_n tup in let accounts = Account.generate_accounts @@ -432,6 +433,8 @@ let init_gen tup ?rng_state ?commitments ?(initial_balances = []) ?tx_rollup_sunset_level ?tx_rollup_origination_size ?sc_rollup_enable + ?dal_enable + ?hard_gas_limit_per_block accounts >|=? fun blk -> (blk, tup_get tup contracts) diff --git a/src/proto_alpha/lib_protocol/test/helpers/context.mli b/src/proto_alpha/lib_protocol/test/helpers/context.mli index 38f49f94fe3d..344e0ba7fbff 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/context.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/context.mli @@ -241,6 +241,8 @@ type 'accounts init := ?tx_rollup_sunset_level:int32 -> ?tx_rollup_origination_size:int -> ?sc_rollup_enable:bool -> + ?dal_enable:bool -> + ?hard_gas_limit_per_block:Gas.Arith.integral -> unit -> (Block.t * 'accounts) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.ml b/src/proto_alpha/lib_protocol/test/helpers/op.ml index 1ec6b5f80254..b54ed3ce5355 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/op.ml @@ -306,8 +306,8 @@ let manager_operation ?(force_reveal = true) ?counter ?(fee = Tez.zero) Contents_list (Cons (op_reveal, Single op)) let revelation ?(fee = Tez.zero) - ?(gas_limit = Gas.Arith.integral_of_int_exn 10000) ?(forge_pkh = None) ctxt - public_key = + ?(gas_limit = Gas.Arith.integral_of_int_exn 10000) ?(storage_limit = Z.zero) + ?counter ?(forge_pkh = None) ctxt public_key = (* If Some pkh is provided to ?forge_pkh we take that hash at face value, otherwise we honestly compute the hash from [public_key]. This is useful to test forging Reveal operations @@ -317,8 +317,12 @@ let revelation ?(fee = Tez.zero) | Some pkh -> pkh | None -> Signature.Public_key.hash public_key in + let source = Contract.Implicit pkh in - Context.Contract.counter ctxt source >>=? fun counter -> + (match counter with + | None -> Context.Contract.counter ctxt source + | Some ctr -> return ctr) + >>=? fun counter -> Context.Contract.manager ctxt source >|=? fun account -> let counter = Z.succ counter in let sop = @@ -331,7 +335,7 @@ let revelation ?(fee = Tez.zero) counter; operation = Reveal public_key; gas_limit; - storage_limit = Z.zero; + storage_limit; })) in sign account.sk ctxt sop @@ -430,12 +434,20 @@ let transaction ?force_reveal ?counter ?fee ?gas_limit ?storage_limit dst amount -let delegation ?force_reveal ?fee ctxt source dst = +let delegation ?force_reveal ?fee ?gas_limit ?counter ?storage_limit ctxt source + dst = let top = Delegation dst in + let gas_limit = + match gas_limit with + | None -> Gas.Arith.integral_of_int_exn 1000 + | Some g -> g + in manager_operation ?force_reveal ?fee - ~gas_limit:(Gas.Arith.integral_of_int_exn 1000) + ?counter + ~gas_limit + ?storage_limit ~source ctxt top @@ -443,12 +455,20 @@ let delegation ?force_reveal ?fee ctxt source dst = Context.Contract.manager ctxt source >|=? fun account -> sign account.sk ctxt sop -let set_deposits_limit ?force_reveal ?fee ctxt source limit = +let set_deposits_limit ?force_reveal ?fee ?gas_limit ?storage_limit ?counter + ctxt source limit = let top = Set_deposits_limit limit in + let gas_limit = + match gas_limit with + | None -> Gas.Arith.integral_of_int_exn 1000 + | Some g -> g + in manager_operation ?force_reveal ?fee - ~gas_limit:(Gas.Arith.integral_of_int_exn 1000) + ?counter + ?storage_limit + ~gas_limit ~source ctxt top @@ -782,9 +802,10 @@ let sc_rollup_cement ?force_reveal ?counter ?fee ?gas_limit ?storage_limit ctxt sign account.sk ctxt to_sign_op let sc_rollup_execute_outbox_message ?counter ?fee ?gas_limit ?storage_limit - ctxt (src : Contract.t) rollup cemented_commitment ~outbox_level - ~message_index ~inclusion_proof ~message = + ?force_reveal ctxt (src : Contract.t) rollup cemented_commitment + ~outbox_level ~message_index ~inclusion_proof ~message = manager_operation + ?force_reveal ?counter ?fee ?gas_limit @@ -804,9 +825,10 @@ let sc_rollup_execute_outbox_message ?counter ?fee ?gas_limit ?storage_limit Context.Contract.manager ctxt src >|=? fun account -> sign account.sk ctxt to_sign_op -let sc_rollup_recover_bond ?counter ?fee ?gas_limit ?storage_limit ctxt - (source : Contract.t) (sc_rollup : Sc_rollup.t) = +let sc_rollup_recover_bond ?counter ?fee ?gas_limit ?storage_limit ?force_reveal + ctxt (source : Contract.t) (sc_rollup : Sc_rollup.t) = manager_operation + ?force_reveal ?counter ?fee ?gas_limit @@ -817,3 +839,63 @@ let sc_rollup_recover_bond ?counter ?fee ?gas_limit ?storage_limit ctxt >>=? fun to_sign_op -> Context.Contract.manager ctxt source >|=? fun account -> sign account.sk ctxt to_sign_op + +let sc_rollup_add_messages ?force_reveal ?counter ?fee ?gas_limit ?storage_limit + ctxt (src : Contract.t) rollup messages = + manager_operation + ?force_reveal + ?counter + ?fee + ?gas_limit + ?storage_limit + ~source:src + ctxt + (Sc_rollup_add_messages {rollup; messages}) + >>=? fun to_sign_op -> + Context.Contract.manager ctxt src >|=? fun account -> + sign account.sk ctxt to_sign_op + +let sc_rollup_refute ?force_reveal ?counter ?fee ?gas_limit ?storage_limit ctxt + (src : Contract.t) rollup opponent refutation is_opening_move = + manager_operation + ?force_reveal + ?counter + ?fee + ?gas_limit + ?storage_limit + ~source:src + ctxt + (Sc_rollup_refute {rollup; opponent; refutation; is_opening_move}) + >>=? fun to_sign_op -> + Context.Contract.manager ctxt src >|=? fun account -> + sign account.sk ctxt to_sign_op + +let sc_rollup_timeout ?force_reveal ?counter ?fee ?gas_limit ?storage_limit ctxt + (src : Contract.t) rollup stakers = + manager_operation + ?force_reveal + ?counter + ?fee + ?gas_limit + ?storage_limit + ~source:src + ctxt + (Sc_rollup_timeout {rollup; stakers}) + >>=? fun to_sign_op -> + Context.Contract.manager ctxt src >|=? fun account -> + sign account.sk ctxt to_sign_op + +let dal_publish_slot_header ?force_reveal ?counter ?fee ?gas_limit + ?storage_limit ctxt (src : Contract.t) slot = + manager_operation + ?force_reveal + ?counter + ?fee + ?gas_limit + ?storage_limit + ~source:src + ctxt + (Dal_publish_slot_header {slot}) + >>=? fun to_sign_op -> + Context.Contract.manager ctxt src >|=? fun account -> + sign account.sk ctxt to_sign_op diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.mli b/src/proto_alpha/lib_protocol/test/helpers/op.mli index c06488e59f61..066c62a9f14e 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/op.mli @@ -26,6 +26,9 @@ open Protocol open Alpha_context +(* TODO: https://gitlab.com/tezos/tezos/-/issues/3181 + Improve documentation of the operation helpers *) + val endorsement : ?delegate:public_key_hash * Slot.t list -> ?slot:Slot.t -> @@ -100,6 +103,9 @@ val unsafe_transaction : val delegation : ?force_reveal:bool -> ?fee:Tez.tez -> + ?gas_limit:Gas.Arith.integral -> + ?counter:Z.t -> + ?storage_limit:Z.t -> Context.t -> Contract.t -> public_key_hash option -> @@ -108,33 +114,41 @@ val delegation : val set_deposits_limit : ?force_reveal:bool -> ?fee:Tez.tez -> + ?gas_limit:Gas.Arith.integral -> + ?storage_limit:Z.t -> + ?counter:Z.t -> Context.t -> Contract.t -> Tez.tez option -> Operation.packed tzresult Lwt.t (** [revelation ?fee ?gas_limit ?forge_pkh ctxt pkh] Creates a new - [Reveal] {!manager_operation} to reveal a public key [pkh] applying - to current context [ctxt]. + [Reveal] {!manager_operation} to reveal a public key [pkh] + applying to current context [ctxt]. Optional arguments allow to override defaults: {ul {li [?fee:Tez.tez]: specify a fee, otherwise set to - [Tez.zero].} + [Tez.zero].} + + {li [?gas_limit:Gas.Arith.integral]: force a gas limit, otherwise + set to 10000 gas units.} - {li [?gas_limit:Gas.Arith.integral]: force a gas limit, - otherwise set to 10000 gas units.} + {li [?forge_pkh]: use a provided [pkh] as source, instead of + hashing [pkh]. Useful for forging non-honest reveal operations} - {li [?forge_pkh]: use a - provided [pkh] as source, instead of hashing [pkh]. Useful for - forging non-honest reveal operations} *) + {li [?storage_limit:counter]: forces a storage limit, otherwise + set to [Z.zero]} +*) val revelation : - ?fee:Tez.tez -> + ?fee:Tez.t -> ?gas_limit:Gas.Arith.integral -> + ?storage_limit:counter -> + ?counter:counter -> ?forge_pkh:public_key_hash option -> Context.t -> public_key -> - Operation.packed tzresult Lwt.t + (packed_operation, tztrace) result Lwt.t val failing_noop : Context.t -> public_key_hash -> string -> Operation.packed tzresult Lwt.t @@ -496,7 +510,7 @@ val sc_rollup_origination : {ul {li [?force_reveal:bool]: prepend the operation to reveal [source]'s public key if the latter has not been revealed - yet. Enabled (set to [true]) by default.}}*) + yet. Enabled (set to [true]) by default.}} *) val sc_rollup_publish : ?force_reveal:bool -> ?counter:Z.t -> @@ -534,6 +548,7 @@ val sc_rollup_execute_outbox_message : ?fee:Tez.t -> ?gas_limit:Gas.Arith.integral -> ?storage_limit:counter -> + ?force_reveal:bool -> Context.t -> Contract.t -> Sc_rollup.t -> @@ -546,6 +561,18 @@ val sc_rollup_execute_outbox_message : (** [sc_rollup_recover_bond ctxt source sc_rollup] returns a commitment bond. *) val sc_rollup_recover_bond : + ?counter:Z.t -> + ?fee:Tez.tez -> + ?gas_limit:Gas.Arith.integral -> + ?storage_limit:Z.t -> + ?force_reveal:bool -> + Context.t -> + Contract.t -> + Sc_rollup.t -> + Operation.packed tzresult Lwt.t + +val sc_rollup_add_messages : + ?force_reveal:bool -> ?counter:Z.t -> ?fee:Tez.tez -> ?gas_limit:Gas.Arith.integral -> @@ -553,4 +580,42 @@ val sc_rollup_recover_bond : Context.t -> Contract.t -> Sc_rollup.t -> + string list -> Operation.packed tzresult Lwt.t + +val sc_rollup_refute : + ?force_reveal:bool -> + ?counter:Z.t -> + ?fee:Tez.tez -> + ?gas_limit:Gas.Arith.integral -> + ?storage_limit:Z.t -> + Context.t -> + Contract.t -> + Sc_rollup.t -> + public_key_hash -> + Sc_rollup.Game.refutation -> + bool -> + Operation.packed tzresult Lwt.t + +val sc_rollup_timeout : + ?force_reveal:bool -> + ?counter:Z.t -> + ?fee:Tez.tez -> + ?gas_limit:Gas.Arith.integral -> + ?storage_limit:Z.t -> + Context.t -> + Contract.t -> + Sc_rollup.t -> + Sc_rollup.Game.Index.t -> + Operation.packed tzresult Lwt.t + +val dal_publish_slot_header : + ?force_reveal:bool -> + ?counter:counter -> + ?fee:Tez.t -> + ?gas_limit:Gas.Arith.integral -> + ?storage_limit:counter -> + Context.t -> + Contract.t -> + Dal.Slot.t -> + (packed_operation, tztrace) result Lwt.t -- GitLab From fdb63d0f0750e9338e70fd2b33421c6b884b4128 Mon Sep 17 00:00:00 2001 From: Zaynah Dargaye Date: Fri, 3 Jun 2022 20:03:49 +0200 Subject: [PATCH 2/4] Proto_alpha/test: add tests-helpers for manager operation precheck Co-authored-by: Albin Coquereau Co-authored-by: Zaynah Dargaye --- .../operations/manager_operation_helpers.ml | 910 ++++++++++++++++++ 1 file changed, 910 insertions(+) create mode 100644 src/proto_alpha/lib_protocol/test/integration/operations/manager_operation_helpers.ml diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/manager_operation_helpers.ml b/src/proto_alpha/lib_protocol/test/integration/operations/manager_operation_helpers.ml new file mode 100644 index 000000000000..3038d9a50d68 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/operations/manager_operation_helpers.ml @@ -0,0 +1,910 @@ +(*****************************************************************************) +(* *) +(* 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; + 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 = 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 + ~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 ~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* operation = + Op.batch_operations + ~source:bootstrap_contract + (B b) + [fund_account1; fund_account2; fund_account3] + in + let+ block = Block.bake ~operation b in + { + block; + account1; + contract1; + account2; + contract2; + account3; + contract3; + 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 + (B infos.block) + infos.contract2 + (Some (Context.Contract.pkh infos.contract2)) + in + let* block = Block.bake infos.block ~operation in + let* operation = + Op.delegation (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 (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_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_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_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_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. *) + +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} + +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 + +let observe ?g_in contract b_in c_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* _ = Assert.equal_tez ~loc:__LOC__ 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 + match g_in with + | Some g_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 + | None -> return_unit + +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 + +let apply_with_diagnostic ?expect_apply_failure (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.add_operation ?expect_apply_failure i op in + observe ~g_in contract b_in c_in prbs i + +(* If the precheck of an operation succeed, whether the application + fail or not, the fees must be paid, the block gas consumption + should be decreased and the counter of operation should be + incremented. *) +let apply_ko_diagnostic (infos : infos) op expect_apply_failure = + apply_with_diagnostic ~expect_apply_failure (infos : infos) op + +let apply_ok_diagnostic (infos : infos) op = + apply_with_diagnostic (infos : infos) op + +(* 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_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 except_not_consumer_in_precheck_subjects = + List.filter + (function + | K_Set_deposits_limit | 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 + | _ -> true) + subjects + +let except_self_delegated_and_revelation_subjects = + List.filter + (function K_Self_delegation | K_Reveal -> false | _ -> true) + subjects + +let revealed_except_set_deposits_limit_and_submit_batch_subjects = + List.filter + (function + | K_Set_deposits_limit | K_Tx_rollup_submit_batch | K_Reveal -> false + | _ -> true) + subjects + +let revealed_only_set_deposits_limit_and_submit_batch_subjects = + List.filter + (function + | K_Set_deposits_limit | K_Tx_rollup_submit_batch -> true | _ -> false) + subjects + +let revealed_subjects = + List.filter (function K_Reveal -> false | _ -> true) subjects -- GitLab From 2db05057694583b1faaa465ed9bdf14e5b51c2d7 Mon Sep 17 00:00:00 2001 From: Zaynah Dargaye Date: Fri, 3 Jun 2022 20:05:52 +0200 Subject: [PATCH 3/4] Proto_alpha/test: add tests for single manager operation precheck Co-authored-by: Albin Coquereau Co-authored-by: Zaynah Dargaye --- .../test/integration/operations/main.ml | 1 + .../test_manager_operation_precheck.ml | 485 ++++++++++++++++++ 2 files changed, 486 insertions(+) create mode 100644 src/proto_alpha/lib_protocol/test/integration/operations/test_manager_operation_precheck.ml diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/main.ml b/src/proto_alpha/lib_protocol/test/integration/operations/main.ml index d7944e194a8e..a5d12e263c1e 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/main.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/main.ml @@ -43,5 +43,6 @@ let () = ("failing_noop operation", Test_failing_noop.tests); ("tx rollup", Test_tx_rollup.tests); ("sc rollup", Test_sc_rollup.tests); + ("precheck manager", Test_manager_operation_precheck.tests); ] |> Lwt_main.run diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_manager_operation_precheck.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_manager_operation_precheck.ml new file mode 100644 index 000000000000..aa5e863073c3 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_manager_operation_precheck.ml @@ -0,0 +1,485 @@ +(*****************************************************************************) +(* *) +(* 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/operations/main.exe \ + -- test "^precheck manager$" + 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 + | 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 _ | 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 _ ), + _ ) -> + 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 ()) + +(* Too low gas limit. *) +let low_gas_limit_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [ + Environment.Ecoproto_error Apply.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 = Gas.Arith.zero 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." + except_not_consumer_in_precheck_subjects + +(* Too high gas limit. *) +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 = 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 + +(* Too high storage limit. *) +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 + +(* Counter in the future. *) +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 + +(* Counter in the past. *) +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 + +(* Not allocated source. *) +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 + +(* Unrevealed source. *) +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 + +(* Not enough balance to pay fees. *) +let high_fee_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error (Contract_storage.Balance_too_low _)] -> + 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 + +(* Emptying delegated implicit contract. *) +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 = Tez.one 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 to empty a delegated source." + revealed_subjects + +(* Exceeding block gas. *) +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 = 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. *) + +(* Fee payment but emptying an 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 = Tez.one in + let* op = + select_op ~fee ~force_reveal:false ~source:infos.contract1 kind infos + in + apply_ko_diagnostic infos op (fun _ -> return_unit) + +let test_emptying_self_delegated_implicit2 kind () = + let open Lwt_result_syntax in + let* infos = init_self_delegated_implicit () in + let fee = Tez.one in + let* op = + select_op ~fee ~force_reveal:false ~source:infos.contract1 kind infos + in + apply_ok_diagnostic infos op + +let generate_tests_emptying_self_delegated_implicit () = + create_Tztest + test_emptying_self_delegated_implicit + "fee payment and just enough to empty a self-delegated source." + revealed_except_set_deposits_limit_and_submit_batch_subjects + @ create_Tztest + test_emptying_self_delegated_implicit2 + "fee payment and just enough to empty a self-delegated source." + revealed_only_set_deposits_limit_and_submit_batch_subjects + +(* Fee payment but emptying an undelegated implicit, test positive. *) +let emptying_undelegated_implicit_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 + apply_ko_diagnostic infos op expect_failure + +let test_emptying_undelegated_implicit kind () = + let open Lwt_result_syntax in + let* infos = init_context () in + let fee = Tez.one in + let* op = + select_op ~fee ~force_reveal:true ~source:infos.contract1 kind infos + in + emptying_undelegated_implicit_diagnostic infos op + +let generate_tests_emptying_undelegated_implicit () = + create_Tztest + test_emptying_undelegated_implicit + "(Positive test) fee payment and just enough to empty an undelegated \ + source." + subjects + +let tests = + (test_ensure_manager_operation_coverage () :: generate_low_gas_limit ()) + @ generate_high_gas_limit () + @ generate_tests_exceeding_block_gas () + @ generate_tests_exceeding_block_gas_mp_mode () + @ generate_high_storage_limit () + @ generate_high_counter () @ generate_low_counter () + @ generate_not_allocated () @ generate_tests_high_fee () + @ generate_tests_emptying_delegated_implicit () + @ generate_tests_emptying_self_delegated_implicit () + @ generate_unrevealed_key () + @ generate_tests_emptying_undelegated_implicit () -- GitLab From 1d84fbc23f5de1102c94557d4e2c6d12f52aec69 Mon Sep 17 00:00:00 2001 From: Zaynah Dargaye Date: Fri, 3 Jun 2022 20:07:26 +0200 Subject: [PATCH 4/4] Proto_alpha/tests: add tests for batches of manager op. precheck Co-authored-by: Albin Coquereau Co-authored-by: Zaynah Dargaye --- .../test/integration/operations/main.ml | 1 + ...test_batched_manager_operation_precheck.ml | 471 ++++++++++++++++++ 2 files changed, 472 insertions(+) create mode 100644 src/proto_alpha/lib_protocol/test/integration/operations/test_batched_manager_operation_precheck.ml diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/main.ml b/src/proto_alpha/lib_protocol/test/integration/operations/main.ml index a5d12e263c1e..bc7536e31332 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/main.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/main.ml @@ -44,5 +44,6 @@ let () = ("tx rollup", Test_tx_rollup.tests); ("sc rollup", Test_sc_rollup.tests); ("precheck manager", Test_manager_operation_precheck.tests); + ("precheck batched manager", Test_batched_manager_operation_precheck.tests); ] |> Lwt_main.run diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_batched_manager_operation_precheck.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_batched_manager_operation_precheck.ml new file mode 100644 index 000000000000..c4e73a3e2f05 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_batched_manager_operation_precheck.ml @@ -0,0 +1,471 @@ +(*****************************************************************************) +(* *) +(* 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/operations/main.exe \ + -- test "^precheck batched manager$" + Subject: Precheck manager operation. +*) + +open Protocol +open Alpha_context +open Manager_operation_helpers + +(* Tests on operation batches. *) + +(* Reveal in the middle: reveal should be in first position. *) +let batch_reveal_in_the_middle_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error Apply.Incorrect_reveal_position] -> + 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_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 counter = Z.succ counter in + let* operation1 = + select_op ~counter ~force_reveal:false ~source:infos.contract1 kind1 infos + in + let counter = Z.succ counter in + let* reveal = mk_reveal ~fee ~counter ~source:infos.contract1 infos in + let counter = Z.succ counter in + let* operation2 = + select_op ~counter ~force_reveal:false ~source:infos.contract1 kind2 infos + in + let* batch = + Op.batch_operations + ~recompute_counters:false + ~source:infos.contract1 + (Context.B infos.block) + [operation1; reveal; operation2] + in + 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." + revealed_subjects + +(* 2 Reveals in a batch: only one reveal per batch. *) +let batch_two_reveals_diagnostic (infos : infos) op = + let expected_failure errs = + match errs with + | [Environment.Ecoproto_error Apply.Incorrect_reveal_position] -> + 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 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 counter = Z.succ counter in + let* reveal = mk_reveal ~fee ~counter ~source:infos.contract1 infos in + let counter = Z.succ counter in + let* reveal1 = mk_reveal ~fee ~counter ~source:infos.contract1 infos in + let counter = Z.succ counter in + let* operation = + select_op ~counter ~force_reveal:false ~source:infos.contract1 kind infos + in + let* batch = + Op.batch_operations + ~recompute_counters:false + ~source:infos.contract1 + (Context.B infos.block) + [reveal; reveal1; operation] + in + batch_two_reveals_diagnostic infos batch + +let generate_tests_batches_two_reveals () = + create_Tztest + test_batch_two_reveals + "Only one revelation per batch." + revealed_subjects + +(* 2 sources in a batch: only one source per batch. *) +let batch_two_sources_diagnostic (infos : infos) op = + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error Apply.Inconsistent_sources] -> 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_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 counter = Z.succ counter in + let* operation1 = + select_op ~counter ~force_reveal:true ~source:infos.contract1 kind1 infos + in + let* operation2 = + select_op ~force_reveal:false ~source:infos.contract2 kind2 infos + in + let* batch = + Op.batch_operations + ~recompute_counters:false + ~source:infos.contract1 + (Context.B infos.block) + [operation1; operation2] + in + batch_two_sources_diagnostic infos batch + +let revealed_except_self_delegation_subjects = + List.filter (function K_Reveal -> false | _ -> true) subjects + +(* With self_delegation, the occurred error is counter inconsistency. *) +let generate_batches_two_sources () = + create_Tztest_batches + test_batch_two_sources + "Only one source per batch." + revealed_except_self_delegation_subjects + +(* Counters in a batch should be a sequence. *) +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 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 + in + let op_counter = operation counter in + let op_counter0 = operation counter0 in + let op_counter2 = operation counter2 in + let op_counter3 = operation counter3 in + let* op1 = op_counter kind1 in + let* op2 = op_counter kind2 in + let* batch_same = + Op.batch_operations + ~recompute_counters:false + ~source + (Context.B infos.block) + [reveal; op1; op2] + in + let* op1 = op_counter2 kind1 in + let* op2 = op_counter3 kind2 in + let* batch_in_the_future = + Op.batch_operations + ~recompute_counters:false + ~source + (Context.B infos.block) + [reveal; op1; op2] + in + let* op1 = op_counter kind1 in + let* op2 = op_counter3 kind2 in + let* batch_missing_one = + Op.batch_operations + ~recompute_counters:false + ~source + (Context.B infos.block) + [reveal; op1; op2] + in + let* op1 = op_counter2 kind1 in + let* op2 = op_counter kind2 in + let* batch_inverse = + Op.batch_operations + ~recompute_counters:false + ~source + (Context.B infos.block) + [reveal; op1; op2] + in + let* op1 = op_counter0 kind1 in + let* op2 = op_counter kind2 in + let* batch_in_the_past = + Op.batch_operations + ~recompute_counters:false + ~source + (Context.B infos.block) + [reveal; op1; op2] + in + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error Apply.Inconsistent_counters] -> return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + let* i = Incremental.begin_construction infos.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 + let* _ = Incremental.add_operation ~expect_failure i batch_inverse in + let* _ = Incremental.add_operation ~expect_failure i batch_in_the_past in + return_unit + +let generate_batches_inconsistent_counters () = + create_Tztest_batches + test_batch_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 + 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 counter = counter in + let source = infos.contract1 in + let* reveal = mk_reveal ~counter ~source infos in + let counter = Z.succ counter in + let operation fee = + select_op ~fee ~counter ~force_reveal:false ~source kind1 infos + in + let counter = Z.succ counter in + let operation2 fee = + select_op ~fee ~counter ~force_reveal:false ~source kind2 infos + in + let* op_case1 = operation init_bal in + let* op2_case1 = operation2 Tez.zero in + let* case1 = + Op.batch_operations + ~recompute_counters:false + ~source + (Context.B infos.block) + [reveal; op_case1; op2_case1] + in + let* i = Incremental.begin_construction infos.block in + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error (Contract_storage.Empty_implicit_contract _)] + -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + let* _ = Incremental.add_operation i case1 ~expect_failure in + return_unit + +let generate_batches_emptying_balance_in_the_middle () = + create_Tztest_batches + test_batch_emptying_balance_in_the_middle + "Fee payment emptying balance should occurs at the end of the batch." + revealed_subjects + +(* Exceeding block gas by a batch. *) +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 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 counter = Z.succ counter in + let operation gas_limit = + select_op ~gas_limit ~counter ~force_reveal:false ~source kind1 infos + in + let counter = Z.succ counter in + let operation2 gas_limit = + select_op ~gas_limit ~counter ~force_reveal:false ~source kind2 infos + in + let* op_case1 = operation g_limit in + let* op2_case1 = operation2 Gas.Arith.zero in + let* op_case2 = operation half_limit in + let* op2_case2 = operation2 g_limit in + let* op_case3 = operation half_limit in + let* op2_case3 = operation2 half_limit in + let* case1 = + Op.batch_operations + ~recompute_counters:false + ~source + (Context.B infos.block) + [reveal; op_case1; op2_case1] + in + let* case3 = + Op.batch_operations + ~recompute_counters:false + ~source + (Context.B infos.block) + [reveal; op_case3; op2_case3] + in + let* case2 = + Op.batch_operations + ~recompute_counters:false + ~source + (Context.B infos.block) + [reveal; op_case2; op2_case2] + in + let* i = Incremental.begin_construction infos.block ~mempool_mode in + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error Gas.Block_quota_exceeded] + when not mempool_mode -> + return_unit + | [ + Environment.Ecoproto_error Gas.Gas_limit_too_high; + Environment.Ecoproto_error Gas.Block_quota_exceeded; + ] + when mempool_mode -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + let* _ = Incremental.add_operation i case1 ~expect_failure in + let* _ = Incremental.add_operation i case3 ~expect_failure in + let* _ = Incremental.add_operation i case2 ~expect_failure in + return_unit + +let generate_batches_exceeding_block_gas () = + create_Tztest_batches + (test_batch_exceeding_block_gas ~mempool_mode:false) + "Too much gas consumption." + revealed_subjects + +let generate_batches_exceeding_block_gas_mp_mode () = + create_Tztest_batches + (test_batch_exceeding_block_gas ~mempool_mode:true) + "Too much gas consumption in mempool mode." + revealed_subjects + +(* Emptying balance at the end of a batch. *) +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*? 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 counter = Z.succ counter in + let operation fee = + select_op ~fee ~counter ~force_reveal:false ~source kind1 infos + in + let counter = Z.succ counter in + let operation2 fee = + select_op ~fee ~counter ~force_reveal:false ~source kind2 infos + in + let* op_case2 = operation Tez.zero in + let* op2_case2 = operation2 init_bal in + let* op_case3 = operation half_init_bal in + let* op2_case3 = operation2 half_init_bal in + let* case3 = + Op.batch_operations + ~recompute_counters:false + ~source + (Context.B infos.block) + [reveal; op_case3; op2_case3] + in + let* case2 = + Op.batch_operations + ~recompute_counters:false + ~source + (Context.B infos.block) + [reveal; op_case2; op2_case2] + in + let* _ = apply_ko_diagnostic infos case2 (fun _ -> return_unit) in + apply_ko_diagnostic infos case3 (fun _ -> 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." + revealed_subjects + +(* 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 counter = counter in + let fee = Tez.one_mutez in + let source = infos.contract1 in + let* reveal = mk_reveal ~fee ~counter ~source infos in + let counter = Z.succ counter in + let* transaction = + mk_transaction ~counter ~force_reveal:false ~source infos + in + let* batch = + Op.batch_operations + ~recompute_counters:false + ~source + (Context.B infos.block) + [reveal; transaction] + in + let* _i = Incremental.begin_construction infos.block in + apply_ko_diagnostic infos batch (fun _ -> return_unit) + +let tests = + generate_batches_reveal_in_the_middle () + @ generate_tests_batches_two_reveals () + @ generate_batches_two_sources () + @ generate_batches_inconsistent_counters () + @ generate_batches_emptying_balance_in_the_middle () + @ generate_batches_exceeding_block_gas () + @ generate_batches_exceeding_block_gas_mp_mode () + @ generate_batches_balance_just_enough () + @ [ + Tztest.tztest + "Prechecked batch with a reveal and a transaction." + `Quick + test_batch_reveal_transaction_ok; + ] -- GitLab