diff --git a/src/proto_alpha/lib_protocol/test/helpers/block.ml b/src/proto_alpha/lib_protocol/test/helpers/block.ml index 75e521f18d298146de7a296059031fe57774a497..b5147b6dbe52e924d8982ca59b70b74c2030de45 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/block.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/block.ml @@ -719,8 +719,45 @@ let finalize_validation_and_application (validation_state, application_state) let* () = finalize_validation validation_state in finalize_application application_state shell_header +let detect_manager_failure : + type kind. kind Apply_results.operation_metadata -> _ = + let rec detect_manager_failure : + type kind. kind Apply_results.contents_result_list -> _ = + let open Apply_results in + let open Apply_operation_result in + let open Apply_internal_results in + let detect_manager_failure_single (type kind) + (Manager_operation_result + {operation_result; internal_operation_results; _} : + kind Kind.manager Apply_results.contents_result) = + let detect_manager_failure (type kind) + (result : (kind, _, _) operation_result) = + match result with + | Applied _ -> Ok () + | Skipped _ -> assert false + | Backtracked (_, None) -> + (* there must be another error for this to happen *) + Ok () + | Backtracked (_, Some errs) -> Error errs + | Failed (_, errs) -> Error errs + in + detect_manager_failure operation_result >>? fun () -> + List.iter_e + (fun (Internal_operation_result (_, r)) -> detect_manager_failure r) + internal_operation_results + in + function + | Single_result (Manager_operation_result _ as res) -> + detect_manager_failure_single res + | Single_result _ -> Ok () + | Cons_result (res, rest) -> + detect_manager_failure_single res >>? fun () -> + detect_manager_failure rest + in + fun {contents} -> detect_manager_failure contents + let apply_with_metadata ?(policy = By_round 0) ?(check_size = true) ~baking_mode - header ?(operations = []) pred = + ~allow_manager_failures header ?(operations = []) pred = let open Environment.Error_monad in ( (match baking_mode with | Application -> @@ -750,10 +787,16 @@ let apply_with_metadata ?(policy = By_round 0) ?(check_size = true) ~baking_mode size %d" operation_size Constants_repr.max_operation_data_length))) ; - validate_and_apply_operation vstate op >|= Environment.wrap_tzresult - >|=? fun (state, _result) -> state) + validate_and_apply_operation vstate op >>=? fun (state, result) -> + if allow_manager_failures then return state + else + match result with + | No_operation_metadata -> return state + | Operation_metadata metadata -> + detect_manager_failure metadata >>?= fun () -> return state) vstate operations + >|= Environment.wrap_tzresult >>=? fun vstate -> finalize_validation_and_application vstate (Some header.shell) >|= Environment.wrap_tzresult @@ -762,12 +805,18 @@ let apply_with_metadata ?(policy = By_round 0) ?(check_size = true) ~baking_mode let hash = Block_header.hash header in ({hash; header; operations; context}, result) -let apply header ?(operations = []) pred = - apply_with_metadata header ~operations pred ~baking_mode:Application +let apply header ?(operations = []) ?(allow_manager_failures = false) pred = + apply_with_metadata + header + ~operations + pred + ~baking_mode:Application + ~allow_manager_failures >>=? fun (t, _metadata) -> return t let bake_with_metadata ?locked_round ?policy ?timestamp ?operation ?operations - ?payload_round ?check_size ~baking_mode ?liquidity_baking_toggle_vote pred = + ?payload_round ?check_size ~baking_mode ?(allow_manager_failures = false) + ?liquidity_baking_toggle_vote pred = let operations = match (operation, operations) with | Some op, Some ops -> Some (op :: ops) @@ -785,14 +834,22 @@ let bake_with_metadata ?locked_round ?policy ?timestamp ?operation ?operations pred >>=? fun header -> Forge.sign_header header >>=? fun header -> - apply_with_metadata ?policy ?check_size ~baking_mode header ?operations pred + apply_with_metadata + ?policy + ?check_size + ~baking_mode + ~allow_manager_failures + header + ?operations + pred -let bake ?(baking_mode = Application) ?payload_round ?locked_round ?policy - ?timestamp ?operation ?operations ?liquidity_baking_toggle_vote ?check_size - pred = +let bake ?(baking_mode = Application) ?(allow_manager_failures = false) + ?payload_round ?locked_round ?policy ?timestamp ?operation ?operations + ?liquidity_baking_toggle_vote ?check_size pred = bake_with_metadata ?payload_round ~baking_mode + ~allow_manager_failures ?locked_round ?policy ?timestamp diff --git a/src/proto_alpha/lib_protocol/test/helpers/block.mli b/src/proto_alpha/lib_protocol/test/helpers/block.mli index 18223a9841209bb7db8c75b6dc827ff59d50ca46..3305024728eea3cdabdcd299f958f78f2560488e 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/block.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/block.mli @@ -185,22 +185,27 @@ val get_construction_vstate : val apply : Block_header.block_header -> ?operations:Operation.packed list -> + ?allow_manager_failures:bool -> t -> t tzresult Lwt.t -(** - [bake b] returns a block [b'] which has as predecessor block [b]. - Optional parameter [policy] allows to pick the next baker in - several ways. If [check_size] is [true] (the default case), then - the function checks that the operations passed as arguments satisfy - the size limit of Tezos operations, as defined in the protocol. - This function bundles together [forge_header], [sign_header] and [apply]. - These functions should be used instead of bake to craft unusual blocks for - testing together with setters for properties of the headers. - For examples see seed.ml or double_baking.ml +(** [bake b] returns a block [b'] which has as predecessor block [b]. + Optional parameter [policy] allows to pick the next baker in + several ways. If [check_size] is [true] (the default case), then + the function checks that the operations passed as arguments satisfy + the size limit of Tezos operations, as defined in the protocol. + This function bundles together [forge_header], [sign_header] and + [apply]. These functions should be used instead of bake to craft + unusual blocks for testing together with setters for properties of + the headers. Setting [allow_manager_failures] (default=false), + allows baking blocks with manager operation(s) that are valid but + that could fail during their application. If this is not set, the + block is correctly baked but the operations' application will fail + silently. For examples see seed.ml or double_baking.ml *) val bake : ?baking_mode:baking_mode -> + ?allow_manager_failures:bool -> ?payload_round:Round.t option -> ?locked_round:Alpha_context.Round.t option -> ?policy:baker_policy -> diff --git a/src/proto_alpha/lib_protocol/test/integration/consensus/test_baking.ml b/src/proto_alpha/lib_protocol/test/integration/consensus/test_baking.ml index 1ad7130585f749ae064da317496ffe7142476a9d..b913fe2fc1879a2acebc7175810e3da1454c5009 100644 --- a/src/proto_alpha/lib_protocol/test/integration/consensus/test_baking.ml +++ b/src/proto_alpha/lib_protocol/test/integration/consensus/test_baking.ml @@ -216,7 +216,7 @@ let test_rewards_block_and_payload_producer () = endorsers in let fee = Tez.one in - Op.transaction (B b1) ~fee baker_b1_contract baker_b1_contract Tez.zero + Op.transaction (B b1) ~fee baker_b1_contract baker_b1_contract Tez.one >>=? fun tx -> Block.bake ~policy:(By_round 0) ~operations:(endos @ [tx]) b1 >>=? fun b2 -> Context.get_baker (B b1) ~round:0 >>=? fun baker_b2 -> diff --git a/src/proto_alpha/lib_protocol/test/integration/consensus/test_consensus_key.ml b/src/proto_alpha/lib_protocol/test/integration/consensus/test_consensus_key.ml index 1bc534d9fa20b54a3b7a579f5bc52b06ce882105..ceadc2560bfa46e69282ddd88f3ed6e0aaea9928 100644 --- a/src/proto_alpha/lib_protocol/test/integration/consensus/test_consensus_key.ml +++ b/src/proto_alpha/lib_protocol/test/integration/consensus/test_consensus_key.ml @@ -87,9 +87,15 @@ let transfer_tokens blk source destination amount = amount >>=? fun transfer_op -> Block.bake ~operation:transfer_op blk -let reveal_manager_key blk pk = - Op.revelation (B blk) pk >>=? fun reveal_op -> - Block.bake ~operation:reveal_op blk +let may_reveal_manager_key blk (pkh, pk) = + let open Lwt_result_syntax in + let* is_revealed = + Context.Contract.is_manager_key_revealed (B blk) (Contract.Implicit pkh) + in + if is_revealed then return blk + else + Op.revelation (B blk) pk >>=? fun reveal_op -> + Block.bake ~operation:reveal_op blk let drain_delegate ~policy blk consensus_key delegate destination expected_final_balance = @@ -125,7 +131,7 @@ let test_drain_delegate ~low_balance ~exclude_ck ~ck_delegates () = else Block.By_account delegate in (if ck_delegates then - reveal_manager_key blk consensus_pk >>=? fun blk -> + may_reveal_manager_key blk (consensus_pkh, consensus_pk) >>=? fun blk -> delegate_stake blk consensus_pkh delegate else return blk) >>=? fun blk -> @@ -134,7 +140,7 @@ let test_drain_delegate ~low_balance ~exclude_ck ~ck_delegates () = (if low_balance then transfer_tokens blk delegate consensus_pkh delegate_balance >>=? fun blk -> - reveal_manager_key blk consensus_pk >>=? fun blk -> + may_reveal_manager_key blk (consensus_pkh, consensus_pk) >>=? fun blk -> transfer_tokens blk consensus_pkh delegate Tez.(of_mutez_exn 1_000_000L) else return blk) >>=? fun blk -> diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml index 7544d1caac1f0938b1053022730270d84585e7f7..69aea03cb08399b6e4847c46d9d7ea05273a09af 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml @@ -1475,7 +1475,7 @@ let test_deposit_too_many_tickets () = originate block account1 >>=? fun (block, tx_rollup) -> Nat_ticket.init_deposit too_many block tx_rollup account1 >>=? fun (operation, b, deposit_contract) -> - Block.bake ~operation b >>=? fun b -> + Block.bake ~allow_manager_failures:true ~operation b >>=? fun b -> let fee = Test_tez.of_int 10 in let parameters = print_deposit_arg (`Typed tx_rollup) (`Hash pkh) in Op.transaction ~fee (B b) account1 deposit_contract Tez.zero ~parameters @@ -1775,7 +1775,8 @@ let test_storage_burn_for_commitment () = ~size_before:storage_size_after_commit ~size_after:freed_space_after_finalize ~expected_delta:inbox_delta ; - + (* bake one more block so the commitment may be removed *) + Block.bake b >>=? fun b -> (* test freed storage space after remove commitment *) Op.tx_rollup_remove_commitment (B b) contract tx_rollup >>=? fun operation -> Block.bake b ~operation >>=? fun b -> @@ -1982,8 +1983,8 @@ let test_full_inbox () = let rec aux n acc = if n < start then acc else aux (n - 1) (n :: acc) in aux top [] in - (* Transactions in blocks [2..17) *) - make_transactions_in tx_rollup contract (range 2 17) b >>=? fun b -> + (* Transactions in blocks [2..16) *) + make_transactions_in tx_rollup contract (range 2 16) b >>=? fun b -> Incremental.begin_construction b >>=? fun i -> Op.tx_rollup_submit_batch (B b) contract tx_rollup "contents" >>=? fun op -> Incremental.add_operation diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml b/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml index eb076f547370b9f3b99262bbff65089c123d5d2c..9db10ff3124b2c1d49cfe0ff7b02459be39ebcea 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml @@ -267,4 +267,6 @@ let wrap ~name ?print ?(count = 1) ?check ~(gen : 'a QCheck2.Gen.t) ~gen f -let wrap_mode infos op mode = validate_diagnostic ~mode infos op +let wrap_mode ?(only_validate = false) infos op mode = + if only_validate then only_validate_diagnostic ~mode infos op + else validate_diagnostic ~mode infos op diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml b/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml index 252a6d87896c9402b7bea16a3117eadd8672e6f6..6f7af4cd1c5969fb19e6bc5116376cd7c2c71f13 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -330,30 +330,19 @@ let self_delegate block pkh = let+ _ = Assert.equal_pkh ~loc:__LOC__ del pkh in block -let delegation block delegator delegate = +let delegation block source 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 contract_source = contract_of source in let* operation = Op.delegation ~force_reveal:true (B block) - contract_delegate + contract_source (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_opt_new = Context.Contract.delegate_opt (B block) contract_source in let* del = Assert.get_some ~loc:__LOC__ del_opt_new in let+ _ = Assert.equal_pkh ~loc:__LOC__ del delegate_pkh in block @@ -364,7 +353,9 @@ let originate_tx_rollup block rollup_account = 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 + let+ block = + Block.bake ~allow_manager_failures:true ~operation:rollup_origination block + in (block, tx_rollup) let originate_sc_rollup block rollup_account = @@ -379,7 +370,9 @@ let originate_sc_rollup block rollup_account = ~boot_sector:"" ~parameters_ty:(Script.lazy_expr (Expr.from_string "1")) in - let+ block = Block.bake ~operation:rollup_origination block in + let+ block = + Block.bake ~allow_manager_failures:true ~operation:rollup_origination block + in (block, sc_rollup) module ZKOperator = Dummy_zk_rollup.Operator (struct @@ -401,7 +394,9 @@ let originate_zk_rollup block rollup_account = ~init_state:ZKOperator.init_state ~nb_ops:1 in - let+ block = Block.bake ~operation:rollup_origination block in + let+ block = + Block.bake ~allow_manager_failures:true ~operation:rollup_origination block + in (block, zk_rollup) (** {2 Setting's context construction} *) @@ -632,7 +627,8 @@ let ctxt_with_delegation : ctxt_req -> infos tzresult Lwt.t = | None -> failwith "Delegate account should be funded" | Some a -> return a in - let+ block = delegation infos.ctxt.block (get_source infos) delegate in + let* block = delegation infos.ctxt.block delegate delegate in + let+ block = delegation block (get_source infos) delegate in let ctxt = {infos.ctxt with block} in {infos with ctxt} @@ -1447,7 +1443,7 @@ let pre_state_of_mode ~mode infos = (** 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 post_state_of_mode ?(only_validate = false) ~mode ctxt ops infos = let open Lwt_result_syntax in match (mode, ctxt) with | (Construction | Mempool), Context.I inc_pre -> @@ -1455,7 +1451,13 @@ let post_state_of_mode ~mode ctxt ops infos = 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 + let+ block = + Block.bake + ~allow_manager_failures:only_validate + ~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" @@ -1471,7 +1473,9 @@ let post_state_of_mode ~mode ctxt ops infos = 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* ctxt_post, infos = + post_state_of_mode ~only_validate ~mode ctxt_pre ops infos + in let _ = observe_list ~only_validate ~mode ctxt_pre ctxt_post ops in return infos @@ -1525,7 +1529,11 @@ let validate_ko_diagnostic ?(mode = Construction) (infos : infos) ops return_unit | Application -> ( let*! res = - Block.bake ~baking_mode:Application ~operations:ops infos.ctxt.block + Block.bake + ~allow_manager_failures:true + ~baking_mode:Application + ~operations:ops + infos.ctxt.block in match res with | Error tr -> expect_failure tr diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml b/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml index 36b57cfa2bd9e5cb8bab92b430d602df4a90b8fa..1431e708f43eb61e27b595c446ed5dcfe1a56a87 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml @@ -42,11 +42,12 @@ let count = 100 let ctxt_cstrs_default = { default_ctxt_cstrs with - src_cstrs = Greater {n = 15000; origin = 15000}; + src_cstrs = Pure 1500000; dest_cstrs = Pure 15000; del_cstrs = Pure 15000; tx_cstrs = Pure 15000; sc_cstrs = Pure 15000; + zk_cstrs = Pure 15000; } let op_cstrs_default b = @@ -107,7 +108,7 @@ let positive_tests = let open Lwt_result_syntax in let* infos = init_ctxt ctxt_req in let* op = select_op operation_req infos in - let* _infos = wrap_mode infos [op] mode in + let* _infos = wrap_mode ~only_validate:true infos [op] mode in return_true) (** Under 1M restriction, neither a block nor a prevalidator's valid @@ -174,7 +175,7 @@ let batch_is_not_singles_tests = let* batch = Op.batch_operations ~source (B infos.ctxt.block) [op1; op2] in - let* _ = validate_diagnostic ~mode infos [batch] in + let* _ = only_validate_diagnostic ~mode infos [batch] in let* _ = validate_ko_diagnostic ~mode infos [op1; op2] expect_failure in return_true) @@ -212,8 +213,8 @@ let conflict_free_tests = } 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 + let* _ = only_validate_diagnostic ~mode infos [op1; op2] in + let* _ = only_validate_diagnostic ~mode infos [op2; op1] in return_true) open Lib_test.Qcheck2_helpers diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/test_covalidity.ml b/src/proto_alpha/lib_protocol/test/integration/validate/test_covalidity.ml index 9d2c613b8d13de8597267374be7685aaa0df33e8..8e266096c096f6fecb619d94dbab5f5fed17c9d9 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/test_covalidity.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_covalidity.ml @@ -112,7 +112,9 @@ let covalid_permutation_and_bake ks nb_bootstrap = |> List.rev_filter is_not_preendorsement in (* Ensure that we can validate and apply this permutation *) - let* _b = Block.bake state.block ~operations in + let* _b = + Block.bake ~allow_manager_failures:true state.block ~operations + in loop (pred n) in loop nb_permutations