From 4c590b0e09d74db35ef38976e59363cae1bf6fcf Mon Sep 17 00:00:00 2001 From: vbot Date: Tue, 27 Sep 2022 13:45:45 +0200 Subject: [PATCH 1/7] Proto/Tests: add consensus key test endorsement --- .../consensus/test_consensus_key.ml | 32 +++++++++++++++++++ .../consensus/test_consensus_key.ml | 32 +++++++++++++++++++ 2 files changed, 64 insertions(+) diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/integration/consensus/test_consensus_key.ml b/src/proto_015_PtLimaPt/lib_protocol/test/integration/consensus/test_consensus_key.ml index 0afd74a2d327..1bc534d9fa20 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/integration/consensus/test_consensus_key.ml +++ b/src/proto_015_PtLimaPt/lib_protocol/test/integration/consensus/test_consensus_key.ml @@ -170,6 +170,34 @@ let test_drain_empty_delegate ~exclude_ck () = "Drain delegate without enough balance for allocation burn or drain \ fees") +let test_endorsement_with_consensus_key () = + Context.init_with_constants1 constants >>=? fun (genesis, contracts) -> + let account1_pkh = Context.Contract.pkh contracts in + let consensus_account = Account.new_account () in + let delegate = account1_pkh in + let consensus_pk = consensus_account.pk in + let consensus_pkh = consensus_account.pkh in + transfer_tokens genesis account1_pkh consensus_pkh Tez.one_mutez + >>=? fun blk' -> + update_consensus_key blk' delegate consensus_pk >>=? fun b_pre -> + Block.bake b_pre >>=? fun b -> + let slot = Slot.of_int_do_not_use_except_for_parameters 0 in + Op.endorsement ~delegate:(account1_pkh, [slot]) ~endorsed_block:b (B b_pre) () + >>=? fun endorsement -> + Block.bake ~operation:(Operation.pack endorsement) b >>= fun res -> + Assert.proto_error ~loc:__LOC__ res (function + | Operation.Invalid_signature -> true + | _ -> false) + >>=? fun () -> + Op.endorsement + ~delegate:(consensus_pkh, [slot]) + ~endorsed_block:b + (B b_pre) + () + >>=? fun endorsement -> + Block.bake ~operation:(Operation.pack endorsement) b + >>=? fun (_good_block : Block.t) -> return_unit + let tests = Tztest. [ @@ -237,4 +265,8 @@ let tests = "test empty drain delegate with ck" `Quick (test_drain_empty_delegate ~exclude_ck:false); + tztest + "test endorsement with ck" + `Quick + test_endorsement_with_consensus_key; ] 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 0afd74a2d327..1bc534d9fa20 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 @@ -170,6 +170,34 @@ let test_drain_empty_delegate ~exclude_ck () = "Drain delegate without enough balance for allocation burn or drain \ fees") +let test_endorsement_with_consensus_key () = + Context.init_with_constants1 constants >>=? fun (genesis, contracts) -> + let account1_pkh = Context.Contract.pkh contracts in + let consensus_account = Account.new_account () in + let delegate = account1_pkh in + let consensus_pk = consensus_account.pk in + let consensus_pkh = consensus_account.pkh in + transfer_tokens genesis account1_pkh consensus_pkh Tez.one_mutez + >>=? fun blk' -> + update_consensus_key blk' delegate consensus_pk >>=? fun b_pre -> + Block.bake b_pre >>=? fun b -> + let slot = Slot.of_int_do_not_use_except_for_parameters 0 in + Op.endorsement ~delegate:(account1_pkh, [slot]) ~endorsed_block:b (B b_pre) () + >>=? fun endorsement -> + Block.bake ~operation:(Operation.pack endorsement) b >>= fun res -> + Assert.proto_error ~loc:__LOC__ res (function + | Operation.Invalid_signature -> true + | _ -> false) + >>=? fun () -> + Op.endorsement + ~delegate:(consensus_pkh, [slot]) + ~endorsed_block:b + (B b_pre) + () + >>=? fun endorsement -> + Block.bake ~operation:(Operation.pack endorsement) b + >>=? fun (_good_block : Block.t) -> return_unit + let tests = Tztest. [ @@ -237,4 +265,8 @@ let tests = "test empty drain delegate with ck" `Quick (test_drain_empty_delegate ~exclude_ck:false); + tztest + "test endorsement with ck" + `Quick + test_endorsement_with_consensus_key; ] -- GitLab From 7b6fd3e76e1db3c856a250199f96c551a14d745e Mon Sep 17 00:00:00 2001 From: Zaynah Dargaye Date: Tue, 30 Aug 2022 16:41:50 +0200 Subject: [PATCH 2/7] Proto/Tests: Qcheck generators for operations use for testing compare_operations --- manifest/main.ml | 1 + .../test/helpers/operation_generator.ml | 1162 ++++++++-------- .../lib_protocol/test/pbt/dune | 10 +- .../{unit => pbt}/test_compare_operations.ml | 89 +- .../lib_protocol/test/unit/main.ml | 1 - .../lib_protocol/alpha_context.mli | 4 + src/proto_alpha/lib_protocol/slot_repr.ml | 4 + src/proto_alpha/lib_protocol/slot_repr.mli | 4 + .../test/helpers/operation_generator.ml | 1168 ++++++++--------- src/proto_alpha/lib_protocol/test/pbt/dune | 10 +- .../{unit => pbt}/test_compare_operations.ml | 89 +- .../lib_protocol/test/unit/main.ml | 1 - 12 files changed, 1171 insertions(+), 1372 deletions(-) rename src/proto_015_PtLimaPt/lib_protocol/test/{unit => pbt}/test_compare_operations.ml (60%) rename src/proto_alpha/lib_protocol/test/{unit => pbt}/test_compare_operations.ml (60%) diff --git a/manifest/main.ml b/manifest/main.ml index 0ce9ec6f85b4..2326bf730236 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -3618,6 +3618,7 @@ end = struct (3, "test_carbonated_map", N.(number >= 013)); (3, "test_zk_rollup_encoding", N.(number >= 015)); (3, "test_dal_slot_proof", N.(number >= 016)); + (3, "test_compare_operations", N.(number >= 015)); ] |> List.filter_map (fun (i, n, b) -> if b then Some (i, n) else None) in diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/helpers/operation_generator.ml b/src/proto_015_PtLimaPt/lib_protocol/test/helpers/operation_generator.ml index e0aad4dd7aa0..0272ea915ded 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/helpers/operation_generator.ml +++ b/src/proto_015_PtLimaPt/lib_protocol/test/helpers/operation_generator.ml @@ -23,14 +23,19 @@ (* *) (*****************************************************************************) +(** These generators aims at generating operations which are not + necessary correct. The goal is to tests functions such as {! + Operation.compare} with as much as possible parameters that play a + role in operation [weight] computation. + + When adding a new operation, one should also add its weight + computation, hence knows which kind of generator should be provided + for this new operation.*) + open Protocol open Alpha_context -module Random = Random.State - -type random_state = {seed : int; rnd_state : Random.t} -let choose_list_element random_state l = - Stdlib.List.nth l (Random.int random_state.rnd_state (List.length l)) +(** {2 Operations kind labelling.} *) let consensus_pass = `PConsensus @@ -111,6 +116,10 @@ let pp_kind fmt k = | `KBallot -> "KBallot" | `KManager -> "KManager") +(** {2 Generators} *) + +(** {3 Selection in hashes list} *) + let block_hashes = List.map Block_hash.of_b58check_exn @@ -120,24 +129,6 @@ let block_hashes = "BLuurCvGmNPTzXSnGCpcFPy5h8A49PwH2LnfAWBnp5R1qv5czwe"; ] -let random_shell random_state : Tezos_base.Operation.shell_header = - {branch = choose_list_element random_state block_hashes} - -let random_slot random_state = - choose_list_element random_state [100; 200; 300] - |> Slot.of_int_do_not_use_except_for_parameters - -let random_level random_state = - choose_list_element random_state [10l; 20l; 30l] |> Raw_level.of_int32 - |> function - | Ok v -> v - | Error _ -> assert false - -let random_round random_state = - choose_list_element random_state [0l; 1l; 2l] |> Round.of_int32 |> function - | Ok v -> v - | Error _ -> assert false - let payload_hashes = List.map Block_payload_hash.of_b58check_exn @@ -147,15 +138,7 @@ let payload_hashes = "vh2TyrWeZ2dydEy9ZjmvrjQvyCs5sdHZPypcZrXDUSM1tNuPermf"; ] -let random_payload_hash random_state = - choose_list_element random_state payload_hashes - -let generate_consensus_content random_state : consensus_content = - let slot = random_slot random_state in - let level = random_level random_state in - let round = random_round random_state in - let block_payload_hash = random_payload_hash random_state in - {slot; level; round; block_payload_hash} +let random_payload_hash = QCheck2.Gen.oneofl payload_hashes let signatures = List.map @@ -166,8 +149,7 @@ let signatures = "sighje7pEbUUwGtJ4GTP7uzMZe5SFz6dRRC3BvZBHnrRHnc47WHGnVdfiscHPMek7esmj7saTuj54QBWy3SezyA2EGbHkmW5"; ] -let random_signature random_state = - Some (choose_list_element random_state signatures) +let random_signature = QCheck2.Gen.oneofl signatures let pkhs = List.map @@ -178,7 +160,7 @@ let pkhs = "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU"; ] -let random_pkh random_state = choose_list_element random_state pkhs +let random_pkh = QCheck2.Gen.oneofl pkhs let pks = List.map @@ -189,16 +171,7 @@ let pks = "edpkuFrRoDSEbJYgxRtLx2ps82UdaYc1WwfS9sE11yhauZt5DgCHbU"; ] -let random_pk random_state = choose_list_element random_state pks - -let random_fee random_state = - choose_list_element random_state [Tez.zero; Tez.one_cent; Tez.one] - -let random_amount random_state = - choose_list_element random_state [Tez.zero; Tez.one_cent; Tez.one] - -let random_amount_in_bytes random_state = - choose_list_element random_state [Z.zero; Z.one; Z.of_int 100] +let random_pk = QCheck2.Gen.oneofl pks let contract_hashes = List.map @@ -209,30 +182,7 @@ let contract_hashes = "KT1RJ6PbjHpwc3M5rw5s2Nbmefwbuwbdxton"; ] -let random_contract_hash random_state = - choose_list_element random_state contract_hashes - -let random_contract random_state = - if Random.bool random_state.rnd_state then - Contract.Implicit (random_pkh random_state) - else - let contract_hash = random_contract_hash random_state in - Contract.Originated contract_hash - -let random_contract_hash random_state = - choose_list_element random_state contract_hashes - -let counters = List.map Z.of_int [123; 456; 789] - -let random_counter random_state = choose_list_element random_state counters - -let random_gas_limit random_state = - choose_list_element - random_state - Gas.Arith.[zero; integral_of_int_exn 1_000; integral_of_int_exn 10_000] - -let random_storage_limit random_state = - choose_list_element random_state Z.[zero; of_int 1_000; of_int 10_000] +let random_contract_hash = QCheck2.Gen.oneofl contract_hashes let block_headers = let bh1 = @@ -252,23 +202,7 @@ let block_headers = | Error _ -> assert false) [bh1; bh2; bh3] -let random_block_header random_state = - choose_list_element random_state block_headers - -let nonces = - List.map - (fun i -> - let b = Bytes.create 32 in - Bytes.set_int8 b 0 i ; - Alpha_context.Nonce.of_bytes b |> function - | Ok v -> v - | Error _ -> assert false) - [1; 2; 3] - -let random_nonce random_state = choose_list_element random_state nonces - -let random_option f random_state = - if Random.bool random_state.rnd_state then Some (f random_state) else None +let random_block_header = QCheck2.Gen.oneofl block_headers let tx_rollups = List.filter_map @@ -279,7 +213,7 @@ let tx_rollups = "txr1TAFTENC2YACvoMDrpJHCbdvdfSSjcjEjc"; ] -let random_tx_rollup random_state = choose_list_element random_state tx_rollups +let random_tx_rollup = QCheck2.Gen.oneofl tx_rollups let sc_rollups = List.map @@ -290,7 +224,7 @@ let sc_rollups = "scr1Kqqbvust2adJMtSu2V4fcd49oQHug4BLb"; ] -let random_sc_rollup random_state = choose_list_element random_state sc_rollups +let random_sc_rollup = QCheck2.Gen.oneofl sc_rollups let protos = List.map @@ -319,44 +253,101 @@ let protos = "ProtoALphaALphaALphaALphaALphaALphaALpha841f2cQqajX"; ] -let random_proto random_state = choose_list_element random_state protos +let random_proto = QCheck2.Gen.oneofl protos -let generate_op random_state (gen_op : random_state -> 'kind contents_list) : - 'kind operation = - let shell = random_shell random_state in - let signature = random_signature random_state in - let contents = gen_op random_state in - let protocol_data = {contents; signature} in - {shell; protocol_data} +let codes = + List.filter_map + Blinded_public_key_hash.activation_code_of_hex + [ + "41f98b15efc63fa893d61d7d6eee4a2ce9427ac4"; + "411dfef031eeecc506de71c9df9f8e44297cf5ba"; + "08d7d355bc3391d12d140780b39717d9f46fcf87"; + ] -let generate_preendorsement random_state = - let gen random_state = - Single (Preendorsement (generate_consensus_content random_state)) - in - generate_op random_state gen +let random_code = QCheck2.Gen.oneofl codes -let generate_endorsement random_state : Kind.endorsement Operation.t = - let gen random_state = - Single (Endorsement (generate_consensus_content random_state)) - in - generate_op random_state gen +(** {2 Operations parameters generators} *) -let generate_dal_slot random_state : Kind.dal_slot_availability Operation.t = - let gen random_state = - let pkh = random_pkh random_state in - let dal_endorsement = Dal.Endorsement.empty in - Single (Dal_slot_availability (pkh, dal_endorsement)) - in - generate_op random_state gen - -let generate_seed_nonce_revelation random_state : - Kind.seed_nonce_revelation Operation.t = - let gen random_state = - let level = random_level random_state in - let nonce = random_nonce random_state in - Single (Seed_nonce_revelation {level; nonce}) - in - generate_op random_state gen +let random_shell : Tezos_base.Operation.shell_header QCheck2.Gen.t = + let open QCheck2.Gen in + let+ branch = oneofl block_hashes in + Tezos_base.Operation.{branch} + +let gen_slot = + let open QCheck2.Gen in + let+ i = small_nat in + Slot.of_int_do_not_use_except_for_parameters i + +let gen_level = + let open QCheck2.Gen in + let+ i = ui32 in + match Raw_level.of_int32 i with Ok v -> v | Error _ -> assert false + +let gen_round = + let open QCheck2.Gen in + let+ i = ui32 in + match Round.of_int32 i with Ok v -> v | Error _ -> assert false + +let generate_consensus_content : consensus_content QCheck2.Gen.t = + let open QCheck2.Gen in + let* slot = gen_slot in + let* level = gen_level in + let* round = gen_round in + let+ block_payload_hash = random_payload_hash in + {slot; level; round; block_payload_hash} + +let gen_tez = + let open QCheck2.Gen in + let+ i = ui64 in + match Tez.of_mutez i with None -> Tez.zero | Some v -> v + +let gen_fee = gen_tez + +let gen_amount = gen_tez + +let gen_amount_in_bytes = + let open QCheck2.Gen in + let+ i = nat in + Z.of_int i + +let random_contract = + let open QCheck2.Gen in + let* b = bool in + if b then + let+ pkh = random_pkh in + Contract.Implicit pkh + else + let+ contract_hash = random_contract_hash in + Contract.Originated contract_hash + +let random_contract_hash = QCheck2.Gen.oneofl contract_hashes + +let gen_counters = + let open QCheck2.Gen in + let+ i = nat in + Z.of_int i + +let gen_gas_limit = + let open QCheck2.Gen in + let+ i = nat in + Gas.Arith.integral_of_int_exn i + +let gen_storage_limit = + let open QCheck2.Gen in + let+ i = nat in + Z.of_int i + +let nonces = + List.map + (fun i -> + let b = Bytes.create 32 in + Bytes.set_int8 b 0 i ; + Alpha_context.Nonce.of_bytes b |> function + | Ok v -> v + | Error _ -> assert false) + [1; 2; 3] + +let random_nonce = QCheck2.Gen.oneofl nonces let vdf_solutions = let open Environment.Vdf in @@ -370,330 +361,308 @@ let vdf_solutions = (result, proof)) [1; 2; 3] -let random_vdf_solution random_state = - choose_list_element random_state vdf_solutions +(** {2 Generators for each Operation Kind} *) -let generate_vdf_revelation random_state : Kind.vdf_revelation Operation.t = - let gen random_state = - let solution = random_vdf_solution random_state in - Single (Vdf_revelation {solution}) - in - generate_op random_state gen - -let generate_double_preendorsement random_state : - Kind.double_preendorsement_evidence Operation.t = - let gen random_state = - let op1 = generate_preendorsement random_state in - let op2 = generate_preendorsement random_state in - Single (Double_preendorsement_evidence {op1; op2}) - in - generate_op random_state gen - -let generate_double_endorsement random_state : - Kind.double_endorsement_evidence Operation.t = - let gen random_state = - let op1 = generate_endorsement random_state in - let op2 = generate_endorsement random_state in - Single (Double_endorsement_evidence {op1; op2}) - in - generate_op random_state gen - -let generate_double_baking random_state : - Kind.double_baking_evidence Operation.t = - let gen random_state = - let bh1 = random_block_header random_state in - let bh2 = random_block_header random_state in - Single (Double_baking_evidence {bh1; bh2}) - in - generate_op random_state gen - -let generate_manager_aux : - type kind. - public_key_hash option -> - random_state -> - (random_state -> kind manager_operation) -> - kind Kind.manager contents = - fun opt_source random_state gen_op -> - let source = - match opt_source with - | None -> random_pkh random_state - | Some source -> source - in - let fee = random_fee random_state in - let counter = random_counter random_state in - let operation = gen_op random_state in - let gas_limit = random_gas_limit random_state in - let storage_limit = random_storage_limit random_state in - Manager_operation {source; fee; counter; operation; gas_limit; storage_limit} +let wrap_operation sh (pdata : 'kind protocol_data) : 'kind operation = + {shell = sh; protocol_data = pdata} -let generate_manager random_state - (gen_op : random_state -> 'kind manager_operation) : - 'kind Kind.manager Operation.t = - let source = Some (random_pkh random_state) in - let shell = random_shell random_state in - let signature = random_signature random_state in - let contents = Single (generate_manager_aux source random_state gen_op) in +let generate_op (gen_op : 'kind contents QCheck2.Gen.t) : + 'kind operation QCheck2.Gen.t = + let open QCheck2.Gen in + let* op = gen_op in + let* signature = random_signature in + let+ shell = random_shell in + let contents = Single op in + let signature = Some signature in let protocol_data = {contents; signature} in - {shell; protocol_data} - -let generate_managers random_state gen_ops = - let source = Some (random_pkh random_state) in - let ops_as_single = - List.map - (fun gen_op -> Contents (generate_manager_aux source random_state gen_op)) - gen_ops - in - Operation.of_list ops_as_single - -let generate_reveal random_state : Kind.reveal Kind.manager Operation.t = - let gen random_state = Reveal (random_pk random_state) in - generate_manager random_state gen - -let generate_transaction random_state = - let gen_trans random_state = - let amount = random_amount random_state in - let parameters = Script.unit_parameter in - let entrypoint = Entrypoint.default in - let destination = random_contract random_state in - Transaction {amount; parameters; entrypoint; destination} - in - generate_manager random_state gen_trans - -let generate_origination random_state : - Kind.origination Kind.manager Operation.t = - let gen_origination random_state = - let delegate = None in - let script = Script.{code = unit_parameter; storage = unit_parameter} in - let credit = random_amount random_state in - Origination {delegate; script; credit} - in - generate_manager random_state gen_origination - -let generate_delegation random_state : Kind.delegation Kind.manager Operation.t - = - let gen_delegation random_state = - let delegate = random_option random_pkh random_state in - Delegation delegate - in - generate_manager random_state gen_delegation + wrap_operation shell protocol_data + +let generate_operation gen_op = + let open QCheck2.Gen in + let+ op = generate_op gen_op in + Operation.pack op + +let generate_preendorsement = + let open QCheck2.Gen in + let+ cc = generate_consensus_content in + Preendorsement cc + +let generate_endorsement = + let open QCheck2.Gen in + let+ cc = generate_consensus_content in + Endorsement cc + +let generate_dal_slot = + let open QCheck2.Gen in + let+ pkh = random_pkh in + Dal_slot_availability (pkh, Dal.Endorsement.empty) + +let generate_vdf_revelation = + let open QCheck2.Gen in + let+ solution = oneofl vdf_solutions in + Vdf_revelation {solution} + +let generate_seed_nonce_revelation = + let open QCheck2.Gen in + let* level = gen_level in + let+ nonce = random_nonce in + Seed_nonce_revelation {level; nonce} + +let generate_double_preendorsement = + let open QCheck2.Gen in + let* op1 = generate_op generate_preendorsement in + let+ op2 = generate_op generate_preendorsement in + Double_preendorsement_evidence {op1; op2} + +let generate_double_endorsement = + let open QCheck2.Gen in + let* op1 = generate_op generate_endorsement in + let+ op2 = generate_op generate_endorsement in + Double_endorsement_evidence {op1; op2} + +let generate_double_baking = + let open QCheck2.Gen in + let* bh1 = random_block_header in + let+ bh2 = random_block_header in + Double_baking_evidence {bh1; bh2} + +let generate_activate_account = + let open QCheck2.Gen in + let* activation_code = random_code in + let+ id = random_pkh in + let id = match id with Signature.Ed25519 pkh -> pkh | _ -> assert false in + Activate_account {id; activation_code} + +let random_period = + let open QCheck2.Gen in + let+ i = ui32 in + i + +let generate_proposals = + let open QCheck2.Gen in + let* source = random_pkh in + let+ period = random_period in + let proposals = [] in + Proposals {source; period; proposals} + +let generate_ballot = + let open QCheck2.Gen in + let* source = random_pkh in + let* period = random_period in + let+ proposal = random_proto in + let ballot = Vote.Pass in + Ballot {source; period; proposal; ballot} + +let generate_manager_aux ?source gen_manop = + let open QCheck2.Gen in + let* source = + match source with None -> random_pkh | Some source -> return source + in + let* fee = gen_fee in + let* counter = gen_counters in + let* gas_limit = gen_gas_limit in + let* storage_limit = gen_storage_limit in + let+ operation = gen_manop in + Manager_operation {source; fee; counter; operation; gas_limit; storage_limit} -let generate_set_deposits_limit random_state : - Kind.set_deposits_limit Kind.manager Operation.t = - let gen_set_deposits_limit random_state = - let amount_opt = random_option random_amount random_state in - Set_deposits_limit amount_opt - in - generate_manager random_state gen_set_deposits_limit - -let generate_increase_paid_storage random_state : - Kind.increase_paid_storage Kind.manager Operation.t = - let gen_increase_paid_storage random_state = - let amount_in_bytes = random_amount_in_bytes random_state in - let destination = random_contract_hash random_state in - Increase_paid_storage {amount_in_bytes; destination} +let generate_manager ?source gen_manop = + generate_op (generate_manager_aux ?source gen_manop) + +let generate_manager_operation ?source gen_manop = + let open QCheck2.Gen in + let+ manop = generate_manager ?source gen_manop in + Operation.pack manop + +let generate_reveal = + let open QCheck2.Gen in + let+ pk = random_pk in + Reveal pk + +let generate_transaction = + let open QCheck2.Gen in + let* amount = gen_amount in + let+ destination = random_contract in + let parameters = Script.unit_parameter in + let entrypoint = Entrypoint.default in + Transaction {amount; parameters; entrypoint; destination} + +let generate_origination = + let open QCheck2.Gen in + let+ credit = gen_amount in + let delegate = None in + let script = Script.{code = unit_parameter; storage = unit_parameter} in + Origination {delegate; script; credit} + +let generate_delegation = + let open QCheck2.Gen in + let+ delegate = option random_pkh in + Delegation delegate + +let generate_increase_paid_storage = + let open QCheck2.Gen in + let* amount_in_bytes = gen_amount_in_bytes in + let+ destination = random_contract_hash in + Increase_paid_storage {amount_in_bytes; destination} + +let generate_set_deposits_limit = + let open QCheck2.Gen in + let+ amount_opt = option gen_amount in + Set_deposits_limit amount_opt + +let generate_register_global_constant = + let value = Script_repr.lazy_expr (Expr.from_string "Pair 1 2") in + QCheck2.Gen.pure (Register_global_constant {value}) + +let generate_tx_rollup_origination = QCheck2.Gen.pure Tx_rollup_origination + +let generate_tx_rollup_submit_batch = + let open QCheck2.Gen in + let+ tx_rollup = random_tx_rollup in + let content = "batch" in + let burn_limit = None in + Tx_rollup_submit_batch {tx_rollup; content; burn_limit} + +let generate_tx_rollup_commit = + let open QCheck2.Gen in + let+ tx_rollup = random_tx_rollup in + let commitment : Tx_rollup_commitment.Full.t = + { + level = Tx_rollup_level.root; + messages = []; + predecessor = None; + inbox_merkle_root = Tx_rollup_inbox.Merkle.merklize_list []; + } in - generate_manager random_state gen_increase_paid_storage - -let generate_register_global_constant random_state : - Kind.register_global_constant Kind.manager Operation.t = - let gen_register_global_constant _ = - let value = Script_repr.lazy_expr (Expr.from_string "Pair 1 2") in - Register_global_constant {value} + Tx_rollup_commit {tx_rollup; commitment} + +let generate_tx_rollup_return_bond = + let open QCheck2.Gen in + let+ tx_rollup = random_tx_rollup in + Tx_rollup_return_bond {tx_rollup} + +let generate_tx_finalize_commitment = + let open QCheck2.Gen in + let+ tx_rollup = random_tx_rollup in + Tx_rollup_finalize_commitment {tx_rollup} + +let generate_tx_rollup_remove_commitment = + let open QCheck2.Gen in + let+ tx_rollup = random_tx_rollup in + Tx_rollup_remove_commitment {tx_rollup} + +let generate_tx_rollup_rejection = + let open QCheck2.Gen in + let+ tx_rollup = random_tx_rollup in + let message, _ = Tx_rollup_message.make_batch "" in + let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in + let message_path = + match Tx_rollup_inbox.Merkle.compute_path [message_hash] 0 with + | Ok message_path -> message_path + | _ -> raise (Invalid_argument "Single_message_inbox.message_path") + in + let proof : Tx_rollup_l2_proof.t = + { + version = 1; + before = `Value Tx_rollup_message_result.empty_l2_context_hash; + after = `Value Context_hash.zero; + state = Seq.empty; + } in - generate_manager random_state gen_register_global_constant - -let generate_tx_rollup_origination random_state : - Kind.tx_rollup_origination Kind.manager Operation.t = - let gen_tx_orig _ = Tx_rollup_origination in - generate_manager random_state gen_tx_orig - -let generate_tx_rollup_submit_batch random_state : - Kind.tx_rollup_submit_batch Kind.manager Operation.t = - let gen_tx_submit random_state = - let tx_rollup = random_tx_rollup random_state in - let content = "batch" in - let burn_limit = None in - Tx_rollup_submit_batch {tx_rollup; content; burn_limit} + 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 - generate_manager random_state gen_tx_submit + let level = Tx_rollup_level.root in + let message_result_hash = Tx_rollup_message_result_hash.zero in + let message_result_path = Tx_rollup_commitment.Merkle.dummy_path in + let previous_message_result_path = Tx_rollup_commitment.Merkle.dummy_path in + let message_position = 0 in + let proof = Tx_rollup_l2_proof.serialize_proof_exn proof in + Tx_rollup_rejection + { + tx_rollup; + level; + message; + message_position; + message_path; + message_result_hash; + message_result_path; + previous_message_result; + previous_message_result_path; + proof; + } -let generate_tx_rollup_commit random_state : - Kind.tx_rollup_commit Kind.manager Operation.t = - let gen_tx_commit random_state = - let tx_rollup = random_tx_rollup random_state in - let commitment : Tx_rollup_commitment.Full.t = +let generate_tx_dispatch_tickets = + let open QCheck2.Gen in + let* tx_rollup = random_tx_rollup in + let* source = random_pkh in + let+ contract = random_contract in + let level = Tx_rollup_level.root in + let message_index = 0 in + let message_result_path = Tx_rollup_commitment.Merkle.dummy_path in + let context_hash = Context_hash.zero in + let reveal = + Tx_rollup_reveal. { - level = Tx_rollup_level.root; - messages = []; - predecessor = None; - inbox_merkle_root = Tx_rollup_inbox.Merkle.merklize_list []; + contents = Script.lazy_expr (Expr.from_string "1"); + ty = Script.lazy_expr (Expr.from_string "nat"); + ticketer = contract; + amount = Tx_rollup_l2_qty.of_int64_exn 10L; + claimer = source; } - in - Tx_rollup_commit {tx_rollup; commitment} in - generate_manager random_state gen_tx_commit - -let generate_tx_rollup_return_bond random_state : - Kind.tx_rollup_return_bond Kind.manager Operation.t = - let gen_tx_return_bd random_state = - let tx_rollup = random_tx_rollup random_state in - Tx_rollup_return_bond {tx_rollup} - in - generate_manager random_state gen_tx_return_bd + let tickets_info = [reveal] in + Tx_rollup_dispatch_tickets + { + tx_rollup; + level; + context_hash; + message_index; + message_result_path; + tickets_info; + } -let generate_tx_finalize_commitment random_state : - Kind.tx_rollup_finalize_commitment Kind.manager Operation.t = - let gen_tx_finalize random_state = - let tx_rollup = random_tx_rollup random_state in - Tx_rollup_finalize_commitment {tx_rollup} - in - generate_manager random_state gen_tx_finalize - -let generate_tx_rollup_remove_commitment random_state : - Kind.tx_rollup_remove_commitment Kind.manager Operation.t = - let gen_tx_remove random_state = - let tx_rollup = random_tx_rollup random_state in - Tx_rollup_remove_commitment {tx_rollup} - in - generate_manager random_state gen_tx_remove - -let generate_tx_rollup_rejection random_state : - Kind.tx_rollup_rejection Kind.manager Operation.t = - let gen_tx_rejection random_state = - let tx_rollup = random_tx_rollup random_state in - let message, _ = Tx_rollup_message.make_batch "" in - let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in - let message_path = - match Tx_rollup_inbox.Merkle.compute_path [message_hash] 0 with - | Ok message_path -> message_path - | _ -> raise (Invalid_argument "Single_message_inbox.message_path") - in - let proof : Tx_rollup_l2_proof.t = - { - version = 1; - before = `Value Tx_rollup_message_result.empty_l2_context_hash; - after = `Value Context_hash.zero; - state = Seq.empty; - } - in - let previous_message_result : Tx_rollup_message_result.t = - { - context_hash = Tx_rollup_message_result.empty_l2_context_hash; - withdraw_list_hash = Tx_rollup_withdraw_list_hash.empty; - } - in - let level = Tx_rollup_level.root in - let message_result_hash = Tx_rollup_message_result_hash.zero in - let message_result_path = Tx_rollup_commitment.Merkle.dummy_path in - let previous_message_result_path = Tx_rollup_commitment.Merkle.dummy_path in - let message_position = 0 in - let proof = Tx_rollup_l2_proof.serialize_proof_exn proof in - Tx_rollup_rejection - { - tx_rollup; - level; - message; - message_position; - message_path; - message_result_hash; - message_result_path; - previous_message_result; - previous_message_result_path; - proof; - } - in - generate_manager random_state gen_tx_rejection - -let generate_tx_dispatch_tickets random_state : - Kind.tx_rollup_dispatch_tickets Kind.manager Operation.t = - let gen_tx_dispatch random_state = - let tx_rollup = random_tx_rollup random_state in - let source = random_pkh random_state in - let contract = random_contract random_state in - let level = Tx_rollup_level.root in - let message_index = 0 in - let message_result_path = Tx_rollup_commitment.Merkle.dummy_path in - let context_hash = Context_hash.zero in - let reveal = - Tx_rollup_reveal. - { - contents = Script.lazy_expr (Expr.from_string "1"); - ty = Script.lazy_expr (Expr.from_string "nat"); - ticketer = contract; - amount = Tx_rollup_l2_qty.of_int64_exn 10L; - claimer = source; - } - in - let tickets_info = [reveal] in - Tx_rollup_dispatch_tickets - { - tx_rollup; - level; - context_hash; - message_index; - message_result_path; - tickets_info; - } - in - generate_manager random_state gen_tx_dispatch - -let generate_transfer_ticket random_state : - Kind.transfer_ticket Kind.manager Operation.t = - let gen_transfer_ticket random_state = - let contents = Script.lazy_expr (Expr.from_string "1") in - let ty = Script.lazy_expr (Expr.from_string "nat") in - let ticketer = random_contract random_state in - let destination = random_contract random_state in - let amount = - WithExceptions.Option.get ~loc:__LOC__ - @@ Ticket_amount.of_n - @@ Script_int.( - add_n one_n - @@ Option.value ~default:zero_n - @@ is_nat @@ of_zint - @@ random_counter random_state) - in - let entrypoint = Entrypoint.default in - Transfer_ticket {contents; ty; ticketer; amount; destination; entrypoint} - in - generate_manager random_state gen_transfer_ticket - -let generate_dal_publish_slot_header random_state : - Kind.dal_publish_slot_header Kind.manager Operation.t = - let gen_dal_publish _ = - let published_level = Alpha_context.Raw_level.of_int32_exn Int32.zero in - let index = Alpha_context.Dal.Slot_index.zero in - let header = Alpha_context.Dal.Slot.Header.zero in - let slot = Alpha_context.Dal.Slot.{id = {published_level; index}; header} in - Dal_publish_slot_header {slot} - in - generate_manager random_state gen_dal_publish - -let generate_sc_rollup_originate random_state : - Kind.sc_rollup_originate Kind.manager Operation.t = - let gen_sc_originate _ = - let kind = Sc_rollup.Kind.Example_arith in - let boot_sector = "" in - let parameters_ty = Script.lazy_expr (Expr.from_string "1") in - let origination_proof = - Lwt_main.run (Sc_rollup_helpers.origination_proof ~boot_sector kind) - in - let (module PVM) = Sc_rollup.wrapped_proof_module origination_proof in - let origination_proof = - Data_encoding.Binary.to_string_exn PVM.proof_encoding PVM.proof - in - Sc_rollup_originate {kind; boot_sector; origination_proof; parameters_ty} - in - generate_manager random_state gen_sc_originate - -let generate_sc_rollup_add_messages random_state : - Kind.sc_rollup_add_messages Kind.manager Operation.t = - let gen_sc_add_messages random_state = - let rollup = random_sc_rollup random_state in - let messages = [] in - Sc_rollup_add_messages {rollup; messages} - in - generate_manager random_state gen_sc_add_messages +let generate_transfer_ticket = + let open QCheck2.Gen in + let* ticketer = random_contract in + let* destination = random_contract in + let+ amount = gen_counters in + let amount = + Option.value (Ticket_amount.of_zint amount) ~default:Ticket_amount.one + in + let contents = Script.lazy_expr (Expr.from_string "1") in + let ty = Script.lazy_expr (Expr.from_string "nat") in + let entrypoint = Entrypoint.default in + Transfer_ticket {contents; ty; ticketer; amount; destination; entrypoint} + +let generate_dal_publish_slot_header = + let published_level = Alpha_context.Raw_level.of_int32_exn Int32.zero in + let index = Alpha_context.Dal.Slot_index.zero in + let header = Alpha_context.Dal.Slot.Header.zero in + let slot = Alpha_context.Dal.Slot.{id = {published_level; index}; header} in + QCheck2.Gen.pure (Dal_publish_slot_header {slot}) + +let generate_sc_rollup_originate = + let kind = Sc_rollup.Kind.Example_arith in + let boot_sector = "" in + let parameters_ty = Script.lazy_expr (Expr.from_string "1") in + let origination_proof = + Lwt_main.run (Sc_rollup_helpers.origination_proof ~boot_sector kind) + in + let (module PVM) = Sc_rollup.wrapped_proof_module origination_proof in + let origination_proof = + Data_encoding.Binary.to_string_exn PVM.proof_encoding PVM.proof + in + QCheck2.Gen.pure + (Sc_rollup_originate {kind; boot_sector; origination_proof; parameters_ty}) + +let generate_sc_rollup_add_messages = + let open QCheck2.Gen in + let+ rollup = random_sc_rollup in + let messages = [] in + Sc_rollup_add_messages {rollup; messages} let sc_dummy_commitment = let number_of_ticks = @@ -709,181 +678,117 @@ let sc_dummy_commitment = compressed_state = Sc_rollup.State_hash.zero; } -let generate_sc_rollup_cement random_state : - Kind.sc_rollup_cement Kind.manager Operation.t = - let gen_sc_cement random_state = - let rollup = random_sc_rollup random_state in - let commitment = - Sc_rollup.Commitment.hash_uncarbonated sc_dummy_commitment - in - Sc_rollup_cement {rollup; commitment} - in - generate_manager random_state gen_sc_cement - -let generate_sc_rollup_publish random_state : - Kind.sc_rollup_publish Kind.manager Operation.t = - let gen_sc_publish random_state = - let rollup = random_sc_rollup random_state in - let commitment = sc_dummy_commitment in - Sc_rollup_publish {rollup; commitment} - in - generate_manager random_state gen_sc_publish - -let generate_sc_rollup_refute random_state : - Kind.sc_rollup_refute Kind.manager Operation.t = - let gen random_state = - let opponent = random_pkh random_state in - let rollup = random_sc_rollup random_state in - let refutation : Sc_rollup.Game.refutation option = - Some {choice = Sc_rollup.Tick.initial; step = Dissection []} - in - Sc_rollup_refute {rollup; opponent; refutation} - in - generate_manager random_state gen - -let generate_sc_rollup_timeout random_state : - Kind.sc_rollup_timeout Kind.manager Operation.t = - let gen random_state = - let source = random_pkh random_state in - let rollup = random_sc_rollup random_state in - let staker = random_pkh random_state in - let stakers = Sc_rollup.Game.Index.make source staker in - Sc_rollup_timeout {rollup; stakers} - in - generate_manager random_state gen - -let generate_sc_rollup_execute_outbox_message random_state : - Kind.sc_rollup_execute_outbox_message Kind.manager Operation.t = - let gen random_state = - let rollup = random_sc_rollup random_state in - let cemented_commitment = - Sc_rollup.Commitment.hash_uncarbonated sc_dummy_commitment - in - let output_proof = "" in - Sc_rollup_execute_outbox_message {rollup; cemented_commitment; output_proof} - in - generate_manager random_state gen - -let generate_sc_rollup_recover_bond random_state : - Kind.sc_rollup_recover_bond Kind.manager Operation.t = - let gen random_state = - let sc_rollup = random_sc_rollup random_state in - Sc_rollup_recover_bond {sc_rollup} - in - generate_manager random_state gen - -let generate_sc_rollup_dal_slot_subscribe random_state : - Kind.sc_rollup_dal_slot_subscribe Kind.manager Operation.t = - let gen random_state = - let rollup = random_sc_rollup random_state in - let slot_index = Alpha_context.Dal.Slot_index.zero in - Sc_rollup_dal_slot_subscribe {rollup; slot_index} - in - generate_manager random_state gen - -let codes = - List.filter_map - Blinded_public_key_hash.activation_code_of_hex - [ - "41f98b15efc63fa893d61d7d6eee4a2ce9427ac4"; - "411dfef031eeecc506de71c9df9f8e44297cf5ba"; - "08d7d355bc3391d12d140780b39717d9f46fcf87"; - ] - -let random_code random_state = choose_list_element random_state codes - -let generate_activate_account random_state : Kind.activate_account Operation.t = - let gen random_state = - let id = - random_pkh random_state |> function - | Ed25519 pkh -> pkh - | _ -> assert false - in - let activation_code = random_code random_state in - Single (Activate_account {id; activation_code}) - in - generate_op random_state gen - -let random_period random_state = choose_list_element random_state [0l; 1l; 2l] - -let generate_proposals random_state : Kind.proposals Operation.t = - let gen random_state = - let source = random_pkh random_state in - let period = random_period random_state in - let proposals = [] in - Single (Proposals {source; period; proposals}) - in - generate_op random_state gen - -let generate_ballot random_state : Kind.ballot Operation.t = - let gen random_state = - let source = random_pkh random_state in - let period = random_period random_state in - let proposal = random_proto random_state in - let ballot = Vote.Pass in - Single (Ballot {source; period; proposal; ballot}) - in - generate_op random_state gen - -let generate_manager_operation batch_size random_state = - let l = - Stdlib.List.init batch_size (fun _ -> - choose_list_element random_state manager_kinds) - in - let packed_manager_ops = - List.map - (function - | `KReveal -> generate_reveal random_state |> Operation.pack - | `KTransaction -> generate_transaction random_state |> Operation.pack - | `KOrigination -> generate_origination random_state |> Operation.pack - | `KSet_deposits_limit -> - generate_set_deposits_limit random_state |> Operation.pack - | `KIncrease_paid_storage -> - generate_increase_paid_storage random_state |> Operation.pack - | `KDelegation -> generate_delegation random_state |> Operation.pack - | `KRegister_global_constant -> - generate_register_global_constant random_state |> Operation.pack - | `KTx_rollup_origination -> - generate_tx_rollup_origination random_state |> Operation.pack - | `KTransfer_ticket -> - generate_transfer_ticket random_state |> Operation.pack - | `KDal_publish_slot_header -> - generate_dal_publish_slot_header random_state |> Operation.pack - | `KTx_rollup_submit_batch -> - generate_tx_rollup_submit_batch random_state |> Operation.pack - | `KTx_rollup_commit -> - generate_tx_rollup_commit random_state |> Operation.pack - | `KTx_rollup_return_bond -> - generate_tx_rollup_return_bond random_state |> Operation.pack - | `KTx_rollup_finalize_commitment -> - generate_tx_finalize_commitment random_state |> Operation.pack - | `KTx_rollup_remove_commitment -> - generate_tx_rollup_remove_commitment random_state |> Operation.pack - | `KTx_rollup_rejection -> - generate_tx_rollup_rejection random_state |> Operation.pack - | `KTx_rollup_dispatch_tickets -> - generate_tx_dispatch_tickets random_state |> Operation.pack - | `KSc_rollup_originate -> - generate_sc_rollup_originate random_state |> Operation.pack - | `KSc_rollup_add_messages -> - generate_sc_rollup_add_messages random_state |> Operation.pack - | `KSc_rollup_cement -> - generate_sc_rollup_cement random_state |> Operation.pack - | `KSc_rollup_publish -> - generate_sc_rollup_publish random_state |> Operation.pack - | `KSc_rollup_refute -> - generate_sc_rollup_refute random_state |> Operation.pack - | `KSc_rollup_timeout -> - generate_sc_rollup_timeout random_state |> Operation.pack - | `KSc_rollup_execute_outbox_message -> - generate_sc_rollup_execute_outbox_message random_state - |> Operation.pack - | `KSc_rollup_recover_bond -> - generate_sc_rollup_recover_bond random_state |> Operation.pack - | `KSc_rollup_dal_slot_subscribe -> - generate_sc_rollup_dal_slot_subscribe random_state |> Operation.pack) - l - in +let generate_sc_rollup_cement = + let open QCheck2.Gen in + let+ rollup = random_sc_rollup in + let commitment = Sc_rollup.Commitment.hash_uncarbonated sc_dummy_commitment in + Sc_rollup_cement {rollup; commitment} + +let generate_sc_rollup_publish = + let open QCheck2.Gen in + let+ rollup = random_sc_rollup in + let commitment = sc_dummy_commitment in + Sc_rollup_publish {rollup; commitment} + +let generate_sc_rollup_refute = + let open QCheck2.Gen in + let* opponent = random_pkh in + let+ rollup = random_sc_rollup in + let refutation : Sc_rollup.Game.refutation option = + Some {choice = Sc_rollup.Tick.initial; step = Dissection []} + in + Sc_rollup_refute {rollup; opponent; refutation} + +let generate_sc_rollup_timeout = + let open QCheck2.Gen in + let* source = random_pkh in + let* rollup = random_sc_rollup in + let+ staker = random_pkh in + let stakers = Sc_rollup.Game.Index.make source staker in + Sc_rollup_timeout {rollup; stakers} + +let generate_sc_rollup_execute_outbox_message = + let open QCheck2.Gen in + let+ rollup = random_sc_rollup in + let cemented_commitment = + Sc_rollup.Commitment.hash_uncarbonated sc_dummy_commitment + in + let output_proof = "" in + Sc_rollup_execute_outbox_message {rollup; cemented_commitment; output_proof} + +let generate_sc_rollup_recover_bond = + let open QCheck2.Gen in + let+ sc_rollup = random_sc_rollup in + Sc_rollup_recover_bond {sc_rollup} + +let generate_sc_rollup_dal_slot_subscribe = + let open QCheck2.Gen in + let+ rollup = random_sc_rollup in + let slot_index = Alpha_context.Dal.Slot_index.zero in + Sc_rollup_dal_slot_subscribe {rollup; slot_index} + +(** {By Kind Operation Generator} *) + +let generator_of ?source = function + | `KReveal -> generate_manager_operation ?source generate_reveal + | `KTransaction -> generate_manager_operation ?source generate_transaction + | `KOrigination -> generate_manager_operation ?source generate_origination + | `KSet_deposits_limit -> + generate_manager_operation ?source generate_set_deposits_limit + | `KIncrease_paid_storage -> + generate_manager_operation ?source generate_increase_paid_storage + | `KDelegation -> generate_manager_operation ?source generate_delegation + | `KRegister_global_constant -> + generate_manager_operation ?source generate_register_global_constant + | `KTx_rollup_origination -> + generate_manager_operation ?source generate_tx_rollup_origination + | `KTransfer_ticket -> + generate_manager_operation ?source generate_transfer_ticket + | `KDal_publish_slot_header -> + generate_manager_operation ?source generate_dal_publish_slot_header + | `KTx_rollup_submit_batch -> + generate_manager_operation ?source generate_tx_rollup_submit_batch + | `KTx_rollup_commit -> + generate_manager_operation ?source generate_tx_rollup_commit + | `KTx_rollup_return_bond -> + generate_manager_operation ?source generate_tx_rollup_return_bond + | `KTx_rollup_finalize_commitment -> + generate_manager_operation ?source generate_tx_finalize_commitment + | `KTx_rollup_remove_commitment -> + generate_manager_operation ?source generate_tx_rollup_remove_commitment + | `KTx_rollup_rejection -> + generate_manager_operation ?source generate_tx_rollup_rejection + | `KTx_rollup_dispatch_tickets -> + generate_manager_operation ?source generate_tx_dispatch_tickets + | `KSc_rollup_originate -> + generate_manager_operation ?source generate_sc_rollup_originate + | `KSc_rollup_add_messages -> + generate_manager_operation ?source generate_sc_rollup_add_messages + | `KSc_rollup_cement -> + generate_manager_operation ?source generate_sc_rollup_cement + | `KSc_rollup_publish -> + generate_manager_operation ?source generate_sc_rollup_publish + | `KSc_rollup_refute -> + generate_manager_operation ?source generate_sc_rollup_refute + | `KSc_rollup_timeout -> + generate_manager_operation ?source generate_sc_rollup_timeout + | `KSc_rollup_execute_outbox_message -> + generate_manager_operation + ?source + generate_sc_rollup_execute_outbox_message + | `KSc_rollup_recover_bond -> + generate_manager_operation ?source generate_sc_rollup_recover_bond + | `KSc_rollup_dal_slot_subscribe -> + generate_manager_operation ?source generate_sc_rollup_dal_slot_subscribe + +let generate_manager_operation batch_size = + let open QCheck2.Gen in + let* source = random_pkh in + let source = Some source in + let* l = + flatten_l (Stdlib.List.init batch_size (fun _ -> oneofl manager_kinds)) + in + let* packed_manager_ops = flatten_l (List.map (generator_of ?source) l) in let first_op = Stdlib.List.hd packed_manager_ops in let unpacked_operations = List.map @@ -916,30 +821,29 @@ let generate_manager_operation batch_size random_state = | Operation_data {signature; _} -> signature in let protocol_data = {contents = contents_list; signature} in - Operation.pack {shell = first_op.shell; protocol_data} + return (Operation.pack {shell = first_op.shell; protocol_data}) -let generate_operation random_state = - let pass = choose_list_element random_state all_passes in - let kind = choose_list_element random_state (pass_to_operation_kinds pass) in - let packed_operation = +let generate_operation = + let open QCheck2.Gen in + let* pass = oneofl all_passes in + let* kind = oneofl (pass_to_operation_kinds pass) in + let+ packed_operation = match kind with - | `KPreendorsement -> generate_preendorsement random_state |> Operation.pack - | `KEndorsement -> generate_endorsement random_state |> Operation.pack - | `KDal_slot -> generate_dal_slot random_state |> Operation.pack + | `KPreendorsement -> generate_operation generate_preendorsement + | `KEndorsement -> generate_operation generate_endorsement + | `KDal_slot -> generate_operation generate_dal_slot | `KSeed_nonce_revelation -> - generate_seed_nonce_revelation random_state |> Operation.pack - | `KVdf_revelation -> generate_vdf_revelation random_state |> Operation.pack - | `KDouble_endorsement -> - generate_double_endorsement random_state |> Operation.pack + generate_operation generate_seed_nonce_revelation + | `KVdf_revelation -> generate_operation generate_vdf_revelation + | `KDouble_endorsement -> generate_operation generate_double_endorsement | `KDouble_preendorsement -> - generate_double_preendorsement random_state |> Operation.pack - | `KDouble_baking -> generate_double_baking random_state |> Operation.pack - | `KActivate_account -> - generate_activate_account random_state |> Operation.pack - | `KProposals -> generate_proposals random_state |> Operation.pack - | `KBallot -> generate_ballot random_state |> Operation.pack + generate_operation generate_double_preendorsement + | `KDouble_baking -> generate_operation generate_double_baking + | `KActivate_account -> generate_operation generate_activate_account + | `KProposals -> generate_operation generate_proposals + | `KBallot -> generate_operation generate_ballot | `KManager -> - let batch_size = 1 + Random.int random_state.rnd_state 3 in - generate_manager_operation batch_size random_state + let* batch_size = int_range 1 49 in + generate_manager_operation batch_size in (kind, (Operation.hash_packed packed_operation, packed_operation)) diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/pbt/dune b/src/proto_015_PtLimaPt/lib_protocol/test/pbt/dune index 68e9a95af65c..c0cb94e0ba63 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/pbt/dune +++ b/src/proto_015_PtLimaPt/lib_protocol/test/pbt/dune @@ -15,7 +15,8 @@ test_sc_rollup_tick_repr test_sc_rollup_encoding test_carbonated_map - test_zk_rollup_encoding) + test_zk_rollup_encoding + test_compare_operations) (libraries tezos-base tezos-micheline @@ -104,6 +105,11 @@ (package tezos-protocol-015-PtLimaPt-tests) (action (run %{dep:./test_zk_rollup_encoding.exe}))) +(rule + (alias runtest) + (package tezos-protocol-015-PtLimaPt-tests) + (action (run %{dep:./test_compare_operations.exe}))) + (rule (alias runtest1) (action (run %{exe:liquidity_baking_pbt.exe}))) (rule (alias runtest1) (action (run %{exe:saturation_fuzzing.exe}))) @@ -129,3 +135,5 @@ (rule (alias runtest3) (action (run %{exe:test_carbonated_map.exe}))) (rule (alias runtest3) (action (run %{exe:test_zk_rollup_encoding.exe}))) + +(rule (alias runtest3) (action (run %{exe:test_compare_operations.exe}))) diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/unit/test_compare_operations.ml b/src/proto_015_PtLimaPt/lib_protocol/test/pbt/test_compare_operations.ml similarity index 60% rename from src/proto_015_PtLimaPt/lib_protocol/test/unit/test_compare_operations.ml rename to src/proto_015_PtLimaPt/lib_protocol/test/pbt/test_compare_operations.ml index 6f7fc26fca51..35610a11e525 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/unit/test_compare_operations.ml +++ b/src/proto_015_PtLimaPt/lib_protocol/test/pbt/test_compare_operations.ml @@ -26,17 +26,23 @@ (** Testing ------- Component: Protocol (Operation compare) - Invocation: dune exec src/proto_alpha/lib_protocol/test/unit/main.exe \ - -- test "\[Unit\] compare operations" + Invocation: dune exec \ + src/proto_015_PtLimaPt/lib_protocol/test/pbt/test_compare_operations.exe Subject: Valid operations Comparison *) open Protocol open Alpha_context open Operation_generator -open Lwt_result_syntax +open QCheck2 -let () = Stdlib.Random.self_init () +let lt = -1 + +let gt = 1 + +let eq = 0 + +let cmp_op op1 op2 res = Compare.Int.equal (Operation.compare op1 op2) res (** A strict order has an equality predicate that is symmetric, reflexive and transitive and an lt (and gt) predicates that is @@ -48,28 +54,22 @@ let () = Stdlib.Random.self_init () when Operation.compare x y = -1 and Operation.compare x y = -1; and that Operation.compare x y = - (Operation.compare y x) when differ from 0. *) -let eq_sym op1 op2 = - if Operation.compare op1 op2 = 0 then assert (Operation.compare op2 op1 = 0) +let eq_sym op1 op2 = if cmp_op op1 op2 eq then assert (cmp_op op2 op1 eq) -let eq_refl op = assert (Operation.compare op op = 0) +let eq_refl op = assert (cmp_op op op eq) let eq_trans op1 op2 op3 = - if Operation.compare op1 op2 = 0 && Operation.compare op2 op3 = 0 then - assert (Operation.compare op1 op3 = 0) + if cmp_op op1 op2 eq && cmp_op op2 op3 eq then assert (cmp_op op1 op3 eq) -let lt_antisym op1 op2 = - if Operation.compare op1 op2 = -1 then assert (Operation.compare op2 op1 = 1) +let lt_antisym op1 op2 = if cmp_op op1 op2 lt then assert (cmp_op op2 op1 gt) let lt_trans op1 op2 op3 = - if Operation.compare op1 op2 = -1 && Operation.compare op2 op3 = -1 then - assert (Operation.compare op1 op3 = -1) + if cmp_op op1 op2 lt && cmp_op op2 op3 lt then assert (cmp_op op1 op3 lt) let gt_trans op1 op2 op3 = - if Operation.compare op1 op2 = 1 && Operation.compare op2 op3 = 1 then - assert (Operation.compare op1 op3 = 1) + if cmp_op op1 op2 gt && cmp_op op2 op3 gt then assert (cmp_op op1 op3 gt) -let gt_antisym op1 op2 = - if Operation.compare op1 op2 = 1 then assert (Operation.compare op2 op1 = -1) +let gt_antisym op1 op2 = if cmp_op op1 op2 gt then assert (cmp_op op2 op1 lt) (** Testing that Operation.compare is a strict order on operations. *) let strorder op1 op2 op3 = @@ -81,40 +81,21 @@ let strorder op1 op2 op3 = gt_trans op1 op2 op3 ; gt_antisym op1 op2 -let run ?seed n = - assert (n >= 0) ; - let seed = - match seed with Some s -> s | None -> Stdlib.Random.int (1 lsl 29) - in - Format.printf "Starting fuzzing with seed: %d@." seed ; - let random_state = {seed; rnd_state = Random.make [|seed|]} in - let rec loop = function - | 0 -> () - | n' -> - (try - let k1, op1 = generate_operation random_state in - let k2, op2 = generate_operation random_state in - let k3, op3 = generate_operation random_state in - try strorder op1 op2 op3 - with exn -> - Format.eprintf - "%a vs. %a vs. %a@." - pp_kind - k1 - pp_kind - k2 - pp_kind - k3 ; - raise exn - with Failure _ -> ()) ; - loop (pred n') - in - loop n - -let test_compare () = - run 1_000_000 ; - return_unit - -let tests = - Tztest. - [tztest "Compare operations is a strict total order." `Slow test_compare] +let test_compare_is_strorder = + Test.make + ~name:"Compare operations is a strict total order" + (Gen.triple generate_operation generate_operation generate_operation) + (fun ((k1, op1), (k2, op2), (k3, op3)) -> + try + strorder op1 op2 op3 ; + true + with exn -> + Format.eprintf "%a vs. %a vs. %a@." pp_kind k1 pp_kind k2 pp_kind k3 ; + raise exn) + +let tests = [test_compare_is_strorder] + +let () = + Alcotest.run + "Compare operations" + [("Compare_operations", Lib_test.Qcheck2_helpers.qcheck_wrap tests)] diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/unit/main.ml b/src/proto_015_PtLimaPt/lib_protocol/test/unit/main.ml index b79bb9239518..b6bbb3489739 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/unit/main.ml +++ b/src/proto_015_PtLimaPt/lib_protocol/test/unit/main.ml @@ -83,7 +83,6 @@ let () = Test_sc_rollup_management_protocol.tests; Unit_test.spec "Bond_id_repr.ml" Test_bond_id_repr.tests; Unit_test.spec "zk rollup storage" Test_zk_rollup_storage.tests; - Unit_test.spec "compare operations" Test_compare_operations.tests; Unit_test.spec "Delegate_consensus_key.ml" Test_consensus_key.tests; ] |> Lwt_main.run diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index c0496c62d1bd..3edb2b9998d9 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -99,6 +99,10 @@ module Slot : sig module Map : Map.S with type key = t module Set : Set.S with type elt = t + + module Internal_for_tests : sig + val of_int : int -> t tzresult + end end (** This module re-exports definitions from {!Tez_repr}. *) diff --git a/src/proto_alpha/lib_protocol/slot_repr.ml b/src/proto_alpha/lib_protocol/slot_repr.ml index 4cb7219bfedc..9e72811663ce 100644 --- a/src/proto_alpha/lib_protocol/slot_repr.ml +++ b/src/proto_alpha/lib_protocol/slot_repr.ml @@ -104,3 +104,7 @@ module Range = struct in f init hi >>=? fun acc -> loop ~acc ~next:(hi - 1) end + +module Internal_for_tests = struct + let of_int = of_int +end diff --git a/src/proto_alpha/lib_protocol/slot_repr.mli b/src/proto_alpha/lib_protocol/slot_repr.mli index cccc2cf43130..27b574b4f2ac 100644 --- a/src/proto_alpha/lib_protocol/slot_repr.mli +++ b/src/proto_alpha/lib_protocol/slot_repr.mli @@ -115,3 +115,7 @@ module Range : sig val rev_fold_es : ('a -> slot -> 'a tzresult Lwt.t) -> 'a -> t -> 'a tzresult Lwt.t end + +module Internal_for_tests : sig + val of_int : int -> t tzresult +end diff --git a/src/proto_alpha/lib_protocol/test/helpers/operation_generator.ml b/src/proto_alpha/lib_protocol/test/helpers/operation_generator.ml index 6a995b2927dc..dfc2b0e17206 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/operation_generator.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/operation_generator.ml @@ -23,14 +23,19 @@ (* *) (*****************************************************************************) +(** These generators aims at generating operations which are not + necessary correct. The goal is to tests functions such as {! + Operation.compare} with as much as possible parameters that play a + role in operation [weight] computation. + + When adding a new operation, one should also add its weight + computation, hence knows which kind of generator should be provided + for this new operation.*) + open Protocol open Alpha_context -module Random = Random.State - -type random_state = {seed : int; rnd_state : Random.t} -let choose_list_element random_state l = - Stdlib.List.nth l (Random.int random_state.rnd_state (List.length l)) +(** {2 Operations kind labelling.} *) let consensus_pass = `PConsensus @@ -111,6 +116,10 @@ let pp_kind fmt k = | `KBallot -> "KBallot" | `KManager -> "KManager") +(** {2 Generators} *) + +(** {3 Selection in hashes list} *) + let block_hashes = List.map Block_hash.of_b58check_exn @@ -120,24 +129,6 @@ let block_hashes = "BLuurCvGmNPTzXSnGCpcFPy5h8A49PwH2LnfAWBnp5R1qv5czwe"; ] -let random_shell random_state : Tezos_base.Operation.shell_header = - {branch = choose_list_element random_state block_hashes} - -let random_slot random_state = - choose_list_element random_state [100; 200; 300] - |> Slot.of_int_do_not_use_except_for_parameters - -let random_level random_state = - choose_list_element random_state [10l; 20l; 30l] |> Raw_level.of_int32 - |> function - | Ok v -> v - | Error _ -> assert false - -let random_round random_state = - choose_list_element random_state [0l; 1l; 2l] |> Round.of_int32 |> function - | Ok v -> v - | Error _ -> assert false - let payload_hashes = List.map Block_payload_hash.of_b58check_exn @@ -147,15 +138,7 @@ let payload_hashes = "vh2TyrWeZ2dydEy9ZjmvrjQvyCs5sdHZPypcZrXDUSM1tNuPermf"; ] -let random_payload_hash random_state = - choose_list_element random_state payload_hashes - -let generate_consensus_content random_state : consensus_content = - let slot = random_slot random_state in - let level = random_level random_state in - let round = random_round random_state in - let block_payload_hash = random_payload_hash random_state in - {slot; level; round; block_payload_hash} +let random_payload_hash = QCheck2.Gen.oneofl payload_hashes let signatures = List.map @@ -166,8 +149,7 @@ let signatures = "sighje7pEbUUwGtJ4GTP7uzMZe5SFz6dRRC3BvZBHnrRHnc47WHGnVdfiscHPMek7esmj7saTuj54QBWy3SezyA2EGbHkmW5"; ] -let random_signature random_state = - Some (choose_list_element random_state signatures) +let random_signature = QCheck2.Gen.oneofl signatures let pkhs = List.map @@ -178,7 +160,7 @@ let pkhs = "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU"; ] -let random_pkh random_state = choose_list_element random_state pkhs +let random_pkh = QCheck2.Gen.oneofl pkhs let pks = List.map @@ -189,16 +171,7 @@ let pks = "edpkuFrRoDSEbJYgxRtLx2ps82UdaYc1WwfS9sE11yhauZt5DgCHbU"; ] -let random_pk random_state = choose_list_element random_state pks - -let random_fee random_state = - choose_list_element random_state [Tez.zero; Tez.one_cent; Tez.one] - -let random_amount random_state = - choose_list_element random_state [Tez.zero; Tez.one_cent; Tez.one] - -let random_amount_in_bytes random_state = - choose_list_element random_state [Z.zero; Z.one; Z.of_int 100] +let random_pk = QCheck2.Gen.oneofl pks let contract_hashes = List.map @@ -209,30 +182,7 @@ let contract_hashes = "KT1RJ6PbjHpwc3M5rw5s2Nbmefwbuwbdxton"; ] -let random_contract_hash random_state = - choose_list_element random_state contract_hashes - -let random_contract random_state = - if Random.bool random_state.rnd_state then - Contract.Implicit (random_pkh random_state) - else - let contract_hash = random_contract_hash random_state in - Contract.Originated contract_hash - -let random_contract_hash random_state = - choose_list_element random_state contract_hashes - -let counters = List.map Z.of_int [123; 456; 789] - -let random_counter random_state = choose_list_element random_state counters - -let random_gas_limit random_state = - choose_list_element - random_state - Gas.Arith.[zero; integral_of_int_exn 1_000; integral_of_int_exn 10_000] - -let random_storage_limit random_state = - choose_list_element random_state Z.[zero; of_int 1_000; of_int 10_000] +let random_contract_hash = QCheck2.Gen.oneofl contract_hashes let block_headers = let bh1 = @@ -252,23 +202,7 @@ let block_headers = | Error _ -> assert false) [bh1; bh2; bh3] -let random_block_header random_state = - choose_list_element random_state block_headers - -let nonces = - List.map - (fun i -> - let b = Bytes.create 32 in - Bytes.set_int8 b 0 i ; - Alpha_context.Nonce.of_bytes b |> function - | Ok v -> v - | Error _ -> assert false) - [1; 2; 3] - -let random_nonce random_state = choose_list_element random_state nonces - -let random_option f random_state = - if Random.bool random_state.rnd_state then Some (f random_state) else None +let random_block_header = QCheck2.Gen.oneofl block_headers let tx_rollups = List.filter_map @@ -279,7 +213,7 @@ let tx_rollups = "txr1TAFTENC2YACvoMDrpJHCbdvdfSSjcjEjc"; ] -let random_tx_rollup random_state = choose_list_element random_state tx_rollups +let random_tx_rollup = QCheck2.Gen.oneofl tx_rollups let sc_rollups = List.map @@ -290,7 +224,7 @@ let sc_rollups = "scr1Kqqbvust2adJMtSu2V4fcd49oQHug4BLb"; ] -let random_sc_rollup random_state = choose_list_element random_state sc_rollups +let random_sc_rollup = QCheck2.Gen.oneofl sc_rollups let protos = List.map @@ -319,44 +253,103 @@ let protos = "ProtoALphaALphaALphaALphaALphaALphaALpha841f2cQqajX"; ] -let random_proto random_state = choose_list_element random_state protos +let random_proto = QCheck2.Gen.oneofl protos -let generate_op random_state (gen_op : random_state -> 'kind contents_list) : - 'kind operation = - let shell = random_shell random_state in - let signature = random_signature random_state in - let contents = gen_op random_state in - let protocol_data = {contents; signature} in - {shell; protocol_data} +let codes = + List.filter_map + Blinded_public_key_hash.activation_code_of_hex + [ + "41f98b15efc63fa893d61d7d6eee4a2ce9427ac4"; + "411dfef031eeecc506de71c9df9f8e44297cf5ba"; + "08d7d355bc3391d12d140780b39717d9f46fcf87"; + ] -let generate_preendorsement random_state = - let gen random_state = - Single (Preendorsement (generate_consensus_content random_state)) - in - generate_op random_state gen +let random_code = QCheck2.Gen.oneofl codes -let generate_endorsement random_state : Kind.endorsement Operation.t = - let gen random_state = - Single (Endorsement (generate_consensus_content random_state)) - in - generate_op random_state gen +(** {2 Operations parameters generators} *) -let generate_dal_slot random_state : Kind.dal_slot_availability Operation.t = - let gen random_state = - let pkh = random_pkh random_state in - let dal_endorsement = Dal.Endorsement.empty in - Single (Dal_slot_availability (pkh, dal_endorsement)) - in - generate_op random_state gen - -let generate_seed_nonce_revelation random_state : - Kind.seed_nonce_revelation Operation.t = - let gen random_state = - let level = random_level random_state in - let nonce = random_nonce random_state in - Single (Seed_nonce_revelation {level; nonce}) - in - generate_op random_state gen +let random_shell : Tezos_base.Operation.shell_header QCheck2.Gen.t = + let open QCheck2.Gen in + let+ branch = oneofl block_hashes in + Tezos_base.Operation.{branch} + +let gen_slot = + let open QCheck2.Gen in + let+ i = small_nat in + match Slot.Internal_for_tests.of_int i with + | Ok slot -> slot + | Error _ -> assert false + +let gen_level = + let open QCheck2.Gen in + let+ i = ui32 in + match Raw_level.of_int32 i with Ok v -> v | Error _ -> assert false + +let gen_round = + let open QCheck2.Gen in + let+ i = ui32 in + match Round.of_int32 i with Ok v -> v | Error _ -> assert false + +let generate_consensus_content : consensus_content QCheck2.Gen.t = + let open QCheck2.Gen in + let* slot = gen_slot in + let* level = gen_level in + let* round = gen_round in + let+ block_payload_hash = random_payload_hash in + {slot; level; round; block_payload_hash} + +let gen_tez = + let open QCheck2.Gen in + let+ i = ui64 in + match Tez.of_mutez i with None -> Tez.zero | Some v -> v + +let gen_fee = gen_tez + +let gen_amount = gen_tez + +let gen_amount_in_bytes = + let open QCheck2.Gen in + let+ i = nat in + Z.of_int i + +let random_contract = + let open QCheck2.Gen in + let* b = bool in + if b then + let+ pkh = random_pkh in + Contract.Implicit pkh + else + let+ contract_hash = random_contract_hash in + Contract.Originated contract_hash + +let random_contract_hash = QCheck2.Gen.oneofl contract_hashes + +let gen_counters = + let open QCheck2.Gen in + let+ i = nat in + Z.of_int i + +let gen_gas_limit = + let open QCheck2.Gen in + let+ i = nat in + Gas.Arith.integral_of_int_exn i + +let gen_storage_limit = + let open QCheck2.Gen in + let+ i = nat in + Z.of_int i + +let nonces = + List.map + (fun i -> + let b = Bytes.create 32 in + Bytes.set_int8 b 0 i ; + Alpha_context.Nonce.of_bytes b |> function + | Ok v -> v + | Error _ -> assert false) + [1; 2; 3] + +let random_nonce = QCheck2.Gen.oneofl nonces let vdf_solutions = let open Environment.Vdf in @@ -370,332 +363,310 @@ let vdf_solutions = (result, proof)) [1; 2; 3] -let random_vdf_solution random_state = - choose_list_element random_state vdf_solutions +(** {2 Generators for each Operation Kind} *) -let generate_vdf_revelation random_state : Kind.vdf_revelation Operation.t = - let gen random_state = - let solution = random_vdf_solution random_state in - Single (Vdf_revelation {solution}) - in - generate_op random_state gen - -let generate_double_preendorsement random_state : - Kind.double_preendorsement_evidence Operation.t = - let gen random_state = - let op1 = generate_preendorsement random_state in - let op2 = generate_preendorsement random_state in - Single (Double_preendorsement_evidence {op1; op2}) - in - generate_op random_state gen - -let generate_double_endorsement random_state : - Kind.double_endorsement_evidence Operation.t = - let gen random_state = - let op1 = generate_endorsement random_state in - let op2 = generate_endorsement random_state in - Single (Double_endorsement_evidence {op1; op2}) - in - generate_op random_state gen - -let generate_double_baking random_state : - Kind.double_baking_evidence Operation.t = - let gen random_state = - let bh1 = random_block_header random_state in - let bh2 = random_block_header random_state in - Single (Double_baking_evidence {bh1; bh2}) - in - generate_op random_state gen - -let generate_manager_aux : - type kind. - public_key_hash option -> - random_state -> - (random_state -> kind manager_operation) -> - kind Kind.manager contents = - fun opt_source random_state gen_op -> - let source = - match opt_source with - | None -> random_pkh random_state - | Some source -> source - in - let fee = random_fee random_state in - let counter = random_counter random_state in - let operation = gen_op random_state in - let gas_limit = random_gas_limit random_state in - let storage_limit = random_storage_limit random_state in - Manager_operation {source; fee; counter; operation; gas_limit; storage_limit} +let wrap_operation sh (pdata : 'kind protocol_data) : 'kind operation = + {shell = sh; protocol_data = pdata} -let generate_manager random_state - (gen_op : random_state -> 'kind manager_operation) : - 'kind Kind.manager Operation.t = - let source = Some (random_pkh random_state) in - let shell = random_shell random_state in - let signature = random_signature random_state in - let contents = Single (generate_manager_aux source random_state gen_op) in +let generate_op (gen_op : 'kind contents QCheck2.Gen.t) : + 'kind operation QCheck2.Gen.t = + let open QCheck2.Gen in + let* op = gen_op in + let* signature = random_signature in + let+ shell = random_shell in + let contents = Single op in + let signature = Some signature in let protocol_data = {contents; signature} in - {shell; protocol_data} - -let generate_managers random_state gen_ops = - let source = Some (random_pkh random_state) in - let ops_as_single = - List.map - (fun gen_op -> Contents (generate_manager_aux source random_state gen_op)) - gen_ops - in - Operation.of_list ops_as_single - -let generate_reveal random_state : Kind.reveal Kind.manager Operation.t = - let gen random_state = Reveal (random_pk random_state) in - generate_manager random_state gen - -let generate_transaction random_state = - let gen_trans random_state = - let amount = random_amount random_state in - let parameters = Script.unit_parameter in - let entrypoint = Entrypoint.default in - let destination = random_contract random_state in - Transaction {amount; parameters; entrypoint; destination} - in - generate_manager random_state gen_trans - -let generate_origination random_state : - Kind.origination Kind.manager Operation.t = - let gen_origination random_state = - let delegate = None in - let script = Script.{code = unit_parameter; storage = unit_parameter} in - let credit = random_amount random_state in - Origination {delegate; script; credit} - in - generate_manager random_state gen_origination - -let generate_delegation random_state : Kind.delegation Kind.manager Operation.t - = - let gen_delegation random_state = - let delegate = random_option random_pkh random_state in - Delegation delegate - in - generate_manager random_state gen_delegation + wrap_operation shell protocol_data + +let generate_operation gen_op = + let open QCheck2.Gen in + let+ op = generate_op gen_op in + Operation.pack op + +let generate_preendorsement = + let open QCheck2.Gen in + let+ cc = generate_consensus_content in + Preendorsement cc + +let generate_endorsement = + let open QCheck2.Gen in + let+ cc = generate_consensus_content in + Endorsement cc + +let generate_dal_slot = + let open QCheck2.Gen in + let+ pkh = random_pkh in + Dal_slot_availability (pkh, Dal.Endorsement.empty) + +let generate_vdf_revelation = + let open QCheck2.Gen in + let+ solution = oneofl vdf_solutions in + Vdf_revelation {solution} + +let generate_seed_nonce_revelation = + let open QCheck2.Gen in + let* level = gen_level in + let+ nonce = random_nonce in + Seed_nonce_revelation {level; nonce} + +let generate_double_preendorsement = + let open QCheck2.Gen in + let* op1 = generate_op generate_preendorsement in + let+ op2 = generate_op generate_preendorsement in + Double_preendorsement_evidence {op1; op2} + +let generate_double_endorsement = + let open QCheck2.Gen in + let* op1 = generate_op generate_endorsement in + let+ op2 = generate_op generate_endorsement in + Double_endorsement_evidence {op1; op2} + +let generate_double_baking = + let open QCheck2.Gen in + let* bh1 = random_block_header in + let+ bh2 = random_block_header in + Double_baking_evidence {bh1; bh2} + +let generate_activate_account = + let open QCheck2.Gen in + let* activation_code = random_code in + let+ id = random_pkh in + let id = match id with Signature.Ed25519 pkh -> pkh | _ -> assert false in + Activate_account {id; activation_code} + +let random_period = + let open QCheck2.Gen in + let+ i = ui32 in + i + +let generate_proposals = + let open QCheck2.Gen in + let* source = random_pkh in + let+ period = random_period in + let proposals = [] in + Proposals {source; period; proposals} + +let generate_ballot = + let open QCheck2.Gen in + let* source = random_pkh in + let* period = random_period in + let+ proposal = random_proto in + let ballot = Vote.Pass in + Ballot {source; period; proposal; ballot} + +let generate_manager_aux ?source gen_manop = + let open QCheck2.Gen in + let* source = + match source with None -> random_pkh | Some source -> return source + in + let* fee = gen_fee in + let* counter = gen_counters in + let* gas_limit = gen_gas_limit in + let* storage_limit = gen_storage_limit in + let+ operation = gen_manop in + Manager_operation {source; fee; counter; operation; gas_limit; storage_limit} -let generate_set_deposits_limit random_state : - Kind.set_deposits_limit Kind.manager Operation.t = - let gen_set_deposits_limit random_state = - let amount_opt = random_option random_amount random_state in - Set_deposits_limit amount_opt - in - generate_manager random_state gen_set_deposits_limit - -let generate_increase_paid_storage random_state : - Kind.increase_paid_storage Kind.manager Operation.t = - let gen_increase_paid_storage random_state = - let amount_in_bytes = random_amount_in_bytes random_state in - let destination = random_contract_hash random_state in - Increase_paid_storage {amount_in_bytes; destination} +let generate_manager ?source gen_manop = + generate_op (generate_manager_aux ?source gen_manop) + +let generate_manager_operation ?source gen_manop = + let open QCheck2.Gen in + let+ manop = generate_manager ?source gen_manop in + Operation.pack manop + +let generate_reveal = + let open QCheck2.Gen in + let+ pk = random_pk in + Reveal pk + +let generate_transaction = + let open QCheck2.Gen in + let* amount = gen_amount in + let+ destination = random_contract in + let parameters = Script.unit_parameter in + let entrypoint = Entrypoint.default in + Transaction {amount; parameters; entrypoint; destination} + +let generate_origination = + let open QCheck2.Gen in + let+ credit = gen_amount in + let delegate = None in + let script = Script.{code = unit_parameter; storage = unit_parameter} in + Origination {delegate; script; credit} + +let generate_delegation = + let open QCheck2.Gen in + let+ delegate = option random_pkh in + Delegation delegate + +let generate_increase_paid_storage = + let open QCheck2.Gen in + let* amount_in_bytes = gen_amount_in_bytes in + let+ destination = random_contract_hash in + Increase_paid_storage {amount_in_bytes; destination} + +let generate_set_deposits_limit = + let open QCheck2.Gen in + let+ amount_opt = option gen_amount in + Set_deposits_limit amount_opt + +let generate_register_global_constant = + let value = Script_repr.lazy_expr (Expr.from_string "Pair 1 2") in + QCheck2.Gen.pure (Register_global_constant {value}) + +let generate_tx_rollup_origination = QCheck2.Gen.pure Tx_rollup_origination + +let generate_tx_rollup_submit_batch = + let open QCheck2.Gen in + let+ tx_rollup = random_tx_rollup in + let content = "batch" in + let burn_limit = None in + Tx_rollup_submit_batch {tx_rollup; content; burn_limit} + +let generate_tx_rollup_commit = + let open QCheck2.Gen in + let+ tx_rollup = random_tx_rollup in + let commitment : Tx_rollup_commitment.Full.t = + { + level = Tx_rollup_level.root; + messages = []; + predecessor = None; + inbox_merkle_root = Tx_rollup_inbox.Merkle.merklize_list []; + } in - generate_manager random_state gen_increase_paid_storage - -let generate_register_global_constant random_state : - Kind.register_global_constant Kind.manager Operation.t = - let gen_register_global_constant _ = - let value = Script_repr.lazy_expr (Expr.from_string "Pair 1 2") in - Register_global_constant {value} + Tx_rollup_commit {tx_rollup; commitment} + +let generate_tx_rollup_return_bond = + let open QCheck2.Gen in + let+ tx_rollup = random_tx_rollup in + Tx_rollup_return_bond {tx_rollup} + +let generate_tx_finalize_commitment = + let open QCheck2.Gen in + let+ tx_rollup = random_tx_rollup in + Tx_rollup_finalize_commitment {tx_rollup} + +let generate_tx_rollup_remove_commitment = + let open QCheck2.Gen in + let+ tx_rollup = random_tx_rollup in + Tx_rollup_remove_commitment {tx_rollup} + +let generate_tx_rollup_rejection = + let open QCheck2.Gen in + let+ tx_rollup = random_tx_rollup in + let message, _ = Tx_rollup_message.make_batch "" in + let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in + let message_path = + match Tx_rollup_inbox.Merkle.compute_path [message_hash] 0 with + | Ok message_path -> message_path + | _ -> raise (Invalid_argument "Single_message_inbox.message_path") + in + let proof : Tx_rollup_l2_proof.t = + { + version = 1; + before = `Value Tx_rollup_message_result.empty_l2_context_hash; + after = `Value Context_hash.zero; + state = Seq.empty; + } in - generate_manager random_state gen_register_global_constant - -let generate_tx_rollup_origination random_state : - Kind.tx_rollup_origination Kind.manager Operation.t = - let gen_tx_orig _ = Tx_rollup_origination in - generate_manager random_state gen_tx_orig - -let generate_tx_rollup_submit_batch random_state : - Kind.tx_rollup_submit_batch Kind.manager Operation.t = - let gen_tx_submit random_state = - let tx_rollup = random_tx_rollup random_state in - let content = "batch" in - let burn_limit = None in - Tx_rollup_submit_batch {tx_rollup; content; burn_limit} + 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 - generate_manager random_state gen_tx_submit + let level = Tx_rollup_level.root in + let message_result_hash = Tx_rollup_message_result_hash.zero in + let message_result_path = Tx_rollup_commitment.Merkle.dummy_path in + let previous_message_result_path = Tx_rollup_commitment.Merkle.dummy_path in + let message_position = 0 in + let proof = Tx_rollup_l2_proof.serialize_proof_exn proof in + Tx_rollup_rejection + { + tx_rollup; + level; + message; + message_position; + message_path; + message_result_hash; + message_result_path; + previous_message_result; + previous_message_result_path; + proof; + } -let generate_tx_rollup_commit random_state : - Kind.tx_rollup_commit Kind.manager Operation.t = - let gen_tx_commit random_state = - let tx_rollup = random_tx_rollup random_state in - let commitment : Tx_rollup_commitment.Full.t = +let generate_tx_dispatch_tickets = + let open QCheck2.Gen in + let* tx_rollup = random_tx_rollup in + let* source = random_pkh in + let+ contract = random_contract in + let level = Tx_rollup_level.root in + let message_index = 0 in + let message_result_path = Tx_rollup_commitment.Merkle.dummy_path in + let context_hash = Context_hash.zero in + let reveal = + Tx_rollup_reveal. { - level = Tx_rollup_level.root; - messages = []; - predecessor = None; - inbox_merkle_root = Tx_rollup_inbox.Merkle.merklize_list []; + contents = Script.lazy_expr (Expr.from_string "1"); + ty = Script.lazy_expr (Expr.from_string "nat"); + ticketer = contract; + amount = Tx_rollup_l2_qty.of_int64_exn 10L; + claimer = source; } - in - Tx_rollup_commit {tx_rollup; commitment} - in - generate_manager random_state gen_tx_commit - -let generate_tx_rollup_return_bond random_state : - Kind.tx_rollup_return_bond Kind.manager Operation.t = - let gen_tx_return_bd random_state = - let tx_rollup = random_tx_rollup random_state in - Tx_rollup_return_bond {tx_rollup} - in - generate_manager random_state gen_tx_return_bd - -let generate_tx_finalize_commitment random_state : - Kind.tx_rollup_finalize_commitment Kind.manager Operation.t = - let gen_tx_finalize random_state = - let tx_rollup = random_tx_rollup random_state in - Tx_rollup_finalize_commitment {tx_rollup} in - generate_manager random_state gen_tx_finalize + let tickets_info = [reveal] in + Tx_rollup_dispatch_tickets + { + tx_rollup; + level; + context_hash; + message_index; + message_result_path; + tickets_info; + } -let generate_tx_rollup_remove_commitment random_state : - Kind.tx_rollup_remove_commitment Kind.manager Operation.t = - let gen_tx_remove random_state = - let tx_rollup = random_tx_rollup random_state in - Tx_rollup_remove_commitment {tx_rollup} - in - generate_manager random_state gen_tx_remove - -let generate_tx_rollup_rejection random_state : - Kind.tx_rollup_rejection Kind.manager Operation.t = - let gen_tx_rejection random_state = - let tx_rollup = random_tx_rollup random_state in - let message, _ = Tx_rollup_message.make_batch "" in - let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in - let message_path = - match Tx_rollup_inbox.Merkle.compute_path [message_hash] 0 with - | Ok message_path -> message_path - | _ -> raise (Invalid_argument "Single_message_inbox.message_path") - in - let proof : Tx_rollup_l2_proof.t = - { - version = 1; - before = `Value Tx_rollup_message_result.empty_l2_context_hash; - after = `Value Context_hash.zero; - state = Seq.empty; - } - in - let previous_message_result : Tx_rollup_message_result.t = - { - context_hash = Tx_rollup_message_result.empty_l2_context_hash; - withdraw_list_hash = Tx_rollup_withdraw_list_hash.empty; - } - in - let level = Tx_rollup_level.root in - let message_result_hash = Tx_rollup_message_result_hash.zero in - let message_result_path = Tx_rollup_commitment.Merkle.dummy_path in - let previous_message_result_path = Tx_rollup_commitment.Merkle.dummy_path in - let message_position = 0 in - let proof = Tx_rollup_l2_proof.serialize_proof_exn proof in - Tx_rollup_rejection - { - tx_rollup; - level; - message; - message_position; - message_path; - message_result_hash; - message_result_path; - previous_message_result; - previous_message_result_path; - proof; - } - in - generate_manager random_state gen_tx_rejection - -let generate_tx_dispatch_tickets random_state : - Kind.tx_rollup_dispatch_tickets Kind.manager Operation.t = - let gen_tx_dispatch random_state = - let tx_rollup = random_tx_rollup random_state in - let source = random_pkh random_state in - let contract = random_contract random_state in - let level = Tx_rollup_level.root in - let message_index = 0 in - let message_result_path = Tx_rollup_commitment.Merkle.dummy_path in - let context_hash = Context_hash.zero in - let reveal = - Tx_rollup_reveal. - { - contents = Script.lazy_expr (Expr.from_string "1"); - ty = Script.lazy_expr (Expr.from_string "nat"); - ticketer = contract; - amount = Tx_rollup_l2_qty.of_int64_exn 10L; - claimer = source; - } - in - let tickets_info = [reveal] in - Tx_rollup_dispatch_tickets - { - tx_rollup; - level; - context_hash; - message_index; - message_result_path; - tickets_info; - } - in - generate_manager random_state gen_tx_dispatch - -let generate_transfer_ticket random_state : - Kind.transfer_ticket Kind.manager Operation.t = - let gen_transfer_ticket random_state = - let contents = Script.lazy_expr (Expr.from_string "1") in - let ty = Script.lazy_expr (Expr.from_string "nat") in - let ticketer = random_contract random_state in - let destination = random_contract random_state in - let amount = - WithExceptions.Option.get ~loc:__LOC__ - @@ Ticket_amount.of_n - @@ Script_int.( - add_n one_n - @@ Option.value ~default:zero_n - @@ is_nat @@ of_zint - @@ random_counter random_state) - in - let entrypoint = Entrypoint.default in - Transfer_ticket {contents; ty; ticketer; amount; destination; entrypoint} - in - generate_manager random_state gen_transfer_ticket - -let generate_dal_publish_slot_header random_state : - Kind.dal_publish_slot_header Kind.manager Operation.t = - let gen_dal_publish _ = - let published_level = Alpha_context.Raw_level.of_int32_exn Int32.zero in - let index = Alpha_context.Dal.Slot_index.zero in - let commitment = Alpha_context.Dal.Slot.Commitment.zero in - let slot_header = - Alpha_context.Dal.Slot.Header.{id = {published_level; index}; commitment} - in - Dal_publish_slot_header {slot_header} - in - generate_manager random_state gen_dal_publish - -let generate_sc_rollup_originate random_state : - Kind.sc_rollup_originate Kind.manager Operation.t = - let gen_sc_originate _ = - let kind = Sc_rollup.Kind.Example_arith in - let boot_sector = "" in - let parameters_ty = Script.lazy_expr (Expr.from_string "1") in - let origination_proof = - Lwt_main.run (Sc_rollup_helpers.origination_proof ~boot_sector kind) - in - let (module PVM) = Sc_rollup.wrapped_proof_module origination_proof in - let origination_proof = - Data_encoding.Binary.to_string_exn PVM.proof_encoding PVM.proof - in - Sc_rollup_originate {kind; boot_sector; origination_proof; parameters_ty} - in - generate_manager random_state gen_sc_originate - -let generate_sc_rollup_add_messages random_state : - Kind.sc_rollup_add_messages Kind.manager Operation.t = - let gen_sc_add_messages random_state = - let rollup = random_sc_rollup random_state in - let messages = [] in - Sc_rollup_add_messages {rollup; messages} - in - generate_manager random_state gen_sc_add_messages +let generate_transfer_ticket = + let open QCheck2.Gen in + let* ticketer = random_contract in + let* destination = random_contract in + let+ amount = gen_counters in + let amount = + Option.value (Ticket_amount.of_zint amount) ~default:Ticket_amount.one + in + let contents = Script.lazy_expr (Expr.from_string "1") in + let ty = Script.lazy_expr (Expr.from_string "nat") in + let entrypoint = Entrypoint.default in + Transfer_ticket {contents; ty; ticketer; amount; destination; entrypoint} + +let generate_dal_publish_slot_header = + let published_level = Alpha_context.Raw_level.of_int32_exn Int32.zero in + let index = Alpha_context.Dal.Slot_index.zero in + let commitment = Alpha_context.Dal.Slot.Commitment.zero in + let slot_header = + Alpha_context.Dal.Slot.Header.{id = {published_level; index}; commitment} + in + QCheck2.Gen.pure (Dal_publish_slot_header {slot_header}) + +let generate_sc_rollup_originate = + let kind = Sc_rollup.Kind.Example_arith in + let boot_sector = "" in + let parameters_ty = Script.lazy_expr (Expr.from_string "1") in + let origination_proof = + Lwt_main.run (Sc_rollup_helpers.origination_proof ~boot_sector kind) + in + let (module PVM) = Sc_rollup.wrapped_proof_module origination_proof in + let origination_proof = + Data_encoding.Binary.to_string_exn PVM.proof_encoding PVM.proof + in + QCheck2.Gen.pure + (Sc_rollup_originate {kind; boot_sector; origination_proof; parameters_ty}) + +let generate_sc_rollup_add_messages = + let open QCheck2.Gen in + let+ rollup = random_sc_rollup in + let messages = [] in + Sc_rollup_add_messages {rollup; messages} let sc_dummy_commitment = let number_of_ticks = @@ -711,181 +682,117 @@ let sc_dummy_commitment = compressed_state = Sc_rollup.State_hash.zero; } -let generate_sc_rollup_cement random_state : - Kind.sc_rollup_cement Kind.manager Operation.t = - let gen_sc_cement random_state = - let rollup = random_sc_rollup random_state in - let commitment = - Sc_rollup.Commitment.hash_uncarbonated sc_dummy_commitment - in - Sc_rollup_cement {rollup; commitment} - in - generate_manager random_state gen_sc_cement - -let generate_sc_rollup_publish random_state : - Kind.sc_rollup_publish Kind.manager Operation.t = - let gen_sc_publish random_state = - let rollup = random_sc_rollup random_state in - let commitment = sc_dummy_commitment in - Sc_rollup_publish {rollup; commitment} - in - generate_manager random_state gen_sc_publish - -let generate_sc_rollup_refute random_state : - Kind.sc_rollup_refute Kind.manager Operation.t = - let gen random_state = - let opponent = random_pkh random_state in - let rollup = random_sc_rollup random_state in - let refutation : Sc_rollup.Game.refutation option = - Some {choice = Sc_rollup.Tick.initial; step = Dissection []} - in - Sc_rollup_refute {rollup; opponent; refutation} - in - generate_manager random_state gen - -let generate_sc_rollup_timeout random_state : - Kind.sc_rollup_timeout Kind.manager Operation.t = - let gen random_state = - let source = random_pkh random_state in - let rollup = random_sc_rollup random_state in - let staker = random_pkh random_state in - let stakers = Sc_rollup.Game.Index.make source staker in - Sc_rollup_timeout {rollup; stakers} - in - generate_manager random_state gen - -let generate_sc_rollup_execute_outbox_message random_state : - Kind.sc_rollup_execute_outbox_message Kind.manager Operation.t = - let gen random_state = - let rollup = random_sc_rollup random_state in - let cemented_commitment = - Sc_rollup.Commitment.hash_uncarbonated sc_dummy_commitment - in - let output_proof = "" in - Sc_rollup_execute_outbox_message {rollup; cemented_commitment; output_proof} - in - generate_manager random_state gen - -let generate_sc_rollup_recover_bond random_state : - Kind.sc_rollup_recover_bond Kind.manager Operation.t = - let gen random_state = - let sc_rollup = random_sc_rollup random_state in - Sc_rollup_recover_bond {sc_rollup} - in - generate_manager random_state gen - -let generate_sc_rollup_dal_slot_subscribe random_state : - Kind.sc_rollup_dal_slot_subscribe Kind.manager Operation.t = - let gen random_state = - let rollup = random_sc_rollup random_state in - let slot_index = Alpha_context.Dal.Slot_index.zero in - Sc_rollup_dal_slot_subscribe {rollup; slot_index} - in - generate_manager random_state gen - -let codes = - List.filter_map - Blinded_public_key_hash.activation_code_of_hex - [ - "41f98b15efc63fa893d61d7d6eee4a2ce9427ac4"; - "411dfef031eeecc506de71c9df9f8e44297cf5ba"; - "08d7d355bc3391d12d140780b39717d9f46fcf87"; - ] - -let random_code random_state = choose_list_element random_state codes - -let generate_activate_account random_state : Kind.activate_account Operation.t = - let gen random_state = - let id = - random_pkh random_state |> function - | Ed25519 pkh -> pkh - | _ -> assert false - in - let activation_code = random_code random_state in - Single (Activate_account {id; activation_code}) - in - generate_op random_state gen - -let random_period random_state = choose_list_element random_state [0l; 1l; 2l] - -let generate_proposals random_state : Kind.proposals Operation.t = - let gen random_state = - let source = random_pkh random_state in - let period = random_period random_state in - let proposals = [] in - Single (Proposals {source; period; proposals}) - in - generate_op random_state gen - -let generate_ballot random_state : Kind.ballot Operation.t = - let gen random_state = - let source = random_pkh random_state in - let period = random_period random_state in - let proposal = random_proto random_state in - let ballot = Vote.Pass in - Single (Ballot {source; period; proposal; ballot}) - in - generate_op random_state gen - -let generate_manager_operation batch_size random_state = - let l = - Stdlib.List.init batch_size (fun _ -> - choose_list_element random_state manager_kinds) - in - let packed_manager_ops = - List.map - (function - | `KReveal -> generate_reveal random_state |> Operation.pack - | `KTransaction -> generate_transaction random_state |> Operation.pack - | `KOrigination -> generate_origination random_state |> Operation.pack - | `KSet_deposits_limit -> - generate_set_deposits_limit random_state |> Operation.pack - | `KIncrease_paid_storage -> - generate_increase_paid_storage random_state |> Operation.pack - | `KDelegation -> generate_delegation random_state |> Operation.pack - | `KRegister_global_constant -> - generate_register_global_constant random_state |> Operation.pack - | `KTx_rollup_origination -> - generate_tx_rollup_origination random_state |> Operation.pack - | `KTransfer_ticket -> - generate_transfer_ticket random_state |> Operation.pack - | `KDal_publish_slot_header -> - generate_dal_publish_slot_header random_state |> Operation.pack - | `KTx_rollup_submit_batch -> - generate_tx_rollup_submit_batch random_state |> Operation.pack - | `KTx_rollup_commit -> - generate_tx_rollup_commit random_state |> Operation.pack - | `KTx_rollup_return_bond -> - generate_tx_rollup_return_bond random_state |> Operation.pack - | `KTx_rollup_finalize_commitment -> - generate_tx_finalize_commitment random_state |> Operation.pack - | `KTx_rollup_remove_commitment -> - generate_tx_rollup_remove_commitment random_state |> Operation.pack - | `KTx_rollup_rejection -> - generate_tx_rollup_rejection random_state |> Operation.pack - | `KTx_rollup_dispatch_tickets -> - generate_tx_dispatch_tickets random_state |> Operation.pack - | `KSc_rollup_originate -> - generate_sc_rollup_originate random_state |> Operation.pack - | `KSc_rollup_add_messages -> - generate_sc_rollup_add_messages random_state |> Operation.pack - | `KSc_rollup_cement -> - generate_sc_rollup_cement random_state |> Operation.pack - | `KSc_rollup_publish -> - generate_sc_rollup_publish random_state |> Operation.pack - | `KSc_rollup_refute -> - generate_sc_rollup_refute random_state |> Operation.pack - | `KSc_rollup_timeout -> - generate_sc_rollup_timeout random_state |> Operation.pack - | `KSc_rollup_execute_outbox_message -> - generate_sc_rollup_execute_outbox_message random_state - |> Operation.pack - | `KSc_rollup_recover_bond -> - generate_sc_rollup_recover_bond random_state |> Operation.pack - | `KSc_rollup_dal_slot_subscribe -> - generate_sc_rollup_dal_slot_subscribe random_state |> Operation.pack) - l - in +let generate_sc_rollup_cement = + let open QCheck2.Gen in + let+ rollup = random_sc_rollup in + let commitment = Sc_rollup.Commitment.hash_uncarbonated sc_dummy_commitment in + Sc_rollup_cement {rollup; commitment} + +let generate_sc_rollup_publish = + let open QCheck2.Gen in + let+ rollup = random_sc_rollup in + let commitment = sc_dummy_commitment in + Sc_rollup_publish {rollup; commitment} + +let generate_sc_rollup_refute = + let open QCheck2.Gen in + let* opponent = random_pkh in + let+ rollup = random_sc_rollup in + let refutation : Sc_rollup.Game.refutation option = + Some {choice = Sc_rollup.Tick.initial; step = Dissection []} + in + Sc_rollup_refute {rollup; opponent; refutation} + +let generate_sc_rollup_timeout = + let open QCheck2.Gen in + let* source = random_pkh in + let* rollup = random_sc_rollup in + let+ staker = random_pkh in + let stakers = Sc_rollup.Game.Index.make source staker in + Sc_rollup_timeout {rollup; stakers} + +let generate_sc_rollup_execute_outbox_message = + let open QCheck2.Gen in + let+ rollup = random_sc_rollup in + let cemented_commitment = + Sc_rollup.Commitment.hash_uncarbonated sc_dummy_commitment + in + let output_proof = "" in + Sc_rollup_execute_outbox_message {rollup; cemented_commitment; output_proof} + +let generate_sc_rollup_recover_bond = + let open QCheck2.Gen in + let+ sc_rollup = random_sc_rollup in + Sc_rollup_recover_bond {sc_rollup} + +let generate_sc_rollup_dal_slot_subscribe = + let open QCheck2.Gen in + let+ rollup = random_sc_rollup in + let slot_index = Alpha_context.Dal.Slot_index.zero in + Sc_rollup_dal_slot_subscribe {rollup; slot_index} + +(** {By Kind Operation Generator} *) + +let generator_of ?source = function + | `KReveal -> generate_manager_operation ?source generate_reveal + | `KTransaction -> generate_manager_operation ?source generate_transaction + | `KOrigination -> generate_manager_operation ?source generate_origination + | `KSet_deposits_limit -> + generate_manager_operation ?source generate_set_deposits_limit + | `KIncrease_paid_storage -> + generate_manager_operation ?source generate_increase_paid_storage + | `KDelegation -> generate_manager_operation ?source generate_delegation + | `KRegister_global_constant -> + generate_manager_operation ?source generate_register_global_constant + | `KTx_rollup_origination -> + generate_manager_operation ?source generate_tx_rollup_origination + | `KTransfer_ticket -> + generate_manager_operation ?source generate_transfer_ticket + | `KDal_publish_slot_header -> + generate_manager_operation ?source generate_dal_publish_slot_header + | `KTx_rollup_submit_batch -> + generate_manager_operation ?source generate_tx_rollup_submit_batch + | `KTx_rollup_commit -> + generate_manager_operation ?source generate_tx_rollup_commit + | `KTx_rollup_return_bond -> + generate_manager_operation ?source generate_tx_rollup_return_bond + | `KTx_rollup_finalize_commitment -> + generate_manager_operation ?source generate_tx_finalize_commitment + | `KTx_rollup_remove_commitment -> + generate_manager_operation ?source generate_tx_rollup_remove_commitment + | `KTx_rollup_rejection -> + generate_manager_operation ?source generate_tx_rollup_rejection + | `KTx_rollup_dispatch_tickets -> + generate_manager_operation ?source generate_tx_dispatch_tickets + | `KSc_rollup_originate -> + generate_manager_operation ?source generate_sc_rollup_originate + | `KSc_rollup_add_messages -> + generate_manager_operation ?source generate_sc_rollup_add_messages + | `KSc_rollup_cement -> + generate_manager_operation ?source generate_sc_rollup_cement + | `KSc_rollup_publish -> + generate_manager_operation ?source generate_sc_rollup_publish + | `KSc_rollup_refute -> + generate_manager_operation ?source generate_sc_rollup_refute + | `KSc_rollup_timeout -> + generate_manager_operation ?source generate_sc_rollup_timeout + | `KSc_rollup_execute_outbox_message -> + generate_manager_operation + ?source + generate_sc_rollup_execute_outbox_message + | `KSc_rollup_recover_bond -> + generate_manager_operation ?source generate_sc_rollup_recover_bond + | `KSc_rollup_dal_slot_subscribe -> + generate_manager_operation ?source generate_sc_rollup_dal_slot_subscribe + +let generate_manager_operation batch_size = + let open QCheck2.Gen in + let* source = random_pkh in + let source = Some source in + let* l = + flatten_l (Stdlib.List.init batch_size (fun _ -> oneofl manager_kinds)) + in + let* packed_manager_ops = flatten_l (List.map (generator_of ?source) l) in let first_op = Stdlib.List.hd packed_manager_ops in let unpacked_operations = List.map @@ -918,30 +825,29 @@ let generate_manager_operation batch_size random_state = | Operation_data {signature; _} -> signature in let protocol_data = {contents = contents_list; signature} in - Operation.pack {shell = first_op.shell; protocol_data} + return (Operation.pack {shell = first_op.shell; protocol_data}) -let generate_operation random_state = - let pass = choose_list_element random_state all_passes in - let kind = choose_list_element random_state (pass_to_operation_kinds pass) in - let packed_operation = +let generate_operation = + let open QCheck2.Gen in + let* pass = oneofl all_passes in + let* kind = oneofl (pass_to_operation_kinds pass) in + let+ packed_operation = match kind with - | `KPreendorsement -> generate_preendorsement random_state |> Operation.pack - | `KEndorsement -> generate_endorsement random_state |> Operation.pack - | `KDal_slot -> generate_dal_slot random_state |> Operation.pack + | `KPreendorsement -> generate_operation generate_preendorsement + | `KEndorsement -> generate_operation generate_endorsement + | `KDal_slot -> generate_operation generate_dal_slot | `KSeed_nonce_revelation -> - generate_seed_nonce_revelation random_state |> Operation.pack - | `KVdf_revelation -> generate_vdf_revelation random_state |> Operation.pack - | `KDouble_endorsement -> - generate_double_endorsement random_state |> Operation.pack + generate_operation generate_seed_nonce_revelation + | `KVdf_revelation -> generate_operation generate_vdf_revelation + | `KDouble_endorsement -> generate_operation generate_double_endorsement | `KDouble_preendorsement -> - generate_double_preendorsement random_state |> Operation.pack - | `KDouble_baking -> generate_double_baking random_state |> Operation.pack - | `KActivate_account -> - generate_activate_account random_state |> Operation.pack - | `KProposals -> generate_proposals random_state |> Operation.pack - | `KBallot -> generate_ballot random_state |> Operation.pack + generate_operation generate_double_preendorsement + | `KDouble_baking -> generate_operation generate_double_baking + | `KActivate_account -> generate_operation generate_activate_account + | `KProposals -> generate_operation generate_proposals + | `KBallot -> generate_operation generate_ballot | `KManager -> - let batch_size = 1 + Random.int random_state.rnd_state 3 in - generate_manager_operation batch_size random_state + let* batch_size = int_range 1 49 in + generate_manager_operation batch_size in (kind, (Operation.hash_packed packed_operation, packed_operation)) diff --git a/src/proto_alpha/lib_protocol/test/pbt/dune b/src/proto_alpha/lib_protocol/test/pbt/dune index 4609fc990173..480c21df3a3c 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/dune +++ b/src/proto_alpha/lib_protocol/test/pbt/dune @@ -17,7 +17,8 @@ test_refutation_game test_carbonated_map test_zk_rollup_encoding - test_dal_slot_proof) + test_dal_slot_proof + test_compare_operations) (libraries tezos-base tezos-micheline @@ -122,6 +123,11 @@ (package tezos-protocol-alpha-tests) (action (run %{dep:./test_dal_slot_proof.exe}))) +(rule + (alias runtest) + (package tezos-protocol-alpha-tests) + (action (run %{dep:./test_compare_operations.exe}))) + (rule (alias runtest1) (action (run %{exe:liquidity_baking_pbt.exe}))) (rule (alias runtest1) (action (run %{exe:saturation_fuzzing.exe}))) @@ -151,3 +157,5 @@ (rule (alias runtest3) (action (run %{exe:test_zk_rollup_encoding.exe}))) (rule (alias runtest3) (action (run %{exe:test_dal_slot_proof.exe}))) + +(rule (alias runtest3) (action (run %{exe:test_compare_operations.exe}))) diff --git a/src/proto_alpha/lib_protocol/test/unit/test_compare_operations.ml b/src/proto_alpha/lib_protocol/test/pbt/test_compare_operations.ml similarity index 60% rename from src/proto_alpha/lib_protocol/test/unit/test_compare_operations.ml rename to src/proto_alpha/lib_protocol/test/pbt/test_compare_operations.ml index 6f7fc26fca51..b09bc8055536 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_compare_operations.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_compare_operations.ml @@ -26,17 +26,23 @@ (** Testing ------- Component: Protocol (Operation compare) - Invocation: dune exec src/proto_alpha/lib_protocol/test/unit/main.exe \ - -- test "\[Unit\] compare operations" + Invocation: dune exec \ + src/proto_alpha/lib_protocol/test/pbt/test_compare_operations.exe Subject: Valid operations Comparison *) open Protocol open Alpha_context open Operation_generator -open Lwt_result_syntax +open QCheck2 -let () = Stdlib.Random.self_init () +let lt = -1 + +let gt = 1 + +let eq = 0 + +let cmp_op op1 op2 res = Compare.Int.equal (Operation.compare op1 op2) res (** A strict order has an equality predicate that is symmetric, reflexive and transitive and an lt (and gt) predicates that is @@ -48,28 +54,22 @@ let () = Stdlib.Random.self_init () when Operation.compare x y = -1 and Operation.compare x y = -1; and that Operation.compare x y = - (Operation.compare y x) when differ from 0. *) -let eq_sym op1 op2 = - if Operation.compare op1 op2 = 0 then assert (Operation.compare op2 op1 = 0) +let eq_sym op1 op2 = if cmp_op op1 op2 eq then assert (cmp_op op2 op1 eq) -let eq_refl op = assert (Operation.compare op op = 0) +let eq_refl op = assert (cmp_op op op eq) let eq_trans op1 op2 op3 = - if Operation.compare op1 op2 = 0 && Operation.compare op2 op3 = 0 then - assert (Operation.compare op1 op3 = 0) + if cmp_op op1 op2 eq && cmp_op op2 op3 eq then assert (cmp_op op1 op3 eq) -let lt_antisym op1 op2 = - if Operation.compare op1 op2 = -1 then assert (Operation.compare op2 op1 = 1) +let lt_antisym op1 op2 = if cmp_op op1 op2 lt then assert (cmp_op op2 op1 gt) let lt_trans op1 op2 op3 = - if Operation.compare op1 op2 = -1 && Operation.compare op2 op3 = -1 then - assert (Operation.compare op1 op3 = -1) + if cmp_op op1 op2 lt && cmp_op op2 op3 lt then assert (cmp_op op1 op3 lt) let gt_trans op1 op2 op3 = - if Operation.compare op1 op2 = 1 && Operation.compare op2 op3 = 1 then - assert (Operation.compare op1 op3 = 1) + if cmp_op op1 op2 gt && cmp_op op2 op3 gt then assert (cmp_op op1 op3 gt) -let gt_antisym op1 op2 = - if Operation.compare op1 op2 = 1 then assert (Operation.compare op2 op1 = -1) +let gt_antisym op1 op2 = if cmp_op op1 op2 gt then assert (cmp_op op2 op1 lt) (** Testing that Operation.compare is a strict order on operations. *) let strorder op1 op2 op3 = @@ -81,40 +81,21 @@ let strorder op1 op2 op3 = gt_trans op1 op2 op3 ; gt_antisym op1 op2 -let run ?seed n = - assert (n >= 0) ; - let seed = - match seed with Some s -> s | None -> Stdlib.Random.int (1 lsl 29) - in - Format.printf "Starting fuzzing with seed: %d@." seed ; - let random_state = {seed; rnd_state = Random.make [|seed|]} in - let rec loop = function - | 0 -> () - | n' -> - (try - let k1, op1 = generate_operation random_state in - let k2, op2 = generate_operation random_state in - let k3, op3 = generate_operation random_state in - try strorder op1 op2 op3 - with exn -> - Format.eprintf - "%a vs. %a vs. %a@." - pp_kind - k1 - pp_kind - k2 - pp_kind - k3 ; - raise exn - with Failure _ -> ()) ; - loop (pred n') - in - loop n - -let test_compare () = - run 1_000_000 ; - return_unit - -let tests = - Tztest. - [tztest "Compare operations is a strict total order." `Slow test_compare] +let test_compare_is_strorder = + Test.make + ~name:"Compare operations is a strict total order" + (Gen.triple generate_operation generate_operation generate_operation) + (fun ((k1, op1), (k2, op2), (k3, op3)) -> + try + strorder op1 op2 op3 ; + true + with exn -> + Format.eprintf "%a vs. %a vs. %a@." pp_kind k1 pp_kind k2 pp_kind k3 ; + raise exn) + +let tests = [test_compare_is_strorder] + +let () = + Alcotest.run + "Compare operations" + [("Compare_operations", Lib_test.Qcheck2_helpers.qcheck_wrap tests)] diff --git a/src/proto_alpha/lib_protocol/test/unit/main.ml b/src/proto_alpha/lib_protocol/test/unit/main.ml index 9df7b4fa13f7..0d0e17ddefcf 100644 --- a/src/proto_alpha/lib_protocol/test/unit/main.ml +++ b/src/proto_alpha/lib_protocol/test/unit/main.ml @@ -83,7 +83,6 @@ let () = Test_sc_rollup_management_protocol.tests; Unit_test.spec "Bond_id_repr.ml" Test_bond_id_repr.tests; Unit_test.spec "zk rollup storage" Test_zk_rollup_storage.tests; - Unit_test.spec "compare operations" Test_compare_operations.tests; Unit_test.spec "Delegate_consensus_key.ml" Test_consensus_key.tests; Unit_test.spec "local_contexts" Test_local_contexts.tests; Unit_test.spec "dal slot proof" Test_dal_slot_proof.tests; -- GitLab From c053769173d2c7dd62512c4f8467f5443aac4f27 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Tue, 11 Oct 2022 10:54:11 +0200 Subject: [PATCH 3/7] Proto/Tests: factorise manager test calls --- .../validate/manager_operation_helpers.ml | 47 ++++++++++++------- .../validate/manager_operation_helpers.ml | 46 +++++++++++------- .../validate/manager_operation_helpers.ml | 47 ++++++++++++------- 3 files changed, 86 insertions(+), 54 deletions(-) diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml index 25fb7cac301f..b66b6247b776 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -1039,25 +1039,36 @@ let select_op (op_req : operation_req) (infos : infos) = let create_Tztest ?hd_msg test tests_msg operations = let tl_msg k = let sk = kind_to_string k in - match hd_msg with None -> sk | Some hd -> Format.sprintf "%s, %s" hd sk + match hd_msg with + | None -> sk + | Some hd -> Format.sprintf "@[%s, %s@]" hd sk in - List.map - (fun kind -> - Tztest.tztest - (Format.sprintf "%s [%s]" tests_msg (tl_msg kind)) - `Quick - (fun () -> test kind ())) - operations - -let rec create_Tztest_batches test tests_msg operations = - let hdmsg k = Format.sprintf "%s" (kind_to_string k) in - let aux hd_msg test operations = - create_Tztest ~hd_msg test tests_msg operations - in - match operations with - | [] -> [] - | kop :: kops as ops -> - aux (hdmsg kop) (test kop) ops @ create_Tztest_batches test tests_msg kops + [ + Tztest.tztest (Format.sprintf "@[%s@]" tests_msg) `Quick (fun () -> + List.iter_es + (fun kind -> + Format.printf "%s %s@." tests_msg (tl_msg kind) ; + test kind ()) + operations); + ] + +let create_Tztest_batches test tests_msg operations = + let hdmsg k = Format.sprintf "@[%s@]" (kind_to_string k) in + [ + Tztest.tztest (Format.sprintf "@[%s@]" tests_msg) `Quick (fun () -> + List.iter_es + (fun kind1 -> + List.iter_es + (fun kind2 -> + Format.printf + "%s [%s / %s] @." + tests_msg + (hdmsg kind1) + (hdmsg kind2) ; + test kind1 kind2 ()) + operations) + operations); + ] (** {2 Diagnostic helpers.} *) diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/manager_operation_helpers.ml b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/manager_operation_helpers.ml index 66743e0a8b08..e2a888275862 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/manager_operation_helpers.ml +++ b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -1147,27 +1147,37 @@ let select_op (op_req : operation_req) (infos : infos) = let create_Tztest ?hd_msg test tests_msg operations = let tl_msg k = let sk = kind_to_string k in - match hd_msg with None -> sk | Some hd -> Format.sprintf "%s, %s" hd sk + match hd_msg with + | None -> sk + | Some hd -> Format.sprintf "@[%s, %s@]" hd sk in - List.map - (fun kind -> - Tztest.tztest - (Format.sprintf "%s [%s]" tests_msg (tl_msg kind)) - `Quick - (fun () -> test kind ())) - operations - -let rec create_Tztest_batches test tests_msg operations = - let hdmsg k = Format.sprintf "%s" (kind_to_string k) in - let aux hd_msg test operations = - create_Tztest ~hd_msg test tests_msg operations - in - match operations with - | [] -> [] - | kop :: kops as ops -> - aux (hdmsg kop) (test kop) ops @ create_Tztest_batches test tests_msg kops + [ + Tztest.tztest (Format.sprintf "@[%s@]" tests_msg) `Quick (fun () -> + List.iter_es + (fun kind -> + Format.printf "%s %s@." tests_msg (tl_msg kind) ; + test kind ()) + operations); + ] (** {2 Diagnostic helpers.} *) +let create_Tztest_batches test tests_msg operations = + let hdmsg k = Format.sprintf "@[%s@]" (kind_to_string k) in + [ + Tztest.tztest (Format.sprintf "@[%s@]" tests_msg) `Quick (fun () -> + List.iter_es + (fun kind1 -> + List.iter_es + (fun kind2 -> + Format.printf + "%s [%s / %s] @." + tests_msg + (hdmsg kind1) + (hdmsg kind2) ; + test kind1 kind2 ()) + operations) + operations); + ] (** The purpose of diagnostic helpers is to state the correct observation according to the validate result of a test. *) 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 82b7af64aff6..9d53e38e5063 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 @@ -1149,25 +1149,36 @@ let select_op (op_req : operation_req) (infos : infos) = let create_Tztest ?hd_msg test tests_msg operations = let tl_msg k = let sk = kind_to_string k in - match hd_msg with None -> sk | Some hd -> Format.sprintf "%s, %s" hd sk + match hd_msg with + | None -> sk + | Some hd -> Format.sprintf "@[%s, %s@]" hd sk in - List.map - (fun kind -> - Tztest.tztest - (Format.sprintf "%s [%s]" tests_msg (tl_msg kind)) - `Quick - (fun () -> test kind ())) - operations - -let rec create_Tztest_batches test tests_msg operations = - let hdmsg k = Format.sprintf "%s" (kind_to_string k) in - let aux hd_msg test operations = - create_Tztest ~hd_msg test tests_msg operations - in - match operations with - | [] -> [] - | kop :: kops as ops -> - aux (hdmsg kop) (test kop) ops @ create_Tztest_batches test tests_msg kops + [ + Tztest.tztest (Format.sprintf "@[%s@]" tests_msg) `Quick (fun () -> + List.iter_es + (fun kind -> + Format.printf "%s %s@." tests_msg (tl_msg kind) ; + test kind ()) + operations); + ] + +let create_Tztest_batches test tests_msg operations = + let hdmsg k = Format.sprintf "@[%s@]" (kind_to_string k) in + [ + Tztest.tztest (Format.sprintf "@[%s@]" tests_msg) `Quick (fun () -> + List.iter_es + (fun kind1 -> + List.iter_es + (fun kind2 -> + Format.printf + "%s [%s / %s] @." + tests_msg + (hdmsg kind1) + (hdmsg kind2) ; + test kind1 kind2 ()) + operations) + operations); + ] (** {2 Diagnostic helpers.} *) -- GitLab From ef0d8eaec3dfba8e5185f17294bd8c5333452d19 Mon Sep 17 00:00:00 2001 From: vbot Date: Wed, 12 Oct 2022 17:45:27 +0200 Subject: [PATCH 4/7] Lib_test: add an alcotest-lwt compatible wrapper --- src/lib_test/qcheck2_helpers.ml | 25 +++++++++++++++++++++++++ src/lib_test/qcheck2_helpers.mli | 23 ++++++++++++++++++++++- 2 files changed, 47 insertions(+), 1 deletion(-) diff --git a/src/lib_test/qcheck2_helpers.ml b/src/lib_test/qcheck2_helpers.ml index 5684485d4ac7..7622f54343e5 100644 --- a/src/lib_test/qcheck2_helpers.ml +++ b/src/lib_test/qcheck2_helpers.ml @@ -26,6 +26,13 @@ let qcheck_wrap ?verbose ?long ?rand = List.map (QCheck_alcotest.to_alcotest ?verbose ?long ?rand) +let qcheck_wrap_lwt ?verbose ?long ?rand = + List.map (fun test -> + let name, speed, f = + QCheck_alcotest.to_alcotest ?verbose ?long ?rand test + in + (name, speed, fun arg -> Lwt.return (f arg))) + let qcheck_make_result ?count ?print ?pp_error ?check ~name ~(gen : 'a QCheck2.Gen.t) (f : 'a -> (bool, 'b) result) = let check = @@ -48,6 +55,24 @@ let qcheck_make_lwt ?count ?print ~extract ~name ~(gen : 'a QCheck2.Gen.t) (f : 'a -> bool Lwt.t) = QCheck2.Test.make ~name ?print ?count gen (fun x -> extract (f x)) +let qcheck_make_result_lwt ?count ?print ?pp_error ?check ~extract ~name + ~(gen : 'a QCheck2.Gen.t) (f : 'a -> (bool, 'b) result Lwt.t) = + let check = + match check with + | Some check -> check + | None -> ( + function + | Ok b -> b + | Error err -> ( + match pp_error with + | Some pp_error -> + QCheck2.Test.fail_reportf "Test failed:@,%a" pp_error err + | None -> + QCheck2.Test.fail_reportf + "Test failed but no pretty printer was provided.")) + in + QCheck2.Test.make ~name ?print ?count gen (fun x -> extract (f x) |> check) + let qcheck_eq ?pp ?cmp ?eq expected actual = let pass = match (eq, cmp) with diff --git a/src/lib_test/qcheck2_helpers.mli b/src/lib_test/qcheck2_helpers.mli index 61086d4dc536..320b9eb41666 100644 --- a/src/lib_test/qcheck2_helpers.mli +++ b/src/lib_test/qcheck2_helpers.mli @@ -23,7 +23,7 @@ (* *) (*****************************************************************************) -(** Wrap QCheck tests into Alcotests. *) +(** Wrap QCheck tests into Alcotest. *) val qcheck_wrap : ?verbose:bool -> ?long:bool -> @@ -31,6 +31,14 @@ val qcheck_wrap : QCheck2.Test.t list -> unit Alcotest.test_case list +(** Wrap QCheck tests into Alcotest_lwt. *) +val qcheck_wrap_lwt : + ?verbose:bool -> + ?long:bool -> + ?rand:Random.State.t -> + QCheck2.Test.t list -> + (string * [`Quick | `Slow] * (unit -> unit Lwt.t)) list + (** [qcheck_make_result ?print ?pp_error ?count ?check ~name ~gen f] is a wrapper around {!QCheck2.Test.make} where [f] returns a result type. If [check] is not provided and if the result of [f] is @@ -59,6 +67,19 @@ val qcheck_make_lwt : ('a -> bool Lwt.t) -> QCheck2.Test.t +(** [qcheck_make_result_lwt ?print ?count ~extract ~name ~gen f] is + the combination of [qcheck_make_result] and [qcheck_make_lwt]. *) +val qcheck_make_result_lwt : + ?count:int -> + ?print:'a QCheck2.Print.t -> + ?pp_error:(Format.formatter -> 'b -> unit) -> + ?check:((bool, 'b) result -> bool) -> + extract:((bool, 'b) result Lwt.t -> (bool, 'b) result) -> + name:string -> + gen:'a QCheck2.Gen.t -> + ('a -> (bool, 'b) result Lwt.t) -> + QCheck2.Test.t + (** [qcheck_eq_tests ~eq ~gen ~eq_name] returns three tests of [eq]: reflexivity, symmetry, and transitivity. -- GitLab From 95097b47246927eaee84ea025fcdaaa28bcbadb7 Mon Sep 17 00:00:00 2001 From: Zaynah Dargaye Date: Wed, 12 Oct 2022 16:44:53 +0200 Subject: [PATCH 5/7] Proto/Tests: test commutativity of valid generated operations Co-authored-by: Vincent Botbol Co-authored-by: Albin Coquereau --- manifest/main.ml | 3 +- .../validate/generator_descriptors.ml | 877 +++++++++++++++++ .../lib_protocol/test/helpers/context.ml | 47 +- .../lib_protocol/test/helpers/context.mli | 44 + .../test/integration/validate/dune | 15 +- .../validate/generator_descriptors.ml | 896 ++++++++++++++++++ .../validate/generator_descriptors.mli | 161 ++++ .../test/integration/validate/generators.ml | 9 +- .../test/integration/validate/main.ml | 21 +- .../validate/manager_operation_helpers.ml | 309 +++--- .../validate/test_1m_restriction.ml | 68 +- .../integration/validate/test_covalidity.ml | 157 +++ .../test_manager_operation_validation.ml | 375 +++----- .../test/integration/validate/test_sanity.ml | 175 ++++ ...validation.ml => test_validation_batch.ml} | 340 ++++--- .../validate/valid_operations_generators.ml | 242 +++++ .../integration/validate/validate_helpers.ml | 393 ++++++++ 17 files changed, 3489 insertions(+), 643 deletions(-) create mode 100644 src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/generator_descriptors.ml create mode 100644 src/proto_alpha/lib_protocol/test/integration/validate/generator_descriptors.ml create mode 100644 src/proto_alpha/lib_protocol/test/integration/validate/generator_descriptors.mli create mode 100644 src/proto_alpha/lib_protocol/test/integration/validate/test_covalidity.ml create mode 100644 src/proto_alpha/lib_protocol/test/integration/validate/test_sanity.ml rename src/proto_alpha/lib_protocol/test/integration/validate/{test_batched_manager_operation_validation.ml => test_validation_batch.ml} (82%) create mode 100644 src/proto_alpha/lib_protocol/test/integration/validate/valid_operations_generators.ml create mode 100644 src/proto_alpha/lib_protocol/test/integration/validate/validate_helpers.ml diff --git a/manifest/main.ml b/manifest/main.ml index 2326bf730236..e022da86120d 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -3560,7 +3560,7 @@ end = struct let _integration_validate = only_if N.(number >= 014) @@ fun () -> tests - ["main"; "test_1m_restriction"] + ("main" :: (if N.(number <= 015) then ["test_1m_restriction"] else [])) ~path:(path // "lib_protocol/test/integration/validate") ~opam:(sf "tezos-protocol-%s-tests" name_dash) ~deps: @@ -3573,6 +3573,7 @@ end = struct client |> if_some |> open_; test_helpers |> if_some |> open_; octez_base_test_helpers |> open_; + plugin |> if_some |> open_; ] in let _integration = diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/generator_descriptors.ml b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/generator_descriptors.ml new file mode 100644 index 000000000000..da8c42c8edb5 --- /dev/null +++ b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/generator_descriptors.ml @@ -0,0 +1,877 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context +open Validate_helpers + +type dbl_endorsement_state = { + temporary : (Block.t * Block.t) option; + slashable_preend : + (Kind.preendorsement operation * Kind.preendorsement operation) list; + slashable_end : (Kind.endorsement operation * Kind.endorsement operation) list; +} + +type state = { + block : Block.t; + pred : Block.t option; + bootstraps : public_key_hash list; + delegates : (public_key_hash * public_key_hash option) list; + voters : Contract.t list; + seed_nonce_to_reveal : (Raw_level.t * Nonce_hash.t) list; + commitments : secret_account list; + protocol_hashes : Protocol_hash.t list; + slashable_bakes : (block_header * block_header) list; + vdf : bool; + dbl_endorsement : dbl_endorsement_state; + manager : Manager.infos; +} + +let init_manager_state bootstraps block = + let open Manager in + let ctxt = + { + block; + bootstraps; + originated_contract = None; + tx_rollup = None; + sc_rollup = None; + zk_rollup = None; + } + in + let accounts = + {sources = []; dest = None; del = None; tx = None; sc = None; zk = None} + in + {ctxt; accounts; flags = all_enabled} + +let init_dbl_endorsement_state = + {temporary = None; slashable_preend = []; slashable_end = []} + +(** Initialize the state according to [state] initialisation + for each operation kind. + + When adding a new operation kind, if such an initialization is + required, it should occur here. *) +let init_state block ~voters ~(bootstraps : Contract.t list) = + let bootstraps = + List.map + (function Contract.Implicit pkh -> pkh | _ -> assert false) + bootstraps + in + { + block; + pred = None; + bootstraps; + delegates = List.map (fun pkh -> (pkh, None)) bootstraps; + voters; + seed_nonce_to_reveal = []; + commitments = []; + protocol_hashes = []; + slashable_bakes = []; + vdf = false; + dbl_endorsement = init_dbl_endorsement_state; + manager = init_manager_state bootstraps block; + } + +type cycle_index = On of int | From of int + +type descriptor = { + parameters : Parameters.t -> Parameters.t; + required_cycle : Parameters.t -> int; + required_block : Parameters.t -> int; + prelude : + cycle_index * (state -> (packed_operation list * state) tzresult Lwt.t); + opt_prelude : + (cycle_index * (state -> (packed_operation list * state) tzresult Lwt.t)) + option; + candidates_generator : state -> packed_operation list tzresult Lwt.t; +} + +let voting_context_params params = + let cycles_per_voting_period = 1l in + let constants = Parameters.{params.constants with cycles_per_voting_period} in + {params with constants} + +let ballot_exploration_prelude state = + let open Lwt_result_syntax in + let* ctxt = Context.to_alpha_ctxt (B state.block) in + let blocks_per_cycle = Alpha_context.Constants.blocks_per_cycle ctxt in + let rem = + Int32.rem state.block.Block.header.Block_header.shell.level blocks_per_cycle + in + if rem = 0l then + match state.voters with + | voter :: voters -> + let* prop = Op.proposals (B state.block) voter [get_n protos 0] in + let* props = + List.map_es + (fun voter -> + Op.proposals (B state.block) voter [Protocol_hash.zero]) + voters + in + return (prop :: props, state) + | _ -> assert false + else return ([], state) + +let activate_descriptor = + { + parameters = + (fun params -> + let commitments = + List.map + (fun {blinded_public_key_hash; amount; _} -> + Commitment.{blinded_public_key_hash; amount}) + secrets + in + {params with commitments}); + required_cycle = (fun _params -> 1); + required_block = (fun _params -> 0); + prelude = + (On 1, fun state -> return ([], {state with commitments = secrets})); + opt_prelude = None; + candidates_generator = + (fun state -> + let gen s = + Op.activation (B state.block) (Ed25519 s.account) s.activation_code + in + List.map_es gen state.commitments); + } + +let ballot_exploration_descriptor = + { + parameters = voting_context_params; + required_cycle = + (fun params -> 1 * Int32.to_int params.constants.cycles_per_voting_period); + required_block = (fun _params -> 0); + prelude = (On 1, ballot_exploration_prelude); + opt_prelude = None; + candidates_generator = + (fun state -> + let open Lwt_result_syntax in + let gen contract = + let* voting_period_info = + Context.Vote.get_current_period (B state.block) + in + assert (voting_period_info.voting_period.kind = Exploration) ; + let ballot = pick_one ballots in + Op.ballot (B state.block) contract Protocol_hash.zero ballot + in + List.map_es gen state.voters); + } + +let proposal_descriptor = + { + parameters = voting_context_params; + required_cycle = (fun _ -> 0); + required_block = (fun _ -> 0); + prelude = + (On 0, fun state -> return ([], {state with protocol_hashes = protos})); + opt_prelude = None; + candidates_generator = + (fun state -> + let open Lwt_result_syntax in + let gen contract = + let* voting_period_info = + Context.Vote.get_current_period (B state.block) + in + assert (voting_period_info.voting_period.kind = Proposal) ; + Op.proposals (B state.block) contract [Protocol_hash.zero] + in + List.map_es gen state.voters); + } + +let ballot_promotion_descriptor = + { + parameters = voting_context_params; + required_cycle = + (fun params -> 3 * Int32.to_int params.constants.cycles_per_voting_period); + required_block = (fun _ -> 0); + prelude = (On 3, ballot_exploration_prelude); + opt_prelude = + Some + ( On 2, + fun state -> + let open Lwt_result_syntax in + let* ctxt = Context.to_alpha_ctxt (B state.block) in + let blocks_per_cycle = + Alpha_context.Constants.blocks_per_cycle ctxt + in + let rem = + Int32.rem + state.block.Block.header.Block_header.shell.level + blocks_per_cycle + in + if rem = 0l then + let* ops = + List.map_es + (fun voter -> + Op.ballot (B state.block) voter Protocol_hash.zero Vote.Yay) + state.voters + in + return (ops, state) + else return ([], state) ); + candidates_generator = + (fun state -> + let open Lwt_result_syntax in + let gen contract = + let* voting_period_info = + Context.Vote.get_current_period (B state.block) + in + assert (voting_period_info.voting_period.kind = Promotion) ; + let ballot = Stdlib.List.hd ballots in + Op.ballot (B state.block) contract Protocol_hash.zero ballot + in + List.map_es gen state.voters); + } + +let seed_nonce_descriptor = + { + parameters = + (fun params -> + assert (params.constants.blocks_per_cycle > 3l) ; + let blocks_per_commitment = + Int32.(div params.constants.blocks_per_cycle 3l) + in + let constants = {params.constants with blocks_per_commitment} in + {params with constants}); + required_cycle = (fun _ -> 1); + required_block = (fun _ -> 0); + prelude = + ( On 1, + fun state -> + let open Lwt_result_syntax in + let b = state.block in + let* seed_nonce_to_reveal = + match + b.Block.header.Block_header.protocol_data.contents.seed_nonce_hash + with + | None -> return state.seed_nonce_to_reveal + | Some nonce_hash -> + let level = + Raw_level.of_int32_exn b.Block.header.Block_header.shell.level + in + return ((level, nonce_hash) :: state.seed_nonce_to_reveal) + in + return ([], {state with seed_nonce_to_reveal}) ); + opt_prelude = None; + candidates_generator = + (fun state -> + let open Lwt_result_syntax in + let gen (level, nonce_hash) = + assert (List.length state.seed_nonce_to_reveal >= 3) ; + let nonce = + WithExceptions.Option.to_exn ~none:Not_found + @@ Registered_nonces.get nonce_hash + in + return (Op.seed_nonce_revelation (B state.block) level nonce) + in + List.map_es gen state.seed_nonce_to_reveal); + } + +(** The heads on which two slashable endorsements or preendorsement + should be made are from the previous level. Hence, the temporary + field of a double_evidence_state is used to transmit them to the + next level in order to make the slashable operations. *) +let register_temporary ba bb state : (Block.t * Block.t) option * state = + let pred_forks = state.dbl_endorsement.temporary in + let temporary = Some (ba, bb) in + let dbl_endorsement = {state.dbl_endorsement with temporary} in + (pred_forks, {state with dbl_endorsement}) + +(** During the slashable period, at each level, two different heads + for the same round are baked by the same baker. At the next level, + a delegate that either preendorses or endorses both heads makes a + pair of slashable pre- or endorsements. + + The pair of heads is placed in the temporary of the + double_evidence_state. If a pair of heads was already in this + field, hence they were baked at the previous level. + + Consequently, two pairs of slashable operations: two endorsements + and two preendorsement, can be made by two distinct endorsers. Each + pair is ordered in operation_hash order. Consequently, each pair + can appear in a denunciation operation and will be valid. *) +let dbl_endorsement_prelude state = + let open Lwt_result_syntax in + let* head_A = Block.bake ~policy:(By_round 0) state.block in + let* addr = pick_addr_endorser (B state.block) in + let ctr = Contract.Implicit addr in + let* operation = Op.transaction (B state.block) ctr ctr Tez.one_mutez in + let* head_B = Block.bake ~policy:(By_round 0) state.block ~operation in + let heads, state = register_temporary head_A head_B state in + match heads with + | None -> return ([], state) + | Some (b1, b2) -> + let* delegate1, delegate2 = pick_two_endorsers (B b1) in + let* op1 = + Op.preendorsement + ~delegate:delegate1 + ~endorsed_block:b1 + (B state.block) + () + in + let* op2 = + Op.preendorsement + ~delegate:delegate1 + ~endorsed_block:b2 + (B state.block) + () + in + let op1, op2 = + let comp = + Operation_hash.compare (Operation.hash op1) (Operation.hash op2) + in + assert (comp <> 0) ; + if comp < 0 then (op1, op2) else (op2, op1) + in + let slashable_preend = + (op1, op2) :: state.dbl_endorsement.slashable_preend + in + let* op3 = + Op.endorsement ~delegate:delegate2 ~endorsed_block:b1 (B state.block) () + in + let* op4 = + Op.endorsement ~delegate:delegate2 ~endorsed_block:b2 (B state.block) () + in + let op3, op4 = + let comp = + Operation_hash.compare (Operation.hash op3) (Operation.hash op4) + in + assert (comp <> 0) ; + if comp < 0 then (op3, op4) else (op4, op3) + in + let slashable_end = (op3, op4) :: state.dbl_endorsement.slashable_end in + let dbl_endorsement = + {state.dbl_endorsement with slashable_preend; slashable_end} + in + return ([], {state with dbl_endorsement}) + +let double_consensus_descriptor = + { + parameters = Fun.id; + required_cycle = (fun _params -> 2); + required_block = (fun _ -> 0); + prelude = (From 2, dbl_endorsement_prelude); + opt_prelude = None; + candidates_generator = + (fun state -> + let open Lwt_result_syntax in + let gen_dbl_pre (op1, op2) = + Op.double_preendorsement (Context.B state.block) op1 op2 + in + let gen_dbl_end (op1, op2) = + Op.double_endorsement (Context.B state.block) op1 op2 + in + let candidates_pre = + List.map gen_dbl_pre state.dbl_endorsement.slashable_preend + in + let candidates_end = + List.map gen_dbl_end state.dbl_endorsement.slashable_end + in + return (candidates_pre @ candidates_end)); + } + +let double_baking_descriptor = + { + parameters = Fun.id; + required_cycle = (fun params -> params.constants.max_slashing_period); + required_block = (fun _ -> 0); + prelude = + ( From 2, + fun state -> + let open Lwt_result_syntax in + let order_block_header bh1 bh2 = + let hash1 = Block_header.hash bh1 in + let hash2 = Block_header.hash bh2 in + let c = Block_hash.compare hash1 hash2 in + if c < 0 then (bh1, bh2) else (bh2, bh1) + in + let* ctxt = Context.to_alpha_ctxt (B state.block) in + let blocks_per_cycle = + Alpha_context.Constants.blocks_per_cycle ctxt + in + let rem = + Int32.rem + state.block.Block.header.Block_header.shell.level + blocks_per_cycle + in + if rem = 0l then return ([], state) + else + let* baker1, _baker2 = + Context.get_first_different_bakers (B state.block) + in + let* addr = pick_addr_endorser (B state.block) in + let ctr = Contract.Implicit addr in + let* operation = + Op.transaction (B state.block) ctr ctr Tez.one_mutez + in + let* ba = + Block.bake ~policy:(By_account baker1) ~operation state.block + in + let* bb = Block.bake ~policy:(By_account baker1) state.block in + let ba, bb = order_block_header ba.Block.header bb.Block.header in + let slashable_bakes = (ba, bb) :: state.slashable_bakes in + return ([], {state with slashable_bakes}) ); + opt_prelude = None; + candidates_generator = + (fun state -> + let open Lwt_result_syntax in + let gen (bh1, bh2) = + return (Op.double_baking (B state.block) bh1 bh2) + in + List.map_es gen state.slashable_bakes); + } + +(** A drain delegate operation is valid when, preserved_cycle before, the + delegate has updated its key. This key must then has enough fund in order to + be revealed. + + At the first level of preserved cycle in the past, the key is funded by a + bootstrap account. At the second level, it reveals and at the third the + delegate updates its key to this key. *) +let drain_delegate_prelude state = + let open Lwt_result_syntax in + let* ctxt = Context.to_alpha_ctxt (B state.block) in + let blocks_per_cycle = Alpha_context.Constants.blocks_per_cycle ctxt in + let rem = + Int32.rem state.block.Block.header.Block_header.shell.level blocks_per_cycle + in + if rem = 0l then + (* Create (n / 2) consensus keys *) + let delegates = + List.mapi + (fun i -> function + | (delegate, None) as del -> + if i mod 2 = 0 then + let acc = Account.new_account () in + (delegate, Some acc.pkh) + else del + | del -> del (* should not happen but apparently does...*)) + state.delegates + in + let dels = + List.filter_map + (function _del, None -> None | del, Some ck -> Some (del, ck)) + delegates + in + let* ops = + List.fold_left_es + (fun ops (del, ck) -> + let* {Account.pk; _} = Account.find ck in + let* op = + Op.update_consensus_key (B state.block) (Contract.Implicit del) pk + in + return (op :: ops)) + [] + dels + in + let state = {state with delegates} in + return (ops, state) + else return ([], state) + +let drain_delegate_descriptor = + { + parameters = Fun.id; + required_cycle = (fun params -> params.constants.preserved_cycles + 1); + required_block = (fun _ -> 0); + prelude = + (On (init_params.constants.preserved_cycles + 1), drain_delegate_prelude); + opt_prelude = None; + candidates_generator = + (fun state -> + let gen (delegate, consensus_key_opt) = + let open Lwt_result_syntax in + match consensus_key_opt with + | None -> return_none + | Some consensus_key -> + let* op = + Op.drain_delegate + (B state.block) + ~consensus_key + ~delegate + ~destination:consensus_key + in + return_some op + in + List.filter_map_es gen state.delegates); + } + +let vdf_revelation_descriptor = + { + parameters = + (fun params -> + {params with constants = {params.constants with vdf_difficulty = 750L}}); + required_cycle = (fun _ -> 1); + required_block = + (fun params -> Int32.to_int params.constants.nonce_revelation_threshold); + prelude = (On 2, fun state -> return ([], {state with vdf = true})); + opt_prelude = None; + candidates_generator = + (fun state -> + let open Lwt_result_syntax in + let* seed_status = Context.get_seed_computation (B state.block) in + let* csts = Context.get_constants (B state.block) in + match seed_status with + | Nonce_revelation_stage | Computation_finished -> assert false + | Vdf_revelation_stage info -> + (* generate the VDF discriminant and challenge *) + let discriminant, challenge = + Alpha_context.Seed.generate_vdf_setup + ~seed_discriminant:info.seed_discriminant + ~seed_challenge:info.seed_challenge + in + (* compute the VDF solution (the result and the proof ) *) + let solution = + (* generate the result and proof *) + Environment.Vdf.prove + discriminant + challenge + csts.parametric.vdf_difficulty + in + return [Op.vdf_revelation (B state.block) solution]); + } + +let preendorsement_descriptor = + { + parameters = Fun.id; + required_cycle = (fun _ -> 1); + required_block = (fun _ -> 1); + prelude = (On 1, fun state -> return ([], state)); + opt_prelude = None; + candidates_generator = + (fun state -> + let open Lwt_result_syntax in + let gen (delegate, ck_opt) = + let* slots_opt = Context.get_endorser_slot (B state.block) delegate in + let delegate = Option.value ~default:delegate ck_opt in + match (state.pred, slots_opt) with + | None, _ -> assert false + | Some _pred, None -> return_none + | Some pred, Some slots -> + let* op = + Op.preendorsement + ~delegate:(delegate, slots) + ~endorsed_block:state.block + (B pred) + () + in + return_some (Alpha_context.Operation.pack op) + in + List.filter_map_es gen state.delegates); + } + +let endorsement_descriptor = + { + parameters = Fun.id; + required_cycle = (fun _ -> 1); + required_block = (fun _ -> 1); + prelude = (On 1, fun state -> return ([], state)); + opt_prelude = None; + candidates_generator = + (fun state -> + let open Lwt_result_syntax in + let gen (delegate, ck_opt) = + let* slots_opt = Context.get_endorser_slot (B state.block) delegate in + let delegate = Option.value ~default:delegate ck_opt in + match (state.pred, slots_opt) with + | None, _ -> assert false + | Some _pred, None -> return_none + | Some pred, Some slots -> + let* op = + Op.endorsement + ~delegate:(delegate, slots) + ~endorsed_block:state.block + (B pred) + () + in + return_some (Alpha_context.Operation.pack op) + in + List.filter_map_es gen state.delegates); + } + +let dal_slot_availability_descriptor = + { + parameters = + (fun params -> + let dal = {params.constants.dal with feature_enable = true} in + let constants = {params.constants with dal} in + {params with constants}); + required_cycle = (fun _ -> 0); + required_block = (fun _ -> 0); + prelude = (On 1, fun state -> return ([], state)); + opt_prelude = None; + candidates_generator = + (fun state -> + let open Lwt_result_syntax in + let gen (del, _) = + let op = Dal_slot_availability (del, Dal.Endorsement.empty) in + Op.pack_operation (B state.block) None (Single op) + in + return (List.map gen state.delegates)); + } + +module Manager = Manager_operation_helpers + +let required_nb_account = 7 + +(** Convertion from [manager_state] to a {! Manager_operation_helper.infos}. *) +let infos_of_state source block infos : Manager.infos = + let open Manager in + let ({ctxt; accounts; flags} : infos) = infos in + let ctxt : ctxt = {ctxt with block} in + let accounts = {accounts with sources = [source]} in + {ctxt; accounts; flags} + +(** Updating a [manager_state] according to a {! Manager_operation_helper.infos}. *) +let update_state_with_infos {Manager.ctxt; accounts; flags} + {Manager.ctxt = ctxt2; accounts = accounts2; _} = + let ctxt = + { + ctxt with + originated_contract = ctxt2.originated_contract; + tx_rollup = ctxt2.tx_rollup; + sc_rollup = ctxt2.sc_rollup; + zk_rollup = ctxt2.zk_rollup; + } + in + let accounts = + { + accounts with + dest = accounts2.dest; + del = accounts2.del; + tx = accounts2.tx; + sc = accounts2.sc; + zk = accounts2.zk; + } + in + {Manager.ctxt; accounts; flags} + +(** According to a [Manager.infos] and a block [b], create and fund + the required contracts and accounts on [b]. In additions to the + initiation performed by {! Manager_operation_helper.init_infos}, it + registers a list of funded sources. *) +let manager_prelude (infos : Manager.infos) b = + let open Lwt_result_syntax in + let nb_sources = List.length infos.ctxt.bootstraps in + let* ops_by_bootstrap = + List.map_es + (fun bootstrap -> + let bootstrap = Contract.Implicit bootstrap in + let* counter = Context.Contract.counter (B b) bootstrap in + return (bootstrap, counter, [])) + (List.take_n nb_sources infos.ctxt.bootstraps) + in + let add bootstrap counter ops ops_by_bootstrap = + List.map + (fun (bootstrap', counter', ops') -> + if bootstrap' = bootstrap then (bootstrap, Z.succ counter, ops) + else (bootstrap', counter', ops')) + ops_by_bootstrap + in + let batches block ops_by_bootstrap = + List.fold_left_es + (fun acc (source, _counter, operations) -> + match operations with + | [] -> return (List.rev acc) + | _ -> + let* batch = Op.batch_operations ~source (B block) operations in + return (batch :: acc)) + [] + ops_by_bootstrap + in + let create_and_fund sources ops_by_bootstrap = + let account = Account.new_account () in + let n = nb_sources - Stdlib.List.length sources in + let bootstrap, counter, ops = Stdlib.List.nth ops_by_bootstrap (n - 1) in + let amount = Tez.of_mutez (Int64.of_int 150000) in + let+ op, counter = + Manager.fund_account_op b bootstrap account.pkh amount counter + in + (account :: sources, add bootstrap counter (op :: ops) ops_by_bootstrap) + in + let* sources, src_operations = + List.fold_left_es + (fun (acc_accounts, acc_ops) _ -> create_and_fund acc_accounts acc_ops) + ([], ops_by_bootstrap) + (1 -- nb_sources) + in + let* operations = batches b src_operations in + let infos = {infos with accounts = {infos.accounts with sources}} in + let* infos2 = + Manager.init_infos + Manager.ctxt_req_default + b + (List.take_n required_nb_account infos.ctxt.bootstraps) + in + let state = update_state_with_infos infos infos2 in + return (operations, state) + +(** Build a manager operation according to the information in [infos] + on [block] for each source in the [manager_state] guaranteering + that they are not conflicting. *) +let manager_candidates block infos batch_max_size = + let open Lwt_result_syntax in + let params = + List.map + (fun src -> + let m = gen_bounded_int 1 batch_max_size in + let kd = pick_n m Manager.revealed_subjects in + (src, kd)) + infos.Manager.accounts.sources + in + let gen (source, ks) = + let infos = infos_of_state source block infos in + let* reveal = + Manager.mk_reveal (Manager.operation_req_default Manager.K_Reveal) infos + in + let* operations = + List.map_es + (fun kd -> Manager.select_op (Manager.operation_req_default kd) infos) + ks + in + let* operations = return (reveal :: operations) in + Op.batch_operations + ~recompute_counters:true + ~source:(Contract.Implicit source.pkh) + (B block) + operations + in + List.map_es gen params + +let manager_descriptor max_batch_size nb_accounts = + { + parameters = + (fun params -> + let ctxt_req_default = Manager.ctxt_req_default in + let hard_gas_limit_per_block = + Some (Gas.Arith.integral_of_int_exn ((nb_accounts + 1) * 5_200_000)) + in + let ctxt_req = {ctxt_req_default with hard_gas_limit_per_block} in + Manager.manager_parameters params ctxt_req); + required_cycle = (fun _ -> 1); + required_block = (fun _ -> 1); + prelude = + ( On 1, + fun state -> + let open Lwt_result_syntax in + let* ops, manager = manager_prelude state.manager state.block in + let state = {state with manager} in + return (ops, state) ); + opt_prelude = None; + candidates_generator = + (fun state -> manager_candidates state.block state.manager max_batch_size); + } + +type op_kind = + | KEndorsement + | KPreendorsement + | KDalslotavail + | KBallotExp + | KBallotProm + | KProposals + | KNonce + | KVdf + | KActivate + | KDbl_consensus + | KDbl_baking + | KDrain + | KManager + +let op_kind_of_packed_operation op = + let (Operation_data {contents; _}) = op.protocol_data in + match contents with + | Single (Preendorsement _) -> KPreendorsement + | Single (Endorsement _) -> KEndorsement + | Single (Dal_slot_availability _) -> KDalslotavail + | Single (Seed_nonce_revelation _) -> KNonce + | Single (Vdf_revelation _) -> KVdf + | Single (Double_endorsement_evidence _) -> KDbl_consensus + | Single (Double_preendorsement_evidence _) -> KDbl_consensus + | Single (Double_baking_evidence _) -> KDbl_baking + | Single (Activate_account _) -> KActivate + | Single (Proposals _) -> KProposals + | Single (Ballot _) -> KBallotExp + | Single (Drain_delegate _) -> KDrain + | Single (Manager_operation _) -> KManager + | Cons (Manager_operation _, _) -> KManager + | Single (Failing_noop _) -> assert false + +let pp_op_kind fmt kind = + Format.fprintf + fmt + (match kind with + | KManager -> "manager" + | KEndorsement -> "endorsement" + | KPreendorsement -> "preendorsement" + | KDalslotavail -> "dal_slot" + | KBallotExp -> "ballot" + | KBallotProm -> "ballot" + | KProposals -> "proposals" + | KNonce -> "nonce" + | KVdf -> "vdf_revelation" + | KActivate -> "activate_account" + | KDbl_consensus -> "double_consensus" + | KDbl_baking -> "double_baking" + | KDrain -> "drain_delegate") + +let descriptor_of ~nb_bootstrap ~max_batch_size = function + | KManager -> manager_descriptor max_batch_size nb_bootstrap + | KEndorsement -> endorsement_descriptor + | KPreendorsement -> preendorsement_descriptor + | KDalslotavail -> dal_slot_availability_descriptor + | KBallotExp -> ballot_exploration_descriptor + | KBallotProm -> ballot_promotion_descriptor + | KProposals -> proposal_descriptor + | KNonce -> seed_nonce_descriptor + | KVdf -> vdf_revelation_descriptor + | KActivate -> activate_descriptor + | KDbl_consensus -> double_consensus_descriptor + | KDbl_baking -> double_baking_descriptor + | KDrain -> drain_delegate_descriptor + +let descriptors_of ~nb_bootstrap ~max_batch_size = + List.map (descriptor_of ~nb_bootstrap ~max_batch_size) + +(** A context is in a unique voting period. *) +let voting_kinds = [KProposals; KBallotExp; KBallotProm] + +(** A context either wait for nonce revelation or vdf revelation + but not both at the same time. *) +let nonce_generation_kinds = [KNonce; KVdf] + +(** All kind list, used in the sanity check.*) +let non_exclusive_kinds = + [ + KManager; + KEndorsement; + KPreendorsement; + KDalslotavail; + KActivate; + KDbl_consensus; + KDbl_baking; + KDrain; + ] + +let all_kinds = voting_kinds @ nonce_generation_kinds @ non_exclusive_kinds diff --git a/src/proto_alpha/lib_protocol/test/helpers/context.ml b/src/proto_alpha/lib_protocol/test/helpers/context.ml index de2e945b3e2f..e672f75228e9 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/context.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/context.ml @@ -131,6 +131,15 @@ let get_endorser ctxt = let endorser = WithExceptions.Option.get ~loc:__LOC__ @@ List.hd endorsers in (endorser.delegate, endorser.slots) +let get_endorser_slot ctxt pkh = + get_endorsers ctxt >|=? fun endorsers -> + List.find_map + (function + | {Plugin.RPC.Validators.delegate; slots; _} -> + if Signature.Public_key_hash.(delegate = pkh) then Some slots + else None) + endorsers + let get_endorser_n ctxt n = Plugin.RPC.Validators.get rpc_ctxt ctxt >|=? fun endorsers -> let endorser = @@ -511,26 +520,48 @@ let init2 = init_gen T2 let init3 = init_gen T3 -let init_with_constants_gen tup constants = - let n = tup_n tup in - Account.generate_accounts n >>?= fun accounts -> +let create_bootstrap_accounts n = + let open Result_syntax in + let* accounts = Account.generate_accounts n in let contracts = List.map (fun a -> Alpha_context.Contract.Implicit Account.(a.pkh)) accounts in let bootstrap_accounts = Account.make_bootstrap_accounts accounts in - let open Tezos_protocol_alpha_parameters in + return (bootstrap_accounts, contracts) + +let init_with_constants_gen tup constants = + let open Lwt_result_syntax in + let n = tup_n tup in + let*? bootstrap_accounts, contracts = create_bootstrap_accounts n in let parameters = - Default_parameters.parameters_of_constants ~bootstrap_accounts constants + Tezos_protocol_alpha_parameters.Default_parameters.parameters_of_constants + ~bootstrap_accounts + constants in - Block.genesis_with_parameters parameters >|=? fun blk -> - (blk, tup_get tup contracts) + let* blk = Block.genesis_with_parameters parameters in + return (blk, tup_get tup contracts) -let init_with_constants_n consts n = init_with_constants_gen (TList n) consts +let init_with_constants_n constants n = + init_with_constants_gen (TList n) constants let init_with_constants1 = init_with_constants_gen T1 let init_with_constants2 = init_with_constants_gen T2 +let init_with_parameters_gen tup parameters = + let open Lwt_result_syntax in + let n = tup_n tup in + let*? bootstrap_accounts, contracts = create_bootstrap_accounts n in + let parameters = Parameters.{parameters with bootstrap_accounts} in + let* blk = Block.genesis_with_parameters parameters in + return (blk, tup_get tup contracts) + +let init_with_parameters_n params n = init_with_parameters_gen (TList n) params + +let init_with_parameters1 = init_with_parameters_gen T1 + +let init_with_parameters2 = init_with_parameters_gen T2 + let default_raw_context () = let open Tezos_protocol_alpha_parameters in let initial_account = Account.new_account () in diff --git a/src/proto_alpha/lib_protocol/test/helpers/context.mli b/src/proto_alpha/lib_protocol/test/helpers/context.mli index 94e7042bf517..75e066a1aca2 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/context.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/context.mli @@ -38,13 +38,26 @@ val get_level : t -> Raw_level.t tzresult build one (in the [Block] case). *) val to_alpha_ctxt : t -> Alpha_context.t tzresult Lwt.t +(** Given a context, returns the list of endorsers charactized by + the [level], the public key hash of the [delegate], its [consensus_key] + and its assigned [slots]. + see {! Plugin.RPC.Validator.t}. *) val get_endorsers : t -> Plugin.RPC.Validators.t list tzresult Lwt.t +(** The 2 first elements of the list returns by [get_endorsers]. *) val get_first_different_endorsers : t -> (Plugin.RPC.Validators.t * Plugin.RPC.Validators.t) tzresult Lwt.t +(** The first element of the list returns by [get_endorsers]. *) val get_endorser : t -> (public_key_hash * Slot.t list) tzresult Lwt.t +(** Given a delegate public key hash [del], and a context [ctxt], + if [del] is in [get_endorsers ctxt] returns the [slots] of [del] otherwise + return [None]. *) +val get_endorser_slot : + t -> public_key_hash -> Slot.t list option tzresult Lwt.t + +(** The [n]th element of the list returns by [get_endorsers]. *) val get_endorser_n : t -> int -> (public_key_hash * Slot.t list) tzresult Lwt.t val get_endorsing_power_for_delegate : @@ -341,6 +354,37 @@ val init_with_constants2 : (Block.t * (Alpha_context.Contract.t * Alpha_context.Contract.t)) tzresult Lwt.t +(** [init_with_parameters_gen tup params] returns an initial block parametrised + with [params] and the implicit contracts corresponding to its bootstrap + accounts. The number of bootstrap accounts, and the structure of the + returned contracts, are specified by the [tup] argument. *) +val init_with_parameters_gen : + (Alpha_context.Contract.t, 'contracts) tup -> + Parameters.t -> + (Block.t * 'contracts) tzresult Lwt.t + +(** [init_with_parameters_n params n] returns an initial block parametrized + with [params] with [n] initialized accounts and the associated implicit + contracts *) +val init_with_parameters_n : + Parameters.t -> + int -> + (Block.t * Alpha_context.Contract.t list) tzresult Lwt.t + +(** [init_with_parameters1 params] returns an initial block parametrized with + [params] with one initialized account and the associated implicit + contract. *) +val init_with_parameters1 : + Parameters.t -> (Block.t * Alpha_context.Contract.t) tzresult Lwt.t + +(** [init_with_parameters2 params] returns an initial block parametrized with + [params] with two initialized accounts and the associated implicit + contracts *) +val init_with_parameters2 : + Parameters.t -> + (Block.t * (Alpha_context.Contract.t * Alpha_context.Contract.t)) tzresult + Lwt.t + (** [default_raw_context] returns a [Raw_context.t] for use in tests below [Alpha_context] *) val default_raw_context : unit -> Raw_context.t tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/dune b/src/proto_alpha/lib_protocol/test/integration/validate/dune index fe89647675a8..6735c7862453 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/dune +++ b/src/proto_alpha/lib_protocol/test/integration/validate/dune @@ -1,8 +1,8 @@ ; This file was automatically generated, do not edit. ; Edit file manifest/main.ml instead. -(executables - (names main test_1m_restriction) +(executable + (name main) (libraries alcotest-lwt tezos-base @@ -10,7 +10,8 @@ qcheck-alcotest tezos-client-alpha tezos-alpha-test-helpers - tezos-base-test-helpers) + tezos-base-test-helpers + tezos-protocol-plugin-alpha) (flags (:standard) -open Tezos_base.TzPervasives @@ -18,14 +19,10 @@ -open Tezos_protocol_alpha -open Tezos_client_alpha -open Tezos_alpha_test_helpers - -open Tezos_base_test_helpers)) + -open Tezos_base_test_helpers + -open Tezos_protocol_plugin_alpha)) (rule (alias runtest) (package tezos-protocol-alpha-tests) (action (run %{dep:./main.exe}))) - -(rule - (alias runtest) - (package tezos-protocol-alpha-tests) - (action (run %{dep:./test_1m_restriction.exe}))) diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/generator_descriptors.ml b/src/proto_alpha/lib_protocol/test/integration/validate/generator_descriptors.ml new file mode 100644 index 000000000000..712a0a7554fc --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/validate/generator_descriptors.ml @@ -0,0 +1,896 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context +open Validate_helpers + +type dbl_endorsement_state = { + temporary : (Block.t * Block.t) option; + slashable_preend : + (Kind.preendorsement operation * Kind.preendorsement operation) list; + slashable_end : (Kind.endorsement operation * Kind.endorsement operation) list; +} + +type state = { + block : Block.t; + pred : Block.t option; + bootstraps : public_key_hash list; + delegates : (public_key_hash * public_key_hash option) list; + voters : Contract.t list; + seed_nonce_to_reveal : (Raw_level.t * Nonce_hash.t) list; + commitments : secret_account list; + protocol_hashes : Protocol_hash.t list; + slashable_bakes : (block_header * block_header) list; + vdf : bool; + dbl_endorsement : dbl_endorsement_state; + manager : Manager.infos; +} + +let init_manager_state bootstraps block = + let open Manager in + let ctxt = + { + block; + bootstraps; + originated_contract = None; + tx_rollup = None; + sc_rollup = None; + zk_rollup = None; + } + in + let accounts = + {sources = []; dest = None; del = None; tx = None; sc = None; zk = None} + in + {ctxt; accounts; flags = all_enabled} + +let init_dbl_endorsement_state = + {temporary = None; slashable_preend = []; slashable_end = []} + +(** Initialize the state according to [state] initialisation + for each operation kind. + + When adding a new operation kind, if such an initialization is + required, it should occur here. *) +let init_state block ~voters ~(bootstraps : Contract.t list) = + let bootstraps = + List.map + (function Contract.Implicit pkh -> pkh | _ -> assert false) + bootstraps + in + { + block; + pred = None; + bootstraps; + delegates = List.map (fun pkh -> (pkh, None)) bootstraps; + voters; + seed_nonce_to_reveal = []; + commitments = []; + protocol_hashes = []; + slashable_bakes = []; + vdf = false; + dbl_endorsement = init_dbl_endorsement_state; + manager = init_manager_state bootstraps block; + } + +type cycle_index = On of int | From of int + +type descriptor = { + parameters : Parameters.t -> Parameters.t; + required_cycle : Parameters.t -> int; + required_block : Parameters.t -> int; + prelude : + cycle_index * (state -> (packed_operation list * state) tzresult Lwt.t); + opt_prelude : + (cycle_index * (state -> (packed_operation list * state) tzresult Lwt.t)) + option; + candidates_generator : state -> packed_operation list tzresult Lwt.t; +} + +(** Each voting period lasts a whole cycle in the generation of valid operations. *) +let voting_context_params params = + let cycles_per_voting_period = 1l in + let constants = Parameters.{params.constants with cycles_per_voting_period} in + {params with constants} + +let ballot_exploration_prelude state = + let open Lwt_result_syntax in + let* ctxt = Context.to_alpha_ctxt (B state.block) in + let blocks_per_cycle = Alpha_context.Constants.blocks_per_cycle ctxt in + let rem = + Int32.rem state.block.Block.header.Block_header.shell.level blocks_per_cycle + in + if rem = 0l then + match state.voters with + | voter :: voters -> + let* prop = Op.proposals (B state.block) voter [get_n protos 0] in + let* props = + List.map_es + (fun voter -> + Op.proposals (B state.block) voter [Protocol_hash.zero]) + voters + in + return (prop :: props, state) + | _ -> assert false + else return ([], state) + +let activate_descriptor = + { + parameters = + (fun params -> + let commitments = + List.map + (fun {blinded_public_key_hash; amount; _} -> + Commitment.{blinded_public_key_hash; amount}) + secrets + in + {params with commitments}); + required_cycle = (fun _params -> 1); + required_block = (fun _params -> 0); + prelude = + (On 1, fun state -> return ([], {state with commitments = secrets})); + opt_prelude = None; + candidates_generator = + (fun state -> + let gen s = + Op.activation (B state.block) (Ed25519 s.account) s.activation_code + in + List.map_es gen state.commitments); + } + +(** During the first voting period in the setup of valid operations generations, + a proposal must win the proposal period -- hence [ballot_exploration_prelude] + takes place during the first cycle. *) +let ballot_exploration_descriptor = + { + parameters = voting_context_params; + required_cycle = + (fun params -> Int32.to_int params.constants.cycles_per_voting_period); + required_block = (fun _params -> 0); + prelude = (On 1, ballot_exploration_prelude); + opt_prelude = None; + candidates_generator = + (fun state -> + let open Lwt_result_syntax in + let gen contract = + let* voting_period_info = + Context.Vote.get_current_period (B state.block) + in + assert (voting_period_info.voting_period.kind = Exploration) ; + let ballot = pick_one ballots in + Op.ballot (B state.block) contract Protocol_hash.zero ballot + in + List.map_es gen state.voters); + } + +let proposal_descriptor = + { + parameters = voting_context_params; + required_cycle = (fun _ -> 0); + required_block = (fun _ -> 0); + prelude = + (On 0, fun state -> return ([], {state with protocol_hashes = protos})); + opt_prelude = None; + candidates_generator = + (fun state -> + let open Lwt_result_syntax in + let gen contract = + let* voting_period_info = + Context.Vote.get_current_period (B state.block) + in + assert (voting_period_info.voting_period.kind = Proposal) ; + Op.proposals (B state.block) contract [Protocol_hash.zero] + in + List.map_es gen state.voters); + } + +(** [Promotion] is the 4th voting period, it requires 3 voting period + to last and be successful. [voting_context_params] set a + voting_period to 1 cycle. To generate a [Ballot] for this + promotion period: + + - the first period should conclude in a proposal wining -- 3 cycles + before generating the [Ballot], the proposal period must succeed:[ + ballot_exploration_prelude], + + - the exploration must conclude in a supermajority for this + proposal -- 2 cycles before generating the [Ballot], the + exploration period must succeed., and + + - the cooldown must last -- 1 cycle before generating the + [Ballot]. *) +let ballot_promotion_descriptor = + { + parameters = voting_context_params; + required_cycle = + (fun params -> 3 * Int32.to_int params.constants.cycles_per_voting_period); + required_block = (fun _ -> 0); + prelude = (On 3, ballot_exploration_prelude); + opt_prelude = + Some + ( On 2, + fun state -> + let open Lwt_result_syntax in + let* ctxt = Context.to_alpha_ctxt (B state.block) in + let blocks_per_cycle = + Alpha_context.Constants.blocks_per_cycle ctxt + in + let rem = + Int32.rem + state.block.Block.header.Block_header.shell.level + blocks_per_cycle + in + if rem = 0l then + let* ops = + List.map_es + (fun voter -> + Op.ballot (B state.block) voter Protocol_hash.zero Vote.Yay) + state.voters + in + return (ops, state) + else return ([], state) ); + candidates_generator = + (fun state -> + let open Lwt_result_syntax in + let gen contract = + let* voting_period_info = + Context.Vote.get_current_period (B state.block) + in + assert (voting_period_info.voting_period.kind = Promotion) ; + let ballot = Stdlib.List.hd ballots in + Op.ballot (B state.block) contract Protocol_hash.zero ballot + in + List.map_es gen state.voters); + } + +let seed_nonce_descriptor = + { + parameters = + (fun params -> + assert (params.constants.blocks_per_cycle > 3l) ; + let blocks_per_commitment = + Int32.(div params.constants.blocks_per_cycle 3l) + in + let constants = {params.constants with blocks_per_commitment} in + {params with constants}); + required_cycle = (fun _ -> 1); + required_block = (fun _ -> 0); + prelude = + ( On 1, + fun state -> + let open Lwt_result_syntax in + let b = state.block in + let* seed_nonce_to_reveal = + match + b.Block.header.Block_header.protocol_data.contents.seed_nonce_hash + with + | None -> return state.seed_nonce_to_reveal + | Some nonce_hash -> + let level = + Raw_level.of_int32_exn b.Block.header.Block_header.shell.level + in + return ((level, nonce_hash) :: state.seed_nonce_to_reveal) + in + return ([], {state with seed_nonce_to_reveal}) ); + opt_prelude = None; + candidates_generator = + (fun state -> + let open Lwt_result_syntax in + let gen (level, nonce_hash) = + assert (List.length state.seed_nonce_to_reveal >= 3) ; + let nonce = + WithExceptions.Option.to_exn ~none:Not_found + @@ Registered_nonces.get nonce_hash + in + return (Op.seed_nonce_revelation (B state.block) level nonce) + in + List.map_es gen state.seed_nonce_to_reveal); + } + +(** The heads on which two slashable endorsements or preendorsement + should be made are from the previous level. Hence, the temporary + field of a double_evidence_state is used to transmit them to the + next level in order to make the slashable operations. *) +let register_temporary ba bb state : (Block.t * Block.t) option * state = + let pred_forks = state.dbl_endorsement.temporary in + let temporary = Some (ba, bb) in + let dbl_endorsement = {state.dbl_endorsement with temporary} in + (pred_forks, {state with dbl_endorsement}) + +(** During the slashable period, at each level, two different heads + for the same round are baked by the same baker. At the next level, + a delegate that either preendorses or endorses both heads makes a + pair of slashable pre- or endorsements. + + The pair of heads is placed in the temporary of the + double_evidence_state. If a pair of heads was already in this + field, hence they were baked at the previous level. + + Consequently, two pairs of slashable operations: two endorsements + and two preendorsement, can be made by two distinct endorsers. Each + pair is ordered in operation_hash order. Consequently, each pair + can appear in a denunciation operation and will be valid. *) +let dbl_endorsement_prelude state = + let open Lwt_result_syntax in + let* head_A = Block.bake ~policy:(By_round 0) state.block in + let* addr = pick_addr_endorser (B state.block) in + let ctr = Contract.Implicit addr in + let* operation = Op.transaction (B state.block) ctr ctr Tez.one_mutez in + let* head_B = Block.bake ~policy:(By_round 0) state.block ~operation in + let heads, state = register_temporary head_A head_B state in + match heads with + | None -> return ([], state) + | Some (b1, b2) -> + let* delegate1, delegate2 = pick_two_endorsers (B b1) in + let* op1 = + Op.preendorsement + ~delegate:delegate1 + ~endorsed_block:b1 + (B state.block) + () + in + let* op2 = + Op.preendorsement + ~delegate:delegate1 + ~endorsed_block:b2 + (B state.block) + () + in + let op1, op2 = + let comp = + Operation_hash.compare (Operation.hash op1) (Operation.hash op2) + in + assert (comp <> 0) ; + if comp < 0 then (op1, op2) else (op2, op1) + in + let slashable_preend = + (op1, op2) :: state.dbl_endorsement.slashable_preend + in + let* op3 = + Op.endorsement ~delegate:delegate2 ~endorsed_block:b1 (B state.block) () + in + let* op4 = + Op.endorsement ~delegate:delegate2 ~endorsed_block:b2 (B state.block) () + in + let op3, op4 = + let comp = + Operation_hash.compare (Operation.hash op3) (Operation.hash op4) + in + assert (comp <> 0) ; + if comp < 0 then (op3, op4) else (op4, op3) + in + let slashable_end = (op3, op4) :: state.dbl_endorsement.slashable_end in + let dbl_endorsement = + {state.dbl_endorsement with slashable_preend; slashable_end} + in + return ([], {state with dbl_endorsement}) + +let double_consensus_descriptor = + { + parameters = Fun.id; + required_cycle = (fun _params -> 2); + required_block = (fun _ -> 0); + prelude = (From 2, dbl_endorsement_prelude); + opt_prelude = None; + candidates_generator = + (fun state -> + let open Lwt_result_syntax in + let gen_dbl_pre (op1, op2) = + Op.double_preendorsement (Context.B state.block) op1 op2 + in + let gen_dbl_end (op1, op2) = + Op.double_endorsement (Context.B state.block) op1 op2 + in + let candidates_pre = + List.map gen_dbl_pre state.dbl_endorsement.slashable_preend + in + let candidates_end = + List.map gen_dbl_end state.dbl_endorsement.slashable_end + in + return (candidates_pre @ candidates_end)); + } + +let double_baking_descriptor = + { + parameters = Fun.id; + required_cycle = (fun params -> params.constants.max_slashing_period); + required_block = (fun _ -> 0); + prelude = + ( From 2, + fun state -> + let open Lwt_result_syntax in + let order_block_header bh1 bh2 = + let hash1 = Block_header.hash bh1 in + let hash2 = Block_header.hash bh2 in + let c = Block_hash.compare hash1 hash2 in + if c < 0 then (bh1, bh2) else (bh2, bh1) + in + let* ctxt = Context.to_alpha_ctxt (B state.block) in + let blocks_per_cycle = + Alpha_context.Constants.blocks_per_cycle ctxt + in + let rem = + Int32.rem + state.block.Block.header.Block_header.shell.level + blocks_per_cycle + in + if rem = 0l then return ([], state) + else + let* baker1, _baker2 = + Context.get_first_different_bakers (B state.block) + in + let* addr = pick_addr_endorser (B state.block) in + let ctr = Contract.Implicit addr in + let* operation = + Op.transaction (B state.block) ctr ctr Tez.one_mutez + in + let* ba = + Block.bake ~policy:(By_account baker1) ~operation state.block + in + let* bb = Block.bake ~policy:(By_account baker1) state.block in + let ba, bb = order_block_header ba.Block.header bb.Block.header in + let slashable_bakes = (ba, bb) :: state.slashable_bakes in + return ([], {state with slashable_bakes}) ); + opt_prelude = None; + candidates_generator = + (fun state -> + let open Lwt_result_syntax in + let gen (bh1, bh2) = + return (Op.double_baking (B state.block) bh1 bh2) + in + List.map_es gen state.slashable_bakes); + } + +(** A drain delegate operation is valid when, preserved_cycle before, the + delegate has updated its key. This key must then has enough fund in order to + be revealed. + + At the first level of preserved cycle in the past, the key is funded by a + bootstrap account. At the second level, it reveals and at the third the + delegate updates its key to this key. *) +let drain_delegate_prelude state = + let open Lwt_result_syntax in + let* ctxt = Context.to_alpha_ctxt (B state.block) in + let blocks_per_cycle = Alpha_context.Constants.blocks_per_cycle ctxt in + let rem = + Int32.rem state.block.Block.header.Block_header.shell.level blocks_per_cycle + in + if rem = 0l then + (* Create (n / 2) consensus keys *) + let delegates = + List.mapi + (fun i -> function + | (delegate, None) as del -> + if i mod 2 = 0 then + let acc = Account.new_account () in + (delegate, Some acc.pkh) + else del + | del -> del (* should not happen but apparently does...*)) + state.delegates + in + let dels = + List.filter_map + (function _del, None -> None | del, Some ck -> Some (del, ck)) + delegates + in + let* ops = + List.fold_left_es + (fun ops (del, ck) -> + let* {Account.pk; _} = Account.find ck in + let* op = + Op.update_consensus_key (B state.block) (Contract.Implicit del) pk + in + return (op :: ops)) + [] + dels + in + let state = {state with delegates} in + return (ops, state) + else return ([], state) + +let drain_delegate_descriptor = + { + parameters = Fun.id; + required_cycle = (fun params -> params.constants.preserved_cycles + 1); + required_block = (fun _ -> 0); + prelude = + (On (init_params.constants.preserved_cycles + 1), drain_delegate_prelude); + opt_prelude = None; + candidates_generator = + (fun state -> + let gen (delegate, consensus_key_opt) = + let open Lwt_result_syntax in + match consensus_key_opt with + | None -> return_none + | Some consensus_key -> + let* op = + Op.drain_delegate + (B state.block) + ~consensus_key + ~delegate + ~destination:consensus_key + in + return_some op + in + List.filter_map_es gen state.delegates); + } + +let vdf_revelation_descriptor = + { + parameters = + (fun params -> + {params with constants = {params.constants with vdf_difficulty = 750L}}); + required_cycle = (fun _ -> 1); + required_block = + (fun params -> Int32.to_int params.constants.nonce_revelation_threshold); + prelude = (On 2, fun state -> return ([], {state with vdf = true})); + opt_prelude = None; + candidates_generator = + (fun state -> + let open Lwt_result_syntax in + let* seed_status = Context.get_seed_computation (B state.block) in + let* csts = Context.get_constants (B state.block) in + match seed_status with + | Nonce_revelation_stage | Computation_finished -> assert false + | Vdf_revelation_stage info -> + (* generate the VDF discriminant and challenge *) + let discriminant, challenge = + Alpha_context.Seed.generate_vdf_setup + ~seed_discriminant:info.seed_discriminant + ~seed_challenge:info.seed_challenge + in + (* compute the VDF solution (the result and the proof ) *) + let solution = + (* generate the result and proof *) + Environment.Vdf.prove + discriminant + challenge + csts.parametric.vdf_difficulty + in + return [Op.vdf_revelation (B state.block) solution]); + } + +let preendorsement_descriptor = + { + parameters = Fun.id; + required_cycle = (fun _ -> 1); + required_block = (fun _ -> 1); + prelude = (On 1, fun state -> return ([], state)); + opt_prelude = None; + candidates_generator = + (fun state -> + let open Lwt_result_syntax in + let gen (delegate, ck_opt) = + let* slots_opt = Context.get_endorser_slot (B state.block) delegate in + let delegate = Option.value ~default:delegate ck_opt in + match (state.pred, slots_opt) with + | None, _ -> assert false + | Some _pred, None -> return_none + | Some pred, Some slots -> + let* op = + Op.preendorsement + ~delegate:(delegate, slots) + ~endorsed_block:state.block + (B pred) + () + in + return_some (Alpha_context.Operation.pack op) + in + List.filter_map_es gen state.delegates); + } + +let endorsement_descriptor = + { + parameters = Fun.id; + required_cycle = (fun _ -> 1); + required_block = (fun _ -> 1); + prelude = (On 1, fun state -> return ([], state)); + opt_prelude = None; + candidates_generator = + (fun state -> + let open Lwt_result_syntax in + let gen (delegate, ck_opt) = + let* slots_opt = Context.get_endorser_slot (B state.block) delegate in + let delegate = Option.value ~default:delegate ck_opt in + match (state.pred, slots_opt) with + | None, _ -> assert false + | Some _pred, None -> return_none + | Some pred, Some slots -> + let* op = + Op.endorsement + ~delegate:(delegate, slots) + ~endorsed_block:state.block + (B pred) + () + in + return_some (Alpha_context.Operation.pack op) + in + List.filter_map_es gen state.delegates); + } + +let dal_slot_availability_descriptor = + { + parameters = + (fun params -> + let dal = {params.constants.dal with feature_enable = true} in + let constants = {params.constants with dal} in + {params with constants}); + required_cycle = (fun _ -> 0); + required_block = (fun _ -> 0); + prelude = (On 1, fun state -> return ([], state)); + opt_prelude = None; + candidates_generator = + (fun state -> + let open Lwt_result_syntax in + let gen (del, _) = + let op = Dal_slot_availability (del, Dal.Endorsement.empty) in + Op.pack_operation (B state.block) None (Single op) + in + return (List.map gen state.delegates)); + } + +module Manager = Manager_operation_helpers + +let required_nb_account = 7 + +(** Convertion from [manager_state] to a {! Manager_operation_helper.infos}. *) +let infos_of_state source block infos : Manager.infos = + let open Manager in + let ({ctxt; accounts; flags} : infos) = infos in + let ctxt : ctxt = {ctxt with block} in + let accounts = {accounts with sources = [source]} in + {ctxt; accounts; flags} + +(** Updating a [manager_state] according to a {! Manager_operation_helper.infos}. *) +let update_state_with_infos {Manager.ctxt; accounts; flags} + {Manager.ctxt = ctxt2; accounts = accounts2; _} = + let ctxt = + { + ctxt with + originated_contract = ctxt2.originated_contract; + tx_rollup = ctxt2.tx_rollup; + sc_rollup = ctxt2.sc_rollup; + zk_rollup = ctxt2.zk_rollup; + } + in + let accounts = + { + accounts with + dest = accounts2.dest; + del = accounts2.del; + tx = accounts2.tx; + sc = accounts2.sc; + zk = accounts2.zk; + } + in + {Manager.ctxt; accounts; flags} + +(** According to a [Manager.infos] and a block [b], create and fund + the required contracts and accounts on [b]. In additions to the + initiation performed by {! Manager_operation_helper.init_infos}, it + registers a list of funded sources. *) +let manager_prelude (infos : Manager.infos) b = + let open Lwt_result_syntax in + let nb_sources = List.length infos.ctxt.bootstraps in + let* ops_by_bootstrap = + List.map_es + (fun bootstrap -> + let bootstrap = Contract.Implicit bootstrap in + let* counter = Context.Contract.counter (B b) bootstrap in + return (bootstrap, counter, [])) + (List.take_n nb_sources infos.ctxt.bootstraps) + in + let add bootstrap counter ops ops_by_bootstrap = + List.map + (fun (bootstrap', counter', ops') -> + if bootstrap' = bootstrap then (bootstrap, Z.succ counter, ops) + else (bootstrap', counter', ops')) + ops_by_bootstrap + in + let batches block ops_by_bootstrap = + List.fold_left_es + (fun acc (source, _counter, operations) -> + match operations with + | [] -> return (List.rev acc) + | _ -> + let* batch = Op.batch_operations ~source (B block) operations in + return (batch :: acc)) + [] + ops_by_bootstrap + in + let create_and_fund sources ops_by_bootstrap = + let account = Account.new_account () in + let n = nb_sources - Stdlib.List.length sources in + let bootstrap, counter, ops = Stdlib.List.nth ops_by_bootstrap (n - 1) in + let amount = Tez.of_mutez (Int64.of_int 150000) in + let+ op, counter = + Manager.fund_account_op b bootstrap account.pkh amount counter + in + (account :: sources, add bootstrap counter (op :: ops) ops_by_bootstrap) + in + let* sources, src_operations = + List.fold_left_es + (fun (acc_accounts, acc_ops) _ -> create_and_fund acc_accounts acc_ops) + ([], ops_by_bootstrap) + (1 -- nb_sources) + in + let* operations = batches b src_operations in + let infos = {infos with accounts = {infos.accounts with sources}} in + let* infos2 = + Manager.init_infos + Manager.ctxt_req_default + b + (List.take_n required_nb_account infos.ctxt.bootstraps) + in + let state = update_state_with_infos infos infos2 in + return (operations, state) + +(** Build a manager operation according to the information in [infos] + on [block] for each source in the [manager_state] guaranteeing + that they are not conflicting. *) +let manager_candidates block infos batch_max_size = + let open Lwt_result_syntax in + let params = + List.map + (fun src -> + let m = gen_bounded_int 1 batch_max_size in + let kd = pick_n m Manager.revealed_subjects in + (src, kd)) + infos.Manager.accounts.sources + in + let gen (source, ks) = + let infos = infos_of_state source block infos in + let* reveal = + Manager.mk_reveal (Manager.operation_req_default Manager.K_Reveal) infos + in + let* operations = + List.map_es + (fun kd -> Manager.select_op (Manager.operation_req_default kd) infos) + ks + in + let* operations = return (reveal :: operations) in + Op.batch_operations + ~recompute_counters:true + ~source:(Contract.Implicit source.pkh) + (B block) + operations + in + List.map_es gen params + +let manager_descriptor max_batch_size nb_accounts = + { + parameters = + (fun params -> + let ctxt_req_default = Manager.ctxt_req_default in + let hard_gas_limit_per_block = + Some (Gas.Arith.integral_of_int_exn ((nb_accounts + 1) * 5_200_000)) + in + let ctxt_req = {ctxt_req_default with hard_gas_limit_per_block} in + Manager.manager_parameters params ctxt_req); + required_cycle = (fun _ -> 1); + required_block = (fun _ -> 1); + prelude = + ( On 1, + fun state -> + let open Lwt_result_syntax in + let* ops, manager = manager_prelude state.manager state.block in + let state = {state with manager} in + return (ops, state) ); + opt_prelude = None; + candidates_generator = + (fun state -> manager_candidates state.block state.manager max_batch_size); + } + +type op_kind = + | KEndorsement + | KPreendorsement + | KDalslotavail + | KBallotExp + | KBallotProm + | KProposals + | KNonce + | KVdf + | KActivate + | KDbl_consensus + | KDbl_baking + | KDrain + | KManager + +let op_kind_of_packed_operation op = + let (Operation_data {contents; _}) = op.protocol_data in + match contents with + | Single (Preendorsement _) -> KPreendorsement + | Single (Endorsement _) -> KEndorsement + | Single (Dal_slot_availability _) -> KDalslotavail + | Single (Seed_nonce_revelation _) -> KNonce + | Single (Vdf_revelation _) -> KVdf + | Single (Double_endorsement_evidence _) -> KDbl_consensus + | Single (Double_preendorsement_evidence _) -> KDbl_consensus + | Single (Double_baking_evidence _) -> KDbl_baking + | Single (Activate_account _) -> KActivate + | Single (Proposals _) -> KProposals + | Single (Ballot _) -> KBallotExp + | Single (Drain_delegate _) -> KDrain + | Single (Manager_operation _) -> KManager + | Cons (Manager_operation _, _) -> KManager + | Single (Failing_noop _) -> assert false + +let pp_op_kind fmt kind = + Format.fprintf + fmt + (match kind with + | KManager -> "manager" + | KEndorsement -> "endorsement" + | KPreendorsement -> "preendorsement" + | KDalslotavail -> "dal_slot" + | KBallotExp -> "ballot" + | KBallotProm -> "ballot" + | KProposals -> "proposals" + | KNonce -> "nonce" + | KVdf -> "vdf_revelation" + | KActivate -> "activate_account" + | KDbl_consensus -> "double_consensus" + | KDbl_baking -> "double_baking" + | KDrain -> "drain_delegate") + +let descriptor_of ~nb_bootstrap ~max_batch_size = function + | KManager -> manager_descriptor max_batch_size nb_bootstrap + | KEndorsement -> endorsement_descriptor + | KPreendorsement -> preendorsement_descriptor + | KDalslotavail -> dal_slot_availability_descriptor + | KBallotExp -> ballot_exploration_descriptor + | KBallotProm -> ballot_promotion_descriptor + | KProposals -> proposal_descriptor + | KNonce -> seed_nonce_descriptor + | KVdf -> vdf_revelation_descriptor + | KActivate -> activate_descriptor + | KDbl_consensus -> double_consensus_descriptor + | KDbl_baking -> double_baking_descriptor + | KDrain -> drain_delegate_descriptor + +let descriptors_of ~nb_bootstrap ~max_batch_size = + List.map (descriptor_of ~nb_bootstrap ~max_batch_size) + +(** A context is in a unique voting period. *) +let voting_kinds = [KProposals; KBallotExp; KBallotProm] + +(** A context either wait for nonce revelation or vdf revelation + but not both at the same time. *) +let nonce_generation_kinds = [KNonce; KVdf] + +(** All kind list, used in the sanity check.*) +let non_exclusive_kinds = + [ + KManager; + KEndorsement; + KPreendorsement; + KDalslotavail; + KActivate; + KDbl_consensus; + KDbl_baking; + KDrain; + ] + +let all_kinds = voting_kinds @ nonce_generation_kinds @ non_exclusive_kinds diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/generator_descriptors.mli b/src/proto_alpha/lib_protocol/test/integration/validate/generator_descriptors.mli new file mode 100644 index 000000000000..df118ca15c6f --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/validate/generator_descriptors.mli @@ -0,0 +1,161 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context +open Validate_helpers + +(** {2 Generation state} *) + +(** The state to generate valid double pre- and endorsement evidence + contains a temporary state for making the slashable evidence, and + the lists of slashables operations, one for each kind: + preendorsement and endorsement. *) +type dbl_endorsement_state = { + temporary : (Block.t * Block.t) option; + slashable_preend : + (Kind.preendorsement operation * Kind.preendorsement operation) list; + slashable_end : (Kind.endorsement operation * Kind.endorsement operation) list; +} + +(** Generic generation state collecting + information to generate any kind of operation. + + For example, {!Manager.infos} for manager + or voters (Contract.t list) for voting operations... + + When adding a new operation kind, [state] might be extended if a + new kind of information is required for this new kind valid + operations generation. *) +type state = { + block : Block.t; + pred : Block.t option; + bootstraps : public_key_hash list; + delegates : (public_key_hash * public_key_hash option) list; + voters : Contract.t list; + seed_nonce_to_reveal : (Raw_level.t * Nonce_hash.t) list; + commitments : secret_account list; + protocol_hashes : Protocol_hash.t list; + slashable_bakes : (block_header * block_header) list; + vdf : bool; + dbl_endorsement : dbl_endorsement_state; + manager : Manager.infos; +} + +(** The initialization of a [state] requires the [voters] contracts -- + the contracts allowed to vote -- and the [bootstraps] contracts. *) +val init_state : + Block.t -> voters:Contract.t list -> bootstraps:Contract.t list -> state + +(** {2 Descriptor for valid operations generation} *) + +(** Each prelude action either takes place on a specific cycle or + from a specific cycle to the end a the context setting. *) +type cycle_index = On of int | From of int + +(** Descriptors are specific to operation kinds, [op_kind]. A + descriptor provides the information and functions used in the + context setup to generate valid operations of its kind and a + generator for such operations. + + - [parameters] enables setting constants in the initial context. + + - [required_cycle] is the number of cycles in the context setup + before generating valid operations of this kind. + + - [required_block] the number of blocks in the last cycle. + + - [prelude] is a set of actions that either gather information in + the setup [state] or perform operations in the setup blocks or both + that have to be performed according to a [cycle_index]. + + - [opt_prelude] is an optional prelude. + + - [candidates_generator] generates operations of the descriptor + [op_kind] according to the information in [state] that are valid + upon [state.block]. *) +type descriptor = { + parameters : Parameters.t -> Parameters.t; + required_cycle : Parameters.t -> int; + required_block : Parameters.t -> int; + prelude : + cycle_index * (state -> (packed_operation list * state) tzresult Lwt.t); + opt_prelude : + (cycle_index * (state -> (packed_operation list * state) tzresult Lwt.t)) + option; + candidates_generator : state -> packed_operation list tzresult Lwt.t; +} + +(** {2 Operation kinds} *) + +(** When adding a new operation: + - a new op_kind [k] should extend the [op_kind] type, + - a [descriptor] defined, + - [descriptor_of] must associate this new descriptor to [k], + - [k] must be added to [all_kinds], + - If the validity of [k] operations is not exclusive with the + validity of other [op_kind], [k] must be added to + [non_exclusive_kinds]. Otherwise, see, for example, how voting + operation op_kinds are handled in {! test_covalidity.tests}. *) +type op_kind = + | KEndorsement + | KPreendorsement + | KDalslotavail + | KBallotExp + | KBallotProm + | KProposals + | KNonce + | KVdf + | KActivate + | KDbl_consensus + | KDbl_baking + | KDrain + | KManager + +val pp_op_kind : Format.formatter -> op_kind -> unit + +(** This sanity function returns the [op_kind] associated to + an [packed_operation].*) +val op_kind_of_packed_operation : packed_operation -> op_kind + +(** Associate to each [op_kind] a [descriptor]. Some descriptors are + parametrized by the number of bootstraps and the maximum size of a + batch.*) +val descriptor_of : + nb_bootstrap:int -> max_batch_size:int -> op_kind -> descriptor + +(** Given a list of [op_kind] returns the list of corresponding + descriptors as provided by [descriptor_of] for each [op_kind]. + Some descriptors are parametrized by the number of bootstraps and + the maximum size of a batch.*) +val descriptors_of : + nb_bootstrap:int -> max_batch_size:int -> op_kind list -> descriptor list + +(** List of all [op_kind] that are non exclusive (i.e. no voting +operation kind or nonce revelation kind) *) +val non_exclusive_kinds : op_kind trace + +(** List of all [op_kind] used for sanity check. *) +val all_kinds : op_kind list diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml b/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml index 5ab558db05f0..eb076f547370 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/generators.ml @@ -255,15 +255,16 @@ let gen_ctxt_req : ctxt_cstrs -> ctxt_req QCheck2.Gen.t = (** {2 Wrappers} *) -let wrap ~name ?print ?count ?check ~(gen : 'a QCheck2.Gen.t) +let wrap ~name ?print ?(count = 1) ?check ~(gen : 'a QCheck2.Gen.t) (f : 'a -> bool tzresult Lwt.t) = - Lib_test.Qcheck2_helpers.qcheck_make_result + Lib_test.Qcheck2_helpers.qcheck_make_result_lwt ~name ?print - ?count + ~count ?check + ~extract:Lwt_main.run ~pp_error:pp_print_trace ~gen - (fun a -> Lwt_main.run (f a)) + f let wrap_mode infos op mode = validate_diagnostic ~mode infos op diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/main.ml b/src/proto_alpha/lib_protocol/test/integration/validate/main.ml index 1da1e1a43966..344152d913f9 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/main.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/main.ml @@ -34,20 +34,11 @@ let () = Alcotest_lwt.run "protocol > integration > validate" [ - ("sanity checks", Test_manager_operation_validation.sanity_tests); - ("Single: gas checks", Test_manager_operation_validation.gas_tests); - ("Single: storage checks", Test_manager_operation_validation.storage_tests); - ("Single: fees checks", Test_manager_operation_validation.fee_tests); - ( "Single: contract checks", - Test_manager_operation_validation.contract_tests ); - ( "Batched: contract checks", - Test_batched_manager_operation_validation.contract_tests ); - ( "Batched: gas checks", - Test_batched_manager_operation_validation.gas_tests ); - ( "Batched: fees checks", - Test_batched_manager_operation_validation.fee_tests ); - ( "Flags: feature flag checks", - Test_manager_operation_validation.flags_tests ); - ("Mempool", Test_mempool.tests); + ("sanity checks", Test_sanity.tests); + ("mempool", Test_mempool.tests); + ("single manager validation", Test_manager_operation_validation.tests); + ("batched managers validation", Test_validation_batch.tests); + ("one-manager restriction", Test_1m_restriction.tests); + ("covalidity", Test_covalidity.tests); ] |> Lwt_main.run diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml b/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml index 9d53e38e5063..252a6d87896c 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 @@ -40,7 +40,8 @@ let half_gb_limit = Gas.Arith.(integral_of_int_exn 50_000) (** Context abstraction in a test. *) type ctxt = { block : Block.t; - originated_contract : Contract_hash.t; + bootstraps : public_key_hash list; + originated_contract : Contract_hash.t option; tx_rollup : Tx_rollup.t option; sc_rollup : Sc_rollup.t option; zk_rollup : Zk_rollup.t option; @@ -52,7 +53,7 @@ type ctxt = { impossible case, [source] is used as a dummy value. In some test that requires a second source, [del] will be used as the second source. *) type accounts = { - source : Account.t; + sources : Account.t list; dest : Account.t option; del : Account.t option; tx : Account.t option; @@ -60,9 +61,12 @@ type accounts = { zk : Account.t option; } +(** Feature flags requirements for a context setting for a test. *) +type feature_flags = {dal : bool; scoru : bool; toru : bool; zkru : bool} + (** Infos describes the information of the setting for a test: the context and used accounts. *) -type infos = {ctxt : ctxt; accounts : accounts} +type infos = {ctxt : ctxt; accounts : accounts; flags : feature_flags} (** This type should be extended for each new manager_operation kind added in the protocol. See @@ -112,9 +116,6 @@ type operation_req = { amount : Tez.t option; } -(** Feature flags requirements for a context setting for a test. *) -type feature_flags = {dal : bool; scoru : bool; toru : bool; zkru : bool} - (** The requirements for a context setting for a test. *) type ctxt_req = { hard_gas_limit_per_block : Gas.Arith.integral option; @@ -405,9 +406,8 @@ let originate_zk_rollup block rollup_account = (** {2 Setting's context construction} *) -let fund_account block bootstrap account fund = +let fund_account_op block bootstrap account fund counter = let open Lwt_result_syntax in - let* counter = Context.Contract.counter (B block) bootstrap in let* fund = match fund with | None -> return Tez.one @@ -417,7 +417,7 @@ let fund_account block bootstrap account fund = Lwt.return (Environment.wrap_tzresult Tez.(source_balance -? one)) else return fund in - let* operation = + let+ op = Op.transaction ~counter ~gas_limit:Op.High @@ -426,25 +426,82 @@ let fund_account block bootstrap account fund = (Contract.Implicit account) fund in + (op, Z.succ counter) + +let fund_account block bootstrap account fund = + let open Lwt_result_syntax in + let* counter = Context.Contract.counter (B block) bootstrap in + let* operation, (_counter : counter) = + fund_account_op block bootstrap account fund counter + in let*! b = Block.bake ~operation block in match b with Error _ -> failwith "Funding account error" | Ok b -> return b -(** The generic setting for a test is built up according to a context - requirement. It provides a context and accounts where the accounts - have been created and funded according to the context - requirements.*) -let init_ctxt : ctxt_req -> infos tzresult Lwt.t = - fun { - hard_gas_limit_per_block; - fund_src; - fund_dest; - fund_del; - reveal_accounts; - fund_tx; - fund_sc; - fund_zk; - flags; - } -> +(** Set the constants according to a [ctxt_req] in an existing parameters. *) +let manager_parameters : Parameters.t -> ctxt_req -> Parameters.t = + fun params {hard_gas_limit_per_block; flags; _} -> + let hard_gas_limit_per_block = + match hard_gas_limit_per_block with + | Some gb -> gb + | None -> Gas.Arith.(integral_of_int_exn 5_200_000) + in + let dal = {params.constants.dal with feature_enable = flags.dal} in + let tx_rollup = + { + params.constants.tx_rollup with + sunset_level = Int32.max_int; + enable = flags.toru; + } + in + let sc_rollup = {params.constants.sc_rollup with enable = flags.scoru} in + let zk_rollup = {params.constants.zk_rollup with enable = flags.zkru} in + let constants = + { + params.constants with + hard_gas_limit_per_block; + dal; + tx_rollup; + zk_rollup; + sc_rollup; + } + in + {params with constants} + +(** Initialize a context with the constants extracted from a context requirements + and 7 bootstrap accounts. *) +let init_ctxt_only ctxtreq = + let open Lwt_result_syntax in + let initial_params = + Tezos_protocol_alpha_parameters.Default_parameters.parameters_of_constants + {Context.default_test_constants with consensus_threshold = 0} + in + let* block, contracts = + Context.init_with_parameters_n (manager_parameters initial_params ctxtreq) 7 + in + return + ( block, + List.map + (function Contract.Implicit pkh -> pkh | Originated _ -> assert false) + contracts ) + +(** Build a generic setting for a test according to a context requirement + on an existing context with 7 bootstraps accounts. *) +let init_infos : + ctxt_req -> Block.t -> public_key_hash list -> infos tzresult Lwt.t = + fun ctxtreq block bootstraps -> + let { + fund_src; + fund_dest; + fund_del; + fund_tx; + fund_sc; + fund_zk; + flags; + reveal_accounts; + _; + } = + ctxtreq + in let open Lwt_result_syntax in let create_and_fund ?originate_rollup block bootstrap fund = match fund with @@ -461,18 +518,6 @@ let init_ctxt : ctxt_req -> infos tzresult Lwt.t = in (block, Some account, rollup) in - let* block, bootstraps = - Context.init_n - 7 - ~consensus_threshold:0 - ?hard_gas_limit_per_block - ~tx_rollup_enable:flags.toru - ~tx_rollup_sunset_level:Int32.max_int - ~sc_rollup_enable:flags.scoru - ~dal_enable:flags.dal - ~zk_rollup_enable:flags.zkru - () - in let reveal_accounts_operations b l = List.filter_map_es (function @@ -482,7 +527,9 @@ let init_ctxt : ctxt_req -> infos tzresult Lwt.t = return_some op) l in - let get_bootstrap bootstraps n = Stdlib.List.nth bootstraps n in + let get_bootstrap bootstraps n = + Contract.Implicit (Stdlib.List.nth bootstraps n) + in let source = Account.new_account () in let* block = fund_account block (get_bootstrap bootstraps 0) source.pkh fund_src @@ -534,8 +581,31 @@ let init_ctxt : ctxt_req -> infos tzresult Lwt.t = in let operations = create_contract_hash :: reveal_operations in let+ block = Block.bake ~operations block in - let ctxt = {block; originated_contract; tx_rollup; sc_rollup; zk_rollup} in - {ctxt; accounts = {source; dest; del; tx; sc; zk}} + let ctxt = + { + block; + bootstraps; + originated_contract = Some originated_contract; + tx_rollup; + sc_rollup; + zk_rollup; + } + in + {ctxt; accounts = {sources = [source]; dest; del; tx; sc; zk}; flags} + +(** The generic setting for a test is built up according to a context + requirement. It provides a context and accounts where the accounts + have been created and funded according to the context + requirements.*) +let init_ctxt : ctxt_req -> infos tzresult Lwt.t = + fun ctxtreq -> + let open Lwt_result_syntax in + let* block, bootstraps = init_ctxt_only ctxtreq in + init_infos ctxtreq block bootstraps + +(** return the first source from the list of sources in [infos] accounts. *) +let get_source infos = + match infos.accounts.sources with source :: _ -> source | [] -> assert false (** In addition of building up a context according to a context requirement, source is self-delegated. @@ -545,7 +615,7 @@ let ctxt_with_self_delegation : ctxt_req -> infos tzresult Lwt.t = fun ctxt_req -> let open Lwt_result_syntax in let* infos = init_ctxt ctxt_req in - let+ block = self_delegate infos.ctxt.block infos.accounts.source.pkh in + let+ block = self_delegate infos.ctxt.block (get_source infos).pkh in let ctxt = {infos.ctxt with block} in {infos with ctxt} @@ -562,7 +632,7 @@ 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 infos.accounts.source delegate in + let+ block = delegation infos.ctxt.block (get_source infos) delegate in let ctxt = {infos.ctxt with block} in {infos with ctxt} @@ -588,10 +658,10 @@ let mk_transaction (oinfos : operation_req) (infos : infos) = ?gas_limit:oinfos.gas_limit ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) (contract_of (match infos.accounts.dest with - | None -> infos.accounts.source + | None -> get_source infos | Some dest -> dest)) (match oinfos.amount with None -> Tez.zero | Some amount -> amount) @@ -603,10 +673,10 @@ let mk_delegation (oinfos : operation_req) (infos : infos) = ?counter:oinfos.counter ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) (Some (match infos.accounts.del with - | None -> infos.accounts.source.pkh + | None -> (get_source infos).pkh | Some delegate -> delegate.pkh)) let mk_undelegation (oinfos : operation_req) (infos : infos) = @@ -617,7 +687,7 @@ let mk_undelegation (oinfos : operation_req) (infos : infos) = ?counter:oinfos.counter ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) None let mk_self_delegation (oinfos : operation_req) (infos : infos) = @@ -628,8 +698,8 @@ let mk_self_delegation (oinfos : operation_req) (infos : infos) = ?counter:oinfos.counter ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - (contract_of infos.accounts.source) - (Some infos.accounts.source.pkh) + (contract_of (get_source infos)) + (Some (get_source infos).pkh) let mk_origination (oinfos : operation_req) (infos : infos) = let open Lwt_result_syntax in @@ -642,7 +712,7 @@ let mk_origination (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ~script:Op.dummy_script (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in op @@ -654,7 +724,7 @@ let mk_register_global_constant (oinfos : operation_req) (infos : infos) = ?gas_limit:oinfos.gas_limit ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - ~source:(contract_of infos.accounts.source) + ~source:(contract_of (get_source infos)) ~value:(Script_repr.lazy_expr (Expr.from_string "Pair 1 2")) let mk_set_deposits_limit (oinfos : operation_req) (infos : infos) = @@ -665,7 +735,7 @@ let mk_set_deposits_limit (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?counter:oinfos.counter (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) None let mk_update_consensus_key (oinfos : operation_req) (infos : infos) = @@ -676,12 +746,21 @@ let mk_update_consensus_key (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?counter:oinfos.counter (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) (match infos.accounts.dest with - | None -> infos.accounts.source.pk + | None -> (get_source infos).pk | Some dest -> dest.pk) let mk_increase_paid_storage (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* destination = + match infos.ctxt.originated_contract with + | None -> + failwith + "infos should be initialized with an origniated contract to be able \ + to add an increase_paid_storage operation." + | Some c -> return c + in Op.increase_paid_storage ?force_reveal:oinfos.force_reveal ?counter:oinfos.counter @@ -689,13 +768,13 @@ let mk_increase_paid_storage (oinfos : operation_req) (infos : infos) = ?gas_limit:oinfos.gas_limit ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - ~source:(contract_of infos.accounts.source) - ~destination:infos.ctxt.originated_contract + ~source:(contract_of (get_source infos)) + ~destination Z.one let mk_reveal (oinfos : operation_req) (infos : infos) = let open Lwt_result_syntax in - let* pk = get_pk (B infos.ctxt.block) (contract_of infos.accounts.source) in + let* pk = get_pk (B infos.ctxt.block) (contract_of (get_source infos)) in Op.revelation ?fee:oinfos.fee ?gas_limit:oinfos.gas_limit @@ -714,7 +793,7 @@ let mk_tx_rollup_origination (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in op @@ -741,7 +820,7 @@ let mk_tx_rollup_submit_batch (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) tx_rollup "batch" @@ -763,7 +842,7 @@ let mk_tx_rollup_commit (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) tx_rollup commitement @@ -777,7 +856,7 @@ let mk_tx_rollup_return_bond (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) tx_rollup let mk_tx_rollup_finalize (oinfos : operation_req) (infos : infos) = @@ -790,7 +869,7 @@ let mk_tx_rollup_finalize (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) tx_rollup let mk_tx_rollup_remove_commitment (oinfos : operation_req) (infos : infos) = @@ -803,7 +882,7 @@ let mk_tx_rollup_remove_commitment (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) tx_rollup let mk_tx_rollup_reject (oinfos : operation_req) (infos : infos) = @@ -837,7 +916,7 @@ let mk_tx_rollup_reject (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) tx_rollup Tx_rollup_level.root message @@ -857,19 +936,19 @@ let mk_transfer_ticket (oinfos : operation_req) (infos : infos) = ?gas_limit:oinfos.gas_limit ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - ~source:(contract_of infos.accounts.source) + ~source:(contract_of (get_source infos)) ~contents:(Script.lazy_expr (Expr.from_string "1")) ~ty:(Script.lazy_expr (Expr.from_string "nat")) ~ticketer: (contract_of (match infos.accounts.tx with - | None -> infos.accounts.source + | None -> get_source infos | Some tx -> tx)) ~amount:Ticket_amount.one ~destination: (contract_of (match infos.accounts.dest with - | None -> infos.accounts.source + | None -> get_source infos | Some dest -> dest)) ~entrypoint:Entrypoint.default @@ -884,12 +963,12 @@ let mk_tx_rollup_dispacth_ticket (oinfos : operation_req) (infos : infos) = ticketer = contract_of (match infos.accounts.dest with - | None -> infos.accounts.source + | None -> get_source infos | Some dest -> dest); amount = Tx_rollup_l2_qty.of_int64_exn 10L; claimer = (match infos.accounts.dest with - | None -> infos.accounts.source.pkh + | None -> (get_source infos).pkh | Some dest -> dest.pkh); } in @@ -900,7 +979,7 @@ let mk_tx_rollup_dispacth_ticket (oinfos : operation_req) (infos : infos) = ?gas_limit:oinfos.gas_limit ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - ~source:(contract_of infos.accounts.source) + ~source:(contract_of (get_source infos)) ~message_index:0 ~message_result_path:Tx_rollup_commitment.Merkle.dummy_path tx_rollup @@ -918,7 +997,7 @@ let mk_sc_rollup_origination (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) Sc_rollup.Kind.Example_arith ~boot_sector:"" ~parameters_ty:(Script.lazy_expr (Expr.from_string "1")) @@ -949,7 +1028,7 @@ let mk_sc_rollup_publish (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) sc_rollup sc_dummy_commitment @@ -963,7 +1042,7 @@ let mk_sc_rollup_cement (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) sc_rollup (Sc_rollup.Commitment.hash_uncarbonated sc_dummy_commitment) @@ -980,10 +1059,10 @@ let mk_sc_rollup_refute (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) sc_rollup (match infos.accounts.dest with - | None -> infos.accounts.source.pkh + | None -> (get_source infos).pkh | Some dest -> dest.pkh) (Some refutation) @@ -997,7 +1076,7 @@ let mk_sc_rollup_add_messages (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) sc_rollup [""] @@ -1011,12 +1090,12 @@ let mk_sc_rollup_timeout (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) sc_rollup (Sc_rollup.Game.Index.make - infos.accounts.source.pkh + (get_source infos).pkh (match infos.accounts.dest with - | None -> infos.accounts.source.pkh + | None -> (get_source infos).pkh | Some dest -> dest.pkh)) let mk_sc_rollup_execute_outbox_message (oinfos : operation_req) (infos : infos) @@ -1030,7 +1109,7 @@ let mk_sc_rollup_execute_outbox_message (oinfos : operation_req) (infos : infos) ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) sc_rollup (Sc_rollup.Commitment.hash_uncarbonated sc_dummy_commitment) ~output_proof:"" @@ -1045,7 +1124,7 @@ let mk_sc_rollup_return_bond (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) sc_rollup let mk_dal_publish_slot_header (oinfos : operation_req) (infos : infos) = @@ -1062,7 +1141,7 @@ let mk_dal_publish_slot_header (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) slot let mk_zk_rollup_origination (oinfos : operation_req) (infos : infos) = @@ -1075,7 +1154,7 @@ let mk_zk_rollup_origination (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) ~public_parameters:ZKOperator.public_parameters ~circuits_info: (Zk_rollup.Account.SMap.of_seq @@ -1100,7 +1179,7 @@ let mk_zk_rollup_publish (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) ~zk_rollup ~ops:[(l2_op, None)] in @@ -1146,39 +1225,35 @@ let select_op (op_req : operation_req) (infos : infos) = in mk_op op_req infos -let create_Tztest ?hd_msg test tests_msg operations = - let tl_msg k = - let sk = kind_to_string k in - match hd_msg with - | None -> sk - | Some hd -> Format.sprintf "@[%s, %s@]" hd sk - in - [ - Tztest.tztest (Format.sprintf "@[%s@]" tests_msg) `Quick (fun () -> - List.iter_es - (fun kind -> - Format.printf "%s %s@." tests_msg (tl_msg kind) ; - test kind ()) - operations); - ] - -let create_Tztest_batches test tests_msg operations = - let hdmsg k = Format.sprintf "@[%s@]" (kind_to_string k) in - [ - Tztest.tztest (Format.sprintf "@[%s@]" tests_msg) `Quick (fun () -> - List.iter_es - (fun kind1 -> - List.iter_es - (fun kind2 -> - Format.printf - "%s [%s / %s] @." - tests_msg - (hdmsg kind1) - (hdmsg kind2) ; - test kind1 kind2 ()) - operations) - operations); - ] +let make_tztest ?(fmt = Format.std_formatter) name test subjects info_builder = + let open Lwt_result_syntax in + Tztest.tztest name `Quick (fun () -> + let* infos = info_builder () in + List.iter_es + (fun kind -> + Format.fprintf fmt "%s: %s@." name (kind_to_string kind) ; + test infos kind) + subjects) + +let make_tztest_batched ?(fmt = Format.std_formatter) name test subjects + info_builder = + let open Lwt_result_syntax in + Tztest.tztest name `Quick (fun () -> + let* infos = info_builder () in + List.iter_es + (fun kind1 -> + let k1s = kind_to_string kind1 in + List.iter_es + (fun kind2 -> + Format.fprintf + fmt + "%s: [%s ; %s]@." + name + k1s + (kind_to_string kind2) ; + test infos kind1 kind2) + subjects) + subjects) (** {2 Diagnostic helpers.} *) 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 7d6a1825e2b4..36b57cfa2bd9 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.ml @@ -27,7 +27,8 @@ ------- Component: Protocol (validate manager) Invocation: dune exec \ - src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.exe + src/proto_alpha/lib_protocol/test/integration/validate/main.exe \ + -- test "^one-manager" Subject: 1M restriction in validation of manager operation. *) @@ -35,6 +36,8 @@ open Protocol open Manager_operation_helpers open Generators +let count = 100 + (** Local default values for the tests. *) let ctxt_cstrs_default = { @@ -88,7 +91,7 @@ let print_ops_pair (ctxt_req, op_req, mode) = (** The application of a valid operation succeeds, at least, to perform the fee payment. *) -let positive_validated_op = +let positive_tests = let gen = QCheck2.Gen.triple (Generators.gen_ctxt_req ctxt_cstrs_default) @@ -96,9 +99,9 @@ let positive_validated_op = Generators.gen_mode in wrap - ~count:1000 + ~count ~print:print_one_op - ~name:"Positive validated op" + ~name:"positive validated op" ~gen (fun (ctxt_req, operation_req, mode) -> let open Lwt_result_syntax in @@ -110,7 +113,7 @@ let positive_validated_op = (** Under 1M restriction, neither a block nor a prevalidator's valid pool should contain two operations with the same manager. It raises a Manager_restriction error. *) -let negative_validated_two_ops_of_same_manager = +let two_op_from_same_manager_tests = let gen = QCheck2.Gen.quad (Generators.gen_ctxt_req ctxt_cstrs_default) @@ -133,9 +136,9 @@ let negative_validated_two_ops_of_same_manager = err in wrap - ~count:1000 + ~count ~print:print_two_ops - ~name:"Negative -- 1M" + ~name:"check conflicts between managers." ~gen (fun (ctxt_req, operation_req, operation_req2, mode) -> let open Lwt_result_syntax in @@ -147,7 +150,7 @@ let negative_validated_two_ops_of_same_manager = (** Under 1M restriction, a batch of two operations cannot be replaced by two single operations. *) -let negative_batch_of_two_is_not_two_single = +let batch_is_not_singles_tests = let gen = QCheck2.Gen.triple (Generators.gen_ctxt_req ctxt_cstrs_default) @@ -158,16 +161,16 @@ let negative_batch_of_two_is_not_two_single = in let expect_failure _ = return_unit in wrap - ~count:1000 + ~count ~print:print_ops_pair - ~name:"Batch is not sequence of Single" + ~name:"batch is not sequence of Single" ~gen (fun (ctxt_req, operation_req, mode) -> let open Lwt_result_syntax in let* infos = init_ctxt ctxt_req in let* op1 = select_op (fst operation_req) infos in let* op2 = select_op (snd operation_req) infos in - let source = contract_of infos.accounts.source in + let source = contract_of (get_source infos) in let* batch = Op.batch_operations ~source (B infos.ctxt.block) [op1; op2] in @@ -178,7 +181,7 @@ let negative_batch_of_two_is_not_two_single = (** The applications of two covalid operations in a certain context succeed, at least, to perform the fee payment of both, in whatever application order. *) -let valid_context_free = +let conflict_free_tests = let gen = QCheck2.Gen.quad (Generators.gen_ctxt_req ctxt_cstrs_default) @@ -187,9 +190,9 @@ let valid_context_free = Generators.gen_mode in wrap - ~count:1000 + ~count ~print:print_two_ops - ~name:"Under 1M, co-valid ops commute" + ~name:"under 1M, co-valid ops commute" ~gen (fun (ctxt_req, operation_req, operation_req', mode) -> let open Lwt_result_syntax in @@ -201,10 +204,10 @@ let valid_context_free = accounts = { infos.accounts with - source = + sources = (match infos.accounts.del with | None -> assert false - | Some s -> s); + | Some s -> [s]); }; } in @@ -215,28 +218,11 @@ let valid_context_free = open Lib_test.Qcheck2_helpers -let positive_tests = qcheck_wrap [positive_validated_op] - -let two_op_from_same_manager_tests = - qcheck_wrap [negative_validated_two_ops_of_same_manager] - -let batch_is_not_singles_tests = - qcheck_wrap [negative_batch_of_two_is_not_two_single] - -let conflict_free_tests = qcheck_wrap [valid_context_free] - -let qcheck_tests = ("Positive tests", positive_tests) - -let qcheck_tests2 = - ("Only one manager op per manager", two_op_from_same_manager_tests) - -let qcheck_tests3 = - ("A batch differs from a sequence", batch_is_not_singles_tests) - -let qcheck_tests4 = - ("Fee payment of two covalid operations commute", conflict_free_tests) - -let () = - Alcotest.run - "1M QCheck" - [qcheck_tests; qcheck_tests2; qcheck_tests3; qcheck_tests4] +let tests : (string * [`Quick | `Slow] * (unit -> unit Lwt.t)) trace = + qcheck_wrap_lwt + [ + positive_tests; + two_op_from_same_manager_tests; + batch_is_not_singles_tests; + conflict_free_tests; + ] 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 new file mode 100644 index 000000000000..9d2c613b8d13 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_covalidity.ml @@ -0,0 +1,157 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic-Labs. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: Protocol (validate manager) + Invocation: dune exec \ + src/proto_alpha/lib_protocol/test/integration/validate/main.exe \ + -- test "^covalidity" + Subject: Validation of operation. +*) +open Validate_helpers + +open Generator_descriptors +open Valid_operations_generators +open Protocol +open Alpha_context + +(** Values of number of bootstraps to create.*) + +let default_batch_max_size = 49 + +let default_nb_bootstrap = 7 + +let nb_permutations = 30 + +let op_of_voting_period : Voting_period.kind -> op_kind = + let open Voting_period in + function + | Proposal -> KProposals + | Exploration -> KBallotExp + | Promotion -> KBallotProm + | _ -> assert false + +type seed_gen = Nonce | Vdf + +let pp_seed fmt = function + | Nonce -> Format.fprintf fmt "nonce" + | Vdf -> Format.fprintf fmt "vdf" + +let op_of_seed_gen = function Nonce -> KNonce | Vdf -> KVdf + +let is_not_preendorsement op = + let open Protocol.Alpha_context in + let (Operation_data {contents; _}) = op.protocol_data in + match contents with Single (Preendorsement _) -> false | _ -> true + +module OpkindMap = Map.Make (struct + type t = op_kind + + let compare = compare +end) + +let partition_op_kind op_kinds = + List.fold_left + (fun map op_kind -> + OpkindMap.update + op_kind + (function None -> Some 1 | Some c -> Some (succ c)) + map) + OpkindMap.empty + op_kinds + +let print_candidates candidates = + Format.printf + "@\n@[%d operations generated:@ %a@]@." + (List.length candidates) + Format.( + pp_print_list ~pp_sep:pp_print_cut (fun fmt (op, c) -> + Format.fprintf fmt "%d: %a" c pp_op_kind op)) + (List.map op_kind_of_packed_operation candidates + |> partition_op_kind |> OpkindMap.bindings) + +(** Test that for the set of covalid operations which kinds belongs to [ks] in a + state, any permutation is covalid and can be baked into a valid block. *) +let covalid_permutation_and_bake ks nb_bootstrap = + let open Lwt_result_syntax in + let* state, candidates = + covalid ks ~nb_bootstrap ~max_batch_size:default_batch_max_size + in + print_candidates candidates ; + let* () = sequential_validate state.block candidates in + let rec loop = function + | 0 -> return_unit + | n -> + let operations = + QCheck2.Gen.shuffle_l candidates + |> QCheck2.Gen.generate1 + |> List.sort Protocol.Alpha_context.Operation.compare_by_passes + |> List.rev_filter is_not_preendorsement + in + (* Ensure that we can validate and apply this permutation *) + let* _b = Block.bake state.block ~operations in + loop (pred n) + in + loop nb_permutations + +(** {2 Tests} *) + +let name voting_period reveal = + Format.asprintf + "scenario: '%a' period, '%a' seed" + Voting_period.pp_kind + voting_period + pp_seed + reveal + +(** Test [covalid_permutation_and_bake]. *) +let test_covalid voting_period seed_gen = + Generators.wrap + ~name:(name voting_period seed_gen) + ~gen:QCheck2.Gen.unit + (fun () -> + let open Lwt_result_syntax in + let ks = + op_of_voting_period voting_period + :: op_of_seed_gen seed_gen :: non_exclusive_kinds + in + let* () = covalid_permutation_and_bake ks default_nb_bootstrap in + return_true) + +let tests = + (* Create a list of all permutation of voting period and all + possible nonce generation *) + let voting_periods = [Voting_period.Proposal; Exploration; Promotion] in + let nonce_gens = [Nonce; Vdf] in + List.fold_left + (fun acc voting_period -> + List.fold_left + (fun acc nonce_gen -> test_covalid voting_period nonce_gen :: acc) + acc + nonce_gens) + [] + voting_periods + |> Lib_test.Qcheck2_helpers.qcheck_wrap_lwt diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml b/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml index 5d352f63cd99..2d16cdda3096 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_manager_operation_validation.ml @@ -28,7 +28,7 @@ Component: Protocol (validate manager) Invocation: dune exec \ src/proto_alpha/lib_protocol/test/integration/validate/main.exe \ - -- test "^Single" + -- test "^single" Subject: Validation of manager operation. *) @@ -36,86 +36,6 @@ open Protocol open Alpha_context open Manager_operation_helpers -(** The goal of this test is to ensure that [select_op] generate the - wanted kind of manager operation - - Note: if a new manager operation kind is added in the protocol, - [Manager_operation_helpers.manager_operation_kind] should be - extended. You will also have to extend - [Manager_operation_helpers.select_op] with a new `mk` for this new - operation. Finally the list [Manager_operation_helpers.subjects] - should also be extended to run the validate test on the new manager - operation kind. *) -let ensure_kind infos kind = - let open Lwt_result_syntax in - let* op = - select_op - {(operation_req_default kind) with force_reveal = Some false} - infos - in - let (Operation_data {contents; _}) = op.protocol_data in - match contents with - | Single (Manager_operation {operation; _}) -> ( - match (operation, kind) with - | Transaction _, K_Transaction - | Reveal _, K_Reveal - | Origination _, K_Origination - | Delegation _, K_Delegation - | Delegation _, K_Undelegation - | Delegation _, K_Self_delegation - | Register_global_constant _, K_Register_global_constant - | Set_deposits_limit _, K_Set_deposits_limit - | Update_consensus_key _, K_Update_consensus_key - | Increase_paid_storage _, K_Increase_paid_storage - | 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 - | Zk_rollup_origination _, K_Zk_rollup_origination - | Zk_rollup_publish _, K_Zk_rollup_publish -> - return_unit - | ( ( Transaction _ | Origination _ | Register_global_constant _ - | Delegation _ | Set_deposits_limit _ | Update_consensus_key _ - | Increase_paid_storage _ | Reveal _ | Tx_rollup_origination - | Tx_rollup_submit_batch _ | Tx_rollup_commit _ - | Tx_rollup_return_bond _ | Tx_rollup_finalize_commitment _ - | Tx_rollup_remove_commitment _ | Tx_rollup_dispatch_tickets _ - | Transfer_ticket _ | Tx_rollup_rejection _ | Sc_rollup_originate _ - | Sc_rollup_publish _ | Sc_rollup_cement _ | Sc_rollup_add_messages _ - | Sc_rollup_refute _ | Sc_rollup_timeout _ - | Sc_rollup_execute_outbox_message _ | Sc_rollup_recover_bond _ - | Dal_publish_slot_header _ | Sc_rollup_dal_slot_subscribe _ - | Zk_rollup_origination _ | Zk_rollup_publish _ ), - _ ) -> - assert false) - | Single _ -> assert false - | Cons _ -> assert false - -let ensure_manager_operation_coverage () = - let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - List.iter_es (fun kind -> ensure_kind infos kind) subjects - -let test_ensure_manager_operation_coverage () = - Tztest.tztest - (Format.sprintf "Ensure manager_operation coverage") - `Quick - (fun () -> ensure_manager_operation_coverage ()) - (** {2 Negative tests assert the case where validate must fail} *) (** Validate fails if the gas limit is too low. @@ -142,9 +62,8 @@ let low_gas_limit_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_low_gas_limit kind () = +let test_low_gas_limit infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* op = select_op { @@ -156,12 +75,6 @@ let test_low_gas_limit kind () = in low_gas_limit_diagnostic infos [op] -let generate_low_gas_limit () = - create_Tztest - test_low_gas_limit - "Gas_limit too low." - gas_consumer_in_validate_subjects - (** Validate fails if the gas limit is too high. This test asserts that the validation of a manager operation with @@ -179,9 +92,8 @@ let high_gas_limit_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_high_gas_limit kind () = +let test_high_gas_limit infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* op = select_op { @@ -194,9 +106,6 @@ let test_high_gas_limit kind () = in high_gas_limit_diagnostic infos [op] -let generate_high_gas_limit () = - create_Tztest test_high_gas_limit "Gas_limit too high." subjects - (** Validate fails if the storage limit is too high. This test asserts that a manager operation with a storage limit @@ -215,9 +124,8 @@ let high_storage_limit_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_high_storage_limit kind () = +let test_high_storage_limit infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* op = select_op { @@ -229,9 +137,6 @@ let test_high_storage_limit kind () = in high_storage_limit_diagnostic infos [op] -let generate_high_storage_limit () = - create_Tztest test_high_gas_limit "Storage_limit too high." subjects - (** Validate fails if the counter is in the future. This test asserts that the validation of @@ -252,9 +157,8 @@ let high_counter_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_high_counter kind () = +let test_high_counter infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* op = select_op { @@ -266,9 +170,6 @@ let test_high_counter kind () = in high_counter_diagnostic infos [op] -let generate_high_counter () = - create_Tztest test_high_counter "Counter too high." subjects - (** Validate fails if the counter is in the past. This test asserts that the validation of a manager operation with a @@ -289,13 +190,12 @@ let low_counter_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_low_counter kind () = +let test_low_counter infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* current_counter = Context.Contract.counter (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in let* op = select_op @@ -308,9 +208,6 @@ let test_low_counter kind () = in low_counter_diagnostic infos [op] -let generate_low_counter () = - create_Tztest test_low_counter "Counter too low." subjects - (** Validate fails if the source is not allocated. This test asserts that the validation of a manager operation which @@ -331,22 +228,18 @@ let not_allocated_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_not_allocated kind () = +let test_not_allocated infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* op = select_op {(operation_req_default kind) with force_reveal = Some false} { infos with - accounts = {infos.accounts with source = Account.(new_account ())}; + accounts = {infos.accounts with sources = [Account.(new_account ())]}; } in not_allocated_diagnostic infos [op] -let generate_not_allocated () = - create_Tztest test_not_allocated "Not allocated source." subjects - (** Validate fails if the source is unrevealed. This test asserts that a manager operation with an unrevealed source @@ -368,9 +261,8 @@ let unrevealed_key_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_unrevealed_key kind () = +let test_unrevealed_key infos kind = let open Lwt_result_syntax in - let* infos = init_ctxt {ctxt_req_default with reveal_accounts = false} in let* op = select_op {(operation_req_default kind) with force_reveal = Some false} @@ -378,12 +270,6 @@ let test_unrevealed_key kind () = in unrevealed_key_diagnostic infos [op] -let generate_unrevealed_key () = - create_Tztest - test_unrevealed_key - "Unrevealed source (find_manager_public_key)." - revealed_subjects - (** Validate fails if the source balance is not enough to pay the fees. This test asserts that validation of a manager operation fails if the @@ -405,9 +291,8 @@ let high_fee_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_high_fee kind () = +let test_high_fee infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let*? fee = Tez.(one +? one) |> Environment.wrap_tzresult in let* op = select_op @@ -420,9 +305,6 @@ let test_high_fee kind () = in high_fee_diagnostic infos [op] -let generate_tests_high_fee () = - create_Tztest test_high_fee "Balance too low for fee payment." subjects - (** Validate fails if the fee payment empties the balance of a delegated implicit contract. @@ -447,13 +329,12 @@ let emptying_delegated_implicit_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_emptying_delegated_implicit kind () = +let test_empty_implicit infos kind = let open Lwt_result_syntax in - let* infos = default_ctxt_with_delegation () in let* fee = Context.Contract.balance (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in let* op = select_op @@ -466,12 +347,6 @@ let test_emptying_delegated_implicit kind () = in emptying_delegated_implicit_diagnostic infos [op] -let generate_tests_emptying_delegated_implicit () = - create_Tztest - test_emptying_delegated_implicit - "Just enough funds to empty a delegated source." - revealed_subjects - (** Validate fails if there is not enough available gas in the block. This test asserts that validate fails with: @@ -504,12 +379,8 @@ let exceeding_block_gas_diagnostic ~mode (infos : infos) op = in validate_ko_diagnostic infos op expect_failure ~mode -let test_exceeding_block_gas ~mode kind () = +let test_exceeding_block_gas ~mode infos kind = let open Lwt_result_syntax in - let ctxt_req = - {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} - in - let* infos = init_ctxt ctxt_req in let* operation = select_op { @@ -524,18 +395,6 @@ let test_exceeding_block_gas ~mode kind () = in exceeding_block_gas_diagnostic ~mode infos [operation] -let generate_tests_exceeding_block_gas () = - create_Tztest - (test_exceeding_block_gas ~mode:Construction) - "Too much gas consumption." - subjects - -let generate_tests_exceeding_block_gas_mp_mode () = - create_Tztest - (test_exceeding_block_gas ~mode:Mempool) - "Too much gas consumption in mempool mode." - subjects - (** {2 Positive tests} *) (** Tests that validate succeeds when: @@ -561,14 +420,33 @@ let generate_tests_exceeding_block_gas_mp_mode () = - the balance is at least decreased by fee, - the available gas in the block decreased by gas limit. *) +(** Fee payment*) +let test_validate infos kind = + let open Lwt_result_syntax in + let* counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of (get_source infos)) + in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + counter = Some counter; + } + infos + in + let* _ = validate_diagnostic infos [op] in + return_unit + (** Fee payment that emptying a self_delegated implicit. *) -let test_emptying_self_delegated_implicit kind () = +let test_emptying_self_delegate infos kind = let open Lwt_result_syntax in - let* infos = default_ctxt_with_self_delegation () in let* fee = Context.Contract.balance (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in let* op = select_op @@ -582,12 +460,6 @@ let test_emptying_self_delegated_implicit kind () = let* _ = only_validate_diagnostic infos [op] in return_unit -let generate_tests_emptying_self_delegated_implicit () = - create_Tztest - test_emptying_self_delegated_implicit - "Validate and empties a self-delegated source." - subjects - (** Minimum gas cost to pass the validation: - cost_of_manager_operation for the generic part - 100 (empiric) for the specific part (script decoding or hash costs) *) @@ -595,13 +467,12 @@ let empiric_minimal_gas_cost_for_validate = Gas.Arith.integral_of_int_exn (Michelson_v1_gas.Internal_for_tests.int_cost_of_manager_operation + 100) -let test_emptying_undelegated_implicit kind () = +let test_empty_undelegate infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* fee = Context.Contract.balance (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in let* op = select_op @@ -616,15 +487,9 @@ let test_emptying_undelegated_implicit kind () = let* _ = only_validate_diagnostic infos [op] in return_unit -let generate_tests_emptying_undelegated_implicit () = - create_Tztest - test_emptying_undelegated_implicit - "Validate and empties an undelegated source." - subjects - (** No gas consumer with the minimal gas limit for manager operations passes validate. *) -let test_low_gas_limit_no_consumer kind () = +let test_low_gas_limit_no_consumer kind = let open Lwt_result_syntax in let* infos = default_init_ctxt () in let* op = @@ -638,36 +503,6 @@ let test_low_gas_limit_no_consumer kind () = in validate_diagnostic infos [op] -let generate_low_gas_limit_no_consumer () = - create_Tztest - test_low_gas_limit - "passes validate with minimal gas limit for manager operations." - gas_consumer_in_validate_subjects - -(** Fee payment.*) -let test_validate kind () = - let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let* counter = - Context.Contract.counter - (B infos.ctxt.block) - (contract_of infos.accounts.source) - in - let* op = - select_op - { - (operation_req_default kind) with - force_reveal = Some true; - counter = Some counter; - } - infos - in - let* _ = validate_diagnostic infos [op] in - return_unit - -let generate_tests_validate () = - create_Tztest test_validate "Validate." subjects - (* Feature flags.*) (* Select the error according to the positionned flag. @@ -707,26 +542,12 @@ let flag_expect_failure flags errs = In order to forge Toru, Scoru or Dal operation when the correspondong feature is disable, we use a [infos_op] with default requirements, so that we have a Tx_rollup.t and a Sc_rollup.t. *) -let test_feature_flags flags kind () = +let test_feature_flags infos kind = let open Lwt_result_syntax in - let* infos_op = default_init_ctxt () in - let* infos = default_init_with_flags flags in - let infos = - { - infos with - ctxt = - { - infos.ctxt with - tx_rollup = infos_op.ctxt.tx_rollup; - sc_rollup = infos_op.ctxt.sc_rollup; - zk_rollup = infos_op.ctxt.zk_rollup; - }; - } - in let* counter = Context.Contract.counter (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in let* op = select_op @@ -736,7 +557,8 @@ let test_feature_flags flags kind () = } infos in - let* _ = + let flags = infos.flags in + let* () = if is_disabled flags kind then validate_ko_diagnostic infos [op] (flag_expect_failure flags) else @@ -745,51 +567,66 @@ let test_feature_flags flags kind () = in return_unit -let generate_dal_flag () = - create_Tztest - (test_feature_flags disabled_dal) - "Validate with dal disabled." - subjects - -let generate_scoru_flag () = - create_Tztest - (test_feature_flags disabled_scoru) - "Validate with scoru disabled." - subjects - -let generate_toru_flag () = - create_Tztest - (test_feature_flags disabled_toru) - "Validate with toru disabled." - subjects - -let generate_zkru_flag () = - create_Tztest - (test_feature_flags disabled_zkru) - "Validate with zkru disabled." - subjects - -let sanity_tests = - test_ensure_manager_operation_coverage () :: generate_tests_validate () - -let gas_tests = - generate_low_gas_limit () @ generate_high_gas_limit () - @ generate_tests_exceeding_block_gas () - @ generate_tests_exceeding_block_gas_mp_mode () - @ generate_low_gas_limit_no_consumer () - -let storage_tests = generate_high_storage_limit () - -let fee_tests = - generate_tests_high_fee () - @ generate_tests_emptying_delegated_implicit () - @ generate_tests_emptying_self_delegated_implicit () - @ generate_tests_emptying_undelegated_implicit () - -let contract_tests = - generate_high_counter () @ generate_low_counter () @ generate_not_allocated () - @ generate_unrevealed_key () - -let flags_tests = - generate_dal_flag () @ generate_toru_flag () @ generate_scoru_flag () - @ generate_zkru_flag () +let tests = + let mk_default () = default_init_ctxt () in + let mk_reveal () = + init_ctxt {ctxt_req_default with reveal_accounts = false} + in + let mk_deleg () = default_ctxt_with_delegation () in + let mk_gas () = + init_ctxt {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} + in + let mk_self_deleg () = default_ctxt_with_self_delegation () in + let mk_flags flags () = + let open Lwt_result_syntax in + let* infos_op = default_init_ctxt () in + let* infos = default_init_with_flags flags in + let infos = + { + infos with + ctxt = + { + infos.ctxt with + tx_rollup = infos_op.ctxt.tx_rollup; + sc_rollup = infos_op.ctxt.sc_rollup; + zk_rollup = infos_op.ctxt.zk_rollup; + }; + } + in + return infos + in + let all = subjects in + let gas_consum = gas_consumer_in_validate_subjects in + let revealed = revealed_subjects in + List.map + (fun (name, f, subjects, info_builder) -> + make_tztest name f subjects info_builder) + [ + (* Expected validation failure *) + ("gas limit too low", test_low_gas_limit, gas_consum, mk_default); + ("gas limit too high", test_high_gas_limit, all, mk_default); + ("storage limit too high", test_high_storage_limit, all, mk_default); + ("counter too high", test_high_counter, all, mk_default); + ("counter too low", test_low_counter, all, mk_default); + ("unallocated source", test_not_allocated, all, mk_default); + ("unrevealed source", test_unrevealed_key, revealed, mk_reveal); + ("balance too low for fee payment", test_high_fee, all, mk_default); + ("empty delegate source", test_empty_implicit, revealed, mk_deleg); + ( "too much gas consumption in block", + test_exceeding_block_gas ~mode:Construction, + all, + mk_gas ); + (* Expected validation success *) + ("fees are taken when valid", test_validate, all, mk_default); + ("empty self-delegate", test_emptying_self_delegate, all, mk_self_deleg); + ( "too much gas consumption in mempool", + test_exceeding_block_gas ~mode:Mempool, + all, + mk_gas ); + ("empty undelegated source", test_empty_undelegate, all, mk_default); + ("minimal gas for manager", test_low_gas_limit, gas_consum, mk_default); + ("check dal disabled", test_feature_flags, all, mk_flags disabled_dal); + ("check toru disabled", test_feature_flags, all, mk_flags disabled_toru); + ("check scoru disabled", test_feature_flags, all, mk_flags disabled_scoru); + ("check zkru disabled", test_feature_flags, all, mk_flags disabled_zkru); + ] diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/test_sanity.ml b/src/proto_alpha/lib_protocol/test/integration/validate/test_sanity.ml new file mode 100644 index 000000000000..98dedeb3932a --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_sanity.ml @@ -0,0 +1,175 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic-Labs. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: Protocol (validate manager) + Invocation: dune exec \ + src/proto_alpha/lib_protocol/test/integration/validate/main.exe \ + -- test "sanity checks" + Subject: Validation of operation. +*) + +open Protocol +open Alpha_context +open Manager_operation_helpers + +(** The goal of this test is to ensure that [select_op] generate the + wanted kind of manager operation + + Note: if a new manager operation kind is added in the protocol, + [Manager_operation_helpers.manager_operation_kind] should be + extended. You will also have to extend + [Manager_operation_helpers.select_op] with a new `mk` for this new + operation. Finally the list [Manager_operation_helpers.subjects] + should also be extended to run the validate test on the new manager + operation kind. *) +let ensure_kind infos kind = + let open Lwt_result_syntax in + let* op = + select_op + {(operation_req_default kind) with force_reveal = Some false} + infos + in + let (Operation_data {contents; _}) = op.protocol_data in + match contents with + | Single (Manager_operation {operation; _}) -> ( + match (operation, kind) with + | Transaction _, K_Transaction + | Reveal _, K_Reveal + | Origination _, K_Origination + | Delegation _, K_Delegation + | Delegation _, K_Undelegation + | Delegation _, K_Self_delegation + | Register_global_constant _, K_Register_global_constant + | Set_deposits_limit _, K_Set_deposits_limit + | Update_consensus_key _, K_Update_consensus_key + | Increase_paid_storage _, K_Increase_paid_storage + | 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 + | Zk_rollup_origination _, K_Zk_rollup_origination + | Zk_rollup_publish _, K_Zk_rollup_publish -> + return_unit + | ( ( Transaction _ | Origination _ | Register_global_constant _ + | Delegation _ | Set_deposits_limit _ | Update_consensus_key _ + | Increase_paid_storage _ | Reveal _ | Tx_rollup_origination + | Tx_rollup_submit_batch _ | Tx_rollup_commit _ + | Tx_rollup_return_bond _ | Tx_rollup_finalize_commitment _ + | Tx_rollup_remove_commitment _ | Tx_rollup_dispatch_tickets _ + | Transfer_ticket _ | Tx_rollup_rejection _ | Sc_rollup_originate _ + | Sc_rollup_publish _ | Sc_rollup_cement _ | Sc_rollup_add_messages _ + | Sc_rollup_refute _ | Sc_rollup_timeout _ + | Sc_rollup_execute_outbox_message _ | Sc_rollup_recover_bond _ + | Dal_publish_slot_header _ | Sc_rollup_dal_slot_subscribe _ + | Zk_rollup_origination _ | Zk_rollup_publish _ ), + _ ) -> + assert false) + | Single _ -> assert false + | Cons _ -> assert false + +let ensure_manager_operation_coverage () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + List.iter_es (fun kind -> ensure_kind infos kind) subjects + +open Generator_descriptors +open Valid_operations_generators + +(** This test ensures that it exists a valid operation generator for + each operation. + + Note: When adding a new operation, one should refer to {! + Generator_descriptor} to see how to add its valid operation + generator. *) +let covalidation_sanity () = + let open Lwt_result_syntax in + let max_batch_size = 1 in + let nb_bootstrap = 7 in + List.iter_es + (fun kind -> + let* _, candidates = covalid [kind] ~nb_bootstrap ~max_batch_size in + match List.hd candidates with + | None -> + failwith "no candidates was generated for kind '%a'" pp_op_kind kind + | Some {protocol_data = Operation_data {contents; _}; _} -> ( + match (contents, kind) with + | Single (Preendorsement _), KPreendorsement -> return_unit + | Single (Preendorsement _), _ -> assert false + | Single (Endorsement _), KEndorsement -> return_unit + | Single (Endorsement _), _ -> assert false + | Single (Dal_slot_availability _), KDalslotavail -> return_unit + | Single (Dal_slot_availability _), _ -> assert false + | Single (Seed_nonce_revelation _), KNonce -> return_unit + | Single (Seed_nonce_revelation _), _ -> assert false + | Single (Vdf_revelation _), KVdf -> return_unit + | Single (Vdf_revelation _), _ -> assert false + | Single (Double_endorsement_evidence _), KDbl_consensus -> + return_unit + | Single (Double_endorsement_evidence _), _ -> assert false + | Single (Double_preendorsement_evidence _), KDbl_consensus -> + return_unit + | Single (Double_preendorsement_evidence _), _ -> assert false + | Single (Double_baking_evidence _), KDbl_baking -> return_unit + | Single (Double_baking_evidence _), _ -> assert false + | Single (Activate_account _), KActivate -> return_unit + | Single (Activate_account _), _ -> assert false + | Single (Proposals _), KProposals -> return_unit + | Single (Proposals _), _ -> assert false + | Single (Ballot _), (KBallotExp | KBallotProm) -> return_unit + | Single (Ballot _), _ -> assert false + | Single (Drain_delegate _), KDrain -> return_unit + | Single (Drain_delegate _), _ -> assert false + | Single (Manager_operation _), KManager + | Cons (Manager_operation _, _), KManager -> + return_unit + | Single (Manager_operation _), _ | Cons (Manager_operation _, _), _ + -> + assert false + | Single (Failing_noop _), _ -> assert false)) + all_kinds + +let tests = + List.map + (fun (name, f) -> Tztest.tztest name `Quick f) + [ + ("manager operation coverage", ensure_manager_operation_coverage); + ("covalidation coverage", covalidation_sanity); + ] diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml b/src/proto_alpha/lib_protocol/test/integration/validate/test_validation_batch.ml similarity index 82% rename from src/proto_alpha/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml rename to src/proto_alpha/lib_protocol/test/integration/validate/test_validation_batch.ml index b97bdf5e1641..4709f1fffb50 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/test_validation_batch.ml @@ -28,7 +28,7 @@ Component: Protocol (validate manager) Invocation: dune exec \ src/proto_alpha/lib_protocol/test/integration/validate/main.exe \ - -- test "^Batched" + -- test "^batched" Subject: Validation of batched manager operation. *) @@ -56,13 +56,12 @@ let batch_reveal_in_the_middle_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_batch_reveal_in_the_middle kind1 kind2 () = +let batch_in_the_middle infos kind1 kind2 = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* counter = Context.Contract.counter (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in let counter = Z.succ counter in let* operation1 = @@ -97,18 +96,12 @@ let test_batch_reveal_in_the_middle kind1 kind2 () = let* batch = Op.batch_operations ~recompute_counters:false - ~source:(contract_of infos.accounts.source) + ~source:(contract_of (get_source infos)) (Context.B infos.ctxt.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 only occur at the beginning of a batch." - revealed_subjects - (** A batch of manager operation contains at most one Revelation.*) let batch_two_reveals_diagnostic (infos : infos) op = let expected_failure errs = @@ -126,13 +119,12 @@ let batch_two_reveals_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expected_failure -let test_batch_two_reveals kind () = +let batch_two_reveals infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* counter = Context.Contract.counter (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in let counter = Z.succ counter in let* reveal = @@ -167,18 +159,12 @@ let test_batch_two_reveals kind () = let* batch = Op.batch_operations ~recompute_counters:false - ~source:(contract_of infos.accounts.source) + ~source:(contract_of (get_source infos)) (Context.B infos.ctxt.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 - (** Every manager operation in a batch concerns the same source.*) let batch_two_sources_diagnostic (infos : infos) op = let expect_failure errs = @@ -194,10 +180,9 @@ let batch_two_sources_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_batch_two_sources kind1 kind2 () = +let batch_two_sources infos kind1 kind2 = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let source = contract_of infos.accounts.source in + let source = contract_of (get_source infos) in let* counter = Context.Contract.counter (B infos.ctxt.block) source in let counter = Z.succ counter in let* operation1 = @@ -213,7 +198,7 @@ let test_batch_two_sources kind1 kind2 () = let source2 = match infos.accounts.del with None -> assert false | Some s -> s in - {infos with accounts = {infos.accounts with source = source2}} + {infos with accounts = {infos.accounts with sources = [source2]}} in let* operation2 = select_op @@ -229,18 +214,11 @@ let test_batch_two_sources kind1 kind2 () = in batch_two_sources_diagnostic infos [batch] -let generate_batches_two_sources () = - create_Tztest_batches - test_batch_two_sources - "Only one source per batch." - revealed_subjects - (** Counters in a batch should be a sequence from the successor of the stored counter associated to source in the initial context. *) -let test_batch_inconsistent_counters kind1 kind2 () = +let batch_incons_counters infos kind1 kind2 = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let source = contract_of infos.accounts.source in + let source = contract_of (get_source infos) in let* counter = Context.Contract.counter (B infos.ctxt.block) source in let fee = Some Tez.one_mutez in let op_infos = operation_req_default K_Reveal in @@ -327,18 +305,11 @@ let test_batch_inconsistent_counters kind1 kind2 () = 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 batch_emptying_balance_in_the_middle infos kind1 kind2 = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let source = contract_of infos.accounts.source in + let source = contract_of (get_source infos) in let* counter = Context.Contract.counter (B infos.ctxt.block) source in let* init_bal = Context.Contract.balance (B infos.ctxt.block) source in let counter = counter in @@ -393,120 +364,11 @@ let test_batch_emptying_balance_in_the_middle kind1 kind2 () = 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 - -(** A batch of manager operation must not exceed the initial available gas in the block. *) -let test_batch_exceeding_block_gas ~mempool_mode kind1 kind2 () = - let open Lwt_result_syntax in - let ctxt_req = - {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} - in - let* infos = init_ctxt ctxt_req in - let source = contract_of infos.accounts.source in - let* counter = Context.Contract.counter (B infos.ctxt.block) source in - let g_limit = Gas.Arith.add gb_limit Gas.Arith.(integral_of_int_exn 1) in - let half_limit = - Gas.Arith.add half_gb_limit Gas.Arith.(integral_of_int_exn 1) - in - let* reveal = - mk_reveal - {(operation_req_default K_Reveal) with counter = Some counter} - infos - in - let counter = Z.succ counter in - let operation gas_limit = - select_op - { - (operation_req_default kind1) with - force_reveal = Some false; - counter = Some counter; - gas_limit = Some (Custom_gas gas_limit); - } - infos - in - let counter = Z.succ counter in - let operation2 gas_limit = - select_op - { - (operation_req_default kind2) with - force_reveal = Some false; - counter = Some counter; - gas_limit = Some (Custom_gas gas_limit); - } - infos - in - let* op_case1 = operation g_limit in - let* op2_case1 = operation2 Gas.Arith.zero in - let* op_case2 = operation half_limit in - let* op2_case2 = operation2 g_limit in - let* op_case3 = operation half_limit in - let* op2_case3 = operation2 half_limit in - let* case1 = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [reveal; op_case1; op2_case1] - in - let* case3 = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [reveal; op_case3; op2_case3] - in - let* case2 = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [reveal; op_case2; op2_case2] - in - let* i = Incremental.begin_construction infos.ctxt.block ~mempool_mode in - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Gas.Block_quota_exceeded] - when not mempool_mode -> - return_unit - | [ - Environment.Ecoproto_error Gas.Gas_limit_too_high; - Environment.Ecoproto_error Gas.Block_quota_exceeded; - ] - when mempool_mode -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - let* _ = Incremental.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 - (** A batch that consumes all the balance for fees only at the end of the batch passes validate.*) -let test_batch_balance_just_enough kind1 kind2 () = +let batch_empty_at_end infos kind1 kind2 = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let source = contract_of infos.accounts.source in + let source = contract_of (get_source infos) in let* counter = Context.Contract.counter (B infos.ctxt.block) source in let* init_bal = Context.Contract.balance (B infos.ctxt.block) source in let*? half_init_bal = Environment.wrap_tzresult @@ Tez.(init_bal /? 2L) in @@ -559,17 +421,10 @@ let test_batch_balance_just_enough kind1 kind2 () = let* _ = validate_diagnostic infos [case3] in return_unit -let generate_batches_balance_just_enough () = - create_Tztest_batches - test_batch_balance_just_enough - "Fee payment emptying balance in a batch." - revealed_subjects - (** Simple reveal followed by a transaction. *) -let test_batch_reveal_transaction_ok () = +let batch_reveal_transaction infos = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let source = contract_of infos.accounts.source in + let source = contract_of (get_source infos) in let* counter = Context.Contract.counter (B infos.ctxt.block) source in let counter = counter in let fee = Tez.one_mutez in @@ -603,22 +458,149 @@ let test_batch_reveal_transaction_ok () = let* _ = validate_diagnostic infos [batch] in return_unit -let contract_tests = - generate_batches_reveal_in_the_middle () - @ generate_tests_batches_two_reveals () - @ generate_batches_two_sources () - @ generate_batches_inconsistent_counters () - @ [ - Tztest.tztest - "Validate a batch with a reveal and a transaction." - `Quick - test_batch_reveal_transaction_ok; +(** A batch of manager operation must not exceed the initial available gas in the block. *) +let batch_exceeding_block_gas ~mempool_mode infos kind1 kind2 = + let open Lwt_result_syntax in + let source = contract_of (get_source infos) in + let* counter = Context.Contract.counter (B infos.ctxt.block) source in + let g_limit = Gas.Arith.add gb_limit Gas.Arith.(integral_of_int_exn 1) in + let half_limit = + Gas.Arith.add half_gb_limit Gas.Arith.(integral_of_int_exn 1) + in + let* reveal = + mk_reveal + {(operation_req_default K_Reveal) with counter = Some counter} + infos + in + let counter = Z.succ counter in + let operation gas_limit = + select_op + { + (operation_req_default kind1) with + force_reveal = Some false; + counter = Some counter; + gas_limit = Some (Custom_gas gas_limit); + } + infos + in + let counter = Z.succ counter in + let operation2 gas_limit = + select_op + { + (operation_req_default kind2) with + force_reveal = Some false; + counter = Some counter; + gas_limit = Some (Custom_gas gas_limit); + } + infos + in + let* op_case1 = operation g_limit in + let* op2_case1 = operation2 Gas.Arith.zero in + let* op_case2 = operation half_limit in + let* op2_case2 = operation2 g_limit in + let* op_case3 = operation half_limit in + let* op2_case3 = operation2 half_limit in + let* case1 = + Op.batch_operations + ~recompute_counters:false + ~source + (Context.B infos.ctxt.block) + [reveal; op_case1; op2_case1] + in + let* case3 = + Op.batch_operations + ~recompute_counters:false + ~source + (Context.B infos.ctxt.block) + [reveal; op_case3; op2_case3] + in + let* case2 = + Op.batch_operations + ~recompute_counters:false + ~source + (Context.B infos.ctxt.block) + [reveal; op_case2; op2_case2] + in + let* i = Incremental.begin_construction infos.ctxt.block ~mempool_mode in + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error Gas.Block_quota_exceeded] + when not mempool_mode -> + return_unit + | [ + Environment.Ecoproto_error Gas.Gas_limit_too_high; + Environment.Ecoproto_error Gas.Block_quota_exceeded; ] + when mempool_mode -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + let* _ = Incremental.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 gas_tests = - generate_batches_exceeding_block_gas () - @ generate_batches_exceeding_block_gas_mp_mode () +let make_tztest_batched ?(fmt = Format.std_formatter) name test subjects + info_builder = + let open Lwt_result_syntax in + Tztest.tztest name `Quick (fun () -> + let* infos = info_builder () in + List.iter_es + (fun kind1 -> + let k1s = kind_to_string kind1 in + List.iter_es + (fun kind2 -> + Format.fprintf + fmt + "%s: [%s ; %s]@." + name + k1s + (kind_to_string kind2) ; + test infos kind1 kind2) + subjects) + subjects) -let fee_tests = - generate_batches_emptying_balance_in_the_middle () - @ generate_batches_balance_just_enough () +let tests = + let open Lwt_result_syntax in + let mk_default () = default_init_ctxt () in + let mk_high_gas_limit () = + init_ctxt {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} + in + let revealed = revealed_subjects in + [ + ( Tztest.tztest "batch reveal and transaction" `Quick @@ fun () -> + let* infos = mk_default () in + batch_reveal_transaction infos ); + ] + @ List.map + (fun (name, f, subjects, info_builder) -> + make_tztest name f subjects info_builder) + [("batch two reveals", batch_two_reveals, revealed, mk_default)] + @ List.map + (fun (name, f, subjects, info_builder) -> + make_tztest_batched name f subjects info_builder) + [ + ("reveal in the middle", batch_in_the_middle, revealed, mk_default); + ("batch two sources", batch_two_sources, revealed, mk_default); + ("batch incons. counters", batch_incons_counters, revealed, mk_default); + ( "empty balance in middle of batch", + batch_emptying_balance_in_the_middle, + revealed, + mk_default ); + ( "empty balance at end of batch", + batch_empty_at_end, + revealed, + mk_default ); + ( "too much gas consumption", + batch_exceeding_block_gas ~mempool_mode:false, + revealed, + mk_high_gas_limit ); + ( "too much gas consumption (mempool)", + batch_exceeding_block_gas ~mempool_mode:true, + revealed, + mk_high_gas_limit ); + ] diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/valid_operations_generators.ml b/src/proto_alpha/lib_protocol/test/integration/validate/valid_operations_generators.ml new file mode 100644 index 000000000000..7cd493cc7e0d --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/validate/valid_operations_generators.ml @@ -0,0 +1,242 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context +open Generator_descriptors + +(** {2 Building the Setup} *) + +(** Setup for generating valid operation of several kind of + operations. It gathers the following information to setup + {! Generator_descriptor.state} into which valid operations + can be generated: + - [nb_cycles] the total number of cycles to bake, + - [nb_blocks] the number of blocks to bake in the last cycle, + - [params] the constants required, and + - [prelude] that associates to each cycle to bake a list of + {! Generator_descriptors.descriptor} prelude functions. *) +type setup = { + prelude : + (int * (state -> (packed_operation list * state) tzresult Lwt.t) list) list; + nb_cycles : int; + nb_blocks : int; + params : Parameters.t; +} + +(** Select the prelude actions of a specific cycle in a setup prelude. *) +let prelude_on_cycle (c : int) + (actions : + (int * (state -> (packed_operation list * state) tzresult Lwt.t) list) + list) : (state -> (packed_operation list * state) tzresult Lwt.t) list = + match List.filter (fun (c1, _actions) -> c = c1) actions with + | (c1, actions) :: _ -> + assert (c = c1) ; + actions + | [] -> [] + +(** Knowing the total number of required cycles, normalize a prelude + on the list of the pair of a cycle and prelude actions. *) +let normalize_preludes nb_cycles (descr : descriptor) = + let normalize prelude = + match prelude with + | On n, actions -> [(nb_cycles - n, actions)] + | From n, actions -> + List.fold_left + (fun acc i -> acc @ [(nb_cycles - n + i, actions)]) + [] + (1 -- n) + in + let prim = normalize descr.prelude in + match descr.opt_prelude with + | Some prelude -> normalize prelude @ prim + | None -> prim + +(** Insert a normalized prelude in a prelude of a setup.*) +let rec insert_normalize_preludes + ((n, action) : + int * (state -> (packed_operation list * state) tzresult Lwt.t)) + (preludes : + (int * (state -> (packed_operation list * state) tzresult Lwt.t) list) + list) = + match preludes with + | [] -> [(n, [action])] + | (m, actions) :: rest -> + if m = n then (m, actions @ [action]) :: rest + else (m, actions) :: insert_normalize_preludes (n, action) rest + +(** Produce a setup prelude from a list of descriptor and a nb of + cycles*) +let compose_preludes nb_cycles descrs = + let normalized_preludes = List.map (normalize_preludes nb_cycles) descrs in + List.fold_left + (fun acc pre -> + List.fold_left (fun acc pr -> insert_normalize_preludes pr acc) acc pre) + [] + normalized_preludes + +(** Agregate the parameters of several {! Generator_descriptors.descriptor}.*) +let initiated_params descrs nb_accounts = + let consensus_committee_size = nb_accounts in + let initial_params = + Tezos_protocol_alpha_parameters.Default_parameters.parameters_of_constants + { + Context.default_test_constants with + consensus_threshold = 0; + consensus_committee_size; + } + in + let descrs_params = List.map (fun descr -> descr.parameters) descrs in + List.fold_left (fun acc f -> f acc) initial_params descrs_params + +(** Make a [setup] from a list of {! Generator_descriptors.descriptor}. The required number of + cycles and number of blocks in the last cycle are the maximum of + required cycle and number of block in the descriptors list. The + prelude is the composition of the composition of the descriptors + preludes list -- see [compose_preludes]. The parameters are the agregation of the + descriptors parameters -- see [initiated_params]. *) +let setup_of descrs nb_accounts = + let params = initiated_params descrs nb_accounts in + let max_list l = List.fold_left max 0 l in + let required_cycle_list l = + List.map (fun descr -> descr.required_cycle params) l + in + let required_block_list l = + List.map (fun descr -> descr.required_block params) l + in + let sorted_descrs = + List.sort + (fun pre1 pre2 -> + Int.compare (pre1.required_cycle params) (pre2.required_cycle params)) + descrs + in + let nb_cycles = max_list (required_cycle_list descrs) in + let nb_blocks = max_list (required_block_list descrs) in + let prelude = compose_preludes nb_cycles sorted_descrs in + {prelude; nb_cycles; nb_blocks; params} + +(** From a number of accounts and a list of descriptors set up the + prelude state. + + Thanks to the setup computing for the list of descriptors -- see [setup_of] --, + initiates a context with the setup parameters, and the number of + accounts. Initiate a state that will be fulfilled during the + preludes. During the required number of cycles of the setup, bakes + each cycle with the setup prelude by selecting the actions to + perform on it. On the last cycle, bake the required number of + blocks of the setup. Finally, adds the delegates at the end of + the prelude in the state. *) +let init nb_accounts descrs = + let open Lwt_result_syntax in + let setup = setup_of descrs nb_accounts in + let* initial_block, bootstraps = + Context.init_with_parameters_n setup.params nb_accounts + in + let* voters = Context.Vote.get_listings (B initial_block) in + let* initial_voters = + List.map_es (fun (c, _) -> return (Contract.Implicit c)) voters + in + let my_bake selected_preludes_for_cycle state = + let* state, operations = + List.fold_left_es + (fun (state, ops) prelude -> + let+ ops', state = prelude state in + let ops = ops' @ ops in + (state, ops)) + (state, []) + selected_preludes_for_cycle + in + let b = state.block in + let operations = + List.sort (fun op1 op2 -> Operation.compare_by_passes op2 op1) operations + in + let+ block = Block.bake ~operations b in + {state with block; pred = Some b} + in + let my_bake_n cycle n state = + List.fold_left_es + (fun state _ -> + let selected_preludes = prelude_on_cycle cycle setup.prelude in + my_bake selected_preludes state) + state + (1 -- n) + in + let my_bake_until_cycle_end cycle state = + let current_level = state.block.Block.header.shell.level in + let current_level = + Int32.rem current_level setup.params.constants.blocks_per_cycle + in + let delta = + Int32.sub setup.params.constants.blocks_per_cycle current_level + in + my_bake_n cycle (Int32.to_int delta) state + in + let* state = + List.fold_left_es + (fun state cycle -> my_bake_until_cycle_end cycle state) + (init_state initial_block ~voters:initial_voters ~bootstraps) + (Stdlib.List.init setup.nb_cycles Fun.id) + in + let my_bake_n_default n state = + List.fold_left_es + (fun state _ -> + let pred = state.block in + let+ block = Block.bake state.block in + {state with block; pred = Some pred}) + state + (1 -- n) + in + let* state = + if setup.nb_blocks >= 1 then my_bake_n_default setup.nb_blocks state + else return state + in + return state + +(** In a state, generates all the valid operations of a list of kinds. *) +let candidates state kinds nb_bootstrap max_batch_size = + let open Lwt_result_syntax in + let* candidates = + List.fold_left_es + (fun acc k -> + let* candidates = + (descriptor_of k ~nb_bootstrap ~max_batch_size).candidates_generator + state + in + let acc = acc @ candidates in + return acc) + [] + kinds + in + return candidates + +(** From a list of kind of operations generates all the valid + operations of this kind and the generation state. *) +let covalid ks ~nb_bootstrap ~max_batch_size = + let open Lwt_result_syntax in + let* state = + init nb_bootstrap (descriptors_of ~nb_bootstrap ~max_batch_size ks) + in + let* candidates = candidates state ks nb_bootstrap max_batch_size in + return (state, candidates) diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/validate_helpers.ml b/src/proto_alpha/lib_protocol/test/integration/validate/validate_helpers.ml new file mode 100644 index 000000000000..7c399cf014af --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/validate/validate_helpers.ml @@ -0,0 +1,393 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module Registered_nonces = Nonce +open Protocol +open Alpha_context +module Manager = Manager_operation_helpers + +(** {2 Helpers} *) + +(** {3 Randomness } *) + +let gen_bounded_int min max = QCheck2.Gen.(generate1 @@ int_range min max) + +let pick_one l = QCheck2.Gen.(generate1 @@ oneofl l) + +let pick_n (n : int) (l : 'a list) : 'a list = + List.take_n n QCheck2.Gen.(generate1 @@ shuffle_l l) + +(** {3 Helpers for lists } *) + +let get_n l n = + assert (List.length l > n) ; + Stdlib.List.nth l n + +let mycombine l1 l2 = + let sz_dels = List.length l1 in + let sz_phs = List.length l2 in + let dels, phs = + if sz_dels = sz_phs then (l1, l2) + else if sz_dels < sz_phs then (l1, List.take_n sz_dels l2) + else (List.take_n sz_phs l1, l2) + in + Stdlib.List.combine dels phs + +(** {3 Global Values}*) + +let ballots = Vote.[Yay; Nay; Pass] + +let protos = + List.map + (fun s -> Protocol_hash.of_b58check_exn s) + [ + "ProtoALphaALphaALphaALphaALphaALphaALpha61322gcLUGH"; + "ProtoALphaALphaALphaALphaALphaALphaALphabc2a7ebx6WB"; + "ProtoALphaALphaALphaALphaALphaALphaALpha84efbeiF6cm"; + "ProtoALphaALphaALphaALphaALphaALphaALpha91249Z65tWS"; + "ProtoALphaALphaALphaALphaALphaALphaALpha537f5h25LnN"; + "ProtoALphaALphaALphaALphaALphaALphaALpha5c8fefgDYkr"; + "ProtoALphaALphaALphaALphaALphaALphaALpha3f31feSSarC"; + "ProtoALphaALphaALphaALphaALphaALphaALphabe31ahnkxSC"; + "ProtoALphaALphaALphaALphaALphaALphaALphabab3bgRb7zQ"; + "ProtoALphaALphaALphaALphaALphaALphaALphaf8d39cctbpk"; + "ProtoALphaALphaALphaALphaALphaALphaALpha3b981byuYxD"; + "ProtoALphaALphaALphaALphaALphaALphaALphaa116bccYowi"; + "ProtoALphaALphaALphaALphaALphaALphaALphacce68eHqboj"; + "ProtoALphaALphaALphaALphaALphaALphaALpha225c7YrWwR7"; + "ProtoALphaALphaALphaALphaALphaALphaALpha58743cJL6FG"; + "ProtoALphaALphaALphaALphaALphaALphaALphac91bcdvmJFR"; + "ProtoALphaALphaALphaALphaALphaALphaALpha1faaadhV7oW"; + "ProtoALphaALphaALphaALphaALphaALphaALpha98232gD94QJ"; + "ProtoALphaALphaALphaALphaALphaALphaALpha9d1d8cijvAh"; + "ProtoALphaALphaALphaALphaALphaALphaALphaeec52dKF6Gx"; + "ProtoALphaALphaALphaALphaALphaALphaALpha841f2cQqajX"; + ] + +type secret_account = { + blinded_public_key_hash : Blinded_public_key_hash.t; + account : Ed25519.Public_key_hash.t; + activation_code : Blinded_public_key_hash.activation_code; + amount : Tez.t; +} + +let secrets = + (* Exported from proto_alpha client - TODO : remove when relocated to lib_crypto *) + let read_key mnemonic email password = + match Tezos_client_base.Bip39.of_words mnemonic with + | None -> assert false + | Some t -> + (* TODO: unicode normalization (NFKD)... *) + let passphrase = Bytes.(cat (of_string email) (of_string password)) in + let sk = Tezos_client_base.Bip39.to_seed ~passphrase t in + let sk = Bytes.sub sk 0 32 in + let sk : Signature.Secret_key.t = + Ed25519 + (Data_encoding.Binary.of_bytes_exn Ed25519.Secret_key.encoding sk) + in + let pk = Signature.Secret_key.to_public_key sk in + let pkh = Signature.Public_key.hash pk in + (pkh, pk, sk) + in + List.map + (fun (mnemonic, secret, amount, pkh, password, email) -> + let pkh', pk, sk = read_key mnemonic email password in + let pkh = Ed25519.Public_key_hash.of_b58check_exn pkh in + assert (Signature.Public_key_hash.equal (Ed25519 pkh) pkh') ; + let activation_code = + Stdlib.Option.get + (Blinded_public_key_hash.activation_code_of_hex secret) + in + let bpkh = Blinded_public_key_hash.of_ed25519_pkh activation_code pkh in + let account = Account.{pkh = Ed25519 pkh; pk; sk} in + Account.add_account account ; + { + blinded_public_key_hash = bpkh; + account = pkh; + activation_code; + amount = + WithExceptions.Option.to_exn + ~none:(Invalid_argument "tez conversion") + (Tez.of_mutez (Int64.of_string amount)); + }) + [ + ( [ + "envelope"; + "hospital"; + "mind"; + "sunset"; + "cancel"; + "muscle"; + "leisure"; + "thumb"; + "wine"; + "market"; + "exit"; + "lucky"; + "style"; + "picnic"; + "success"; + ], + "0f39ed0b656509c2ecec4771712d9cddefe2afac", + "23932454669343", + "tz1MawerETND6bqJqx8GV3YHUrvMBCDasRBF", + "z0eZHQQGKt", + "cjgfoqmk.wpxnvnup@tezos.example.org" ); + ( [ + "flag"; + "quote"; + "will"; + "valley"; + "mouse"; + "chat"; + "hold"; + "prosper"; + "silk"; + "tent"; + "cruel"; + "cause"; + "demise"; + "bottom"; + "practice"; + ], + "41f98b15efc63fa893d61d7d6eee4a2ce9427ac4", + "72954577464032", + "tz1X4maqF9tC1Yn4jULjHRAyzjAtc25Z68TX", + "MHErskWPE6", + "oklmcktr.ztljnpzc@tezos.example.org" ); + ( [ + "library"; + "away"; + "inside"; + "paper"; + "wise"; + "focus"; + "sweet"; + "expose"; + "require"; + "change"; + "stove"; + "planet"; + "zone"; + "reflect"; + "finger"; + ], + "411dfef031eeecc506de71c9df9f8e44297cf5ba", + "217487035428349", + "tz1SWBY7rWMutEuWS54Pt33MkzAS6eWkUuTc", + "0AO6BzQNfN", + "ctgnkvqm.kvtiybky@tezos.example.org" ); + ( [ + "cruel"; + "fluid"; + "damage"; + "demand"; + "mimic"; + "above"; + "village"; + "alpha"; + "vendor"; + "staff"; + "absent"; + "uniform"; + "fire"; + "asthma"; + "milk"; + ], + "08d7d355bc3391d12d140780b39717d9f46fcf87", + "4092742372031", + "tz1amUjiZaevaxQy5wKn4SSRvVoERCip3nZS", + "9kbZ7fR6im", + "bnyxxzqr.tdszcvqb@tezos.example.org" ); + ( [ + "opera"; + "divorce"; + "easy"; + "myself"; + "idea"; + "aim"; + "dash"; + "scout"; + "case"; + "resource"; + "vote"; + "humor"; + "ticket"; + "client"; + "edge"; + ], + "9b7cad042fba557618bdc4b62837c5f125b50e56", + "17590039016550", + "tz1Zaee3QBtD4ErY1SzqUvyYTrENrExu6yQM", + "suxT5H09yY", + "iilkhohu.otnyuvna@tezos.example.org" ); + ( [ + "token"; + "similar"; + "ginger"; + "tongue"; + "gun"; + "sort"; + "piano"; + "month"; + "hotel"; + "vote"; + "undo"; + "success"; + "hobby"; + "shell"; + "cart"; + ], + "124c0ca217f11ffc6c7b76a743d867c8932e5afd", + "26322312350555", + "tz1geDUUhfXK1EMj7VQdRjug1MoFe6gHWnCU", + "4odVdLykaa", + "kwhlglvr.slriitzy@tezos.example.org" ); + ( [ + "shield"; + "warrior"; + "gorilla"; + "birth"; + "steak"; + "neither"; + "feel"; + "only"; + "liberty"; + "float"; + "oven"; + "extend"; + "pulse"; + "suffer"; + "vapor"; + ], + "ac7a2125beea68caf5266a647f24dce9fea018a7", + "244951387881443", + "tz1h3nY7jcZciJgAwRhWcrEwqfVp7VQoffur", + "A6yeMqBFG8", + "lvrmlbyj.yczltcxn@tezos.example.org" ); + ( [ + "waste"; + "open"; + "scan"; + "tip"; + "subway"; + "dance"; + "rent"; + "copper"; + "garlic"; + "laundry"; + "defense"; + "clerk"; + "another"; + "staff"; + "liar"; + ], + "2b3e94be133a960fa0ef87f6c0922c19f9d87ca2", + "80065050465525", + "tz1VzL4Xrb3fL3ckvqCWy6bdGMzU2w9eoRqs", + "oVZqpq60sk", + "rfodmrha.zzdndvyk@tezos.example.org" ); + ( [ + "fiber"; + "next"; + "property"; + "cradle"; + "silk"; + "obey"; + "gossip"; + "push"; + "key"; + "second"; + "across"; + "minimum"; + "nice"; + "boil"; + "age"; + ], + "dac31640199f2babc157aadc0021cd71128ca9ea", + "3569618927693", + "tz1RUHg536oRKhPLFfttcB5gSWAhh4E9TWjX", + "FfytQTTVbu", + "owecikdy.gxnyttya@tezos.example.org" ); + ( [ + "print"; + "labor"; + "budget"; + "speak"; + "poem"; + "diet"; + "chunk"; + "eternal"; + "book"; + "saddle"; + "pioneer"; + "ankle"; + "happy"; + "only"; + "exclude"; + ], + "bb841227f250a066eb8429e56937ad504d7b34dd", + "9034781424478", + "tz1M1LFbgctcPWxstrao9aLr2ECW1fV4pH5u", + "zknAl3lrX2", + "ettilrvh.zsrqrbud@tezos.example.org" ); + ] + +(** {3 Context Manipulations } *) + +let pick_two_endorsers ctxt = + let module V = Plugin.RPC.Validators in + Context.get_endorsers ctxt >>=? function + | a :: b :: _ -> return ((a.V.delegate, a.V.slots), (b.V.delegate, b.V.slots)) + | _ -> assert false + +let pick_addr_endorser ctxt = + let module V = Plugin.RPC.Validators in + Context.get_endorsers ctxt >>=? function + | a :: _ -> return a.V.delegate + | _ -> assert false + +let init_params = + Tezos_protocol_alpha_parameters.Default_parameters.parameters_of_constants + {Context.default_test_constants with consensus_threshold = 0} + +let delegates_of_block block = + let open Lwt_result_syntax in + let+ validators = Context.get_endorsers (B block) in + List.map + (fun Plugin.RPC.Validators.{delegate; slots; _} -> (delegate, slots)) + validators + +(** Sequential validation of an operation list. *) +let sequential_validate ?(mempool_mode = true) block operations = + let open Lwt_result_syntax in + let* inc = Incremental.begin_construction ~mempool_mode block in + let* _inc = + List.fold_left_es + (fun acc op -> Incremental.validate_operation acc op) + inc + operations + in + return_unit -- GitLab From 623e4adfa7a7027993240f7bbe97c7822e93e447 Mon Sep 17 00:00:00 2001 From: vbot Date: Thu, 13 Oct 2022 00:49:17 +0200 Subject: [PATCH 6/7] Lima/Tests: backport validate integration tests --- manifest/main.ml | 2 +- .../lib_protocol/test/helpers/context.ml | 34 ++ .../lib_protocol/test/helpers/context.mli | 44 ++ .../test/integration/validate/dune | 15 +- .../validate/generator_descriptors.ml | 22 +- .../validate/generator_descriptors.mli | 161 +++++++ .../test/integration/validate/generators.ml | 9 +- .../test/integration/validate/main.ml | 23 +- .../validate/manager_operation_helpers.ml | 330 +++++++++------ .../validate/test_1m_restriction.ml | 68 ++- .../integration/validate/test_covalidity.ml | 157 +++++++ .../test_manager_operation_validation.ml | 377 +++++------------ .../test/integration/validate/test_mempool.ml | 2 +- .../test/integration/validate/test_sanity.ml | 174 ++++++++ ...validation.ml => test_validation_batch.ml} | 342 +++++++-------- .../validate/valid_operations_generators.ml | 243 +++++++++++ .../integration/validate/validate_helpers.ml | 394 ++++++++++++++++++ .../lib_protocol/test/helpers/context.mli | 6 +- 18 files changed, 1739 insertions(+), 664 deletions(-) create mode 100644 src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/generator_descriptors.mli create mode 100644 src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_covalidity.ml create mode 100644 src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_sanity.ml rename src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/{test_batched_manager_operation_validation.ml => test_validation_batch.ml} (81%) create mode 100644 src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/valid_operations_generators.ml create mode 100644 src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/validate_helpers.ml diff --git a/manifest/main.ml b/manifest/main.ml index e022da86120d..2abce2cbd963 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -3560,7 +3560,7 @@ end = struct let _integration_validate = only_if N.(number >= 014) @@ fun () -> tests - ("main" :: (if N.(number <= 015) then ["test_1m_restriction"] else [])) + ("main" :: (if N.(number == 014) then ["test_1m_restriction"] else [])) ~path:(path // "lib_protocol/test/integration/validate") ~opam:(sf "tezos-protocol-%s-tests" name_dash) ~deps: diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/helpers/context.ml b/src/proto_015_PtLimaPt/lib_protocol/test/helpers/context.ml index e6883fadbd2a..56f6d77c79e4 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/helpers/context.ml +++ b/src/proto_015_PtLimaPt/lib_protocol/test/helpers/context.ml @@ -131,6 +131,15 @@ let get_endorser ctxt = let endorser = WithExceptions.Option.get ~loc:__LOC__ @@ List.hd endorsers in (endorser.delegate, endorser.slots) +let get_endorser_slot ctxt pkh = + get_endorsers ctxt >|=? fun endorsers -> + List.find_map + (function + | {Plugin.RPC.Validators.delegate; slots; _} -> + if Signature.Public_key_hash.(delegate = pkh) then Some slots + else None) + endorsers + let get_endorser_n ctxt n = Plugin.RPC.Validators.get rpc_ctxt ctxt >|=? fun endorsers -> let endorser = @@ -512,6 +521,18 @@ let init2 = init_gen T2 let init3 = init_gen T3 +let create_bootstrap_accounts n = + let accounts = Account.generate_accounts n in + let open Tezos_protocol_015_PtLimaPt_parameters in + List.fold_left + (fun (boostrap_account, contracts) (account, tez, delegate_to) -> + ( Default_parameters.make_bootstrap_account + (Account.(account.pkh), Account.(account.pk), tez, delegate_to, None) + :: boostrap_account, + Alpha_context.Contract.Implicit Account.(account.pkh) :: contracts )) + ([], []) + accounts + let init_with_constants_gen tup constants = let n = tup_n tup in let accounts = Account.generate_accounts n in @@ -540,6 +561,19 @@ let init_with_constants1 = init_with_constants_gen T1 let init_with_constants2 = init_with_constants_gen T2 +let init_with_parameters_gen tup parameters = + let n = tup_n tup in + let bootstrap_accounts, contracts = create_bootstrap_accounts n in + let parameters = Parameters.{parameters with bootstrap_accounts} in + Block.genesis_with_parameters parameters >|=? fun blk -> + (blk, tup_get tup contracts) + +let init_with_parameters_n params n = init_with_parameters_gen (TList n) params + +let init_with_parameters1 = init_with_parameters_gen T1 + +let init_with_parameters2 = init_with_parameters_gen T2 + let default_raw_context () = let initial_accounts = Account.generate_accounts ~initial_balances:[100_000_000_000L] 1 diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/helpers/context.mli b/src/proto_015_PtLimaPt/lib_protocol/test/helpers/context.mli index 31b691bc5ff6..3fc360b70470 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/helpers/context.mli +++ b/src/proto_015_PtLimaPt/lib_protocol/test/helpers/context.mli @@ -38,13 +38,26 @@ val get_level : t -> Raw_level.t tzresult build one (in the [Block] case). *) val to_alpha_ctxt : t -> Alpha_context.t tzresult Lwt.t +(** Given a context, returns the list of endorsers charactized by + the [level], the public key hash of the [delegate], its [consensus_key] + and its assigned [slots]. + see {! Plugin.RPC.Validator.t}. *) val get_endorsers : t -> Plugin.RPC.Validators.t list tzresult Lwt.t +(** Return the two first elements of the list returns by [get_endorsers]. *) val get_first_different_endorsers : t -> (Plugin.RPC.Validators.t * Plugin.RPC.Validators.t) tzresult Lwt.t +(** Return the first element of the list returns by [get_endorsers]. *) val get_endorser : t -> (public_key_hash * Slot.t list) tzresult Lwt.t +(** Given a delegate public key hash [del], and a context [ctxt], + if [del] is in [get_endorsers ctxt] returns the [slots] of [del] otherwise + return [None]. *) +val get_endorser_slot : + t -> public_key_hash -> Slot.t list option tzresult Lwt.t + +(** Return the [n]th element of the list returns by [get_endorsers]. *) val get_endorser_n : t -> int -> (public_key_hash * Slot.t list) tzresult Lwt.t val get_endorsing_power_for_delegate : @@ -341,6 +354,37 @@ val init_with_constants2 : (Block.t * (Alpha_context.Contract.t * Alpha_context.Contract.t)) tzresult Lwt.t +(** [init_with_parameters_gen tup params] returns an initial block parametrised + with [params] and the implicit contracts corresponding to its bootstrap + accounts. The number of bootstrap accounts, and the structure of the + returned contracts, are specified by the [tup] argument. *) +val init_with_parameters_gen : + (Alpha_context.Contract.t, 'contracts) tup -> + Parameters.t -> + (Block.t * 'contracts) tzresult Lwt.t + +(** [init_with_parameters_n params n] returns an initial block parametrized + with [params] with [n] initialized accounts and the associated implicit + contracts *) +val init_with_parameters_n : + Parameters.t -> + int -> + (Block.t * Alpha_context.Contract.t list) tzresult Lwt.t + +(** [init_with_parameters1 params] returns an initial block parametrized with + [params] with one initialized account and the associated implicit + contract. *) +val init_with_parameters1 : + Parameters.t -> (Block.t * Alpha_context.Contract.t) tzresult Lwt.t + +(** [init_with_parameters2 params] returns an initial block parametrized with + [params] with two initialized accounts and the associated implicit + contracts *) +val init_with_parameters2 : + Parameters.t -> + (Block.t * (Alpha_context.Contract.t * Alpha_context.Contract.t)) tzresult + Lwt.t + (** [default_raw_context] returns a [Raw_context.t] for use in tests below [Alpha_context] *) val default_raw_context : unit -> Raw_context.t tzresult Lwt.t diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/dune b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/dune index f312447301b1..d1d919f89806 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/dune +++ b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/dune @@ -1,8 +1,8 @@ ; This file was automatically generated, do not edit. ; Edit file manifest/main.ml instead. -(executables - (names main test_1m_restriction) +(executable + (name main) (libraries alcotest-lwt tezos-base @@ -10,7 +10,8 @@ qcheck-alcotest tezos-client-015-PtLimaPt tezos-015-PtLimaPt-test-helpers - tezos-base-test-helpers) + tezos-base-test-helpers + tezos-protocol-plugin-015-PtLimaPt) (flags (:standard) -open Tezos_base.TzPervasives @@ -18,14 +19,10 @@ -open Tezos_protocol_015_PtLimaPt -open Tezos_client_015_PtLimaPt -open Tezos_015_PtLimaPt_test_helpers - -open Tezos_base_test_helpers)) + -open Tezos_base_test_helpers + -open Tezos_protocol_plugin_015_PtLimaPt)) (rule (alias runtest) (package tezos-protocol-015-PtLimaPt-tests) (action (run %{dep:./main.exe}))) - -(rule - (alias runtest) - (package tezos-protocol-015-PtLimaPt-tests) - (action (run %{dep:./test_1m_restriction.exe}))) diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/generator_descriptors.ml b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/generator_descriptors.ml index da8c42c8edb5..d33e29fc1868 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/generator_descriptors.ml +++ b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/generator_descriptors.ml @@ -159,11 +159,14 @@ let activate_descriptor = List.map_es gen state.commitments); } +(** During the first voting period in the setup of valid operations generations, + a proposal must win the proposal period -- hence [ballot_exploration_prelude] + takes place during the first cycle. *) let ballot_exploration_descriptor = { parameters = voting_context_params; required_cycle = - (fun params -> 1 * Int32.to_int params.constants.cycles_per_voting_period); + (fun params -> Int32.to_int params.constants.cycles_per_voting_period); required_block = (fun _params -> 0); prelude = (On 1, ballot_exploration_prelude); opt_prelude = None; @@ -202,6 +205,21 @@ let proposal_descriptor = List.map_es gen state.voters); } +(** [Promotion] is the 4th voting period, it requires 3 voting period + to last and be successful. [voting_context_params] set a + voting_period to 1 cycle. To generate a [Ballot] for this + promotion period: + + - the first period should conclude in a proposal wining -- 3 cycles + before generating the [Ballot], the proposal period must succeed:[ + ballot_exploration_prelude], + + - the exploration must conclude in a supermajority for this + proposal -- 2 cycles before generating the [Ballot], the + exploration period must succeed., and + + - the cooldown must last -- 1 cycle before generating the + [Ballot]. *) let ballot_promotion_descriptor = { parameters = voting_context_params; @@ -729,7 +747,7 @@ let manager_prelude (infos : Manager.infos) b = return (operations, state) (** Build a manager operation according to the information in [infos] - on [block] for each source in the [manager_state] guaranteering + on [block] for each source in the [manager_state] guaranteeing that they are not conflicting. *) let manager_candidates block infos batch_max_size = let open Lwt_result_syntax in diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/generator_descriptors.mli b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/generator_descriptors.mli new file mode 100644 index 000000000000..df118ca15c6f --- /dev/null +++ b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/generator_descriptors.mli @@ -0,0 +1,161 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context +open Validate_helpers + +(** {2 Generation state} *) + +(** The state to generate valid double pre- and endorsement evidence + contains a temporary state for making the slashable evidence, and + the lists of slashables operations, one for each kind: + preendorsement and endorsement. *) +type dbl_endorsement_state = { + temporary : (Block.t * Block.t) option; + slashable_preend : + (Kind.preendorsement operation * Kind.preendorsement operation) list; + slashable_end : (Kind.endorsement operation * Kind.endorsement operation) list; +} + +(** Generic generation state collecting + information to generate any kind of operation. + + For example, {!Manager.infos} for manager + or voters (Contract.t list) for voting operations... + + When adding a new operation kind, [state] might be extended if a + new kind of information is required for this new kind valid + operations generation. *) +type state = { + block : Block.t; + pred : Block.t option; + bootstraps : public_key_hash list; + delegates : (public_key_hash * public_key_hash option) list; + voters : Contract.t list; + seed_nonce_to_reveal : (Raw_level.t * Nonce_hash.t) list; + commitments : secret_account list; + protocol_hashes : Protocol_hash.t list; + slashable_bakes : (block_header * block_header) list; + vdf : bool; + dbl_endorsement : dbl_endorsement_state; + manager : Manager.infos; +} + +(** The initialization of a [state] requires the [voters] contracts -- + the contracts allowed to vote -- and the [bootstraps] contracts. *) +val init_state : + Block.t -> voters:Contract.t list -> bootstraps:Contract.t list -> state + +(** {2 Descriptor for valid operations generation} *) + +(** Each prelude action either takes place on a specific cycle or + from a specific cycle to the end a the context setting. *) +type cycle_index = On of int | From of int + +(** Descriptors are specific to operation kinds, [op_kind]. A + descriptor provides the information and functions used in the + context setup to generate valid operations of its kind and a + generator for such operations. + + - [parameters] enables setting constants in the initial context. + + - [required_cycle] is the number of cycles in the context setup + before generating valid operations of this kind. + + - [required_block] the number of blocks in the last cycle. + + - [prelude] is a set of actions that either gather information in + the setup [state] or perform operations in the setup blocks or both + that have to be performed according to a [cycle_index]. + + - [opt_prelude] is an optional prelude. + + - [candidates_generator] generates operations of the descriptor + [op_kind] according to the information in [state] that are valid + upon [state.block]. *) +type descriptor = { + parameters : Parameters.t -> Parameters.t; + required_cycle : Parameters.t -> int; + required_block : Parameters.t -> int; + prelude : + cycle_index * (state -> (packed_operation list * state) tzresult Lwt.t); + opt_prelude : + (cycle_index * (state -> (packed_operation list * state) tzresult Lwt.t)) + option; + candidates_generator : state -> packed_operation list tzresult Lwt.t; +} + +(** {2 Operation kinds} *) + +(** When adding a new operation: + - a new op_kind [k] should extend the [op_kind] type, + - a [descriptor] defined, + - [descriptor_of] must associate this new descriptor to [k], + - [k] must be added to [all_kinds], + - If the validity of [k] operations is not exclusive with the + validity of other [op_kind], [k] must be added to + [non_exclusive_kinds]. Otherwise, see, for example, how voting + operation op_kinds are handled in {! test_covalidity.tests}. *) +type op_kind = + | KEndorsement + | KPreendorsement + | KDalslotavail + | KBallotExp + | KBallotProm + | KProposals + | KNonce + | KVdf + | KActivate + | KDbl_consensus + | KDbl_baking + | KDrain + | KManager + +val pp_op_kind : Format.formatter -> op_kind -> unit + +(** This sanity function returns the [op_kind] associated to + an [packed_operation].*) +val op_kind_of_packed_operation : packed_operation -> op_kind + +(** Associate to each [op_kind] a [descriptor]. Some descriptors are + parametrized by the number of bootstraps and the maximum size of a + batch.*) +val descriptor_of : + nb_bootstrap:int -> max_batch_size:int -> op_kind -> descriptor + +(** Given a list of [op_kind] returns the list of corresponding + descriptors as provided by [descriptor_of] for each [op_kind]. + Some descriptors are parametrized by the number of bootstraps and + the maximum size of a batch.*) +val descriptors_of : + nb_bootstrap:int -> max_batch_size:int -> op_kind list -> descriptor list + +(** List of all [op_kind] that are non exclusive (i.e. no voting +operation kind or nonce revelation kind) *) +val non_exclusive_kinds : op_kind trace + +(** List of all [op_kind] used for sanity check. *) +val all_kinds : op_kind list diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/generators.ml b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/generators.ml index 5ab558db05f0..eb076f547370 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/generators.ml +++ b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/generators.ml @@ -255,15 +255,16 @@ let gen_ctxt_req : ctxt_cstrs -> ctxt_req QCheck2.Gen.t = (** {2 Wrappers} *) -let wrap ~name ?print ?count ?check ~(gen : 'a QCheck2.Gen.t) +let wrap ~name ?print ?(count = 1) ?check ~(gen : 'a QCheck2.Gen.t) (f : 'a -> bool tzresult Lwt.t) = - Lib_test.Qcheck2_helpers.qcheck_make_result + Lib_test.Qcheck2_helpers.qcheck_make_result_lwt ~name ?print - ?count + ~count ?check + ~extract:Lwt_main.run ~pp_error:pp_print_trace ~gen - (fun a -> Lwt_main.run (f a)) + f let wrap_mode infos op mode = validate_diagnostic ~mode infos op diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/main.ml b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/main.ml index 1da1e1a43966..1ddc623484c1 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/main.ml +++ b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/main.ml @@ -26,7 +26,7 @@ (** Testing ------- Component: Protocol - Invocation: dune runtest src/proto_alpha/lib_protocol/test/integration/validate + Invocation: dune runtest src/proto_015_PtLimaPt/lib_protocol/test/integration/validate Subject: Integration > Validate *) @@ -34,20 +34,11 @@ let () = Alcotest_lwt.run "protocol > integration > validate" [ - ("sanity checks", Test_manager_operation_validation.sanity_tests); - ("Single: gas checks", Test_manager_operation_validation.gas_tests); - ("Single: storage checks", Test_manager_operation_validation.storage_tests); - ("Single: fees checks", Test_manager_operation_validation.fee_tests); - ( "Single: contract checks", - Test_manager_operation_validation.contract_tests ); - ( "Batched: contract checks", - Test_batched_manager_operation_validation.contract_tests ); - ( "Batched: gas checks", - Test_batched_manager_operation_validation.gas_tests ); - ( "Batched: fees checks", - Test_batched_manager_operation_validation.fee_tests ); - ( "Flags: feature flag checks", - Test_manager_operation_validation.flags_tests ); - ("Mempool", Test_mempool.tests); + ("sanity checks", Test_sanity.tests); + ("mempool", Test_mempool.tests); + ("single manager validation", Test_manager_operation_validation.tests); + ("batched managers validation", Test_validation_batch.tests); + ("one-manager restriction", Test_1m_restriction.tests); + ("covalidity", Test_covalidity.tests); ] |> Lwt_main.run diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/manager_operation_helpers.ml b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/manager_operation_helpers.ml index e2a888275862..8213576d46a6 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/manager_operation_helpers.ml +++ b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -40,7 +40,8 @@ let half_gb_limit = Gas.Arith.(integral_of_int_exn 50_000) (** Context abstraction in a test. *) type ctxt = { block : Block.t; - originated_contract : Contract_hash.t; + bootstraps : public_key_hash list; + originated_contract : Contract_hash.t option; tx_rollup : Tx_rollup.t option; sc_rollup : Sc_rollup.t option; zk_rollup : Zk_rollup.t option; @@ -52,7 +53,7 @@ type ctxt = { impossible case, [source] is used as a dummy value. In some test that requires a second source, [del] will be used as the second source. *) type accounts = { - source : Account.t; + sources : Account.t list; dest : Account.t option; del : Account.t option; tx : Account.t option; @@ -60,9 +61,12 @@ type accounts = { zk : Account.t option; } +(** Feature flags requirements for a context setting for a test. *) +type feature_flags = {dal : bool; scoru : bool; toru : bool; zkru : bool} + (** Infos describes the information of the setting for a test: the context and used accounts. *) -type infos = {ctxt : ctxt; accounts : accounts} +type infos = {ctxt : ctxt; accounts : accounts; flags : feature_flags} (** This type should be extended for each new manager_operation kind added in the protocol. See @@ -97,7 +101,6 @@ type manager_operation_kind = | K_Sc_rollup_timeout | K_Sc_rollup_execute_outbox_message | K_Sc_rollup_recover_bond - | K_Dal_publish_slot_header | K_Zk_rollup_origination | K_Zk_rollup_publish @@ -112,9 +115,6 @@ type operation_req = { amount : Tez.t option; } -(** Feature flags requirements for a context setting for a test. *) -type feature_flags = {dal : bool; scoru : bool; toru : bool; zkru : bool} - (** The requirements for a context setting for a test. *) type ctxt_req = { hard_gas_limit_per_block : Gas.Arith.integral option; @@ -202,7 +202,6 @@ let kind_to_string = function | K_Sc_rollup_add_messages -> "Sc_rollup_add_messages" | K_Sc_rollup_execute_outbox_message -> "Sc_rollup_execute_outbox_message" | K_Sc_rollup_recover_bond -> "Sc_rollup_recover_bond" - | K_Dal_publish_slot_header -> "Dal_publish_slot_header" | K_Zk_rollup_origination -> "Zk_rollup_origination" | K_Zk_rollup_publish -> "Zk_rollup_publish" @@ -405,9 +404,8 @@ let originate_zk_rollup block rollup_account = (** {2 Setting's context construction} *) -let fund_account block bootstrap account fund = +let fund_account_op block bootstrap account fund counter = let open Lwt_result_syntax in - let* counter = Context.Contract.counter (B block) bootstrap in let* fund = match fund with | None -> return Tez.one @@ -417,7 +415,7 @@ let fund_account block bootstrap account fund = Lwt.return (Environment.wrap_tzresult Tez.(source_balance -? one)) else return fund in - let* operation = + let+ op = Op.transaction ~counter ~gas_limit:Op.High @@ -426,25 +424,83 @@ let fund_account block bootstrap account fund = (Contract.Implicit account) fund in + (op, Z.succ counter) + +let fund_account block bootstrap account fund = + let open Lwt_result_syntax in + let* counter = Context.Contract.counter (B block) bootstrap in + let* operation, (_counter : counter) = + fund_account_op block bootstrap account fund counter + in let*! b = Block.bake ~operation block in match b with Error _ -> failwith "Funding account error" | Ok b -> return b -(** The generic setting for a test is built up according to a context - requirement. It provides a context and accounts where the accounts - have been created and funded according to the context - requirements.*) -let init_ctxt : ctxt_req -> infos tzresult Lwt.t = - fun { - hard_gas_limit_per_block; - fund_src; - fund_dest; - fund_del; - reveal_accounts; - fund_tx; - fund_sc; - fund_zk; - flags; - } -> +(** Set the constants according to a [ctxt_req] in an existing parameters. *) +let manager_parameters : Parameters.t -> ctxt_req -> Parameters.t = + fun params {hard_gas_limit_per_block; flags; _} -> + let hard_gas_limit_per_block = + match hard_gas_limit_per_block with + | Some gb -> gb + | None -> Gas.Arith.(integral_of_int_exn 5_200_000) + in + let dal = {params.constants.dal with feature_enable = flags.dal} in + let tx_rollup = + { + params.constants.tx_rollup with + sunset_level = Int32.max_int; + enable = flags.toru; + } + in + let sc_rollup = {params.constants.sc_rollup with enable = flags.scoru} in + let zk_rollup = {params.constants.zk_rollup with enable = flags.zkru} in + let constants = + { + params.constants with + hard_gas_limit_per_block; + dal; + tx_rollup; + zk_rollup; + sc_rollup; + } + in + {params with constants} + +(** Initialize a context with the constants extracted from a context requirements + and 7 bootstrap accounts. *) +let init_ctxt_only ctxtreq = + let open Lwt_result_syntax in + let initial_params = + Tezos_protocol_015_PtLimaPt_parameters.Default_parameters + .parameters_of_constants + {Context.default_test_constants with consensus_threshold = 0} + in + let* block, contracts = + Context.init_with_parameters_n (manager_parameters initial_params ctxtreq) 7 + in + return + ( block, + List.map + (function Contract.Implicit pkh -> pkh | Originated _ -> assert false) + contracts ) + +(** Build a generic setting for a test according to a context requirement + on an existing context with 7 bootstraps accounts. *) +let init_infos : + ctxt_req -> Block.t -> public_key_hash list -> infos tzresult Lwt.t = + fun ctxtreq block bootstraps -> + let { + fund_src; + fund_dest; + fund_del; + fund_tx; + fund_sc; + fund_zk; + flags; + reveal_accounts; + _; + } = + ctxtreq + in let open Lwt_result_syntax in let create_and_fund ?originate_rollup block bootstrap fund = match fund with @@ -461,18 +517,6 @@ let init_ctxt : ctxt_req -> infos tzresult Lwt.t = in (block, Some account, rollup) in - let* block, bootstraps = - Context.init_n - 7 - ~consensus_threshold:0 - ?hard_gas_limit_per_block - ~tx_rollup_enable:flags.toru - ~tx_rollup_sunset_level:Int32.max_int - ~sc_rollup_enable:flags.scoru - ~dal_enable:flags.dal - ~zk_rollup_enable:flags.zkru - () - in let reveal_accounts_operations b l = List.filter_map_es (function @@ -482,7 +526,9 @@ let init_ctxt : ctxt_req -> infos tzresult Lwt.t = return_some op) l in - let get_bootstrap bootstraps n = Stdlib.List.nth bootstraps n in + let get_bootstrap bootstraps n = + Contract.Implicit (Stdlib.List.nth bootstraps n) + in let source = Account.new_account () in let* block = fund_account block (get_bootstrap bootstraps 0) source.pkh fund_src @@ -534,8 +580,31 @@ let init_ctxt : ctxt_req -> infos tzresult Lwt.t = in let operations = create_contract_hash :: reveal_operations in let+ block = Block.bake ~operations block in - let ctxt = {block; originated_contract; tx_rollup; sc_rollup; zk_rollup} in - {ctxt; accounts = {source; dest; del; tx; sc; zk}} + let ctxt = + { + block; + bootstraps; + originated_contract = Some originated_contract; + tx_rollup; + sc_rollup; + zk_rollup; + } + in + {ctxt; accounts = {sources = [source]; dest; del; tx; sc; zk}; flags} + +(** The generic setting for a test is built up according to a context + requirement. It provides a context and accounts where the accounts + have been created and funded according to the context + requirements.*) +let init_ctxt : ctxt_req -> infos tzresult Lwt.t = + fun ctxtreq -> + let open Lwt_result_syntax in + let* block, bootstraps = init_ctxt_only ctxtreq in + init_infos ctxtreq block bootstraps + +(** return the first source from the list of sources in [infos] accounts. *) +let get_source infos = + match infos.accounts.sources with source :: _ -> source | [] -> assert false (** In addition of building up a context according to a context requirement, source is self-delegated. @@ -545,7 +614,7 @@ let ctxt_with_self_delegation : ctxt_req -> infos tzresult Lwt.t = fun ctxt_req -> let open Lwt_result_syntax in let* infos = init_ctxt ctxt_req in - let+ block = self_delegate infos.ctxt.block infos.accounts.source.pkh in + let+ block = self_delegate infos.ctxt.block (get_source infos).pkh in let ctxt = {infos.ctxt with block} in {infos with ctxt} @@ -562,7 +631,7 @@ 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 infos.accounts.source delegate in + let+ block = delegation infos.ctxt.block (get_source infos) delegate in let ctxt = {infos.ctxt with block} in {infos with ctxt} @@ -588,10 +657,10 @@ let mk_transaction (oinfos : operation_req) (infos : infos) = ?gas_limit:oinfos.gas_limit ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) (contract_of (match infos.accounts.dest with - | None -> infos.accounts.source + | None -> get_source infos | Some dest -> dest)) (match oinfos.amount with None -> Tez.zero | Some amount -> amount) @@ -603,10 +672,10 @@ let mk_delegation (oinfos : operation_req) (infos : infos) = ?counter:oinfos.counter ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) (Some (match infos.accounts.del with - | None -> infos.accounts.source.pkh + | None -> (get_source infos).pkh | Some delegate -> delegate.pkh)) let mk_undelegation (oinfos : operation_req) (infos : infos) = @@ -617,7 +686,7 @@ let mk_undelegation (oinfos : operation_req) (infos : infos) = ?counter:oinfos.counter ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) None let mk_self_delegation (oinfos : operation_req) (infos : infos) = @@ -628,8 +697,8 @@ let mk_self_delegation (oinfos : operation_req) (infos : infos) = ?counter:oinfos.counter ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - (contract_of infos.accounts.source) - (Some infos.accounts.source.pkh) + (contract_of (get_source infos)) + (Some (get_source infos).pkh) let mk_origination (oinfos : operation_req) (infos : infos) = let open Lwt_result_syntax in @@ -642,7 +711,7 @@ let mk_origination (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ~script:Op.dummy_script (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in op @@ -654,7 +723,7 @@ let mk_register_global_constant (oinfos : operation_req) (infos : infos) = ?gas_limit:oinfos.gas_limit ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - ~source:(contract_of infos.accounts.source) + ~source:(contract_of (get_source infos)) ~value:(Script_repr.lazy_expr (Expr.from_string "Pair 1 2")) let mk_set_deposits_limit (oinfos : operation_req) (infos : infos) = @@ -665,7 +734,7 @@ let mk_set_deposits_limit (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?counter:oinfos.counter (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) None let mk_update_consensus_key (oinfos : operation_req) (infos : infos) = @@ -676,12 +745,21 @@ let mk_update_consensus_key (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?counter:oinfos.counter (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) (match infos.accounts.dest with - | None -> infos.accounts.source.pk + | None -> (get_source infos).pk | Some dest -> dest.pk) let mk_increase_paid_storage (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* destination = + match infos.ctxt.originated_contract with + | None -> + failwith + "infos should be initialized with an origniated contract to be able \ + to add an increase_paid_storage operation." + | Some c -> return c + in Op.increase_paid_storage ?force_reveal:oinfos.force_reveal ?counter:oinfos.counter @@ -689,13 +767,13 @@ let mk_increase_paid_storage (oinfos : operation_req) (infos : infos) = ?gas_limit:oinfos.gas_limit ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - ~source:(contract_of infos.accounts.source) - ~destination:infos.ctxt.originated_contract + ~source:(contract_of (get_source infos)) + ~destination Z.one let mk_reveal (oinfos : operation_req) (infos : infos) = let open Lwt_result_syntax in - let* pk = get_pk (B infos.ctxt.block) (contract_of infos.accounts.source) in + let* pk = get_pk (B infos.ctxt.block) (contract_of (get_source infos)) in Op.revelation ?fee:oinfos.fee ?gas_limit:oinfos.gas_limit @@ -714,7 +792,7 @@ let mk_tx_rollup_origination (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in op @@ -741,7 +819,7 @@ let mk_tx_rollup_submit_batch (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) tx_rollup "batch" @@ -763,7 +841,7 @@ let mk_tx_rollup_commit (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) tx_rollup commitement @@ -777,7 +855,7 @@ let mk_tx_rollup_return_bond (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) tx_rollup let mk_tx_rollup_finalize (oinfos : operation_req) (infos : infos) = @@ -790,7 +868,7 @@ let mk_tx_rollup_finalize (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) tx_rollup let mk_tx_rollup_remove_commitment (oinfos : operation_req) (infos : infos) = @@ -803,7 +881,7 @@ let mk_tx_rollup_remove_commitment (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) tx_rollup let mk_tx_rollup_reject (oinfos : operation_req) (infos : infos) = @@ -837,7 +915,7 @@ let mk_tx_rollup_reject (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) tx_rollup Tx_rollup_level.root message @@ -857,19 +935,19 @@ let mk_transfer_ticket (oinfos : operation_req) (infos : infos) = ?gas_limit:oinfos.gas_limit ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - ~source:(contract_of infos.accounts.source) + ~source:(contract_of (get_source infos)) ~contents:(Script.lazy_expr (Expr.from_string "1")) ~ty:(Script.lazy_expr (Expr.from_string "nat")) ~ticketer: (contract_of (match infos.accounts.tx with - | None -> infos.accounts.source + | None -> get_source infos | Some tx -> tx)) ~amount:Ticket_amount.one ~destination: (contract_of (match infos.accounts.dest with - | None -> infos.accounts.source + | None -> get_source infos | Some dest -> dest)) ~entrypoint:Entrypoint.default @@ -884,12 +962,12 @@ let mk_tx_rollup_dispacth_ticket (oinfos : operation_req) (infos : infos) = ticketer = contract_of (match infos.accounts.dest with - | None -> infos.accounts.source + | None -> get_source infos | Some dest -> dest); amount = Tx_rollup_l2_qty.of_int64_exn 10L; claimer = (match infos.accounts.dest with - | None -> infos.accounts.source.pkh + | None -> (get_source infos).pkh | Some dest -> dest.pkh); } in @@ -900,7 +978,7 @@ let mk_tx_rollup_dispacth_ticket (oinfos : operation_req) (infos : infos) = ?gas_limit:oinfos.gas_limit ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - ~source:(contract_of infos.accounts.source) + ~source:(contract_of (get_source infos)) ~message_index:0 ~message_result_path:Tx_rollup_commitment.Merkle.dummy_path tx_rollup @@ -918,7 +996,7 @@ let mk_sc_rollup_origination (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) Sc_rollup.Kind.Example_arith ~boot_sector:"" ~parameters_ty:(Script.lazy_expr (Expr.from_string "1")) @@ -949,7 +1027,7 @@ let mk_sc_rollup_publish (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) sc_rollup sc_dummy_commitment @@ -963,7 +1041,7 @@ let mk_sc_rollup_cement (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) sc_rollup (Sc_rollup.Commitment.hash_uncarbonated sc_dummy_commitment) @@ -980,10 +1058,10 @@ let mk_sc_rollup_refute (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) sc_rollup (match infos.accounts.dest with - | None -> infos.accounts.source.pkh + | None -> (get_source infos).pkh | Some dest -> dest.pkh) (Some refutation) @@ -997,7 +1075,7 @@ let mk_sc_rollup_add_messages (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) sc_rollup [""] @@ -1011,12 +1089,12 @@ let mk_sc_rollup_timeout (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) sc_rollup (Sc_rollup.Game.Index.make - infos.accounts.source.pkh + (get_source infos).pkh (match infos.accounts.dest with - | None -> infos.accounts.source.pkh + | None -> (get_source infos).pkh | Some dest -> dest.pkh)) let mk_sc_rollup_execute_outbox_message (oinfos : operation_req) (infos : infos) @@ -1030,7 +1108,7 @@ let mk_sc_rollup_execute_outbox_message (oinfos : operation_req) (infos : infos) ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) sc_rollup (Sc_rollup.Commitment.hash_uncarbonated sc_dummy_commitment) ~output_proof:"" @@ -1045,24 +1123,9 @@ let mk_sc_rollup_return_bond (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) sc_rollup -let mk_dal_publish_slot_header (oinfos : operation_req) (infos : infos) = - let published_level = Alpha_context.Raw_level.of_int32_exn Int32.zero in - let index = Alpha_context.Dal.Slot_index.zero in - let header = Alpha_context.Dal.Slot.Header.zero in - let slot = Alpha_context.Dal.Slot.{id = {published_level; index}; header} in - Op.dal_publish_slot_header - ?fee:oinfos.fee - ?gas_limit:oinfos.gas_limit - ?counter:oinfos.counter - ?storage_limit:oinfos.storage_limit - ?force_reveal:oinfos.force_reveal - (B infos.ctxt.block) - (contract_of infos.accounts.source) - slot - let mk_zk_rollup_origination (oinfos : operation_req) (infos : infos) = let open Lwt_result_syntax in let* op, _ = @@ -1073,7 +1136,7 @@ let mk_zk_rollup_origination (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) ~public_parameters:ZKOperator.public_parameters ~circuits_info: (Zk_rollup.Account.SMap.of_seq @@ -1098,7 +1161,7 @@ let mk_zk_rollup_publish (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) ~zk_rollup ~ops:[(l2_op, None)] in @@ -1138,46 +1201,42 @@ let select_op (op_req : operation_req) (infos : infos) = | K_Sc_rollup_timeout -> mk_sc_rollup_timeout | K_Sc_rollup_execute_outbox_message -> mk_sc_rollup_execute_outbox_message | K_Sc_rollup_recover_bond -> mk_sc_rollup_return_bond - | K_Dal_publish_slot_header -> mk_dal_publish_slot_header | K_Zk_rollup_origination -> mk_zk_rollup_origination | K_Zk_rollup_publish -> mk_zk_rollup_publish in mk_op op_req infos -let create_Tztest ?hd_msg test tests_msg operations = - let tl_msg k = - let sk = kind_to_string k in - match hd_msg with - | None -> sk - | Some hd -> Format.sprintf "@[%s, %s@]" hd sk - in - [ - Tztest.tztest (Format.sprintf "@[%s@]" tests_msg) `Quick (fun () -> - List.iter_es - (fun kind -> - Format.printf "%s %s@." tests_msg (tl_msg kind) ; - test kind ()) - operations); - ] +let make_tztest ?(fmt = Format.std_formatter) name test subjects info_builder = + let open Lwt_result_syntax in + Tztest.tztest name `Quick (fun () -> + let* infos = info_builder () in + List.iter_es + (fun kind -> + Format.fprintf fmt "%s: %s@." name (kind_to_string kind) ; + test infos kind) + subjects) + +let make_tztest_batched ?(fmt = Format.std_formatter) name test subjects + info_builder = + let open Lwt_result_syntax in + Tztest.tztest name `Quick (fun () -> + let* infos = info_builder () in + List.iter_es + (fun kind1 -> + let k1s = kind_to_string kind1 in + List.iter_es + (fun kind2 -> + Format.fprintf + fmt + "%s: [%s ; %s]@." + name + k1s + (kind_to_string kind2) ; + test infos kind1 kind2) + subjects) + subjects) (** {2 Diagnostic helpers.} *) -let create_Tztest_batches test tests_msg operations = - let hdmsg k = Format.sprintf "@[%s@]" (kind_to_string k) in - [ - Tztest.tztest (Format.sprintf "@[%s@]" tests_msg) `Quick (fun () -> - List.iter_es - (fun kind1 -> - List.iter_es - (fun kind2 -> - Format.printf - "%s [%s / %s] @." - tests_msg - (hdmsg kind1) - (hdmsg kind2) ; - test kind1 kind2 ()) - operations) - operations); - ] (** The purpose of diagnostic helpers is to state the correct observation according to the validate result of a test. *) @@ -1484,7 +1543,6 @@ let subjects = K_Sc_rollup_timeout; K_Sc_rollup_execute_outbox_message; K_Sc_rollup_recover_bond; - K_Dal_publish_slot_header; K_Zk_rollup_origination; ] @@ -1496,8 +1554,7 @@ let is_consumer = function | 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 - | K_Zk_rollup_origination | K_Zk_rollup_publish -> + | K_Sc_rollup_recover_bond | K_Zk_rollup_origination | K_Zk_rollup_publish -> false | K_Transaction | K_Origination | K_Register_global_constant | K_Tx_rollup_dispatch_tickets | K_Transfer_ticket -> @@ -1523,5 +1580,4 @@ let is_disabled flags = function | K_Sc_rollup_add_messages | K_Sc_rollup_refute | K_Sc_rollup_timeout | K_Sc_rollup_execute_outbox_message | K_Sc_rollup_recover_bond -> flags.scoru = false - | K_Dal_publish_slot_header -> flags.dal = false | K_Zk_rollup_origination | K_Zk_rollup_publish -> flags.zkru = false diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_1m_restriction.ml b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_1m_restriction.ml index 7d6a1825e2b4..3f44f5c77800 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_1m_restriction.ml +++ b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_1m_restriction.ml @@ -27,7 +27,8 @@ ------- Component: Protocol (validate manager) Invocation: dune exec \ - src/proto_alpha/lib_protocol/test/integration/validate/test_1m_restriction.exe + src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/main.exe \ + -- test "^one-manager" Subject: 1M restriction in validation of manager operation. *) @@ -35,6 +36,8 @@ open Protocol open Manager_operation_helpers open Generators +let count = 100 + (** Local default values for the tests. *) let ctxt_cstrs_default = { @@ -88,7 +91,7 @@ let print_ops_pair (ctxt_req, op_req, mode) = (** The application of a valid operation succeeds, at least, to perform the fee payment. *) -let positive_validated_op = +let positive_tests = let gen = QCheck2.Gen.triple (Generators.gen_ctxt_req ctxt_cstrs_default) @@ -96,9 +99,9 @@ let positive_validated_op = Generators.gen_mode in wrap - ~count:1000 + ~count ~print:print_one_op - ~name:"Positive validated op" + ~name:"positive validated op" ~gen (fun (ctxt_req, operation_req, mode) -> let open Lwt_result_syntax in @@ -110,7 +113,7 @@ let positive_validated_op = (** Under 1M restriction, neither a block nor a prevalidator's valid pool should contain two operations with the same manager. It raises a Manager_restriction error. *) -let negative_validated_two_ops_of_same_manager = +let two_op_from_same_manager_tests = let gen = QCheck2.Gen.quad (Generators.gen_ctxt_req ctxt_cstrs_default) @@ -133,9 +136,9 @@ let negative_validated_two_ops_of_same_manager = err in wrap - ~count:1000 + ~count ~print:print_two_ops - ~name:"Negative -- 1M" + ~name:"check conflicts between managers." ~gen (fun (ctxt_req, operation_req, operation_req2, mode) -> let open Lwt_result_syntax in @@ -147,7 +150,7 @@ let negative_validated_two_ops_of_same_manager = (** Under 1M restriction, a batch of two operations cannot be replaced by two single operations. *) -let negative_batch_of_two_is_not_two_single = +let batch_is_not_singles_tests = let gen = QCheck2.Gen.triple (Generators.gen_ctxt_req ctxt_cstrs_default) @@ -158,16 +161,16 @@ let negative_batch_of_two_is_not_two_single = in let expect_failure _ = return_unit in wrap - ~count:1000 + ~count ~print:print_ops_pair - ~name:"Batch is not sequence of Single" + ~name:"batch is not sequence of Single" ~gen (fun (ctxt_req, operation_req, mode) -> let open Lwt_result_syntax in let* infos = init_ctxt ctxt_req in let* op1 = select_op (fst operation_req) infos in let* op2 = select_op (snd operation_req) infos in - let source = contract_of infos.accounts.source in + let source = contract_of (get_source infos) in let* batch = Op.batch_operations ~source (B infos.ctxt.block) [op1; op2] in @@ -178,7 +181,7 @@ let negative_batch_of_two_is_not_two_single = (** The applications of two covalid operations in a certain context succeed, at least, to perform the fee payment of both, in whatever application order. *) -let valid_context_free = +let conflict_free_tests = let gen = QCheck2.Gen.quad (Generators.gen_ctxt_req ctxt_cstrs_default) @@ -187,9 +190,9 @@ let valid_context_free = Generators.gen_mode in wrap - ~count:1000 + ~count ~print:print_two_ops - ~name:"Under 1M, co-valid ops commute" + ~name:"under 1M, co-valid ops commute" ~gen (fun (ctxt_req, operation_req, operation_req', mode) -> let open Lwt_result_syntax in @@ -201,10 +204,10 @@ let valid_context_free = accounts = { infos.accounts with - source = + sources = (match infos.accounts.del with | None -> assert false - | Some s -> s); + | Some s -> [s]); }; } in @@ -215,28 +218,11 @@ let valid_context_free = open Lib_test.Qcheck2_helpers -let positive_tests = qcheck_wrap [positive_validated_op] - -let two_op_from_same_manager_tests = - qcheck_wrap [negative_validated_two_ops_of_same_manager] - -let batch_is_not_singles_tests = - qcheck_wrap [negative_batch_of_two_is_not_two_single] - -let conflict_free_tests = qcheck_wrap [valid_context_free] - -let qcheck_tests = ("Positive tests", positive_tests) - -let qcheck_tests2 = - ("Only one manager op per manager", two_op_from_same_manager_tests) - -let qcheck_tests3 = - ("A batch differs from a sequence", batch_is_not_singles_tests) - -let qcheck_tests4 = - ("Fee payment of two covalid operations commute", conflict_free_tests) - -let () = - Alcotest.run - "1M QCheck" - [qcheck_tests; qcheck_tests2; qcheck_tests3; qcheck_tests4] +let tests : (string * [`Quick | `Slow] * (unit -> unit Lwt.t)) trace = + qcheck_wrap_lwt + [ + positive_tests; + two_op_from_same_manager_tests; + batch_is_not_singles_tests; + conflict_free_tests; + ] diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_covalidity.ml b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_covalidity.ml new file mode 100644 index 000000000000..8d4cc266d810 --- /dev/null +++ b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_covalidity.ml @@ -0,0 +1,157 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic-Labs. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: Protocol (validate manager) + Invocation: dune exec \ + src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/main.exe \ + -- test "^covalidity" + Subject: Validation of operation. +*) +open Validate_helpers + +open Generator_descriptors +open Valid_operations_generators +open Protocol +open Alpha_context + +(** Values of number of bootstraps to create.*) + +let default_batch_max_size = 49 + +let default_nb_bootstrap = 7 + +let nb_permutations = 30 + +let op_of_voting_period : Voting_period.kind -> op_kind = + let open Voting_period in + function + | Proposal -> KProposals + | Exploration -> KBallotExp + | Promotion -> KBallotProm + | _ -> assert false + +type seed_gen = Nonce | Vdf + +let pp_seed fmt = function + | Nonce -> Format.fprintf fmt "nonce" + | Vdf -> Format.fprintf fmt "vdf" + +let op_of_seed_gen = function Nonce -> KNonce | Vdf -> KVdf + +let is_not_preendorsement op = + let open Protocol.Alpha_context in + let (Operation_data {contents; _}) = op.protocol_data in + match contents with Single (Preendorsement _) -> false | _ -> true + +module OpkindMap = Map.Make (struct + type t = op_kind + + let compare = compare +end) + +let partition_op_kind op_kinds = + List.fold_left + (fun map op_kind -> + OpkindMap.update + op_kind + (function None -> Some 1 | Some c -> Some (succ c)) + map) + OpkindMap.empty + op_kinds + +let print_candidates candidates = + Format.printf + "@\n@[%d operations generated:@ %a@]@." + (List.length candidates) + Format.( + pp_print_list ~pp_sep:pp_print_cut (fun fmt (op, c) -> + Format.fprintf fmt "%d: %a" c pp_op_kind op)) + (List.map op_kind_of_packed_operation candidates + |> partition_op_kind |> OpkindMap.bindings) + +(** Test that for the set of covalid operations which kinds belongs to [ks] in a + state, any permutation is covalid and can be baked into a valid block. *) +let covalid_permutation_and_bake ks nb_bootstrap = + let open Lwt_result_syntax in + let* state, candidates = + covalid ks ~nb_bootstrap ~max_batch_size:default_batch_max_size + in + print_candidates candidates ; + let* () = sequential_validate state.block candidates in + let rec loop = function + | 0 -> return_unit + | n -> + let operations = + QCheck2.Gen.shuffle_l candidates + |> QCheck2.Gen.generate1 + |> List.sort Protocol.Alpha_context.Operation.compare_by_passes + |> List.rev_filter is_not_preendorsement + in + (* Ensure that we can validate and apply this permutation *) + let* _b = Block.bake state.block ~operations in + loop (pred n) + in + loop nb_permutations + +(** {2 Tests} *) + +let name voting_period reveal = + Format.asprintf + "scenario: '%a' period, '%a' seed" + Voting_period.pp_kind + voting_period + pp_seed + reveal + +(** Test [covalid_permutation_and_bake]. *) +let test_covalid voting_period seed_gen = + Generators.wrap + ~name:(name voting_period seed_gen) + ~gen:QCheck2.Gen.unit + (fun () -> + let open Lwt_result_syntax in + let ks = + op_of_voting_period voting_period + :: op_of_seed_gen seed_gen :: non_exclusive_kinds + in + let* () = covalid_permutation_and_bake ks default_nb_bootstrap in + return_true) + +let tests = + (* Create a list of all permutation of voting period and all + possible nonce generation *) + let voting_periods = [Voting_period.Proposal; Exploration; Promotion] in + let nonce_gens = [Nonce; Vdf] in + List.fold_left + (fun acc voting_period -> + List.fold_left + (fun acc nonce_gen -> test_covalid voting_period nonce_gen :: acc) + acc + nonce_gens) + [] + voting_periods + |> Lib_test.Qcheck2_helpers.qcheck_wrap_lwt diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_manager_operation_validation.ml b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_manager_operation_validation.ml index 5d352f63cd99..1264dca31933 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_manager_operation_validation.ml +++ b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_manager_operation_validation.ml @@ -27,8 +27,8 @@ ------- Component: Protocol (validate manager) Invocation: dune exec \ - src/proto_alpha/lib_protocol/test/integration/validate/main.exe \ - -- test "^Single" + src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/main.exe \ + -- test "^single" Subject: Validation of manager operation. *) @@ -36,86 +36,6 @@ open Protocol open Alpha_context open Manager_operation_helpers -(** The goal of this test is to ensure that [select_op] generate the - wanted kind of manager operation - - Note: if a new manager operation kind is added in the protocol, - [Manager_operation_helpers.manager_operation_kind] should be - extended. You will also have to extend - [Manager_operation_helpers.select_op] with a new `mk` for this new - operation. Finally the list [Manager_operation_helpers.subjects] - should also be extended to run the validate test on the new manager - operation kind. *) -let ensure_kind infos kind = - let open Lwt_result_syntax in - let* op = - select_op - {(operation_req_default kind) with force_reveal = Some false} - infos - in - let (Operation_data {contents; _}) = op.protocol_data in - match contents with - | Single (Manager_operation {operation; _}) -> ( - match (operation, kind) with - | Transaction _, K_Transaction - | Reveal _, K_Reveal - | Origination _, K_Origination - | Delegation _, K_Delegation - | Delegation _, K_Undelegation - | Delegation _, K_Self_delegation - | Register_global_constant _, K_Register_global_constant - | Set_deposits_limit _, K_Set_deposits_limit - | Update_consensus_key _, K_Update_consensus_key - | Increase_paid_storage _, K_Increase_paid_storage - | 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 - | Zk_rollup_origination _, K_Zk_rollup_origination - | Zk_rollup_publish _, K_Zk_rollup_publish -> - return_unit - | ( ( Transaction _ | Origination _ | Register_global_constant _ - | Delegation _ | Set_deposits_limit _ | Update_consensus_key _ - | Increase_paid_storage _ | Reveal _ | Tx_rollup_origination - | Tx_rollup_submit_batch _ | Tx_rollup_commit _ - | Tx_rollup_return_bond _ | Tx_rollup_finalize_commitment _ - | Tx_rollup_remove_commitment _ | Tx_rollup_dispatch_tickets _ - | Transfer_ticket _ | Tx_rollup_rejection _ | Sc_rollup_originate _ - | Sc_rollup_publish _ | Sc_rollup_cement _ | Sc_rollup_add_messages _ - | Sc_rollup_refute _ | Sc_rollup_timeout _ - | Sc_rollup_execute_outbox_message _ | Sc_rollup_recover_bond _ - | Dal_publish_slot_header _ | Sc_rollup_dal_slot_subscribe _ - | Zk_rollup_origination _ | Zk_rollup_publish _ ), - _ ) -> - assert false) - | Single _ -> assert false - | Cons _ -> assert false - -let ensure_manager_operation_coverage () = - let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - List.iter_es (fun kind -> ensure_kind infos kind) subjects - -let test_ensure_manager_operation_coverage () = - Tztest.tztest - (Format.sprintf "Ensure manager_operation coverage") - `Quick - (fun () -> ensure_manager_operation_coverage ()) - (** {2 Negative tests assert the case where validate must fail} *) (** Validate fails if the gas limit is too low. @@ -142,9 +62,8 @@ let low_gas_limit_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_low_gas_limit kind () = +let test_low_gas_limit infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* op = select_op { @@ -156,12 +75,6 @@ let test_low_gas_limit kind () = in low_gas_limit_diagnostic infos [op] -let generate_low_gas_limit () = - create_Tztest - test_low_gas_limit - "Gas_limit too low." - gas_consumer_in_validate_subjects - (** Validate fails if the gas limit is too high. This test asserts that the validation of a manager operation with @@ -179,9 +92,8 @@ let high_gas_limit_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_high_gas_limit kind () = +let test_high_gas_limit infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* op = select_op { @@ -194,9 +106,6 @@ let test_high_gas_limit kind () = in high_gas_limit_diagnostic infos [op] -let generate_high_gas_limit () = - create_Tztest test_high_gas_limit "Gas_limit too high." subjects - (** Validate fails if the storage limit is too high. This test asserts that a manager operation with a storage limit @@ -215,9 +124,8 @@ let high_storage_limit_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_high_storage_limit kind () = +let test_high_storage_limit infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* op = select_op { @@ -229,9 +137,6 @@ let test_high_storage_limit kind () = in high_storage_limit_diagnostic infos [op] -let generate_high_storage_limit () = - create_Tztest test_high_gas_limit "Storage_limit too high." subjects - (** Validate fails if the counter is in the future. This test asserts that the validation of @@ -252,9 +157,8 @@ let high_counter_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_high_counter kind () = +let test_high_counter infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* op = select_op { @@ -266,9 +170,6 @@ let test_high_counter kind () = in high_counter_diagnostic infos [op] -let generate_high_counter () = - create_Tztest test_high_counter "Counter too high." subjects - (** Validate fails if the counter is in the past. This test asserts that the validation of a manager operation with a @@ -289,13 +190,12 @@ let low_counter_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_low_counter kind () = +let test_low_counter infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* current_counter = Context.Contract.counter (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in let* op = select_op @@ -308,9 +208,6 @@ let test_low_counter kind () = in low_counter_diagnostic infos [op] -let generate_low_counter () = - create_Tztest test_low_counter "Counter too low." subjects - (** Validate fails if the source is not allocated. This test asserts that the validation of a manager operation which @@ -331,22 +228,18 @@ let not_allocated_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_not_allocated kind () = +let test_not_allocated infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* op = select_op {(operation_req_default kind) with force_reveal = Some false} { infos with - accounts = {infos.accounts with source = Account.(new_account ())}; + accounts = {infos.accounts with sources = [Account.(new_account ())]}; } in not_allocated_diagnostic infos [op] -let generate_not_allocated () = - create_Tztest test_not_allocated "Not allocated source." subjects - (** Validate fails if the source is unrevealed. This test asserts that a manager operation with an unrevealed source @@ -368,9 +261,8 @@ let unrevealed_key_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_unrevealed_key kind () = +let test_unrevealed_key infos kind = let open Lwt_result_syntax in - let* infos = init_ctxt {ctxt_req_default with reveal_accounts = false} in let* op = select_op {(operation_req_default kind) with force_reveal = Some false} @@ -378,12 +270,6 @@ let test_unrevealed_key kind () = in unrevealed_key_diagnostic infos [op] -let generate_unrevealed_key () = - create_Tztest - test_unrevealed_key - "Unrevealed source (find_manager_public_key)." - revealed_subjects - (** Validate fails if the source balance is not enough to pay the fees. This test asserts that validation of a manager operation fails if the @@ -405,9 +291,8 @@ let high_fee_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_high_fee kind () = +let test_high_fee infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let*? fee = Tez.(one +? one) |> Environment.wrap_tzresult in let* op = select_op @@ -420,9 +305,6 @@ let test_high_fee kind () = in high_fee_diagnostic infos [op] -let generate_tests_high_fee () = - create_Tztest test_high_fee "Balance too low for fee payment." subjects - (** Validate fails if the fee payment empties the balance of a delegated implicit contract. @@ -447,13 +329,12 @@ let emptying_delegated_implicit_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_emptying_delegated_implicit kind () = +let test_empty_implicit infos kind = let open Lwt_result_syntax in - let* infos = default_ctxt_with_delegation () in let* fee = Context.Contract.balance (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in let* op = select_op @@ -466,12 +347,6 @@ let test_emptying_delegated_implicit kind () = in emptying_delegated_implicit_diagnostic infos [op] -let generate_tests_emptying_delegated_implicit () = - create_Tztest - test_emptying_delegated_implicit - "Just enough funds to empty a delegated source." - revealed_subjects - (** Validate fails if there is not enough available gas in the block. This test asserts that validate fails with: @@ -504,12 +379,8 @@ let exceeding_block_gas_diagnostic ~mode (infos : infos) op = in validate_ko_diagnostic infos op expect_failure ~mode -let test_exceeding_block_gas ~mode kind () = +let test_exceeding_block_gas ~mode infos kind = let open Lwt_result_syntax in - let ctxt_req = - {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} - in - let* infos = init_ctxt ctxt_req in let* operation = select_op { @@ -524,18 +395,6 @@ let test_exceeding_block_gas ~mode kind () = in exceeding_block_gas_diagnostic ~mode infos [operation] -let generate_tests_exceeding_block_gas () = - create_Tztest - (test_exceeding_block_gas ~mode:Construction) - "Too much gas consumption." - subjects - -let generate_tests_exceeding_block_gas_mp_mode () = - create_Tztest - (test_exceeding_block_gas ~mode:Mempool) - "Too much gas consumption in mempool mode." - subjects - (** {2 Positive tests} *) (** Tests that validate succeeds when: @@ -561,14 +420,33 @@ let generate_tests_exceeding_block_gas_mp_mode () = - the balance is at least decreased by fee, - the available gas in the block decreased by gas limit. *) +(** Fee payment*) +let test_validate infos kind = + let open Lwt_result_syntax in + let* counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of (get_source infos)) + in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + counter = Some counter; + } + infos + in + let* _ = validate_diagnostic infos [op] in + return_unit + (** Fee payment that emptying a self_delegated implicit. *) -let test_emptying_self_delegated_implicit kind () = +let test_emptying_self_delegate infos kind = let open Lwt_result_syntax in - let* infos = default_ctxt_with_self_delegation () in let* fee = Context.Contract.balance (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in let* op = select_op @@ -582,12 +460,6 @@ let test_emptying_self_delegated_implicit kind () = let* _ = only_validate_diagnostic infos [op] in return_unit -let generate_tests_emptying_self_delegated_implicit () = - create_Tztest - test_emptying_self_delegated_implicit - "Validate and empties a self-delegated source." - subjects - (** Minimum gas cost to pass the validation: - cost_of_manager_operation for the generic part - 100 (empiric) for the specific part (script decoding or hash costs) *) @@ -595,13 +467,12 @@ let empiric_minimal_gas_cost_for_validate = Gas.Arith.integral_of_int_exn (Michelson_v1_gas.Internal_for_tests.int_cost_of_manager_operation + 100) -let test_emptying_undelegated_implicit kind () = +let test_empty_undelegate infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* fee = Context.Contract.balance (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in let* op = select_op @@ -616,15 +487,9 @@ let test_emptying_undelegated_implicit kind () = let* _ = only_validate_diagnostic infos [op] in return_unit -let generate_tests_emptying_undelegated_implicit () = - create_Tztest - test_emptying_undelegated_implicit - "Validate and empties an undelegated source." - subjects - (** No gas consumer with the minimal gas limit for manager operations passes validate. *) -let test_low_gas_limit_no_consumer kind () = +let test_low_gas_limit_no_consumer kind = let open Lwt_result_syntax in let* infos = default_init_ctxt () in let* op = @@ -638,36 +503,6 @@ let test_low_gas_limit_no_consumer kind () = in validate_diagnostic infos [op] -let generate_low_gas_limit_no_consumer () = - create_Tztest - test_low_gas_limit - "passes validate with minimal gas limit for manager operations." - gas_consumer_in_validate_subjects - -(** Fee payment.*) -let test_validate kind () = - let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let* counter = - Context.Contract.counter - (B infos.ctxt.block) - (contract_of infos.accounts.source) - in - let* op = - select_op - { - (operation_req_default kind) with - force_reveal = Some true; - counter = Some counter; - } - infos - in - let* _ = validate_diagnostic infos [op] in - return_unit - -let generate_tests_validate () = - create_Tztest test_validate "Validate." subjects - (* Feature flags.*) (* Select the error according to the positionned flag. @@ -707,26 +542,12 @@ let flag_expect_failure flags errs = In order to forge Toru, Scoru or Dal operation when the correspondong feature is disable, we use a [infos_op] with default requirements, so that we have a Tx_rollup.t and a Sc_rollup.t. *) -let test_feature_flags flags kind () = +let test_feature_flags infos kind = let open Lwt_result_syntax in - let* infos_op = default_init_ctxt () in - let* infos = default_init_with_flags flags in - let infos = - { - infos with - ctxt = - { - infos.ctxt with - tx_rollup = infos_op.ctxt.tx_rollup; - sc_rollup = infos_op.ctxt.sc_rollup; - zk_rollup = infos_op.ctxt.zk_rollup; - }; - } - in let* counter = Context.Contract.counter (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in let* op = select_op @@ -736,7 +557,8 @@ let test_feature_flags flags kind () = } infos in - let* _ = + let flags = infos.flags in + let* () = if is_disabled flags kind then validate_ko_diagnostic infos [op] (flag_expect_failure flags) else @@ -745,51 +567,66 @@ let test_feature_flags flags kind () = in return_unit -let generate_dal_flag () = - create_Tztest - (test_feature_flags disabled_dal) - "Validate with dal disabled." - subjects - -let generate_scoru_flag () = - create_Tztest - (test_feature_flags disabled_scoru) - "Validate with scoru disabled." - subjects - -let generate_toru_flag () = - create_Tztest - (test_feature_flags disabled_toru) - "Validate with toru disabled." - subjects - -let generate_zkru_flag () = - create_Tztest - (test_feature_flags disabled_zkru) - "Validate with zkru disabled." - subjects - -let sanity_tests = - test_ensure_manager_operation_coverage () :: generate_tests_validate () - -let gas_tests = - generate_low_gas_limit () @ generate_high_gas_limit () - @ generate_tests_exceeding_block_gas () - @ generate_tests_exceeding_block_gas_mp_mode () - @ generate_low_gas_limit_no_consumer () - -let storage_tests = generate_high_storage_limit () - -let fee_tests = - generate_tests_high_fee () - @ generate_tests_emptying_delegated_implicit () - @ generate_tests_emptying_self_delegated_implicit () - @ generate_tests_emptying_undelegated_implicit () - -let contract_tests = - generate_high_counter () @ generate_low_counter () @ generate_not_allocated () - @ generate_unrevealed_key () - -let flags_tests = - generate_dal_flag () @ generate_toru_flag () @ generate_scoru_flag () - @ generate_zkru_flag () +let tests = + let mk_default () = default_init_ctxt () in + let mk_reveal () = + init_ctxt {ctxt_req_default with reveal_accounts = false} + in + let mk_deleg () = default_ctxt_with_delegation () in + let mk_gas () = + init_ctxt {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} + in + let mk_self_deleg () = default_ctxt_with_self_delegation () in + let mk_flags flags () = + let open Lwt_result_syntax in + let* infos_op = default_init_ctxt () in + let* infos = default_init_with_flags flags in + let infos = + { + infos with + ctxt = + { + infos.ctxt with + tx_rollup = infos_op.ctxt.tx_rollup; + sc_rollup = infos_op.ctxt.sc_rollup; + zk_rollup = infos_op.ctxt.zk_rollup; + }; + } + in + return infos + in + let all = subjects in + let gas_consum = gas_consumer_in_validate_subjects in + let revealed = revealed_subjects in + List.map + (fun (name, f, subjects, info_builder) -> + make_tztest name f subjects info_builder) + [ + (* Expected validation failure *) + ("gas limit too low", test_low_gas_limit, gas_consum, mk_default); + ("gas limit too high", test_high_gas_limit, all, mk_default); + ("storage limit too high", test_high_storage_limit, all, mk_default); + ("counter too high", test_high_counter, all, mk_default); + ("counter too low", test_low_counter, all, mk_default); + ("unallocated source", test_not_allocated, all, mk_default); + ("unrevealed source", test_unrevealed_key, revealed, mk_reveal); + ("balance too low for fee payment", test_high_fee, all, mk_default); + ("empty delegate source", test_empty_implicit, revealed, mk_deleg); + ( "too much gas consumption in block", + test_exceeding_block_gas ~mode:Construction, + all, + mk_gas ); + (* Expected validation success *) + ("fees are taken when valid", test_validate, all, mk_default); + ("empty self-delegate", test_emptying_self_delegate, all, mk_self_deleg); + ( "too much gas consumption in mempool", + test_exceeding_block_gas ~mode:Mempool, + all, + mk_gas ); + ("empty undelegated source", test_empty_undelegate, all, mk_default); + ("minimal gas for manager", test_low_gas_limit, gas_consum, mk_default); + ("check dal disabled", test_feature_flags, all, mk_flags disabled_dal); + ("check toru disabled", test_feature_flags, all, mk_flags disabled_toru); + ("check scoru disabled", test_feature_flags, all, mk_flags disabled_scoru); + ("check zkru disabled", test_feature_flags, all, mk_flags disabled_zkru); + ] diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_mempool.ml b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_mempool.ml index a6ab57cc546e..f4d4699d7ccb 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_mempool.ml +++ b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_mempool.ml @@ -27,7 +27,7 @@ ------- Component: Protocol Invocation: dune exec \ - src/proto_alpha/lib_protocol/test/integration/validate/main.exe \ + src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/main.exe \ -- test "^Mempool" Subject: Integration > Validate > Mempool mode *) diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_sanity.ml b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_sanity.ml new file mode 100644 index 000000000000..d671c847a041 --- /dev/null +++ b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_sanity.ml @@ -0,0 +1,174 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic-Labs. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: Protocol (validate manager) + Invocation: dune exec \ + src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/main.exe \ + -- test "sanity checks" + Subject: Validation of operation. +*) + +open Protocol +open Alpha_context +open Manager_operation_helpers + +(** The goal of this test is to ensure that [select_op] generate the + wanted kind of manager operation + + Note: if a new manager operation kind is added in the protocol, + [Manager_operation_helpers.manager_operation_kind] should be + extended. You will also have to extend + [Manager_operation_helpers.select_op] with a new `mk` for this new + operation. Finally the list [Manager_operation_helpers.subjects] + should also be extended to run the validate test on the new manager + operation kind. *) +let ensure_kind infos kind = + let open Lwt_result_syntax in + let* op = + select_op + {(operation_req_default kind) with force_reveal = Some false} + infos + in + let (Operation_data {contents; _}) = op.protocol_data in + match contents with + | Single (Manager_operation {operation; _}) -> ( + match (operation, kind) with + | Transaction _, K_Transaction + | Reveal _, K_Reveal + | Origination _, K_Origination + | Delegation _, K_Delegation + | Delegation _, K_Undelegation + | Delegation _, K_Self_delegation + | Register_global_constant _, K_Register_global_constant + | Set_deposits_limit _, K_Set_deposits_limit + | Update_consensus_key _, K_Update_consensus_key + | Increase_paid_storage _, K_Increase_paid_storage + | 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 + | Zk_rollup_origination _, K_Zk_rollup_origination + | Zk_rollup_publish _, K_Zk_rollup_publish -> + return_unit + | ( ( Transaction _ | Origination _ | Register_global_constant _ + | Delegation _ | Set_deposits_limit _ | Update_consensus_key _ + | Increase_paid_storage _ | Reveal _ | Tx_rollup_origination + | Tx_rollup_submit_batch _ | Tx_rollup_commit _ + | Tx_rollup_return_bond _ | Tx_rollup_finalize_commitment _ + | Tx_rollup_remove_commitment _ | Tx_rollup_dispatch_tickets _ + | Transfer_ticket _ | Tx_rollup_rejection _ | Sc_rollup_originate _ + | Sc_rollup_publish _ | Sc_rollup_cement _ | Sc_rollup_add_messages _ + | Sc_rollup_refute _ | Sc_rollup_timeout _ + | Sc_rollup_execute_outbox_message _ | Sc_rollup_recover_bond _ + | Dal_publish_slot_header _ | Sc_rollup_dal_slot_subscribe _ + | Zk_rollup_origination _ | Zk_rollup_publish _ ), + _ ) -> + assert false) + | Single _ -> assert false + | Cons _ -> assert false + +let ensure_manager_operation_coverage () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + List.iter_es (fun kind -> ensure_kind infos kind) subjects + +open Generator_descriptors +open Valid_operations_generators + +(** This test ensures that it exists a valid operation generator for + each operation. + + Note: When adding a new operation, one should refer to {! + Generator_descriptor} to see how to add its valid operation + generator. *) +let covalidation_sanity () = + let open Lwt_result_syntax in + let max_batch_size = 1 in + let nb_bootstrap = 7 in + List.iter_es + (fun kind -> + let* _, candidates = covalid [kind] ~nb_bootstrap ~max_batch_size in + match List.hd candidates with + | None -> + failwith "no candidates was generated for kind '%a'" pp_op_kind kind + | Some {protocol_data = Operation_data {contents; _}; _} -> ( + match (contents, kind) with + | Single (Preendorsement _), KPreendorsement -> return_unit + | Single (Preendorsement _), _ -> assert false + | Single (Endorsement _), KEndorsement -> return_unit + | Single (Endorsement _), _ -> assert false + | Single (Dal_slot_availability _), KDalslotavail -> return_unit + | Single (Dal_slot_availability _), _ -> assert false + | Single (Seed_nonce_revelation _), KNonce -> return_unit + | Single (Seed_nonce_revelation _), _ -> assert false + | Single (Vdf_revelation _), KVdf -> return_unit + | Single (Vdf_revelation _), _ -> assert false + | Single (Double_endorsement_evidence _), KDbl_consensus -> + return_unit + | Single (Double_endorsement_evidence _), _ -> assert false + | Single (Double_preendorsement_evidence _), KDbl_consensus -> + return_unit + | Single (Double_preendorsement_evidence _), _ -> assert false + | Single (Double_baking_evidence _), KDbl_baking -> return_unit + | Single (Double_baking_evidence _), _ -> assert false + | Single (Activate_account _), KActivate -> return_unit + | Single (Activate_account _), _ -> assert false + | Single (Proposals _), KProposals -> return_unit + | Single (Proposals _), _ -> assert false + | Single (Ballot _), (KBallotExp | KBallotProm) -> return_unit + | Single (Ballot _), _ -> assert false + | Single (Drain_delegate _), KDrain -> return_unit + | Single (Drain_delegate _), _ -> assert false + | Single (Manager_operation _), KManager + | Cons (Manager_operation _, _), KManager -> + return_unit + | Single (Manager_operation _), _ | Cons (Manager_operation _, _), _ + -> + assert false + | Single (Failing_noop _), _ -> assert false)) + all_kinds + +let tests = + List.map + (fun (name, f) -> Tztest.tztest name `Quick f) + [ + ("manager operation coverage", ensure_manager_operation_coverage); + ("covalidation coverage", covalidation_sanity); + ] diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_validation_batch.ml similarity index 81% rename from src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml rename to src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_validation_batch.ml index b97bdf5e1641..c823264c6089 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml +++ b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/test_validation_batch.ml @@ -27,8 +27,8 @@ ------- Component: Protocol (validate manager) Invocation: dune exec \ - src/proto_alpha/lib_protocol/test/integration/validate/main.exe \ - -- test "^Batched" + src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/main.exe \ + -- test "^batched" Subject: Validation of batched manager operation. *) @@ -56,13 +56,12 @@ let batch_reveal_in_the_middle_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_batch_reveal_in_the_middle kind1 kind2 () = +let batch_in_the_middle infos kind1 kind2 = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* counter = Context.Contract.counter (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in let counter = Z.succ counter in let* operation1 = @@ -97,18 +96,12 @@ let test_batch_reveal_in_the_middle kind1 kind2 () = let* batch = Op.batch_operations ~recompute_counters:false - ~source:(contract_of infos.accounts.source) + ~source:(contract_of (get_source infos)) (Context.B infos.ctxt.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 only occur at the beginning of a batch." - revealed_subjects - (** A batch of manager operation contains at most one Revelation.*) let batch_two_reveals_diagnostic (infos : infos) op = let expected_failure errs = @@ -126,13 +119,12 @@ let batch_two_reveals_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expected_failure -let test_batch_two_reveals kind () = +let batch_two_reveals infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* counter = Context.Contract.counter (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in let counter = Z.succ counter in let* reveal = @@ -167,18 +159,12 @@ let test_batch_two_reveals kind () = let* batch = Op.batch_operations ~recompute_counters:false - ~source:(contract_of infos.accounts.source) + ~source:(contract_of (get_source infos)) (Context.B infos.ctxt.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 - (** Every manager operation in a batch concerns the same source.*) let batch_two_sources_diagnostic (infos : infos) op = let expect_failure errs = @@ -194,10 +180,9 @@ let batch_two_sources_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_batch_two_sources kind1 kind2 () = +let batch_two_sources infos kind1 kind2 = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let source = contract_of infos.accounts.source in + let source = contract_of (get_source infos) in let* counter = Context.Contract.counter (B infos.ctxt.block) source in let counter = Z.succ counter in let* operation1 = @@ -213,7 +198,7 @@ let test_batch_two_sources kind1 kind2 () = let source2 = match infos.accounts.del with None -> assert false | Some s -> s in - {infos with accounts = {infos.accounts with source = source2}} + {infos with accounts = {infos.accounts with sources = [source2]}} in let* operation2 = select_op @@ -229,18 +214,11 @@ let test_batch_two_sources kind1 kind2 () = in batch_two_sources_diagnostic infos [batch] -let generate_batches_two_sources () = - create_Tztest_batches - test_batch_two_sources - "Only one source per batch." - revealed_subjects - (** Counters in a batch should be a sequence from the successor of the stored counter associated to source in the initial context. *) -let test_batch_inconsistent_counters kind1 kind2 () = +let batch_incons_counters infos kind1 kind2 = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let source = contract_of infos.accounts.source in + let source = contract_of (get_source infos) in let* counter = Context.Contract.counter (B infos.ctxt.block) source in let fee = Some Tez.one_mutez in let op_infos = operation_req_default K_Reveal in @@ -327,18 +305,11 @@ let test_batch_inconsistent_counters kind1 kind2 () = 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 batch_emptying_balance_in_the_middle infos kind1 kind2 = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let source = contract_of infos.accounts.source in + let source = contract_of (get_source infos) in let* counter = Context.Contract.counter (B infos.ctxt.block) source in let* init_bal = Context.Contract.balance (B infos.ctxt.block) source in let counter = counter in @@ -393,120 +364,11 @@ let test_batch_emptying_balance_in_the_middle kind1 kind2 () = 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 - -(** A batch of manager operation must not exceed the initial available gas in the block. *) -let test_batch_exceeding_block_gas ~mempool_mode kind1 kind2 () = - let open Lwt_result_syntax in - let ctxt_req = - {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} - in - let* infos = init_ctxt ctxt_req in - let source = contract_of infos.accounts.source in - let* counter = Context.Contract.counter (B infos.ctxt.block) source in - let g_limit = Gas.Arith.add gb_limit Gas.Arith.(integral_of_int_exn 1) in - let half_limit = - Gas.Arith.add half_gb_limit Gas.Arith.(integral_of_int_exn 1) - in - let* reveal = - mk_reveal - {(operation_req_default K_Reveal) with counter = Some counter} - infos - in - let counter = Z.succ counter in - let operation gas_limit = - select_op - { - (operation_req_default kind1) with - force_reveal = Some false; - counter = Some counter; - gas_limit = Some (Custom_gas gas_limit); - } - infos - in - let counter = Z.succ counter in - let operation2 gas_limit = - select_op - { - (operation_req_default kind2) with - force_reveal = Some false; - counter = Some counter; - gas_limit = Some (Custom_gas gas_limit); - } - infos - in - let* op_case1 = operation g_limit in - let* op2_case1 = operation2 Gas.Arith.zero in - let* op_case2 = operation half_limit in - let* op2_case2 = operation2 g_limit in - let* op_case3 = operation half_limit in - let* op2_case3 = operation2 half_limit in - let* case1 = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [reveal; op_case1; op2_case1] - in - let* case3 = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [reveal; op_case3; op2_case3] - in - let* case2 = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [reveal; op_case2; op2_case2] - in - let* i = Incremental.begin_construction infos.ctxt.block ~mempool_mode in - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Gas.Block_quota_exceeded] - when not mempool_mode -> - return_unit - | [ - Environment.Ecoproto_error Gas.Gas_limit_too_high; - Environment.Ecoproto_error Gas.Block_quota_exceeded; - ] - when mempool_mode -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - let* _ = Incremental.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 - (** A batch that consumes all the balance for fees only at the end of the batch passes validate.*) -let test_batch_balance_just_enough kind1 kind2 () = +let batch_empty_at_end infos kind1 kind2 = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let source = contract_of infos.accounts.source in + let source = contract_of (get_source infos) in let* counter = Context.Contract.counter (B infos.ctxt.block) source in let* init_bal = Context.Contract.balance (B infos.ctxt.block) source in let*? half_init_bal = Environment.wrap_tzresult @@ Tez.(init_bal /? 2L) in @@ -559,17 +421,10 @@ let test_batch_balance_just_enough kind1 kind2 () = let* _ = validate_diagnostic infos [case3] in return_unit -let generate_batches_balance_just_enough () = - create_Tztest_batches - test_batch_balance_just_enough - "Fee payment emptying balance in a batch." - revealed_subjects - (** Simple reveal followed by a transaction. *) -let test_batch_reveal_transaction_ok () = +let batch_reveal_transaction infos = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let source = contract_of infos.accounts.source in + let source = contract_of (get_source infos) in let* counter = Context.Contract.counter (B infos.ctxt.block) source in let counter = counter in let fee = Tez.one_mutez in @@ -603,22 +458,149 @@ let test_batch_reveal_transaction_ok () = let* _ = validate_diagnostic infos [batch] in return_unit -let contract_tests = - generate_batches_reveal_in_the_middle () - @ generate_tests_batches_two_reveals () - @ generate_batches_two_sources () - @ generate_batches_inconsistent_counters () - @ [ - Tztest.tztest - "Validate a batch with a reveal and a transaction." - `Quick - test_batch_reveal_transaction_ok; +(** A batch of manager operation must not exceed the initial available gas in the block. *) +let batch_exceeding_block_gas ~mempool_mode infos kind1 kind2 = + let open Lwt_result_syntax in + let source = contract_of (get_source infos) in + let* counter = Context.Contract.counter (B infos.ctxt.block) source in + let g_limit = Gas.Arith.add gb_limit Gas.Arith.(integral_of_int_exn 1) in + let half_limit = + Gas.Arith.add half_gb_limit Gas.Arith.(integral_of_int_exn 1) + in + let* reveal = + mk_reveal + {(operation_req_default K_Reveal) with counter = Some counter} + infos + in + let counter = Z.succ counter in + let operation gas_limit = + select_op + { + (operation_req_default kind1) with + force_reveal = Some false; + counter = Some counter; + gas_limit = Some (Custom_gas gas_limit); + } + infos + in + let counter = Z.succ counter in + let operation2 gas_limit = + select_op + { + (operation_req_default kind2) with + force_reveal = Some false; + counter = Some counter; + gas_limit = Some (Custom_gas gas_limit); + } + infos + in + let* op_case1 = operation g_limit in + let* op2_case1 = operation2 Gas.Arith.zero in + let* op_case2 = operation half_limit in + let* op2_case2 = operation2 g_limit in + let* op_case3 = operation half_limit in + let* op2_case3 = operation2 half_limit in + let* case1 = + Op.batch_operations + ~recompute_counters:false + ~source + (Context.B infos.ctxt.block) + [reveal; op_case1; op2_case1] + in + let* case3 = + Op.batch_operations + ~recompute_counters:false + ~source + (Context.B infos.ctxt.block) + [reveal; op_case3; op2_case3] + in + let* case2 = + Op.batch_operations + ~recompute_counters:false + ~source + (Context.B infos.ctxt.block) + [reveal; op_case2; op2_case2] + in + let* i = Incremental.begin_construction infos.ctxt.block ~mempool_mode in + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error Gas.Block_quota_exceeded] + when not mempool_mode -> + return_unit + | [ + Environment.Ecoproto_error Gas.Gas_limit_too_high; + Environment.Ecoproto_error Gas.Block_quota_exceeded; ] + when mempool_mode -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + let* _ = Incremental.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 gas_tests = - generate_batches_exceeding_block_gas () - @ generate_batches_exceeding_block_gas_mp_mode () +let make_tztest_batched ?(fmt = Format.std_formatter) name test subjects + info_builder = + let open Lwt_result_syntax in + Tztest.tztest name `Quick (fun () -> + let* infos = info_builder () in + List.iter_es + (fun kind1 -> + let k1s = kind_to_string kind1 in + List.iter_es + (fun kind2 -> + Format.fprintf + fmt + "%s: [%s ; %s]@." + name + k1s + (kind_to_string kind2) ; + test infos kind1 kind2) + subjects) + subjects) -let fee_tests = - generate_batches_emptying_balance_in_the_middle () - @ generate_batches_balance_just_enough () +let tests = + let open Lwt_result_syntax in + let mk_default () = default_init_ctxt () in + let mk_high_gas_limit () = + init_ctxt {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} + in + let revealed = revealed_subjects in + [ + ( Tztest.tztest "batch reveal and transaction" `Quick @@ fun () -> + let* infos = mk_default () in + batch_reveal_transaction infos ); + ] + @ List.map + (fun (name, f, subjects, info_builder) -> + make_tztest name f subjects info_builder) + [("batch two reveals", batch_two_reveals, revealed, mk_default)] + @ List.map + (fun (name, f, subjects, info_builder) -> + make_tztest_batched name f subjects info_builder) + [ + ("reveal in the middle", batch_in_the_middle, revealed, mk_default); + ("batch two sources", batch_two_sources, revealed, mk_default); + ("batch incons. counters", batch_incons_counters, revealed, mk_default); + ( "empty balance in middle of batch", + batch_emptying_balance_in_the_middle, + revealed, + mk_default ); + ( "empty balance at end of batch", + batch_empty_at_end, + revealed, + mk_default ); + ( "too much gas consumption", + batch_exceeding_block_gas ~mempool_mode:false, + revealed, + mk_high_gas_limit ); + ( "too much gas consumption (mempool)", + batch_exceeding_block_gas ~mempool_mode:true, + revealed, + mk_high_gas_limit ); + ] diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/valid_operations_generators.ml b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/valid_operations_generators.ml new file mode 100644 index 000000000000..78694ffc2706 --- /dev/null +++ b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/valid_operations_generators.ml @@ -0,0 +1,243 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context +open Generator_descriptors + +(** {2 Building the Setup} *) + +(** Setup for generating valid operation of several kind of + operations. It gathers the following information to setup + {! Generator_descriptor.state} into which valid operations + can be generated: + - [nb_cycles] the total number of cycles to bake, + - [nb_blocks] the number of blocks to bake in the last cycle, + - [params] the constants required, and + - [prelude] that associates to each cycle to bake a list of + {! Generator_descriptors.descriptor} prelude functions. *) +type setup = { + prelude : + (int * (state -> (packed_operation list * state) tzresult Lwt.t) list) list; + nb_cycles : int; + nb_blocks : int; + params : Parameters.t; +} + +(** Select the prelude actions of a specific cycle in a setup prelude. *) +let prelude_on_cycle (c : int) + (actions : + (int * (state -> (packed_operation list * state) tzresult Lwt.t) list) + list) : (state -> (packed_operation list * state) tzresult Lwt.t) list = + match List.filter (fun (c1, _actions) -> c = c1) actions with + | (c1, actions) :: _ -> + assert (c = c1) ; + actions + | [] -> [] + +(** Knowing the total number of required cycles, normalize a prelude + on the list of the pair of a cycle and prelude actions. *) +let normalize_preludes nb_cycles (descr : descriptor) = + let normalize prelude = + match prelude with + | On n, actions -> [(nb_cycles - n, actions)] + | From n, actions -> + List.fold_left + (fun acc i -> acc @ [(nb_cycles - n + i, actions)]) + [] + (1 -- n) + in + let prim = normalize descr.prelude in + match descr.opt_prelude with + | Some prelude -> normalize prelude @ prim + | None -> prim + +(** Insert a normalized prelude in a prelude of a setup.*) +let rec insert_normalize_preludes + ((n, action) : + int * (state -> (packed_operation list * state) tzresult Lwt.t)) + (preludes : + (int * (state -> (packed_operation list * state) tzresult Lwt.t) list) + list) = + match preludes with + | [] -> [(n, [action])] + | (m, actions) :: rest -> + if m = n then (m, actions @ [action]) :: rest + else (m, actions) :: insert_normalize_preludes (n, action) rest + +(** Produce a setup prelude from a list of descriptor and a nb of + cycles*) +let compose_preludes nb_cycles descrs = + let normalized_preludes = List.map (normalize_preludes nb_cycles) descrs in + List.fold_left + (fun acc pre -> + List.fold_left (fun acc pr -> insert_normalize_preludes pr acc) acc pre) + [] + normalized_preludes + +(** Agregate the parameters of several {! Generator_descriptors.descriptor}.*) +let initiated_params descrs nb_accounts = + let consensus_committee_size = nb_accounts in + let initial_params = + Tezos_protocol_015_PtLimaPt_parameters.Default_parameters + .parameters_of_constants + { + Context.default_test_constants with + consensus_threshold = 0; + consensus_committee_size; + } + in + let descrs_params = List.map (fun descr -> descr.parameters) descrs in + List.fold_left (fun acc f -> f acc) initial_params descrs_params + +(** Make a [setup] from a list of {! Generator_descriptors.descriptor}. The required number of + cycles and number of blocks in the last cycle are the maximum of + required cycle and number of block in the descriptors list. The + prelude is the composition of the composition of the descriptors + preludes list -- see [compose_preludes]. The parameters are the agregation of the + descriptors parameters -- see [initiated_params]. *) +let setup_of descrs nb_accounts = + let params = initiated_params descrs nb_accounts in + let max_list l = List.fold_left max 0 l in + let required_cycle_list l = + List.map (fun descr -> descr.required_cycle params) l + in + let required_block_list l = + List.map (fun descr -> descr.required_block params) l + in + let sorted_descrs = + List.sort + (fun pre1 pre2 -> + Int.compare (pre1.required_cycle params) (pre2.required_cycle params)) + descrs + in + let nb_cycles = max_list (required_cycle_list descrs) in + let nb_blocks = max_list (required_block_list descrs) in + let prelude = compose_preludes nb_cycles sorted_descrs in + {prelude; nb_cycles; nb_blocks; params} + +(** From a number of accounts and a list of descriptors set up the + prelude state. + + Thanks to the setup computing for the list of descriptors -- see [setup_of] --, + initiates a context with the setup parameters, and the number of + accounts. Initiate a state that will be fulfilled during the + preludes. During the required number of cycles of the setup, bakes + each cycle with the setup prelude by selecting the actions to + perform on it. On the last cycle, bake the required number of + blocks of the setup. Finally, adds the delegates at the end of + the prelude in the state. *) +let init nb_accounts descrs = + let open Lwt_result_syntax in + let setup = setup_of descrs nb_accounts in + let* initial_block, bootstraps = + Context.init_with_parameters_n setup.params nb_accounts + in + let* voters = Context.Vote.get_listings (B initial_block) in + let* initial_voters = + List.map_es (fun (c, _) -> return (Contract.Implicit c)) voters + in + let my_bake selected_preludes_for_cycle state = + let* state, operations = + List.fold_left_es + (fun (state, ops) prelude -> + let+ ops', state = prelude state in + let ops = ops' @ ops in + (state, ops)) + (state, []) + selected_preludes_for_cycle + in + let b = state.block in + let operations = + List.sort (fun op1 op2 -> Operation.compare_by_passes op2 op1) operations + in + let+ block = Block.bake ~operations b in + {state with block; pred = Some b} + in + let my_bake_n cycle n state = + List.fold_left_es + (fun state _ -> + let selected_preludes = prelude_on_cycle cycle setup.prelude in + my_bake selected_preludes state) + state + (1 -- n) + in + let my_bake_until_cycle_end cycle state = + let current_level = state.block.Block.header.shell.level in + let current_level = + Int32.rem current_level setup.params.constants.blocks_per_cycle + in + let delta = + Int32.sub setup.params.constants.blocks_per_cycle current_level + in + my_bake_n cycle (Int32.to_int delta) state + in + let* state = + List.fold_left_es + (fun state cycle -> my_bake_until_cycle_end cycle state) + (init_state initial_block ~voters:initial_voters ~bootstraps) + (Stdlib.List.init setup.nb_cycles Fun.id) + in + let my_bake_n_default n state = + List.fold_left_es + (fun state _ -> + let pred = state.block in + let+ block = Block.bake state.block in + {state with block; pred = Some pred}) + state + (1 -- n) + in + let* state = + if setup.nb_blocks >= 1 then my_bake_n_default setup.nb_blocks state + else return state + in + return state + +(** In a state, generates all the valid operations of a list of kinds. *) +let candidates state kinds nb_bootstrap max_batch_size = + let open Lwt_result_syntax in + let* candidates = + List.fold_left_es + (fun acc k -> + let* candidates = + (descriptor_of k ~nb_bootstrap ~max_batch_size).candidates_generator + state + in + let acc = acc @ candidates in + return acc) + [] + kinds + in + return candidates + +(** From a list of kind of operations generates all the valid + operations of this kind and the generation state. *) +let covalid ks ~nb_bootstrap ~max_batch_size = + let open Lwt_result_syntax in + let* state = + init nb_bootstrap (descriptors_of ~nb_bootstrap ~max_batch_size ks) + in + let* candidates = candidates state ks nb_bootstrap max_batch_size in + return (state, candidates) diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/validate_helpers.ml b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/validate_helpers.ml new file mode 100644 index 000000000000..be0326836db7 --- /dev/null +++ b/src/proto_015_PtLimaPt/lib_protocol/test/integration/validate/validate_helpers.ml @@ -0,0 +1,394 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module Registered_nonces = Nonce +open Protocol +open Alpha_context +module Manager = Manager_operation_helpers + +(** {2 Helpers} *) + +(** {3 Randomness } *) + +let gen_bounded_int min max = QCheck2.Gen.(generate1 @@ int_range min max) + +let pick_one l = QCheck2.Gen.(generate1 @@ oneofl l) + +let pick_n (n : int) (l : 'a list) : 'a list = + List.take_n n QCheck2.Gen.(generate1 @@ shuffle_l l) + +(** {3 Helpers for lists } *) + +let get_n l n = + assert (List.length l > n) ; + Stdlib.List.nth l n + +let mycombine l1 l2 = + let sz_dels = List.length l1 in + let sz_phs = List.length l2 in + let dels, phs = + if sz_dels = sz_phs then (l1, l2) + else if sz_dels < sz_phs then (l1, List.take_n sz_dels l2) + else (List.take_n sz_phs l1, l2) + in + Stdlib.List.combine dels phs + +(** {3 Global Values}*) + +let ballots = Vote.[Yay; Nay; Pass] + +let protos = + List.map + (fun s -> Protocol_hash.of_b58check_exn s) + [ + "ProtoALphaALphaALphaALphaALphaALphaALpha61322gcLUGH"; + "ProtoALphaALphaALphaALphaALphaALphaALphabc2a7ebx6WB"; + "ProtoALphaALphaALphaALphaALphaALphaALpha84efbeiF6cm"; + "ProtoALphaALphaALphaALphaALphaALphaALpha91249Z65tWS"; + "ProtoALphaALphaALphaALphaALphaALphaALpha537f5h25LnN"; + "ProtoALphaALphaALphaALphaALphaALphaALpha5c8fefgDYkr"; + "ProtoALphaALphaALphaALphaALphaALphaALpha3f31feSSarC"; + "ProtoALphaALphaALphaALphaALphaALphaALphabe31ahnkxSC"; + "ProtoALphaALphaALphaALphaALphaALphaALphabab3bgRb7zQ"; + "ProtoALphaALphaALphaALphaALphaALphaALphaf8d39cctbpk"; + "ProtoALphaALphaALphaALphaALphaALphaALpha3b981byuYxD"; + "ProtoALphaALphaALphaALphaALphaALphaALphaa116bccYowi"; + "ProtoALphaALphaALphaALphaALphaALphaALphacce68eHqboj"; + "ProtoALphaALphaALphaALphaALphaALphaALpha225c7YrWwR7"; + "ProtoALphaALphaALphaALphaALphaALphaALpha58743cJL6FG"; + "ProtoALphaALphaALphaALphaALphaALphaALphac91bcdvmJFR"; + "ProtoALphaALphaALphaALphaALphaALphaALpha1faaadhV7oW"; + "ProtoALphaALphaALphaALphaALphaALphaALpha98232gD94QJ"; + "ProtoALphaALphaALphaALphaALphaALphaALpha9d1d8cijvAh"; + "ProtoALphaALphaALphaALphaALphaALphaALphaeec52dKF6Gx"; + "ProtoALphaALphaALphaALphaALphaALphaALpha841f2cQqajX"; + ] + +type secret_account = { + blinded_public_key_hash : Blinded_public_key_hash.t; + account : Ed25519.Public_key_hash.t; + activation_code : Blinded_public_key_hash.activation_code; + amount : Tez.t; +} + +let secrets = + (* Exported from proto_alpha client - TODO : remove when relocated to lib_crypto *) + let read_key mnemonic email password = + match Tezos_client_base.Bip39.of_words mnemonic with + | None -> assert false + | Some t -> + (* TODO: unicode normalization (NFKD)... *) + let passphrase = Bytes.(cat (of_string email) (of_string password)) in + let sk = Tezos_client_base.Bip39.to_seed ~passphrase t in + let sk = Bytes.sub sk 0 32 in + let sk : Signature.Secret_key.t = + Ed25519 + (Data_encoding.Binary.of_bytes_exn Ed25519.Secret_key.encoding sk) + in + let pk = Signature.Secret_key.to_public_key sk in + let pkh = Signature.Public_key.hash pk in + (pkh, pk, sk) + in + List.map + (fun (mnemonic, secret, amount, pkh, password, email) -> + let pkh', pk, sk = read_key mnemonic email password in + let pkh = Ed25519.Public_key_hash.of_b58check_exn pkh in + assert (Signature.Public_key_hash.equal (Ed25519 pkh) pkh') ; + let activation_code = + Stdlib.Option.get + (Blinded_public_key_hash.activation_code_of_hex secret) + in + let bpkh = Blinded_public_key_hash.of_ed25519_pkh activation_code pkh in + let account = Account.{pkh = Ed25519 pkh; pk; sk} in + Account.add_account account ; + { + blinded_public_key_hash = bpkh; + account = pkh; + activation_code; + amount = + WithExceptions.Option.to_exn + ~none:(Invalid_argument "tez conversion") + (Tez.of_mutez (Int64.of_string amount)); + }) + [ + ( [ + "envelope"; + "hospital"; + "mind"; + "sunset"; + "cancel"; + "muscle"; + "leisure"; + "thumb"; + "wine"; + "market"; + "exit"; + "lucky"; + "style"; + "picnic"; + "success"; + ], + "0f39ed0b656509c2ecec4771712d9cddefe2afac", + "23932454669343", + "tz1MawerETND6bqJqx8GV3YHUrvMBCDasRBF", + "z0eZHQQGKt", + "cjgfoqmk.wpxnvnup@tezos.example.org" ); + ( [ + "flag"; + "quote"; + "will"; + "valley"; + "mouse"; + "chat"; + "hold"; + "prosper"; + "silk"; + "tent"; + "cruel"; + "cause"; + "demise"; + "bottom"; + "practice"; + ], + "41f98b15efc63fa893d61d7d6eee4a2ce9427ac4", + "72954577464032", + "tz1X4maqF9tC1Yn4jULjHRAyzjAtc25Z68TX", + "MHErskWPE6", + "oklmcktr.ztljnpzc@tezos.example.org" ); + ( [ + "library"; + "away"; + "inside"; + "paper"; + "wise"; + "focus"; + "sweet"; + "expose"; + "require"; + "change"; + "stove"; + "planet"; + "zone"; + "reflect"; + "finger"; + ], + "411dfef031eeecc506de71c9df9f8e44297cf5ba", + "217487035428349", + "tz1SWBY7rWMutEuWS54Pt33MkzAS6eWkUuTc", + "0AO6BzQNfN", + "ctgnkvqm.kvtiybky@tezos.example.org" ); + ( [ + "cruel"; + "fluid"; + "damage"; + "demand"; + "mimic"; + "above"; + "village"; + "alpha"; + "vendor"; + "staff"; + "absent"; + "uniform"; + "fire"; + "asthma"; + "milk"; + ], + "08d7d355bc3391d12d140780b39717d9f46fcf87", + "4092742372031", + "tz1amUjiZaevaxQy5wKn4SSRvVoERCip3nZS", + "9kbZ7fR6im", + "bnyxxzqr.tdszcvqb@tezos.example.org" ); + ( [ + "opera"; + "divorce"; + "easy"; + "myself"; + "idea"; + "aim"; + "dash"; + "scout"; + "case"; + "resource"; + "vote"; + "humor"; + "ticket"; + "client"; + "edge"; + ], + "9b7cad042fba557618bdc4b62837c5f125b50e56", + "17590039016550", + "tz1Zaee3QBtD4ErY1SzqUvyYTrENrExu6yQM", + "suxT5H09yY", + "iilkhohu.otnyuvna@tezos.example.org" ); + ( [ + "token"; + "similar"; + "ginger"; + "tongue"; + "gun"; + "sort"; + "piano"; + "month"; + "hotel"; + "vote"; + "undo"; + "success"; + "hobby"; + "shell"; + "cart"; + ], + "124c0ca217f11ffc6c7b76a743d867c8932e5afd", + "26322312350555", + "tz1geDUUhfXK1EMj7VQdRjug1MoFe6gHWnCU", + "4odVdLykaa", + "kwhlglvr.slriitzy@tezos.example.org" ); + ( [ + "shield"; + "warrior"; + "gorilla"; + "birth"; + "steak"; + "neither"; + "feel"; + "only"; + "liberty"; + "float"; + "oven"; + "extend"; + "pulse"; + "suffer"; + "vapor"; + ], + "ac7a2125beea68caf5266a647f24dce9fea018a7", + "244951387881443", + "tz1h3nY7jcZciJgAwRhWcrEwqfVp7VQoffur", + "A6yeMqBFG8", + "lvrmlbyj.yczltcxn@tezos.example.org" ); + ( [ + "waste"; + "open"; + "scan"; + "tip"; + "subway"; + "dance"; + "rent"; + "copper"; + "garlic"; + "laundry"; + "defense"; + "clerk"; + "another"; + "staff"; + "liar"; + ], + "2b3e94be133a960fa0ef87f6c0922c19f9d87ca2", + "80065050465525", + "tz1VzL4Xrb3fL3ckvqCWy6bdGMzU2w9eoRqs", + "oVZqpq60sk", + "rfodmrha.zzdndvyk@tezos.example.org" ); + ( [ + "fiber"; + "next"; + "property"; + "cradle"; + "silk"; + "obey"; + "gossip"; + "push"; + "key"; + "second"; + "across"; + "minimum"; + "nice"; + "boil"; + "age"; + ], + "dac31640199f2babc157aadc0021cd71128ca9ea", + "3569618927693", + "tz1RUHg536oRKhPLFfttcB5gSWAhh4E9TWjX", + "FfytQTTVbu", + "owecikdy.gxnyttya@tezos.example.org" ); + ( [ + "print"; + "labor"; + "budget"; + "speak"; + "poem"; + "diet"; + "chunk"; + "eternal"; + "book"; + "saddle"; + "pioneer"; + "ankle"; + "happy"; + "only"; + "exclude"; + ], + "bb841227f250a066eb8429e56937ad504d7b34dd", + "9034781424478", + "tz1M1LFbgctcPWxstrao9aLr2ECW1fV4pH5u", + "zknAl3lrX2", + "ettilrvh.zsrqrbud@tezos.example.org" ); + ] + +(** {3 Context Manipulations } *) + +let pick_two_endorsers ctxt = + let module V = Plugin.RPC.Validators in + Context.get_endorsers ctxt >>=? function + | a :: b :: _ -> return ((a.V.delegate, a.V.slots), (b.V.delegate, b.V.slots)) + | _ -> assert false + +let pick_addr_endorser ctxt = + let module V = Plugin.RPC.Validators in + Context.get_endorsers ctxt >>=? function + | a :: _ -> return a.V.delegate + | _ -> assert false + +let init_params = + Tezos_protocol_015_PtLimaPt_parameters.Default_parameters + .parameters_of_constants + {Context.default_test_constants with consensus_threshold = 0} + +let delegates_of_block block = + let open Lwt_result_syntax in + let+ validators = Context.get_endorsers (B block) in + List.map + (fun Plugin.RPC.Validators.{delegate; slots; _} -> (delegate, slots)) + validators + +(** Sequential validation of an operation list. *) +let sequential_validate ?(mempool_mode = true) block operations = + let open Lwt_result_syntax in + let* inc = Incremental.begin_construction ~mempool_mode block in + let* _inc = + List.fold_left_es + (fun acc op -> Incremental.validate_operation acc op) + inc + operations + in + return_unit diff --git a/src/proto_alpha/lib_protocol/test/helpers/context.mli b/src/proto_alpha/lib_protocol/test/helpers/context.mli index 75e066a1aca2..a5bfdb6c5687 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/context.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/context.mli @@ -44,11 +44,11 @@ val to_alpha_ctxt : t -> Alpha_context.t tzresult Lwt.t see {! Plugin.RPC.Validator.t}. *) val get_endorsers : t -> Plugin.RPC.Validators.t list tzresult Lwt.t -(** The 2 first elements of the list returns by [get_endorsers]. *) +(** Return the two first elements of the list returns by [get_endorsers]. *) val get_first_different_endorsers : t -> (Plugin.RPC.Validators.t * Plugin.RPC.Validators.t) tzresult Lwt.t -(** The first element of the list returns by [get_endorsers]. *) +(** Return the first element of the list returns by [get_endorsers]. *) val get_endorser : t -> (public_key_hash * Slot.t list) tzresult Lwt.t (** Given a delegate public key hash [del], and a context [ctxt], @@ -57,7 +57,7 @@ val get_endorser : t -> (public_key_hash * Slot.t list) tzresult Lwt.t val get_endorser_slot : t -> public_key_hash -> Slot.t list option tzresult Lwt.t -(** The [n]th element of the list returns by [get_endorsers]. *) +(** Return the [n]th element of the list returns by [get_endorsers]. *) val get_endorser_n : t -> int -> (public_key_hash * Slot.t list) tzresult Lwt.t val get_endorsing_power_for_delegate : -- GitLab From 97667266b5cca633d6102b47c016327a1df670aa Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 14 Oct 2022 11:05:43 +0200 Subject: [PATCH 7/7] Kathmandu/Tests: backport optimisations of integration tests --- manifest/main.ml | 4 +- .../lib_protocol/test/helpers/context.ml | 25 ++ .../lib_protocol/test/helpers/context.mli | 31 ++ .../test/integration/validate/dune | 15 +- .../test/integration/validate/generators.ml | 10 +- .../test/integration/validate/main.ml | 18 +- .../validate/manager_operation_helpers.ml | 377 +++++++++++------- .../validate/test_1m_restriction.ml | 72 ++-- .../test_manager_operation_validation.ml | 373 +++++------------ .../test/integration/validate/test_sanity.ml | 111 ++++++ ...validation.ml => test_validation_batch.ml} | 340 ++++++++-------- 11 files changed, 716 insertions(+), 660 deletions(-) create mode 100644 src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_sanity.ml rename src/proto_014_PtKathma/lib_protocol/test/integration/validate/{test_batched_manager_operation_validation.ml => test_validation_batch.ml} (82%) diff --git a/manifest/main.ml b/manifest/main.ml index 2abce2cbd963..3ee3e7c4e0ce 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -3559,8 +3559,8 @@ end = struct in let _integration_validate = only_if N.(number >= 014) @@ fun () -> - tests - ("main" :: (if N.(number == 014) then ["test_1m_restriction"] else [])) + test + "main" ~path:(path // "lib_protocol/test/integration/validate") ~opam:(sf "tezos-protocol-%s-tests" name_dash) ~deps: diff --git a/src/proto_014_PtKathma/lib_protocol/test/helpers/context.ml b/src/proto_014_PtKathma/lib_protocol/test/helpers/context.ml index 84b97a45337e..51d339a46d3c 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/helpers/context.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/helpers/context.ml @@ -448,6 +448,18 @@ let init2 = init_gen T2 let init3 = init_gen T3 +let create_bootstrap_accounts n = + let accounts = Account.generate_accounts n in + let open Tezos_protocol_014_PtKathma_parameters in + List.fold_left + (fun (boostrap_account, contracts) (account, tez, delegate_to) -> + ( Default_parameters.make_bootstrap_account + (Account.(account.pkh), Account.(account.pk), tez, delegate_to) + :: boostrap_account, + Alpha_context.Contract.Implicit Account.(account.pkh) :: contracts )) + ([], []) + accounts + let init_with_constants_gen tup constants = let n = tup_n tup in let accounts = Account.generate_accounts n in @@ -476,6 +488,19 @@ let init_with_constants1 = init_with_constants_gen T1 let init_with_constants2 = init_with_constants_gen T2 +let init_with_parameters_gen tup parameters = + let n = tup_n tup in + let bootstrap_accounts, contracts = create_bootstrap_accounts n in + let parameters = Parameters.{parameters with bootstrap_accounts} in + Block.genesis_with_parameters parameters >|=? fun blk -> + (blk, tup_get tup contracts) + +let init_with_parameters_n params n = init_with_parameters_gen (TList n) params + +let init_with_parameters1 = init_with_parameters_gen T1 + +let init_with_parameters2 = init_with_parameters_gen T2 + let default_raw_context () = let initial_accounts = Account.generate_accounts ~initial_balances:[100_000_000_000L] 1 diff --git a/src/proto_014_PtKathma/lib_protocol/test/helpers/context.mli b/src/proto_014_PtKathma/lib_protocol/test/helpers/context.mli index c11e6c102021..208de369394f 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/helpers/context.mli +++ b/src/proto_014_PtKathma/lib_protocol/test/helpers/context.mli @@ -287,6 +287,37 @@ val init_with_constants2 : (Block.t * (Alpha_context.Contract.t * Alpha_context.Contract.t)) tzresult Lwt.t +(** [init_with_parameters_gen tup params] returns an initial block parametrised + with [params] and the implicit contracts corresponding to its bootstrap + accounts. The number of bootstrap accounts, and the structure of the + returned contracts, are specified by the [tup] argument. *) +val init_with_parameters_gen : + (Alpha_context.Contract.t, 'contracts) tup -> + Parameters.t -> + (Block.t * 'contracts) tzresult Lwt.t + +(** [init_with_parameters_n params n] returns an initial block parametrized + with [params] with [n] initialized accounts and the associated implicit + contracts *) +val init_with_parameters_n : + Parameters.t -> + int -> + (Block.t * Alpha_context.Contract.t list) tzresult Lwt.t + +(** [init_with_parameters1 params] returns an initial block parametrized with + [params] with 1 initialized accounts and the associated implicit + contracts *) +val init_with_parameters1 : + Parameters.t -> (Block.t * Alpha_context.Contract.t) tzresult Lwt.t + +(** [init_with_parameters2 params] returns an initial block parametrized with + [params] with two initialized accounts and the associated implicit + contracts *) +val init_with_parameters2 : + Parameters.t -> + (Block.t * (Alpha_context.Contract.t * Alpha_context.Contract.t)) tzresult + Lwt.t + (** [default_raw_context] returns a [Raw_context.t] for use in tests below [Alpha_context] *) val default_raw_context : unit -> Raw_context.t tzresult Lwt.t diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/dune b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/dune index 9e56b2994a37..08e476d64fb5 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/dune +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/dune @@ -1,8 +1,8 @@ ; This file was automatically generated, do not edit. ; Edit file manifest/main.ml instead. -(executables - (names main test_1m_restriction) +(executable + (name main) (libraries alcotest-lwt tezos-base @@ -10,7 +10,8 @@ qcheck-alcotest tezos-client-014-PtKathma tezos-014-PtKathma-test-helpers - tezos-base-test-helpers) + tezos-base-test-helpers + tezos-protocol-plugin-014-PtKathma) (flags (:standard) -open Tezos_base.TzPervasives @@ -18,14 +19,10 @@ -open Tezos_protocol_014_PtKathma -open Tezos_client_014_PtKathma -open Tezos_014_PtKathma_test_helpers - -open Tezos_base_test_helpers)) + -open Tezos_base_test_helpers + -open Tezos_protocol_plugin_014_PtKathma)) (rule (alias runtest) (package tezos-protocol-014-PtKathma-tests) (action (run %{dep:./main.exe}))) - -(rule - (alias runtest) - (package tezos-protocol-014-PtKathma-tests) - (action (run %{dep:./test_1m_restriction.exe}))) diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/generators.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/generators.ml index dd40f8c10039..f046a7e3a26c 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/generators.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/generators.ml @@ -242,6 +242,7 @@ let gen_ctxt_req : ctxt_cstrs -> ctxt_req QCheck2.Gen.t = fund_src; fund_dest; fund_del; + reveal_accounts = true; fund_tx; fund_sc; flags = all_enabled; @@ -249,15 +250,16 @@ let gen_ctxt_req : ctxt_cstrs -> ctxt_req QCheck2.Gen.t = (** {2 Wrappers} *) -let wrap ~name ?print ?count ?check ~(gen : 'a QCheck2.Gen.t) +let wrap ~name ?print ?(count = 1) ?check ~(gen : 'a QCheck2.Gen.t) (f : 'a -> bool tzresult Lwt.t) = - Lib_test.Qcheck2_helpers.qcheck_make_result + Lib_test.Qcheck2_helpers.qcheck_make_result_lwt ~name ?print - ?count + ~count ?check + ~extract:Lwt_main.run ~pp_error:pp_print_trace ~gen - (fun a -> Lwt_main.run (f a)) + f let wrap_mode infos op mode = validate_diagnostic ~mode infos op diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml index 1f6fca58d06a..71d13f0c0fcf 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.ml @@ -34,19 +34,9 @@ let () = Alcotest_lwt.run "protocol > integration > validate" [ - ("sanity checks", Test_manager_operation_validation.sanity_tests); - ("Single: gas checks", Test_manager_operation_validation.gas_tests); - ("Single: storage checks", Test_manager_operation_validation.storage_tests); - ("Single: fees checks", Test_manager_operation_validation.fee_tests); - ( "Single: contract checks", - Test_manager_operation_validation.contract_tests ); - ( "Batched: contract checks", - Test_batched_manager_operation_validation.contract_tests ); - ( "Batched: gas checks", - Test_batched_manager_operation_validation.gas_tests ); - ( "Batched: fees checks", - Test_batched_manager_operation_validation.fee_tests ); - ( "Flags: feature flag checks", - Test_manager_operation_validation.flags_tests ); + ("sanity checks", Test_sanity.tests); + ("single manager validation", Test_manager_operation_validation.tests); + ("batched managers validation", Test_validation_batch.tests); + ("one-manager restriction", Test_1m_restriction.tests); ] |> Lwt_main.run diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml index b66b6247b776..b8a6f9ac3d45 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -40,29 +40,31 @@ let half_gb_limit = Gas.Arith.(integral_of_int_exn 50_000) (** Context abstraction in a test. *) type ctxt = { block : Block.t; - originated_contract : Contract_hash.t; + bootstraps : public_key_hash list; + originated_contract : Contract_hash.t option; tx_rollup : Tx_rollup.t option; sc_rollup : Sc_rollup.t option; } -(** Accounts manipulated in the tests. - By convention, each field name specifies the role - of the account in a test. It is the case in most of the tests. - In smart contructors of operations, it happens that in impossible case, - [source] is used as a dummy value. - In some test that requires a second source, [del] will be used as the second - source. *) +(** Accounts manipulated in the tests. By convention, each field name + specifies the role of the account in a test. It is the case in most + of the tests. In operations smart contructors, it happens that in + impossible case, [source] is used as a dummy value. In some test that + requires a second source, [del] will be used as the second source. *) type accounts = { - source : Account.t; + sources : Account.t list; dest : Account.t option; del : Account.t option; tx : Account.t option; sc : Account.t option; } +(** Feature flags requirements for a context setting for a test. *) +type feature_flags = {dal : bool; scoru : bool; toru : bool} + (** Infos describes the information of the setting for a test: the context and used accounts. *) -type infos = {ctxt : ctxt; accounts : accounts} +type infos = {ctxt : ctxt; accounts : accounts; flags : feature_flags} (** This type should be extended for each new manager_operation kind added in the protocol. See @@ -77,8 +79,8 @@ type manager_operation_kind = | K_Undelegation | K_Self_delegation | K_Set_deposits_limit - | K_Reveal | K_Increase_paid_storage + | K_Reveal | K_Tx_rollup_origination | K_Tx_rollup_submit_batch | K_Tx_rollup_commit @@ -109,15 +111,13 @@ type operation_req = { amount : Tez.t option; } -(** Feature flags requirements for a context setting for a test. *) -type feature_flags = {dal : bool; scoru : bool; toru : bool} - (** The requirements for a context setting for a test. *) type ctxt_req = { hard_gas_limit_per_block : Gas.Arith.integral option; fund_src : Tez.t option; fund_dest : Tez.t option; fund_del : Tez.t option; + reveal_accounts : bool; fund_tx : Tez.t option; fund_sc : Tez.t option; flags : feature_flags; @@ -146,6 +146,7 @@ let ctxt_req_default_to_flag flags = fund_src = Some Tez.one; fund_dest = Some Tez.one; fund_del = Some Tez.one; + reveal_accounts = true; fund_tx = Some Tez.one; fund_sc = Some Tez.one; flags; @@ -164,8 +165,7 @@ let operation_req_default kind = amount = None; } -(** {2 String of datatypes} *) - +(** {2 String_of data} *) let kind_to_string = function | K_Transaction -> "Transaction" | K_Delegation -> "Delegation" @@ -174,8 +174,8 @@ let kind_to_string = function | K_Set_deposits_limit -> "Set deposits limit" | K_Origination -> "Origination" | K_Register_global_constant -> "Register global constant" - | K_Reveal -> "Revelation" | K_Increase_paid_storage -> "Increase paid storage" + | K_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" @@ -242,6 +242,7 @@ let pp_ctxt_req pp fund_src; fund_dest; fund_del; + reveal_accounts; fund_tx; fund_sc; flags; @@ -253,6 +254,7 @@ let pp_ctxt_req pp fund_src: %a tz@,\ fund_dest: %a tz@,\ fund_del: %a tz@,\ + reveal_accounts: %b tz@,\ fund_tx: %a tz@,\ fund_sc: %a tz@,\ dal_flag: %a@,\ @@ -267,6 +269,7 @@ let pp_ctxt_req pp fund_dest (pp_opt Tez.pp) fund_del + reveal_accounts (pp_opt Tez.pp) fund_tx (pp_opt Tez.pp) @@ -362,9 +365,8 @@ let originate_sc_rollup block rollup_account = (** {2 Setting's context construction} *) -let fund_account block bootstrap account fund = +let fund_account_op block bootstrap account fund counter = let open Lwt_result_syntax in - let* counter = Context.Contract.counter (B block) bootstrap in let* fund = match fund with | None -> return Tez.one @@ -374,7 +376,7 @@ let fund_account block bootstrap account fund = Lwt.return (Environment.wrap_tzresult Tez.(source_balance -? one)) else return fund in - let* operation = + let+ op = Op.transaction ~counter ~gas_limit:Op.High @@ -383,23 +385,74 @@ let fund_account block bootstrap account fund = (Contract.Implicit account) fund in + (op, Z.succ counter) + +let fund_account block bootstrap account fund = + let open Lwt_result_syntax in + let* counter = Context.Contract.counter (B block) bootstrap in + let* operation, (_counter : counter) = + fund_account_op block bootstrap account fund counter + in let*! b = Block.bake ~operation block in match b with Error _ -> failwith "Funding account error" | Ok b -> return b -(** The generic setting for a test is built up according to a context - requirement. It provides a context and accounts where the accounts - have been created and funded according to the context - requirements.*) -let init_ctxt : ctxt_req -> infos tzresult Lwt.t = - fun { - hard_gas_limit_per_block; - fund_src; - fund_dest; - fund_del; - fund_tx; - fund_sc; - flags; - } -> +(** Set the constants according to a [ctxt_req] in an existing parameters. *) +let manager_parameters : Parameters.t -> ctxt_req -> Parameters.t = + fun params {hard_gas_limit_per_block; flags; _} -> + let hard_gas_limit_per_block = + match hard_gas_limit_per_block with + | Some gb -> gb + | None -> Gas.Arith.(integral_of_int_exn 5_200_000) + in + let dal = {params.constants.dal with feature_enable = flags.dal} in + let tx_rollup = + { + params.constants.tx_rollup with + sunset_level = Int32.max_int; + enable = flags.toru; + } + in + let sc_rollup = {params.constants.sc_rollup with enable = flags.scoru} in + let constants = + {params.constants with hard_gas_limit_per_block; dal; tx_rollup; sc_rollup} + in + {params with constants} + +(** Initial a context with the constants extracted from a context requirements + and 7 bootstrap accounts. *) +let init_ctxt_only ctxtreq = + let open Lwt_result_syntax in + let initial_params = + Tezos_protocol_014_PtKathma_parameters.Default_parameters + .parameters_of_constants + {Context.default_test_constants with consensus_threshold = 0} + in + let* block, contracts = + Context.init_with_parameters_n (manager_parameters initial_params ctxtreq) 7 + in + return + ( block, + List.map + (function Contract.Implicit pkh -> pkh | Originated _ -> assert false) + contracts ) + +(** Build a generic setting for a test according to a context requirement + on an existing context with 7 bootstraps accounts. *) +let init_infos : + ctxt_req -> Block.t -> public_key_hash list -> infos tzresult Lwt.t = + fun ctxtreq block bootstraps -> + let { + fund_src; + fund_dest; + fund_del; + fund_tx; + fund_sc; + flags; + reveal_accounts; + _; + } = + ctxtreq + in let open Lwt_result_syntax in let create_and_fund ?originate_rollup block bootstrap fund = match fund with @@ -416,18 +469,18 @@ let init_ctxt : ctxt_req -> infos tzresult Lwt.t = in (block, Some account, rollup) in - let* block, bootstraps = - Context.init_n - 6 - ~consensus_threshold:0 - ?hard_gas_limit_per_block - ~tx_rollup_enable:flags.toru - ~tx_rollup_sunset_level:Int32.max_int - ~sc_rollup_enable:flags.scoru - ~dal_enable:flags.dal - () + let reveal_accounts_operations b l = + List.filter_map_es + (function + | None -> return_none + | Some account -> + let* op = Op.revelation ~gas_limit:Low (B b) account.Account.pk in + return_some op) + l + in + let get_bootstrap bootstraps n = + Contract.Implicit (Stdlib.List.nth bootstraps n) in - let get_bootstrap bootstraps n = Stdlib.List.nth bootstraps n in let source = Account.new_account () in let* block = fund_account block (get_bootstrap bootstraps 0) source.pkh fund_src @@ -441,8 +494,7 @@ let init_ctxt : ctxt_req -> infos tzresult Lwt.t = let* block, tx, tx_rollup = if flags.toru then create_and_fund - ~originate_rollup:(fun infos account -> - originate_tx_rollup infos account) + ~originate_rollup:originate_tx_rollup block (get_bootstrap bootstraps 3) fund_tx @@ -451,8 +503,7 @@ let init_ctxt : ctxt_req -> infos tzresult Lwt.t = let* block, sc, sc_rollup = if flags.scoru then create_and_fund - ~originate_rollup:(fun infos account -> - originate_sc_rollup infos account) + ~originate_rollup:originate_sc_rollup block (get_bootstrap bootstraps 4) fund_sc @@ -461,30 +512,58 @@ let init_ctxt : ctxt_req -> infos tzresult Lwt.t = let* create_contract_hash, originated_contract = Op.contract_origination_hash (B block) - (get_bootstrap bootstraps 5) + (get_bootstrap bootstraps 6) ~fee:Tez.zero ~script:Op.dummy_script in - let+ block = Block.bake ~operation:create_contract_hash block in - let ctxt = {block; originated_contract; tx_rollup; sc_rollup} in - {ctxt; accounts = {source; dest; del; tx; sc}} + let* reveal_operations = + if reveal_accounts then + reveal_accounts_operations block [Some source; dest; del] + else return [] + in + let operations = create_contract_hash :: reveal_operations in + let+ block = Block.bake ~operations block in + let ctxt = + { + block; + bootstraps; + originated_contract = Some originated_contract; + tx_rollup; + sc_rollup; + } + in + {ctxt; accounts = {sources = [source]; dest; del; tx; sc}; flags} + +(** The generic setting for a test is built up according to a context + requirement. It provides a context and accounts where the accounts + have been created and funded according to the context + requirements.*) +let init_ctxt : ctxt_req -> infos tzresult Lwt.t = + fun ctxtreq -> + let open Lwt_result_syntax in + let* block, bootstraps = init_ctxt_only ctxtreq in + init_infos ctxtreq block bootstraps + +(** return the first source from the list of sources in [infos] accounts. *) +let get_source infos = + match infos.accounts.sources with source :: _ -> source | [] -> assert false (** In addition of building up a context according to a context requirement, source is self-delegated. - See [init_ctxt] description. *) + see [init_ctxt] description. *) let ctxt_with_self_delegation : ctxt_req -> infos tzresult Lwt.t = fun ctxt_req -> let open Lwt_result_syntax in let* infos = init_ctxt ctxt_req in - let+ block = self_delegate infos.ctxt.block infos.accounts.source.pkh in + let+ block = self_delegate infos.ctxt.block (get_source infos).pkh in let ctxt = {infos.ctxt with block} in {infos with ctxt} (** In addition of building up a context accordning to a context requirement, source delegates to del. - See [init_ctxt] description. *) + See [init_ctxt] description. *) let ctxt_with_delegation : ctxt_req -> infos tzresult Lwt.t = fun ctxt_req -> let open Lwt_result_syntax in @@ -494,7 +573,7 @@ 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 infos.accounts.source delegate in + let+ block = delegation infos.ctxt.block (get_source infos) delegate in let ctxt = {infos.ctxt with block} in {infos with ctxt} @@ -509,7 +588,7 @@ let default_ctxt_with_delegation () = ctxt_with_delegation ctxt_req_default (** {2 Smart constructors} *) -(** Smart contructors to forge manager operations according to +(** Smart constructors to forge manager operations according to operation requirements in a test setting. *) let mk_transaction (oinfos : operation_req) (infos : infos) = @@ -520,10 +599,10 @@ let mk_transaction (oinfos : operation_req) (infos : infos) = ?gas_limit:oinfos.gas_limit ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) (contract_of (match infos.accounts.dest with - | None -> infos.accounts.source + | None -> get_source infos | Some dest -> dest)) (match oinfos.amount with None -> Tez.zero | Some amount -> amount) @@ -535,10 +614,10 @@ let mk_delegation (oinfos : operation_req) (infos : infos) = ?counter:oinfos.counter ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) (Some (match infos.accounts.del with - | None -> infos.accounts.source.pkh + | None -> (get_source infos).pkh | Some delegate -> delegate.pkh)) let mk_undelegation (oinfos : operation_req) (infos : infos) = @@ -549,7 +628,7 @@ let mk_undelegation (oinfos : operation_req) (infos : infos) = ?counter:oinfos.counter ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) None let mk_self_delegation (oinfos : operation_req) (infos : infos) = @@ -560,8 +639,8 @@ let mk_self_delegation (oinfos : operation_req) (infos : infos) = ?counter:oinfos.counter ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - (contract_of infos.accounts.source) - (Some infos.accounts.source.pkh) + (contract_of (get_source infos)) + (Some (get_source infos).pkh) let mk_origination (oinfos : operation_req) (infos : infos) = let open Lwt_result_syntax in @@ -574,7 +653,7 @@ let mk_origination (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ~script:Op.dummy_script (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in op @@ -586,7 +665,7 @@ let mk_register_global_constant (oinfos : operation_req) (infos : infos) = ?gas_limit:oinfos.gas_limit ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - ~source:(contract_of infos.accounts.source) + ~source:(contract_of (get_source infos)) ~value:(Script_repr.lazy_expr (Expr.from_string "Pair 1 2")) let mk_set_deposits_limit (oinfos : operation_req) (infos : infos) = @@ -597,10 +676,19 @@ let mk_set_deposits_limit (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?counter:oinfos.counter (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) None let mk_increase_paid_storage (oinfos : operation_req) (infos : infos) = + let open Lwt_result_syntax in + let* destination = + match infos.ctxt.originated_contract with + | None -> + failwith + "infos should be initialized with an origniated contract to be able \ + to add an increase_paid_storage operation." + | Some c -> return c + in Op.increase_paid_storage ?force_reveal:oinfos.force_reveal ?counter:oinfos.counter @@ -608,13 +696,13 @@ let mk_increase_paid_storage (oinfos : operation_req) (infos : infos) = ?gas_limit:oinfos.gas_limit ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - ~source:(contract_of infos.accounts.source) - ~destination:infos.ctxt.originated_contract + ~source:(contract_of (get_source infos)) + ~destination Z.one let mk_reveal (oinfos : operation_req) (infos : infos) = let open Lwt_result_syntax in - let* pk = get_pk (B infos.ctxt.block) (contract_of infos.accounts.source) in + let* pk = get_pk (B infos.ctxt.block) (contract_of (get_source infos)) in Op.revelation ?fee:oinfos.fee ?gas_limit:oinfos.gas_limit @@ -633,7 +721,7 @@ let mk_tx_rollup_origination (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in op @@ -648,6 +736,7 @@ let sc_rollup_of = function let mk_tx_rollup_submit_batch (oinfos : operation_req) (infos : infos) = let open Lwt_result_syntax in let* tx_rollup = tx_rollup_of infos.ctxt.tx_rollup in + Op.tx_rollup_submit_batch ?fee:oinfos.fee ?gas_limit:oinfos.gas_limit @@ -655,7 +744,7 @@ let mk_tx_rollup_submit_batch (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) tx_rollup "batch" @@ -677,7 +766,7 @@ let mk_tx_rollup_commit (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) tx_rollup commitement @@ -691,7 +780,7 @@ let mk_tx_rollup_return_bond (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) tx_rollup let mk_tx_rollup_finalize (oinfos : operation_req) (infos : infos) = @@ -704,7 +793,7 @@ let mk_tx_rollup_finalize (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) tx_rollup let mk_tx_rollup_remove_commitment (oinfos : operation_req) (infos : infos) = @@ -717,7 +806,7 @@ let mk_tx_rollup_remove_commitment (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) tx_rollup let mk_tx_rollup_reject (oinfos : operation_req) (infos : infos) = @@ -751,7 +840,7 @@ let mk_tx_rollup_reject (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) tx_rollup Tx_rollup_level.root message @@ -771,19 +860,19 @@ let mk_transfer_ticket (oinfos : operation_req) (infos : infos) = ?gas_limit:oinfos.gas_limit ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - ~source:(contract_of infos.accounts.source) + ~source:(contract_of (get_source infos)) ~contents:(Script.lazy_expr (Expr.from_string "1")) ~ty:(Script.lazy_expr (Expr.from_string "nat")) ~ticketer: (contract_of (match infos.accounts.tx with - | None -> infos.accounts.source + | None -> get_source infos | Some tx -> tx)) - Z.zero + Z.one ~destination: (contract_of (match infos.accounts.dest with - | None -> infos.accounts.source + | None -> get_source infos | Some dest -> dest)) Entrypoint.default @@ -798,12 +887,12 @@ let mk_tx_rollup_dispacth_ticket (oinfos : operation_req) (infos : infos) = ticketer = contract_of (match infos.accounts.dest with - | None -> infos.accounts.source + | None -> get_source infos | Some dest -> dest); amount = Tx_rollup_l2_qty.of_int64_exn 10L; claimer = (match infos.accounts.dest with - | None -> infos.accounts.source.pkh + | None -> (get_source infos).pkh | Some dest -> dest.pkh); } in @@ -814,7 +903,7 @@ let mk_tx_rollup_dispacth_ticket (oinfos : operation_req) (infos : infos) = ?gas_limit:oinfos.gas_limit ?storage_limit:oinfos.storage_limit (B infos.ctxt.block) - ~source:(contract_of infos.accounts.source) + ~source:(contract_of (get_source infos)) ~message_index:0 ~message_result_path:Tx_rollup_commitment.Merkle.dummy_path tx_rollup @@ -832,7 +921,7 @@ let mk_sc_rollup_origination (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) Sc_rollup.Kind.Example_arith "" (Script.lazy_expr (Expr.from_string "1")) @@ -840,16 +929,16 @@ let mk_sc_rollup_origination (oinfos : operation_req) (infos : infos) = 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 + let number_of_messages = + match Sc_rollup.Number_of_messages.of_int32 3l with + | Some x -> x + | None -> Stdlib.failwith "Bad Number_of_messages" + in Sc_rollup.Commitment. { predecessor = Sc_rollup.Commitment.Hash.zero; @@ -869,7 +958,7 @@ let mk_sc_rollup_publish (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) sc_rollup sc_dummy_commitment @@ -883,7 +972,7 @@ let mk_sc_rollup_cement (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) sc_rollup (Sc_rollup.Commitment.hash sc_dummy_commitment) @@ -900,13 +989,13 @@ let mk_sc_rollup_refute (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) sc_rollup (match infos.accounts.dest with - | None -> infos.accounts.source.pkh + | None -> (get_source infos).pkh | Some dest -> dest.pkh) refutation - false + true let mk_sc_rollup_add_messages (oinfos : operation_req) (infos : infos) = let open Lwt_result_syntax in @@ -918,7 +1007,7 @@ let mk_sc_rollup_add_messages (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) sc_rollup [""] @@ -932,12 +1021,12 @@ let mk_sc_rollup_timeout (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) sc_rollup (Sc_rollup.Game.Index.make - infos.accounts.source.pkh + (get_source infos).pkh (match infos.accounts.dest with - | None -> infos.accounts.source.pkh + | None -> (get_source infos).pkh | Some dest -> dest.pkh)) let mk_sc_rollup_execute_outbox_message (oinfos : operation_req) (infos : infos) @@ -951,7 +1040,7 @@ let mk_sc_rollup_execute_outbox_message (oinfos : operation_req) (infos : infos) ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) sc_rollup (Sc_rollup.Commitment.hash sc_dummy_commitment) ~outbox_level:(Raw_level.of_int32_exn 0l) @@ -969,7 +1058,7 @@ let mk_sc_rollup_return_bond (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) sc_rollup let mk_dal_publish_slot_header (oinfos : operation_req) (infos : infos) = @@ -996,7 +1085,7 @@ let mk_dal_publish_slot_header (oinfos : operation_req) (infos : infos) = ?storage_limit:oinfos.storage_limit ?force_reveal:oinfos.force_reveal (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) slot (** {2 Helpers for generation of generic check tests by manager operation} *) @@ -1013,8 +1102,8 @@ let select_op (op_req : operation_req) (infos : infos) = | K_Undelegation -> mk_undelegation | K_Self_delegation -> mk_self_delegation | K_Set_deposits_limit -> mk_set_deposits_limit - | K_Reveal -> mk_reveal | K_Increase_paid_storage -> mk_increase_paid_storage + | K_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 @@ -1034,41 +1123,38 @@ let select_op (op_req : operation_req) (infos : infos) = | K_Sc_rollup_recover_bond -> mk_sc_rollup_return_bond | K_Dal_publish_slot_header -> mk_dal_publish_slot_header in - mk_op op_req infos -let create_Tztest ?hd_msg test tests_msg operations = - let tl_msg k = - let sk = kind_to_string k in - match hd_msg with - | None -> sk - | Some hd -> Format.sprintf "@[%s, %s@]" hd sk - in - [ - Tztest.tztest (Format.sprintf "@[%s@]" tests_msg) `Quick (fun () -> - List.iter_es - (fun kind -> - Format.printf "%s %s@." tests_msg (tl_msg kind) ; - test kind ()) - operations); - ] + mk_op op_req infos -let create_Tztest_batches test tests_msg operations = - let hdmsg k = Format.sprintf "@[%s@]" (kind_to_string k) in - [ - Tztest.tztest (Format.sprintf "@[%s@]" tests_msg) `Quick (fun () -> - List.iter_es - (fun kind1 -> - List.iter_es - (fun kind2 -> - Format.printf - "%s [%s / %s] @." - tests_msg - (hdmsg kind1) - (hdmsg kind2) ; - test kind1 kind2 ()) - operations) - operations); - ] +let make_tztest ?(fmt = Format.std_formatter) name test subjects info_builder = + let open Lwt_result_syntax in + Tztest.tztest name `Quick (fun () -> + let* infos = info_builder () in + List.iter_es + (fun kind -> + Format.fprintf fmt "%s: %s@." name (kind_to_string kind) ; + test infos kind) + subjects) + +let make_tztest_batched ?(fmt = Format.std_formatter) name test subjects + info_builder = + let open Lwt_result_syntax in + Tztest.tztest name `Quick (fun () -> + let* infos = info_builder () in + List.iter_es + (fun kind1 -> + let k1s = kind_to_string kind1 in + List.iter_es + (fun kind2 -> + Format.fprintf + fmt + "%s: [%s ; %s]@." + name + k1s + (kind_to_string kind2) ; + test infos kind1 kind2) + subjects) + subjects) (** {2 Diagnostic helpers.} *) @@ -1111,7 +1197,7 @@ let manager_content_infos op = | _ -> failwith "Should only handle manager operation" (** We need a way to get the available gas in a context of type - block. *) + block. *) let available_gas = function | Context.I inc -> Some (Gas.block_level (Incremental.alpha_ctxt inc)) | B _ -> None @@ -1129,10 +1215,10 @@ let witness ctxt source = (** According to the witness in pre-state and the probes, computes the expected outputs. In any mode the expected witness: - - the balance of source should be the one in the pre-state minus - the fee of probes, - - the counter of source should be the one in the pre-state plus - the number of counter in probes. + - the balance of source should be the one in the pre-state minus + the fee of probes, + - the counter of source should be the one in the pre-state plus + the number of counter in probes. Concerning the expected available gas in the block: - In [Application] mode, it cannot be computed, so we do not expect any, @@ -1346,7 +1432,7 @@ let validate_ko_diagnostic ?(mode = Construction) (infos : infos) ops | Error tr -> expect_failure tr | _ -> failwith "Block application was expected to fail") -(** List of operation kind that must run on generic tests. This list +(** List of operation kinds that must run on generic tests. This list should be extended for each new manager_operation kind. *) let subjects = [ @@ -1376,7 +1462,6 @@ let subjects = K_Sc_rollup_timeout; K_Sc_rollup_execute_outbox_message; K_Sc_rollup_recover_bond; - K_Dal_publish_slot_header; ] let is_consumer = function @@ -1401,8 +1486,8 @@ let revealed_subjects = let is_disabled flags = function | K_Transaction | K_Origination | K_Register_global_constant | K_Delegation - | K_Undelegation | K_Self_delegation | K_Set_deposits_limit | K_Reveal - | K_Increase_paid_storage -> + | K_Undelegation | K_Self_delegation | K_Set_deposits_limit + | K_Increase_paid_storage | K_Reveal -> false | K_Tx_rollup_origination | K_Tx_rollup_submit_batch | K_Tx_rollup_commit | K_Tx_rollup_return_bond | K_Tx_rollup_finalize diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml index 6950d40876ae..297e4f5efdd7 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.ml @@ -27,7 +27,8 @@ ------- Component: Protocol (validate manager) Invocation: dune exec \ - src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_1m_restriction.exe + src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.exe \ + -- test "^one-manager" Subject: 1M restriction in validation of manager operation. *) @@ -35,6 +36,8 @@ open Protocol open Manager_operation_helpers open Generators +let count = 100 + (** Local default values for the tests. *) let ctxt_cstrs_default = { @@ -88,7 +91,7 @@ let print_ops_pair (ctxt_req, op_req, mode) = (** The application of a valid operation succeeds, at least, to perform the fee payment. *) -let positive_validated_op = +let positive_tests = let gen = QCheck2.Gen.triple (Generators.gen_ctxt_req ctxt_cstrs_default) @@ -96,9 +99,9 @@ let positive_validated_op = Generators.gen_mode in wrap - ~count:1000 + ~count ~print:print_one_op - ~name:"Positive validated op" + ~name:"positive validated op" ~gen (fun (ctxt_req, operation_req, mode) -> let open Lwt_result_syntax in @@ -110,7 +113,7 @@ let positive_validated_op = (** Under 1M restriction, neither a block nor a prevalidator's valid pool should contain two operations with the same manager. It raises a Manager_restriction error. *) -let negative_validated_two_ops_of_same_manager = +let two_op_from_same_manager_tests = let gen = QCheck2.Gen.quad (Generators.gen_ctxt_req ctxt_cstrs_default) @@ -133,9 +136,9 @@ let negative_validated_two_ops_of_same_manager = err in wrap - ~count:1000 + ~count ~print:print_two_ops - ~name:"Negative -- 1M" + ~name:"check conflicts between managers." ~gen (fun (ctxt_req, operation_req, operation_req2, mode) -> let open Lwt_result_syntax in @@ -147,7 +150,7 @@ let negative_validated_two_ops_of_same_manager = (** Under 1M restriction, a batch of two operations cannot be replaced by two single operations. *) -let negative_batch_of_two_is_not_two_single = +let batch_is_not_singles_tests = let gen = QCheck2.Gen.triple (Generators.gen_ctxt_req ctxt_cstrs_default) @@ -158,16 +161,16 @@ let negative_batch_of_two_is_not_two_single = in let expect_failure _ = return_unit in wrap - ~count:1000 + ~count ~print:print_ops_pair - ~name:"Batch is not sequence of Single" + ~name:"batch is not sequence of Single" ~gen (fun (ctxt_req, operation_req, mode) -> let open Lwt_result_syntax in let* infos = init_ctxt ctxt_req in let* op1 = select_op (fst operation_req) infos in let* op2 = select_op (snd operation_req) infos in - let source = contract_of infos.accounts.source in + let source = contract_of (get_source infos) in let* batch = Op.batch_operations ~source (B infos.ctxt.block) [op1; op2] in @@ -176,9 +179,9 @@ let negative_batch_of_two_is_not_two_single = return_true) (** The applications of two covalid operations in a certain context - succeed, at least, to perform the fee payment of both, in whatever - application order. *) -let valid_context_free = + succeed, at least, to perform the fee payment of both, in whatever + application order. *) +let conflict_free_tests = let gen = QCheck2.Gen.quad (Generators.gen_ctxt_req ctxt_cstrs_default) @@ -187,9 +190,9 @@ let valid_context_free = Generators.gen_mode in wrap - ~count:1000 + ~count ~print:print_two_ops - ~name:"Under 1M, co-valid ops commute" + ~name:"under 1M, co-valid ops commute" ~gen (fun (ctxt_req, operation_req, operation_req', mode) -> let open Lwt_result_syntax in @@ -201,10 +204,10 @@ let valid_context_free = accounts = { infos.accounts with - source = + sources = (match infos.accounts.del with | None -> assert false - | Some s -> s); + | Some s -> [s]); }; } in @@ -215,28 +218,11 @@ let valid_context_free = open Lib_test.Qcheck2_helpers -let positive_tests = qcheck_wrap [positive_validated_op] - -let two_op_from_same_manager_tests = - qcheck_wrap [negative_validated_two_ops_of_same_manager] - -let batch_is_not_singles_tests = - qcheck_wrap [negative_batch_of_two_is_not_two_single] - -let conflict_free_tests = qcheck_wrap [valid_context_free] - -let qcheck_tests = ("Positive tests", positive_tests) - -let qcheck_tests2 = - ("Only one manager op per manager", two_op_from_same_manager_tests) - -let qcheck_tests3 = - ("A batch differs from a sequence", batch_is_not_singles_tests) - -let qcheck_tests4 = - ("Fee payment of two covalid operations commute", conflict_free_tests) - -let () = - Alcotest.run - "1M QCheck" - [qcheck_tests; qcheck_tests2; qcheck_tests3; qcheck_tests4] +let tests : (string * [`Quick | `Slow] * (unit -> unit Lwt.t)) trace = + qcheck_wrap_lwt + [ + positive_tests; + two_op_from_same_manager_tests; + batch_is_not_singles_tests; + conflict_free_tests; + ] diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml index ed3c312e9b6f..f273039ae7dd 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_manager_operation_validation.ml @@ -28,7 +28,7 @@ Component: Protocol (validate manager) Invocation: dune exec \ src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.exe \ - -- test "^Single" + -- test "^single" Subject: Validation of manager operation. *) @@ -36,82 +36,6 @@ open Protocol open Alpha_context open Manager_operation_helpers -(** The goal of this test is to ensure that [select_op] generate the - wanted kind of manager operation - - Note: if a new manager operation kind is added in the protocol, - [Manager_operation_helpers.manager_operation_kind] should be - extended. You will also have to extend - [Manager_operation_helpers.select_op] with a new `mk` for this new - operation. Finally the list [Manager_operation_helpers.subjects] - should also be extended to run the validate test on the new manager - operation kind. *) -let ensure_kind infos kind = - let open Lwt_result_syntax in - let* op = - select_op - {(operation_req_default kind) with force_reveal = Some false} - infos - in - let (Operation_data {contents; _}) = op.protocol_data in - match contents with - | Single (Manager_operation {operation; _}) -> ( - match (operation, kind) with - | Transaction _, K_Transaction - | Reveal _, K_Reveal - | Origination _, K_Origination - | Delegation _, K_Delegation - | Delegation _, K_Undelegation - | Delegation _, K_Self_delegation - | Register_global_constant _, K_Register_global_constant - | Set_deposits_limit _, K_Set_deposits_limit - | Increase_paid_storage _, K_Increase_paid_storage - | Tx_rollup_origination, K_Tx_rollup_origination - | Tx_rollup_submit_batch _, K_Tx_rollup_submit_batch - | Tx_rollup_commit _, K_Tx_rollup_commit - | Tx_rollup_return_bond _, K_Tx_rollup_return_bond - | Tx_rollup_finalize_commitment _, K_Tx_rollup_finalize - | Tx_rollup_remove_commitment _, K_Tx_rollup_remove_commitment - | Tx_rollup_rejection _, K_Tx_rollup_reject - | Tx_rollup_dispatch_tickets _, K_Tx_rollup_dispatch_tickets - | Transfer_ticket _, K_Transfer_ticket - | Sc_rollup_originate _, K_Sc_rollup_origination - | Sc_rollup_add_messages _, K_Sc_rollup_add_messages - | Sc_rollup_cement _, K_Sc_rollup_cement - | Sc_rollup_publish _, K_Sc_rollup_publish - | Sc_rollup_refute _, K_Sc_rollup_refute - | Sc_rollup_timeout _, K_Sc_rollup_timeout - | Sc_rollup_execute_outbox_message _, K_Sc_rollup_execute_outbox_message - | Sc_rollup_recover_bond _, K_Sc_rollup_recover_bond - | Dal_publish_slot_header _, K_Dal_publish_slot_header -> - return_unit - | ( ( Transaction _ | Origination _ | Register_global_constant _ - | Delegation _ | Set_deposits_limit _ | Increase_paid_storage _ - | Reveal _ | Tx_rollup_origination | Tx_rollup_submit_batch _ - | Tx_rollup_commit _ | Tx_rollup_return_bond _ - | Tx_rollup_finalize_commitment _ | Tx_rollup_remove_commitment _ - | Tx_rollup_dispatch_tickets _ | Transfer_ticket _ - | Tx_rollup_rejection _ | Sc_rollup_originate _ | Sc_rollup_publish _ - | Sc_rollup_cement _ | Sc_rollup_add_messages _ | Sc_rollup_refute _ - | Sc_rollup_timeout _ | Sc_rollup_execute_outbox_message _ - | Sc_rollup_recover_bond _ | Dal_publish_slot_header _ - | Sc_rollup_dal_slot_subscribe _ ), - _ ) -> - assert false) - | Single _ -> assert false - | Cons _ -> assert false - -let ensure_manager_operation_coverage () = - let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - List.iter_es (fun kind -> ensure_kind infos kind) subjects - -let test_ensure_manager_operation_coverage () = - Tztest.tztest - (Format.sprintf "Ensure manager_operation coverage") - `Quick - (fun () -> ensure_manager_operation_coverage ()) - (** {2 Negative tests assert the case where validate must fail} *) (** Validate fails if the gas limit is too low. @@ -138,9 +62,8 @@ let low_gas_limit_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_low_gas_limit kind () = +let test_low_gas_limit infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* op = select_op { @@ -152,12 +75,6 @@ let test_low_gas_limit kind () = in low_gas_limit_diagnostic infos [op] -let generate_low_gas_limit () = - create_Tztest - test_low_gas_limit - "Gas_limit too low." - gas_consumer_in_validate_subjects - (** Validate fails if the gas limit is too high. This test asserts that the validation of a manager operation with @@ -175,9 +92,8 @@ let high_gas_limit_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_high_gas_limit kind () = +let test_high_gas_limit infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* op = select_op { @@ -190,9 +106,6 @@ let test_high_gas_limit kind () = in high_gas_limit_diagnostic infos [op] -let generate_high_gas_limit () = - create_Tztest test_high_gas_limit "Gas_limit too high." subjects - (** Validate fails if the storage limit is too high. This test asserts that a manager operation with a storage limit @@ -211,9 +124,8 @@ let high_storage_limit_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_high_storage_limit kind () = +let test_high_storage_limit infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* op = select_op { @@ -225,9 +137,6 @@ let test_high_storage_limit kind () = in high_storage_limit_diagnostic infos [op] -let generate_high_storage_limit () = - create_Tztest test_high_gas_limit "Storage_limit too high." subjects - (** Validate fails if the counter is in the future. This test asserts that the validation of @@ -248,9 +157,8 @@ let high_counter_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_high_counter kind () = +let test_high_counter infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* op = select_op { @@ -262,9 +170,6 @@ let test_high_counter kind () = in high_counter_diagnostic infos [op] -let generate_high_counter () = - create_Tztest test_high_counter "Counter too high." subjects - (** Validate fails if the counter is in the past. This test asserts that the validation of a manager operation with a @@ -285,13 +190,12 @@ let low_counter_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_low_counter kind () = +let test_low_counter infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* current_counter = Context.Contract.counter (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in let* op = select_op @@ -304,9 +208,6 @@ let test_low_counter kind () = in low_counter_diagnostic infos [op] -let generate_low_counter () = - create_Tztest test_low_counter "Counter too low." subjects - (** Validate fails if the source is not allocated. This test asserts that the validation of a manager operation which @@ -327,22 +228,18 @@ let not_allocated_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_not_allocated kind () = +let test_not_allocated infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* op = select_op {(operation_req_default kind) with force_reveal = Some false} { infos with - accounts = {infos.accounts with source = Account.(new_account ())}; + accounts = {infos.accounts with sources = [Account.(new_account ())]}; } in not_allocated_diagnostic infos [op] -let generate_not_allocated () = - create_Tztest test_not_allocated "Not allocated source." subjects - (** Validate fails if the source is unrevealed. This test asserts that a manager operation with an unrevealed source @@ -364,9 +261,8 @@ let unrevealed_key_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_unrevealed_key kind () = +let test_unrevealed_key infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* op = select_op {(operation_req_default kind) with force_reveal = Some false} @@ -374,12 +270,6 @@ let test_unrevealed_key kind () = in unrevealed_key_diagnostic infos [op] -let generate_unrevealed_key () = - create_Tztest - test_unrevealed_key - "Unrevealed source (find_manager_public_key)." - revealed_subjects - (** Validate fails if the source balance is not enough to pay the fees. This test asserts that validation of a manager operation fails if the @@ -401,9 +291,8 @@ let high_fee_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_high_fee kind () = +let test_high_fee infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let*? fee = Tez.(one +? one) |> Environment.wrap_tzresult in let* op = select_op @@ -416,9 +305,6 @@ let test_high_fee kind () = in high_fee_diagnostic infos [op] -let generate_tests_high_fee () = - create_Tztest test_high_fee "Balance too low for fee payment." subjects - (** Validate fails if the fee payment empties the balance of a delegated implicit contract. @@ -443,13 +329,12 @@ let emptying_delegated_implicit_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_emptying_delegated_implicit kind () = +let test_empty_implicit infos kind = let open Lwt_result_syntax in - let* infos = default_ctxt_with_delegation () in let* fee = Context.Contract.balance (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in let* op = select_op @@ -462,12 +347,6 @@ let test_emptying_delegated_implicit kind () = in emptying_delegated_implicit_diagnostic infos [op] -let generate_tests_emptying_delegated_implicit () = - create_Tztest - test_emptying_delegated_implicit - "Just enough funds to empty a delegated source." - revealed_subjects - (** Validate fails if there is not enough available gas in the block. This test asserts that validate fails with: @@ -500,12 +379,8 @@ let exceeding_block_gas_diagnostic ~mode (infos : infos) op = in validate_ko_diagnostic infos op expect_failure ~mode -let test_exceeding_block_gas ~mode kind () = +let test_exceeding_block_gas ~mode infos kind = let open Lwt_result_syntax in - let ctxt_req = - {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} - in - let* infos = init_ctxt ctxt_req in let* operation = select_op { @@ -520,28 +395,16 @@ let test_exceeding_block_gas ~mode kind () = in exceeding_block_gas_diagnostic ~mode infos [operation] -let generate_tests_exceeding_block_gas () = - create_Tztest - (test_exceeding_block_gas ~mode:Construction) - "Too much gas consumption." - subjects - -let generate_tests_exceeding_block_gas_mp_mode () = - create_Tztest - (test_exceeding_block_gas ~mode:Mempool) - "Too much gas consumption in mempool mode." - subjects - (** {2 Positive tests} *) (** Tests that validate succeeds when: - it empties the balance of a self_delegated implicit source, - it empties the balance of an undelegated implicit source, and - in case: - - the counter is the successor of the one stored in the context, - - the fee is lesser than the balance, - - the storage limit is lesser than the maximum authorized storage, - - the gas limit is: + - the counter is the successor of the one stored in the context, + - the fee is lesser than the balance, + - the storage limit is lesser than the maximum authorized storage, + - the gas limit is: - lesser than the available gas in the block, - less than the maximum gas consumable by an operation, and - greater than the minimum gas consumable by an operation. @@ -557,14 +420,33 @@ let generate_tests_exceeding_block_gas_mp_mode () = - the balance is at least decreased by fee, - the available gas in the block decreased by gas limit. *) +(** Fee payment*) +let test_validate infos kind = + let open Lwt_result_syntax in + let* counter = + Context.Contract.counter + (B infos.ctxt.block) + (contract_of (get_source infos)) + in + let* op = + select_op + { + (operation_req_default kind) with + force_reveal = Some true; + counter = Some counter; + } + infos + in + let* _ = validate_diagnostic infos [op] in + return_unit + (** Fee payment that emptying a self_delegated implicit. *) -let test_emptying_self_delegated_implicit kind () = +let test_emptying_self_delegate infos kind = let open Lwt_result_syntax in - let* infos = default_ctxt_with_self_delegation () in let* fee = Context.Contract.balance (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in let* op = select_op @@ -578,26 +460,19 @@ let test_emptying_self_delegated_implicit kind () = let* _ = only_validate_diagnostic infos [op] in return_unit -let generate_tests_emptying_self_delegated_implicit () = - create_Tztest - test_emptying_self_delegated_implicit - "Validate and empties a self-delegated source." - subjects - (** Minimum gas cost to pass the validation: - - cost_of_manager_operation for the generic part - - 100 (empiric) for the specific part (script decoding or hash costs) *) + - cost_of_manager_operation for the generic part + - 100 (empiric) for the specific part (script decoding or hash costs) *) let empiric_minimal_gas_cost_for_validate = Gas.Arith.integral_of_int_exn (Michelson_v1_gas.Internal_for_tests.int_cost_of_manager_operation + 100) -let test_emptying_undelegated_implicit kind () = +let test_empty_undelegate infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* fee = Context.Contract.balance (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in let* op = select_op @@ -612,15 +487,9 @@ let test_emptying_undelegated_implicit kind () = let* _ = only_validate_diagnostic infos [op] in return_unit -let generate_tests_emptying_undelegated_implicit () = - create_Tztest - test_emptying_undelegated_implicit - "Validate and empties an undelegated source." - subjects - (** No gas consumer with the minimal gas limit for manager operations passes validate. *) -let test_low_gas_limit_no_consumer kind () = +let test_low_gas_limit_no_consumer kind = let open Lwt_result_syntax in let* infos = default_init_ctxt () in let* op = @@ -634,36 +503,6 @@ let test_low_gas_limit_no_consumer kind () = in validate_diagnostic infos [op] -let generate_low_gas_limit_no_consumer () = - create_Tztest - test_low_gas_limit - "passes validate with minimal gas limit for manager operations." - gas_consumer_in_validate_subjects - -(** Fee payment.*) -let test_validate kind () = - let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let* counter = - Context.Contract.counter - (B infos.ctxt.block) - (contract_of infos.accounts.source) - in - let* op = - select_op - { - (operation_req_default kind) with - force_reveal = Some true; - counter = Some counter; - } - infos - in - let* _ = validate_diagnostic infos [op] in - return_unit - -let generate_tests_validate () = - create_Tztest test_validate "Validate." subjects - (* Feature flags.*) (* Select the error according to the positionned flag. @@ -700,25 +539,12 @@ let flag_expect_failure flags errs = In order to forge Toru, Scoru or Dal operation when the correspondong feature is disable, we use a [infos_op] with default requirements, so that we have a Tx_rollup.t and a Sc_rollup.t. *) -let test_feature_flags flags kind () = +let test_feature_flags infos kind = let open Lwt_result_syntax in - let* infos_op = default_init_ctxt () in - let* infos = default_init_with_flags flags in - let infos = - { - infos with - ctxt = - { - infos.ctxt with - tx_rollup = infos_op.ctxt.tx_rollup; - sc_rollup = infos_op.ctxt.sc_rollup; - }; - } - in let* counter = Context.Contract.counter (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in let* op = select_op @@ -728,7 +554,8 @@ let test_feature_flags flags kind () = } infos in - let* _ = + let flags = infos.flags in + let* () = if is_disabled flags kind then validate_ko_diagnostic infos [op] (flag_expect_failure flags) else @@ -737,44 +564,64 @@ let test_feature_flags flags kind () = in return_unit -let generate_dal_flag () = - create_Tztest - (test_feature_flags disabled_dal) - "Validate with dal disabled." - subjects - -let generate_scoru_flag () = - create_Tztest - (test_feature_flags disabled_scoru) - "Validate with scoru disabled." - subjects - -let generate_toru_flag () = - create_Tztest - (test_feature_flags disabled_toru) - "Validate with toru disabled." - subjects - -let sanity_tests = - test_ensure_manager_operation_coverage () :: generate_tests_validate () - -let gas_tests = - generate_low_gas_limit () @ generate_high_gas_limit () - @ generate_tests_exceeding_block_gas () - @ generate_tests_exceeding_block_gas_mp_mode () - @ generate_low_gas_limit_no_consumer () - -let storage_tests = generate_high_storage_limit () - -let fee_tests = - generate_tests_high_fee () - @ generate_tests_emptying_delegated_implicit () - @ generate_tests_emptying_self_delegated_implicit () - @ generate_tests_emptying_undelegated_implicit () - -let contract_tests = - generate_high_counter () @ generate_low_counter () @ generate_not_allocated () - @ generate_unrevealed_key () - -let flags_tests = - generate_dal_flag () @ generate_toru_flag () @ generate_scoru_flag () +let tests = + let mk_default () = default_init_ctxt () in + let mk_reveal () = + init_ctxt {ctxt_req_default with reveal_accounts = false} + in + let mk_deleg () = default_ctxt_with_delegation () in + let mk_gas () = + init_ctxt {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} + in + let mk_self_deleg () = default_ctxt_with_self_delegation () in + let mk_flags flags () = + let open Lwt_result_syntax in + let* infos_op = default_init_ctxt () in + let* infos = default_init_with_flags flags in + let infos = + { + infos with + ctxt = + { + infos.ctxt with + tx_rollup = infos_op.ctxt.tx_rollup; + sc_rollup = infos_op.ctxt.sc_rollup; + }; + } + in + return infos + in + let all = subjects in + let gas_consum = gas_consumer_in_validate_subjects in + let revealed = revealed_subjects in + List.map + (fun (name, f, subjects, info_builder) -> + make_tztest name f subjects info_builder) + [ + (* Expected validation failure *) + ("gas limit too low", test_low_gas_limit, gas_consum, mk_default); + ("gas limit too high", test_high_gas_limit, all, mk_default); + ("storage limit too high", test_high_storage_limit, all, mk_default); + ("counter too high", test_high_counter, all, mk_default); + ("counter too low", test_low_counter, all, mk_default); + ("unallocated source", test_not_allocated, all, mk_default); + ("unrevealed source", test_unrevealed_key, revealed, mk_reveal); + ("balance too low for fee payment", test_high_fee, all, mk_default); + ("empty delegate source", test_empty_implicit, revealed, mk_deleg); + ( "too much gas consumption in block", + test_exceeding_block_gas ~mode:Construction, + all, + mk_gas ); + (* Expected validation success *) + ("fees are taken when valid", test_validate, all, mk_default); + ("empty self-delegate", test_emptying_self_delegate, all, mk_self_deleg); + ( "too much gas consumption in mempool", + test_exceeding_block_gas ~mode:Mempool, + all, + mk_gas ); + ("empty undelegated source", test_empty_undelegate, all, mk_default); + ("minimal gas for manager", test_low_gas_limit, gas_consum, mk_default); + ("check dal disabled", test_feature_flags, all, mk_flags disabled_dal); + ("check toru disabled", test_feature_flags, all, mk_flags disabled_toru); + ("check scoru disabled", test_feature_flags, all, mk_flags disabled_scoru); + ] diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_sanity.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_sanity.ml new file mode 100644 index 000000000000..f26affbf2dcb --- /dev/null +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_sanity.ml @@ -0,0 +1,111 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic-Labs. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: Protocol (validate manager) + Invocation: dune exec \ + src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.exe \ + -- test "^sanity checks" + Subject: Sanity check for Validation of manager operation tests. +*) + +open Protocol +open Alpha_context +open Manager_operation_helpers + +(** The goal of this test is to ensure that [select_op] generate the + wanted kind of manager operation + + Note: if a new manager operation kind is added in the protocol, + [Manager_operation_helpers.manager_operation_kind] should be + extended. You will also have to extend + [Manager_operation_helpers.select_op] with a new `mk` for this new + operation. Finally the list [Manager_operation_helpers.subjects] + should also be extended to run the validate test on the new manager + operation kind. *) +let ensure_kind infos kind = + let open Lwt_result_syntax in + let* op = + select_op + {(operation_req_default kind) with force_reveal = Some false} + infos + in + let (Operation_data {contents; _}) = op.protocol_data in + match contents with + | Single (Manager_operation {operation; _}) -> ( + match (operation, kind) with + | Transaction _, K_Transaction + | Reveal _, K_Reveal + | Origination _, K_Origination + | Delegation _, K_Delegation + | Delegation _, K_Undelegation + | Delegation _, K_Self_delegation + | Register_global_constant _, K_Register_global_constant + | Set_deposits_limit _, K_Set_deposits_limit + | Increase_paid_storage _, K_Increase_paid_storage + | Tx_rollup_origination, K_Tx_rollup_origination + | Tx_rollup_submit_batch _, K_Tx_rollup_submit_batch + | Tx_rollup_commit _, K_Tx_rollup_commit + | Tx_rollup_return_bond _, K_Tx_rollup_return_bond + | Tx_rollup_finalize_commitment _, K_Tx_rollup_finalize + | Tx_rollup_remove_commitment _, K_Tx_rollup_remove_commitment + | Tx_rollup_rejection _, K_Tx_rollup_reject + | Tx_rollup_dispatch_tickets _, K_Tx_rollup_dispatch_tickets + | Transfer_ticket _, K_Transfer_ticket + | Sc_rollup_originate _, K_Sc_rollup_origination + | Sc_rollup_add_messages _, K_Sc_rollup_add_messages + | Sc_rollup_cement _, K_Sc_rollup_cement + | Sc_rollup_publish _, K_Sc_rollup_publish + | Sc_rollup_refute _, K_Sc_rollup_refute + | Sc_rollup_timeout _, K_Sc_rollup_timeout + | Sc_rollup_execute_outbox_message _, K_Sc_rollup_execute_outbox_message + | Sc_rollup_recover_bond _, K_Sc_rollup_recover_bond -> + return_unit + | ( ( Transaction _ | Origination _ | Register_global_constant _ + | Delegation _ | Set_deposits_limit _ | Increase_paid_storage _ + | Reveal _ | Tx_rollup_origination | Tx_rollup_submit_batch _ + | Tx_rollup_commit _ | Tx_rollup_return_bond _ + | Tx_rollup_finalize_commitment _ | Tx_rollup_remove_commitment _ + | Tx_rollup_dispatch_tickets _ | Transfer_ticket _ + | Tx_rollup_rejection _ | Sc_rollup_originate _ | Sc_rollup_publish _ + | Sc_rollup_cement _ | Sc_rollup_add_messages _ | Sc_rollup_refute _ + | Sc_rollup_timeout _ | Sc_rollup_execute_outbox_message _ + | Sc_rollup_recover_bond _ | Dal_publish_slot_header _ + | Sc_rollup_dal_slot_subscribe _ ), + _ ) -> + assert false) + | Single _ -> assert false + | Cons _ -> assert false + +let ensure_manager_operation_coverage () = + let open Lwt_result_syntax in + let* infos = default_init_ctxt () in + List.iter_es (fun kind -> ensure_kind infos kind) subjects + +let tests = + List.map + (fun (name, f) -> Tztest.tztest name `Quick f) + [("manager operation coverage", ensure_manager_operation_coverage)] diff --git a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_validation_batch.ml similarity index 82% rename from src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml rename to src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_validation_batch.ml index 12f3dc3df4db..427265984d9d 100644 --- a/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_batched_manager_operation_validation.ml +++ b/src/proto_014_PtKathma/lib_protocol/test/integration/validate/test_validation_batch.ml @@ -28,7 +28,7 @@ Component: Protocol (validate manager) Invocation: dune exec \ src/proto_014_PtKathma/lib_protocol/test/integration/validate/main.exe \ - -- test "^Batched" + -- test "^batched" Subject: Validation of batched manager operation. *) @@ -56,13 +56,12 @@ let batch_reveal_in_the_middle_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_batch_reveal_in_the_middle kind1 kind2 () = +let batch_in_the_middle infos kind1 kind2 = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* counter = Context.Contract.counter (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in let counter = Z.succ counter in let* operation1 = @@ -97,18 +96,12 @@ let test_batch_reveal_in_the_middle kind1 kind2 () = let* batch = Op.batch_operations ~recompute_counters:false - ~source:(contract_of infos.accounts.source) + ~source:(contract_of (get_source infos)) (Context.B infos.ctxt.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 only occur at the beginning of a batch." - revealed_subjects - (** A batch of manager operation contains at most one Revelation.*) let batch_two_reveals_diagnostic (infos : infos) op = let expected_failure errs = @@ -126,13 +119,12 @@ let batch_two_reveals_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expected_failure -let test_batch_two_reveals kind () = +let batch_two_reveals infos kind = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in let* counter = Context.Contract.counter (B infos.ctxt.block) - (contract_of infos.accounts.source) + (contract_of (get_source infos)) in let counter = Z.succ counter in let* reveal = @@ -167,18 +159,12 @@ let test_batch_two_reveals kind () = let* batch = Op.batch_operations ~recompute_counters:false - ~source:(contract_of infos.accounts.source) + ~source:(contract_of (get_source infos)) (Context.B infos.ctxt.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 - (** Every manager operation in a batch concerns the same source.*) let batch_two_sources_diagnostic (infos : infos) op = let expect_failure errs = @@ -195,10 +181,9 @@ let batch_two_sources_diagnostic (infos : infos) op = in validate_ko_diagnostic infos op expect_failure -let test_batch_two_sources kind1 kind2 () = +let batch_two_sources infos kind1 kind2 = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let source = contract_of infos.accounts.source in + let source = contract_of (get_source infos) in let* counter = Context.Contract.counter (B infos.ctxt.block) source in let counter = Z.succ counter in let* operation1 = @@ -214,7 +199,7 @@ let test_batch_two_sources kind1 kind2 () = let source2 = match infos.accounts.del with None -> assert false | Some s -> s in - {infos with accounts = {infos.accounts with source = source2}} + {infos with accounts = {infos.accounts with sources = [source2]}} in let* operation2 = select_op @@ -230,18 +215,11 @@ let test_batch_two_sources kind1 kind2 () = in batch_two_sources_diagnostic infos [batch] -let generate_batches_two_sources () = - create_Tztest_batches - test_batch_two_sources - "Only one source per batch." - revealed_subjects - (** Counters in a batch should be a sequence from the successor of the stored counter associated to source in the initial context. *) -let test_batch_inconsistent_counters kind1 kind2 () = +let batch_incons_counters infos kind1 kind2 = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let source = contract_of infos.accounts.source in + let source = contract_of (get_source infos) in let* counter = Context.Contract.counter (B infos.ctxt.block) source in let fee = Some Tez.one_mutez in let op_infos = operation_req_default K_Reveal in @@ -329,18 +307,11 @@ let test_batch_inconsistent_counters kind1 kind2 () = 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 batch_emptying_balance_in_the_middle infos kind1 kind2 = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let source = contract_of infos.accounts.source in + let source = contract_of (get_source infos) in let* counter = Context.Contract.counter (B infos.ctxt.block) source in let* init_bal = Context.Contract.balance (B infos.ctxt.block) source in let counter = counter in @@ -395,120 +366,11 @@ let test_batch_emptying_balance_in_the_middle kind1 kind2 () = 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 - -(** A batch of manager operation must not exceed the initial available gas in the block. *) -let test_batch_exceeding_block_gas ~mempool_mode kind1 kind2 () = - let open Lwt_result_syntax in - let ctxt_req = - {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} - in - let* infos = init_ctxt ctxt_req in - let source = contract_of infos.accounts.source in - let* counter = Context.Contract.counter (B infos.ctxt.block) source in - let g_limit = Gas.Arith.add gb_limit Gas.Arith.(integral_of_int_exn 1) in - let half_limit = - Gas.Arith.add half_gb_limit Gas.Arith.(integral_of_int_exn 1) - in - let* reveal = - mk_reveal - {(operation_req_default K_Reveal) with counter = Some counter} - infos - in - let counter = Z.succ counter in - let operation gas_limit = - select_op - { - (operation_req_default kind1) with - force_reveal = Some false; - counter = Some counter; - gas_limit = Some (Custom_gas gas_limit); - } - infos - in - let counter = Z.succ counter in - let operation2 gas_limit = - select_op - { - (operation_req_default kind2) with - force_reveal = Some false; - counter = Some counter; - gas_limit = Some (Custom_gas gas_limit); - } - infos - in - let* op_case1 = operation g_limit in - let* op2_case1 = operation2 Gas.Arith.zero in - let* op_case2 = operation half_limit in - let* op2_case2 = operation2 g_limit in - let* op_case3 = operation half_limit in - let* op2_case3 = operation2 half_limit in - let* case1 = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [reveal; op_case1; op2_case1] - in - let* case3 = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [reveal; op_case3; op2_case3] - in - let* case2 = - Op.batch_operations - ~recompute_counters:false - ~source - (Context.B infos.ctxt.block) - [reveal; op_case2; op2_case2] - in - let* i = Incremental.begin_construction infos.ctxt.block ~mempool_mode in - let expect_failure errs = - match errs with - | [Environment.Ecoproto_error Gas.Block_quota_exceeded] - when not mempool_mode -> - return_unit - | [ - Environment.Ecoproto_error Gas.Gas_limit_too_high; - Environment.Ecoproto_error Gas.Block_quota_exceeded; - ] - when mempool_mode -> - return_unit - | err -> - failwith - "Error trace:@, %a does not match the expected one" - Error_monad.pp_print_trace - err - in - let* _ = Incremental.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 - (** A batch that consumes all the balance for fees only at the end of the batch passes validate.*) -let test_batch_balance_just_enough kind1 kind2 () = +let batch_empty_at_end infos kind1 kind2 = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let source = contract_of infos.accounts.source in + let source = contract_of (get_source infos) in let* counter = Context.Contract.counter (B infos.ctxt.block) source in let* init_bal = Context.Contract.balance (B infos.ctxt.block) source in let*? half_init_bal = Environment.wrap_tzresult @@ Tez.(init_bal /? 2L) in @@ -561,17 +423,10 @@ let test_batch_balance_just_enough kind1 kind2 () = let* _ = validate_diagnostic infos [case3] in return_unit -let generate_batches_balance_just_enough () = - create_Tztest_batches - test_batch_balance_just_enough - "Fee payment emptying balance in a batch." - revealed_subjects - (** Simple reveal followed by a transaction. *) -let test_batch_reveal_transaction_ok () = +let batch_reveal_transaction infos = let open Lwt_result_syntax in - let* infos = default_init_ctxt () in - let source = contract_of infos.accounts.source in + let source = contract_of (get_source infos) in let* counter = Context.Contract.counter (B infos.ctxt.block) source in let counter = counter in let fee = Tez.one_mutez in @@ -605,22 +460,149 @@ let test_batch_reveal_transaction_ok () = let* _ = validate_diagnostic infos [batch] in return_unit -let contract_tests = - generate_batches_reveal_in_the_middle () - @ generate_tests_batches_two_reveals () - @ generate_batches_two_sources () - @ generate_batches_inconsistent_counters () - @ [ - Tztest.tztest - "Validate a batch with a reveal and a transaction." - `Quick - test_batch_reveal_transaction_ok; +(** A batch of manager operation must not exceed the initial available gas in the block. *) +let batch_exceeding_block_gas ~mempool_mode infos kind1 kind2 = + let open Lwt_result_syntax in + let source = contract_of (get_source infos) in + let* counter = Context.Contract.counter (B infos.ctxt.block) source in + let g_limit = Gas.Arith.add gb_limit Gas.Arith.(integral_of_int_exn 1) in + let half_limit = + Gas.Arith.add half_gb_limit Gas.Arith.(integral_of_int_exn 1) + in + let* reveal = + mk_reveal + {(operation_req_default K_Reveal) with counter = Some counter} + infos + in + let counter = Z.succ counter in + let operation gas_limit = + select_op + { + (operation_req_default kind1) with + force_reveal = Some false; + counter = Some counter; + gas_limit = Some (Custom_gas gas_limit); + } + infos + in + let counter = Z.succ counter in + let operation2 gas_limit = + select_op + { + (operation_req_default kind2) with + force_reveal = Some false; + counter = Some counter; + gas_limit = Some (Custom_gas gas_limit); + } + infos + in + let* op_case1 = operation g_limit in + let* op2_case1 = operation2 Gas.Arith.zero in + let* op_case2 = operation half_limit in + let* op2_case2 = operation2 g_limit in + let* op_case3 = operation half_limit in + let* op2_case3 = operation2 half_limit in + let* case1 = + Op.batch_operations + ~recompute_counters:false + ~source + (Context.B infos.ctxt.block) + [reveal; op_case1; op2_case1] + in + let* case3 = + Op.batch_operations + ~recompute_counters:false + ~source + (Context.B infos.ctxt.block) + [reveal; op_case3; op2_case3] + in + let* case2 = + Op.batch_operations + ~recompute_counters:false + ~source + (Context.B infos.ctxt.block) + [reveal; op_case2; op2_case2] + in + let* i = Incremental.begin_construction infos.ctxt.block ~mempool_mode in + let expect_failure errs = + match errs with + | [Environment.Ecoproto_error Gas.Block_quota_exceeded] + when not mempool_mode -> + return_unit + | [ + Environment.Ecoproto_error Gas.Gas_limit_too_high; + Environment.Ecoproto_error Gas.Block_quota_exceeded; ] + when mempool_mode -> + return_unit + | err -> + failwith + "Error trace:@, %a does not match the expected one" + Error_monad.pp_print_trace + err + in + let* _ = Incremental.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 gas_tests = - generate_batches_exceeding_block_gas () - @ generate_batches_exceeding_block_gas_mp_mode () +let make_tztest_batched ?(fmt = Format.std_formatter) name test subjects + info_builder = + let open Lwt_result_syntax in + Tztest.tztest name `Quick (fun () -> + let* infos = info_builder () in + List.iter_es + (fun kind1 -> + let k1s = kind_to_string kind1 in + List.iter_es + (fun kind2 -> + Format.fprintf + fmt + "%s: [%s ; %s]@." + name + k1s + (kind_to_string kind2) ; + test infos kind1 kind2) + subjects) + subjects) -let fee_tests = - generate_batches_emptying_balance_in_the_middle () - @ generate_batches_balance_just_enough () +let tests = + let open Lwt_result_syntax in + let mk_default () = default_init_ctxt () in + let mk_high_gas_limit () = + init_ctxt {ctxt_req_default with hard_gas_limit_per_block = Some gb_limit} + in + let revealed = revealed_subjects in + [ + ( Tztest.tztest "batch reveal and transaction" `Quick @@ fun () -> + let* infos = mk_default () in + batch_reveal_transaction infos ); + ] + @ List.map + (fun (name, f, subjects, info_builder) -> + make_tztest name f subjects info_builder) + [("batch two reveals", batch_two_reveals, revealed, mk_default)] + @ List.map + (fun (name, f, subjects, info_builder) -> + make_tztest_batched name f subjects info_builder) + [ + ("reveal in the middle", batch_in_the_middle, revealed, mk_default); + ("batch two sources", batch_two_sources, revealed, mk_default); + ("batch incons. counters", batch_incons_counters, revealed, mk_default); + ( "empty balance in middle of batch", + batch_emptying_balance_in_the_middle, + revealed, + mk_default ); + ( "empty balance at end of batch", + batch_empty_at_end, + revealed, + mk_default ); + ( "too much gas consumption", + batch_exceeding_block_gas ~mempool_mode:false, + revealed, + mk_high_gas_limit ); + ( "too much gas consumption (mempool)", + batch_exceeding_block_gas ~mempool_mode:true, + revealed, + mk_high_gas_limit ); + ] -- GitLab