From 836d176ad5b241bb94cd24087024675a683e3e16 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Sat, 11 Jun 2022 19:33:24 +0100 Subject: [PATCH 1/6] Proto: allow-zero flag for ticket-scanner --- .../lib_benchmarks_proto/ticket_benchmarks.ml | 1 + .../lib_protocol/ticket_accounting.ml | 7 +- .../lib_protocol/ticket_lazy_storage_diff.ml | 1 + .../lib_protocol/ticket_operations_diff.ml | 14 +++- .../lib_protocol/ticket_scanner.ml | 84 +++++++++++++++---- .../lib_protocol/ticket_scanner.mli | 4 + 6 files changed, 92 insertions(+), 19 deletions(-) diff --git a/src/proto_alpha/lib_benchmarks_proto/ticket_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/ticket_benchmarks.ml index 8fa7eac8ef88..5a9813b17e33 100644 --- a/src/proto_alpha/lib_benchmarks_proto/ticket_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/ticket_benchmarks.ml @@ -286,6 +286,7 @@ module Collect_tickets_benchmark : Benchmark.S = struct (Ticket_scanner.tickets_of_value ctxt ~include_lazy:true + ~allow_zero_amount_tickets:true has_tickets boxed_ticket_list)) in diff --git a/src/proto_alpha/lib_protocol/ticket_accounting.ml b/src/proto_alpha/lib_protocol/ticket_accounting.ml index eff0753f365a..bc99fc9528b2 100644 --- a/src/proto_alpha/lib_protocol/ticket_accounting.ml +++ b/src/proto_alpha/lib_protocol/ticket_accounting.ml @@ -74,7 +74,12 @@ module Ticket_token_map = struct end let ticket_balances_of_value ctxt ~include_lazy ty value = - Ticket_scanner.tickets_of_value ~include_lazy ctxt ty value + Ticket_scanner.tickets_of_value + ~include_lazy + ~allow_zero_amount_tickets:true + ctxt + ty + value >>=? fun (tickets, ctxt) -> List.fold_left_e (fun (acc, ctxt) ticket -> diff --git a/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml index 850f7789d45c..d2aaa66055fc 100644 --- a/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml @@ -81,6 +81,7 @@ let collect_token_diffs_of_node ctxt has_tickets node ~get_token_and_amount acc (* It's currently not possible to have nested lazy structures, but this is for future proofing. *) ~include_lazy:true + ~allow_zero_amount_tickets:true has_tickets (Micheline.root node) >>=? fun (ex_tickets, ctxt) -> diff --git a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml index eaab5557d06b..d638cc724425 100644 --- a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml @@ -146,7 +146,12 @@ let tickets_of_transaction ctxt ~destination ~parameters_ty ~parameters = let destination = Destination.Contract (Originated destination) in Ticket_scanner.type_has_tickets ctxt parameters_ty >>?= fun (has_tickets, ctxt) -> - Ticket_scanner.tickets_of_value ~include_lazy:true ctxt has_tickets parameters + Ticket_scanner.tickets_of_value + ~include_lazy:true + ~allow_zero_amount_tickets:true + ctxt + has_tickets + parameters >>=? fun (tickets, ctxt) -> return (Some {destination; tickets}, ctxt) (** Extract tickets of an origination operation by scanning the storage. *) @@ -155,7 +160,12 @@ let tickets_of_origination ctxt ~preorigination ~storage_type ~storage = storage does not contain tickets, storage is not scanned. *) Ticket_scanner.type_has_tickets ctxt storage_type >>?= fun (has_tickets, ctxt) -> - Ticket_scanner.tickets_of_value ctxt ~include_lazy:true has_tickets storage + Ticket_scanner.tickets_of_value + ctxt + ~include_lazy:true + ~allow_zero_amount_tickets:true + has_tickets + storage >|=? fun (tickets, ctxt) -> let destination = Destination.Contract (Originated preorigination) in (Some {tickets; destination}, ctxt) diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.ml b/src/proto_alpha/lib_protocol/ticket_scanner.ml index d203e4ee0c91..992f01194c77 100644 --- a/src/proto_alpha/lib_protocol/ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/ticket_scanner.ml @@ -26,7 +26,10 @@ open Alpha_context -type error += Unsupported_non_empty_overlay | Unsupported_type_operation +type error += + | (* Permanent *) Unsupported_non_empty_overlay + | (* Permanent *) Unsupported_type_operation + | (* Permanent *) Forbidden_zero_ticket_quantity let () = register_error_kind @@ -48,7 +51,16 @@ let () = Format.fprintf ppf "Types embedding operations are not supported") Data_encoding.empty (function Unsupported_type_operation -> Some () | _ -> None) - (fun () -> Unsupported_type_operation) + (fun () -> Unsupported_type_operation) ; + register_error_kind + `Permanent + ~id:"forbidden_zero_amount_ticket" + ~title:"Zero ticket amount is not allowed" + ~description: + "It is not allowed to use a zero amount ticket in this operation." + Data_encoding.empty + (function Forbidden_zero_ticket_quantity -> Some () | _ -> None) + (fun () -> Forbidden_zero_ticket_quantity) type ex_ticket = | Ex_ticket : @@ -266,7 +278,7 @@ module Ticket_collection = struct let tickets_of_comparable : type a ret. - Alpha_context.context -> + context -> a Script_typed_ir.comparable_ty -> accumulator -> ret continuation -> @@ -310,14 +322,15 @@ module Ticket_collection = struct let rec tickets_of_value : type a ac ret. include_lazy:bool -> - Alpha_context.context -> + allow_zero_amount_tickets:bool -> + context -> a Ticket_inspection.has_tickets -> (a, ac) Script_typed_ir.ty -> a -> accumulator -> ret continuation -> ret tzresult Lwt.t = - fun ~include_lazy ctxt hty ty x acc k -> + fun ~include_lazy ~allow_zero_amount_tickets ctxt hty ty x acc k -> let open Script_typed_ir in consume_gas_steps ctxt ~num_steps:1 >>?= fun ctxt -> match (hty, ty) with @@ -326,6 +339,7 @@ module Ticket_collection = struct let l, r = x in (tickets_of_value [@ocaml.tailcall]) ~include_lazy + ~allow_zero_amount_tickets ctxt hty1 ty1 @@ -334,6 +348,7 @@ module Ticket_collection = struct (fun ctxt acc -> (tickets_of_value [@ocaml.tailcall]) ~include_lazy + ~allow_zero_amount_tickets ctxt hty2 ty2 @@ -345,6 +360,7 @@ module Ticket_collection = struct | L v -> (tickets_of_value [@ocaml.tailcall]) ~include_lazy + ~allow_zero_amount_tickets ctxt htyl tyl @@ -354,6 +370,7 @@ module Ticket_collection = struct | R v -> (tickets_of_value [@ocaml.tailcall]) ~include_lazy + ~allow_zero_amount_tickets ctxt htyr tyr @@ -365,6 +382,7 @@ module Ticket_collection = struct | Some x -> (tickets_of_value [@ocaml.tailcall]) ~include_lazy + ~allow_zero_amount_tickets ctxt el_hty el_ty @@ -377,6 +395,7 @@ module Ticket_collection = struct (tickets_of_list [@ocaml.tailcall]) ctxt ~include_lazy + ~allow_zero_amount_tickets el_hty el_ty elements @@ -393,6 +412,7 @@ module Ticket_collection = struct (tickets_of_map [@ocaml.tailcall]) ctxt ~include_lazy + ~allow_zero_amount_tickets val_hty val_ty x @@ -400,27 +420,41 @@ module Ticket_collection = struct k) | Big_map_ht (_, val_hty), Big_map_t (key_ty, _, _) -> if include_lazy then - (tickets_of_big_map [@ocaml.tailcall]) ctxt val_hty key_ty x acc k + (tickets_of_big_map [@ocaml.tailcall]) + ctxt + ~allow_zero_amount_tickets + val_hty + key_ty + x + acc + k else (k [@ocaml.tailcall]) ctxt acc | True_ht, Ticket_t (comp_ty, _) -> - (k [@ocaml.tailcall]) ctxt (Ex_ticket (comp_ty, x) :: acc) + let Script_typed_ir.{ticketer = _; contents = _; amount} = x in + fail_when + ((not allow_zero_amount_tickets) + && Compare.Int.(Script_int.compare amount Script_int.zero_n = 0)) + Forbidden_zero_ticket_quantity + >>=? fun () -> (k [@ocaml.tailcall]) ctxt (Ex_ticket (comp_ty, x) :: acc) and tickets_of_list : type a ac ret. - Alpha_context.context -> + context -> include_lazy:bool -> + allow_zero_amount_tickets:bool -> a Ticket_inspection.has_tickets -> (a, ac) Script_typed_ir.ty -> a list -> accumulator -> ret continuation -> ret tzresult Lwt.t = - fun ctxt ~include_lazy el_hty el_ty elements acc k -> + fun ctxt ~include_lazy ~allow_zero_amount_tickets el_hty el_ty elements acc k -> consume_gas_steps ctxt ~num_steps:1 >>?= fun ctxt -> match elements with | elem :: elems -> (tickets_of_value [@ocaml.tailcall]) ~include_lazy + ~allow_zero_amount_tickets ctxt el_hty el_ty @@ -429,6 +463,7 @@ module Ticket_collection = struct (fun ctxt acc -> (tickets_of_list [@ocaml.tailcall]) ~include_lazy + ~allow_zero_amount_tickets ctxt el_hty el_ty @@ -440,14 +475,15 @@ module Ticket_collection = struct and tickets_of_map : type k v vc ret. include_lazy:bool -> - Alpha_context.context -> + allow_zero_amount_tickets:bool -> + context -> v Ticket_inspection.has_tickets -> (v, vc) Script_typed_ir.ty -> (k, v) Script_typed_ir.map -> accumulator -> ret continuation -> ret tzresult Lwt.t = - fun ~include_lazy ctxt val_hty val_ty map acc k -> + fun ~include_lazy ~allow_zero_amount_tickets ctxt val_hty val_ty map acc k -> let (module M) = Script_map.get_module map in consume_gas_steps ctxt ~num_steps:1 >>?= fun ctxt -> (* Pay gas for folding over the values *) @@ -455,6 +491,7 @@ module Ticket_collection = struct let values = M.OPS.fold (fun _ v vs -> v :: vs) M.boxed [] in (tickets_of_list [@ocaml.tailcall]) ~include_lazy + ~allow_zero_amount_tickets ctxt val_hty val_ty @@ -464,7 +501,8 @@ module Ticket_collection = struct and tickets_of_big_map : type k v ret. - Alpha_context.context -> + context -> + allow_zero_amount_tickets:bool -> v Ticket_inspection.has_tickets -> k Script_typed_ir.comparable_ty -> (k, v) Script_typed_ir.big_map -> @@ -472,6 +510,7 @@ module Ticket_collection = struct ret continuation -> ret tzresult Lwt.t = fun ctxt + ~allow_zero_amount_tickets val_hty key_ty (Big_map {id; diff = {map = _; size}; key_type = _; value_type}) @@ -500,6 +539,7 @@ module Ticket_collection = struct List.fold_left_es accum ([], ctxt) exps >>=? fun (values, ctxt) -> (tickets_of_list [@ocaml.tailcall]) ~include_lazy:true + ~allow_zero_amount_tickets ctxt val_hty value_type @@ -522,13 +562,20 @@ let type_has_tickets ctxt ty = Ticket_inspection.has_tickets_of_ty ctxt ty >|? fun (has_tickets, ctxt) -> (Has_tickets (has_tickets, ty), ctxt) -let tickets_of_value ctxt ~include_lazy (Has_tickets (ht, ty)) = - Ticket_collection.tickets_of_value ctxt ~include_lazy ht ty +let tickets_of_value ctxt ~include_lazy ~allow_zero_amount_tickets + (Has_tickets (ht, ty)) = + Ticket_collection.tickets_of_value + ctxt + ~include_lazy + ~allow_zero_amount_tickets + ht + ty let has_tickets (Has_tickets (ht, _)) = match ht with Ticket_inspection.False_ht -> false | _ -> true -let tickets_of_node ctxt ~include_lazy has_tickets expr = +let tickets_of_node ctxt ~include_lazy ~allow_zero_amount_tickets has_tickets + expr = let (Has_tickets (ht, ty)) = has_tickets in match ht with | Ticket_inspection.False_ht -> return ([], ctxt) @@ -540,4 +587,9 @@ let tickets_of_node ctxt ~include_lazy has_tickets expr = ty expr >>=? fun (value, ctxt) -> - tickets_of_value ctxt ~include_lazy has_tickets value + tickets_of_value + ctxt + ~include_lazy + ~allow_zero_amount_tickets + has_tickets + value diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.mli b/src/proto_alpha/lib_protocol/ticket_scanner.mli index 209c633ab74a..bb6be0d5e850 100644 --- a/src/proto_alpha/lib_protocol/ticket_scanner.mli +++ b/src/proto_alpha/lib_protocol/ticket_scanner.mli @@ -26,6 +26,8 @@ (** This module provides an API for extracting tickets of arbitrary types from an OCaml values, given a type-witness. *) +type error += (* Permanent *) Forbidden_zero_ticket_quantity + (** A type for representing existentially quantified tickets (tickets with different types of payloads). An [ex_ticket] value consists of: - A type-witness representing the type of the content of the ticket. @@ -63,6 +65,7 @@ val type_has_tickets : val tickets_of_value : Alpha_context.context -> include_lazy:bool -> + allow_zero_amount_tickets:bool -> 'a has_tickets -> 'a -> (ex_ticket list * Alpha_context.context) tzresult Lwt.t @@ -83,6 +86,7 @@ val tickets_of_value : val tickets_of_node : Alpha_context.context -> include_lazy:bool -> + allow_zero_amount_tickets:bool -> 'a has_tickets -> Alpha_context.Script.node -> (ex_ticket list * Alpha_context.context) tzresult Lwt.t -- GitLab From 0a443d282eb044c729929fd94c25cb36475fc18e Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Sat, 11 Jun 2022 19:45:02 +0100 Subject: [PATCH 2/6] Proto: use ticket-scanner error --- src/proto_alpha/lib_protocol/apply.ml | 18 +++++------------- src/proto_alpha/lib_protocol/apply.mli | 1 - .../integration/operations/test_tx_rollup.ml | 6 +++--- 3 files changed, 8 insertions(+), 17 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index d42c765fe1fc..bd65117ab13d 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -126,7 +126,6 @@ type error += | Inconsistent_sources | Failing_noop_error | Zero_frozen_deposits of Signature.Public_key_hash.t - | Forbidden_zero_ticket_quantity | Incorrect_reveal_position let () = @@ -781,15 +780,6 @@ let () = Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding)) (function Zero_frozen_deposits delegate -> Some delegate | _ -> None) (fun delegate -> Zero_frozen_deposits delegate) ; - register_error_kind - `Permanent - ~id:"forbidden_zero_amount_ticket" - ~title:"Zero ticket amount is not allowed" - ~description: - "It is not allowed to use a zero amount ticket in this operation." - Data_encoding.empty - (function Forbidden_zero_ticket_quantity -> Some () | _ -> None) - (fun () -> Forbidden_zero_ticket_quantity) ; register_error_kind `Permanent ~id:"operations.incorrect_reveal_position" @@ -1028,7 +1018,7 @@ let apply_transaction_to_tx_rollup ~ctxt ~parameters_ty ~parameters ~payer >>?= fun ticket_amount -> error_when Tx_rollup_l2_qty.(ticket_amount <= zero) - Forbidden_zero_ticket_quantity + Ticket_scanner.Forbidden_zero_ticket_quantity >>?= fun () -> let deposit, message_size = Tx_rollup_message.make_deposit @@ -1348,7 +1338,7 @@ let apply_external_manager_operation_content : Tx_rollup_reveal.{contents; ty; ticketer; amount; claimer} -> error_when Tx_rollup_l2_qty.(amount <= zero) - Forbidden_zero_ticket_quantity + Ticket_scanner.Forbidden_zero_ticket_quantity >>?= fun () -> Tx_rollup_ticket.parse_ticket ~consume_deserialization_gas @@ -1418,7 +1408,9 @@ let apply_external_manager_operation_content : | Transfer_ticket {contents; ty; ticketer; amount; destination; entrypoint} -> (* The encoding ensures that the amount is in a natural number. Here is mainly to check that it is non-zero.*) - error_when Compare.Z.(amount <= Z.zero) Forbidden_zero_ticket_quantity + error_when + Compare.Z.(amount <= Z.zero) + Ticket_scanner.Forbidden_zero_ticket_quantity >>?= fun () -> error_when (match destination with Implicit _ -> true | Originated _ -> false) diff --git a/src/proto_alpha/lib_protocol/apply.mli b/src/proto_alpha/lib_protocol/apply.mli index ae2d7c9fff29..f2b8258f2cdb 100644 --- a/src/proto_alpha/lib_protocol/apply.mli +++ b/src/proto_alpha/lib_protocol/apply.mli @@ -44,7 +44,6 @@ type error += | Tx_rollup_invalid_transaction_ticket_amount | Sc_rollup_feature_disabled | Inconsistent_counters - | Forbidden_zero_ticket_quantity | Incorrect_reveal_position | Inconsistent_sources diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml index 0917d6acebba..464deb25f90f 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml @@ -5517,7 +5517,7 @@ module Withdraw = struct Incremental.begin_construction block >>=? fun incr -> Incremental.add_operation ~expect_apply_failure: - (check_proto_error Apply.Forbidden_zero_ticket_quantity) + (check_proto_error Ticket_scanner.Forbidden_zero_ticket_quantity) incr operation >>=? fun _incr -> return_unit @@ -5559,7 +5559,7 @@ module Withdraw = struct Incremental.begin_construction block >>=? fun incr -> Incremental.add_operation ~expect_apply_failure: - (check_proto_error Apply.Forbidden_zero_ticket_quantity) + (check_proto_error Ticket_scanner.Forbidden_zero_ticket_quantity) incr operation >>=? fun _incr -> return_unit @@ -5578,7 +5578,7 @@ module Withdraw = struct Incremental.begin_construction block >>=? fun incr -> Incremental.add_operation ~expect_apply_failure: - (check_proto_error Apply.Forbidden_zero_ticket_quantity) + (check_proto_error Ticket_scanner.Forbidden_zero_ticket_quantity) incr operation >>=? fun _incr -> return_unit -- GitLab From 70053d16bc4702f6c414f17e427d1e95911bbcfe Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Sat, 11 Jun 2022 19:48:34 +0100 Subject: [PATCH 3/6] Proto: amend tests --- .../test/integration/michelson/test_ticket_manager.ml | 7 ++++++- .../test/integration/michelson/test_ticket_scanner.ml | 8 +++++++- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_manager.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_manager.ml index 6fb79efb53f6..d372e19e0c59 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_manager.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_manager.ml @@ -65,7 +65,12 @@ let collect_token_amounts ctxt tickets = let tokens_of_value ~include_lazy ctxt ty x = let*? has_tickets, ctxt = Ticket_scanner.type_has_tickets ctxt ty in let* tickets, ctxt = - Ticket_scanner.tickets_of_value ~include_lazy ctxt has_tickets x + Ticket_scanner.tickets_of_value + ~include_lazy + ~allow_zero_amount_tickets:true + ctxt + has_tickets + x in let* tas, ctxt = collect_token_amounts ctxt tickets in let* bm, ctxt = diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml index ea75ba0e06b7..5ff975e5aaa1 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml @@ -125,7 +125,13 @@ let tickets_of_value ctxt ~include_lazy ~type_exp ~value_exp = let* ht, ctxt = wrap @@ Lwt.return @@ Ticket_scanner.type_has_tickets ctxt ty in - wrap @@ Ticket_scanner.tickets_of_value ctxt ~include_lazy ht value + wrap + @@ Ticket_scanner.tickets_of_value + ctxt + ~include_lazy + ~allow_zero_amount_tickets:true + ht + value let assert_contains_tickets ctxt ~loc ~include_lazy ~type_exp ~value_exp expected = -- GitLab From be1149cda1a7057ed8858bc0af06cefc14f80ec9 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Sun, 12 Jun 2022 09:11:22 +0100 Subject: [PATCH 4/6] Proto: allow-zero flag for ticket op diffs --- .../lib_protocol/ticket_accounting.ml | 5 ++- .../lib_protocol/ticket_operations_diff.ml | 36 +++++++++++++------ .../lib_protocol/ticket_operations_diff.mli | 16 ++++++--- 3 files changed, 40 insertions(+), 17 deletions(-) diff --git a/src/proto_alpha/lib_protocol/ticket_accounting.ml b/src/proto_alpha/lib_protocol/ticket_accounting.ml index bc99fc9528b2..64c2273f18fd 100644 --- a/src/proto_alpha/lib_protocol/ticket_accounting.ml +++ b/src/proto_alpha/lib_protocol/ticket_accounting.ml @@ -220,7 +220,10 @@ let update_ticket_balances ctxt ~self ~ticket_diffs operations = (Compare.Z.(Script_int.to_zint amount <= Z.neg balance_diff), ctxt) in (* Collect diffs from operations *) - Ticket_operations_diff.ticket_diffs_of_operations ctxt operations + Ticket_operations_diff.ticket_diffs_of_operations + ~allow_zero_amount_tickets:true + ctxt + operations >>=? fun (ticket_op_diffs, ctxt) -> (* Update balances for self-contract. *) Ticket_token_map.to_list ctxt ticket_diffs >>?= fun (ticket_diffs, ctxt) -> diff --git a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml index d638cc724425..8779159f09c5 100644 --- a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml @@ -142,20 +142,22 @@ module Ticket_token_map = struct map end -let tickets_of_transaction ctxt ~destination ~parameters_ty ~parameters = +let tickets_of_transaction ctxt ~allow_zero_amount_tickets ~destination + ~parameters_ty ~parameters = let destination = Destination.Contract (Originated destination) in Ticket_scanner.type_has_tickets ctxt parameters_ty >>?= fun (has_tickets, ctxt) -> Ticket_scanner.tickets_of_value ~include_lazy:true - ~allow_zero_amount_tickets:true + ~allow_zero_amount_tickets ctxt has_tickets parameters >>=? fun (tickets, ctxt) -> return (Some {destination; tickets}, ctxt) (** Extract tickets of an origination operation by scanning the storage. *) -let tickets_of_origination ctxt ~preorigination ~storage_type ~storage = +let tickets_of_origination ctxt ~allow_zero_amount_tickets ~preorigination + ~storage_type ~storage = (* Extract any tickets from the storage. Note that if the type of the contract storage does not contain tickets, storage is not scanned. *) Ticket_scanner.type_has_tickets ctxt storage_type @@ -163,14 +165,14 @@ let tickets_of_origination ctxt ~preorigination ~storage_type ~storage = Ticket_scanner.tickets_of_value ctxt ~include_lazy:true - ~allow_zero_amount_tickets:true + ~allow_zero_amount_tickets has_tickets storage >|=? fun (tickets, ctxt) -> let destination = Destination.Contract (Originated preorigination) in (Some {tickets; destination}, ctxt) -let tickets_of_operation ctxt +let tickets_of_operation ctxt ~allow_zero_amount_tickets (Script_typed_ir.Internal_operation {source = _; operation; nonce = _}) = match operation with | Transaction_to_contract {destination = Implicit _; _} -> return (None, ctxt) @@ -184,7 +186,12 @@ let tickets_of_operation ctxt parameters_ty; parameters; } -> - tickets_of_transaction ctxt ~destination ~parameters_ty ~parameters + tickets_of_transaction + ctxt + ~allow_zero_amount_tickets + ~destination + ~parameters_ty + ~parameters | Transaction_to_tx_rollup {destination; unparsed_parameters = _; parameters_ty; parameters} -> Tx_rollup_parameters.get_deposit_parameters parameters_ty parameters @@ -203,7 +210,12 @@ let tickets_of_operation ctxt storage_type; storage; } -> - tickets_of_origination ctxt ~preorigination ~storage_type ~storage + tickets_of_origination + ctxt + ~allow_zero_amount_tickets + ~preorigination + ~storage_type + ~storage | Delegation _ -> return (None, ctxt) let add_transfer_to_token_map ctxt token_map {destination; tickets} = @@ -216,10 +228,11 @@ let add_transfer_to_token_map ctxt token_map {destination; tickets} = (token_map, ctxt) tickets -let ticket_token_map_of_operations ctxt ops = +let ticket_token_map_of_operations ctxt ~allow_zero_amount_tickets ops = List.fold_left_es (fun (token_map, ctxt) op -> - tickets_of_operation ctxt op >>=? fun (res, ctxt) -> + tickets_of_operation ctxt ~allow_zero_amount_tickets op + >>=? fun (res, ctxt) -> match res with | Some ticket_trans -> add_transfer_to_token_map ctxt token_map ticket_trans @@ -228,8 +241,9 @@ let ticket_token_map_of_operations ctxt ops = ops (** Traverses a list of operations and scans for tickets. *) -let ticket_diffs_of_operations ctxt operations = - ticket_token_map_of_operations ctxt operations >>=? fun (token_map, ctxt) -> +let ticket_diffs_of_operations ctxt ~allow_zero_amount_tickets operations = + ticket_token_map_of_operations ctxt ~allow_zero_amount_tickets operations + >>=? fun (token_map, ctxt) -> Ticket_token_map.fold ctxt (fun ctxt acc ticket_token destination_map -> diff --git a/src/proto_alpha/lib_protocol/ticket_operations_diff.mli b/src/proto_alpha/lib_protocol/ticket_operations_diff.mli index 6ad466927970..79d35af1d6e8 100644 --- a/src/proto_alpha/lib_protocol/ticket_operations_diff.mli +++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.mli @@ -39,12 +39,18 @@ type ticket_token_diff = private { (Alpha_context.Destination.t * Script_int.n Script_int.num) list; } -(** [ticket_diffs_of_operations ctxt ops] returns a list of ticket-tokens diffs - given a context, [ctxt], and list of packed operations, [ops]. The diffs - result from either a [Transaction] operation with parameters containing - tickets, or an [Origination] operation with the initial storage containing - tickets. *) +(** [ticket_diffs_of_operations ctxt ~allow_zero_amount_tickets ops] returns a + list of ticket-tokens diffs given a context, [ctxt], and list of packed + operations, [ops]. The diffs result from either a [Transaction] operation + with parameters containing tickets, or an [Origination] operation with the + initial storage containing tickets. + + The flag [allow_zero_amount_tickets] decides whether or not tickets with + amount zero are allowed. If the flag is set to [false] and a zero-amount + ticket is encountered, an {!Ticket_scanner.Forbidden_zero_ticket_quantity} + error is returned. *) val ticket_diffs_of_operations : Alpha_context.context -> + allow_zero_amount_tickets:bool -> Script_typed_ir.packed_internal_operation list -> (ticket_token_diff list * Alpha_context.context) tzresult Lwt.t -- GitLab From eb582c126927f03fd60b9d2b0ab15e79d32c9881 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Tue, 31 May 2022 20:01:10 +0100 Subject: [PATCH 5/6] Test: add test for zero-amount-ticket --- .../michelson/test_ticket_operations_diff.ml | 248 +++++++++++++++--- 1 file changed, 206 insertions(+), 42 deletions(-) diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml index c38be69b0ca1..8dfec04534e7 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml @@ -52,6 +52,26 @@ let ( let* ) m f = m >>=? f let wrap m = m >|= Environment.wrap_tzresult +let assert_fails ~loc ?error m = + let open Lwt_result_syntax in + let*! res = m in + match res with + | Ok _ -> Stdlib.failwith "Expected failure" + | Error err_res -> ( + match (err_res, error) with + | Environment.Ecoproto_error err' :: _, Some err when err = err' -> + (* Matched exact error. *) + return_unit + | _, Some _ -> + (* Expected a different error. *) + let msg = + Printf.sprintf "Expected a different error at location %s" loc + in + Stdlib.failwith msg + | _, None -> + (* Any error is ok. *) + return ()) + let big_map_updates_of_key_values ctxt key_values = List.fold_right_es (fun (key, value) (kvs, ctxt) -> @@ -339,10 +359,11 @@ let transfer_operation_to_tx_rollup ~incr ~src ~parameters_ty ~parameters }, incr ) -let ticket_diffs_of_operations incr operations = +let ticket_diffs_of_operations incr ~allow_zero_amount_tickets operations = wrap @@ Ticket_operations_diff.ticket_diffs_of_operations (Incremental.alpha_ctxt incr) + ~allow_zero_amount_tickets operations let unit_script = @@ -390,7 +411,9 @@ let test_non_ticket_operations () = let* _baker, src, block = init () in let* incr = Incremental.begin_construction block in let operations = [delegation_operation ~src] in - let* ticket_diffs, ctxt = ticket_diffs_of_operations incr operations in + let* ticket_diffs, ctxt = + ticket_diffs_of_operations incr ~allow_zero_amount_tickets:true operations + in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] (** Test transfer to a contract that does not take tickets. *) @@ -413,7 +436,9 @@ let test_transfer_to_non_ticket_contract () = ~parameters_ty:unit_t ~parameters:() in - let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = + ticket_diffs_of_operations incr ~allow_zero_amount_tickets:true [operation] + in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] (** Test transfer an empty list of tickets. *) @@ -431,7 +456,9 @@ let test_transfer_empty_ticket_list () = let* operation, incr = transfer_tickets_operation ~incr ~src ~destination:orig_contract [] in - let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = + ticket_diffs_of_operations incr ~allow_zero_amount_tickets:true [operation] + in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] (** Test transfer a list of one ticket. *) @@ -454,7 +481,9 @@ let test_transfer_one_ticket () = ~destination:orig_contract [(ticketer, "white", 1)] in - let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = + ticket_diffs_of_operations incr ~allow_zero_amount_tickets:true [operation] + in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -468,7 +497,9 @@ let test_transfer_one_ticket () = }; ] -(** Test transfer a list of multiple tickets. *) +(** Test transferring a list of multiple tickets. This should work when + zero-tickets are disabled as well as when the parameters do not contain any + zero-amount tickets. *) let test_transfer_multiple_tickets () = let* baker, src, block = init () in let* ticketer = one_ticketer block in @@ -493,29 +524,36 @@ let test_transfer_multiple_tickets () = (ticketer, "red", 4); ] in - let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in - assert_equal_ticket_token_diffs - ctxt - ~loc:__LOC__ - ticket_diffs - ~expected: - [ - { - ticket_token = string_token ~ticketer "red"; - total_amount = nat 5; - destinations = [(Destination.Contract orig_contract, nat 5)]; - }; - { - ticket_token = string_token ~ticketer "blue"; - total_amount = nat 2; - destinations = [(Destination.Contract orig_contract, nat 2)]; - }; - { - ticket_token = string_token ~ticketer "green"; - total_amount = nat 3; - destinations = [(Destination.Contract orig_contract, nat 3)]; - }; - ] + let test allow_zero_amount_tickets = + let* ticket_diffs, ctxt = + ticket_diffs_of_operations incr ~allow_zero_amount_tickets [operation] + in + assert_equal_ticket_token_diffs + ctxt + ~loc:__LOC__ + ticket_diffs + ~expected: + [ + { + ticket_token = string_token ~ticketer "red"; + total_amount = nat 5; + destinations = [(Destination.Contract orig_contract, nat 5)]; + }; + { + ticket_token = string_token ~ticketer "blue"; + total_amount = nat 2; + destinations = [(Destination.Contract orig_contract, nat 2)]; + }; + { + ticket_token = string_token ~ticketer "green"; + total_amount = nat 3; + destinations = [(Destination.Contract orig_contract, nat 3)]; + }; + ] + in + (* Check for both value of the allow-zero-amount-tickets flag. *) + let* () = test true in + test false (** Test transfer a list of tickets of different types. *) let test_transfer_different_tickets () = @@ -547,7 +585,9 @@ let test_transfer_different_tickets () = (ticketer1, "blue", 1); ] in - let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = + ticket_diffs_of_operations incr ~allow_zero_amount_tickets:true [operation] + in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -619,7 +659,10 @@ let test_transfer_to_two_contracts_with_different_tickets () = transfer_tickets_operation ~incr ~src ~destination:destination2 parameters in let* ticket_diffs, ctxt = - ticket_diffs_of_operations incr [operation1; operation2] + ticket_diffs_of_operations + incr + ~allow_zero_amount_tickets:true + [operation1; operation2] in assert_equal_ticket_token_diffs ctxt @@ -668,7 +711,9 @@ let test_originate_non_ticket_contract () = ~storage:"Unit" ~forges_tickets:false in - let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = + ticket_diffs_of_operations incr ~allow_zero_amount_tickets:true [operation] + in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] (** Test originate a contract with an empty list of tickets. *) @@ -684,7 +729,9 @@ let test_originate_with_empty_tickets_list () = ~storage ~forges_tickets:false in - let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = + ticket_diffs_of_operations incr ~allow_zero_amount_tickets:true [operation] + in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] (** Test originate a contract with a single ticket. *) @@ -703,7 +750,9 @@ let test_originate_with_one_ticket () = ~storage ~forges_tickets:true in - let* ticket_diffs, ctxt = ticket_diffs_of_operations ctxt [operation] in + let* ticket_diffs, ctxt = + ticket_diffs_of_operations ctxt ~allow_zero_amount_tickets:true [operation] + in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -744,7 +793,9 @@ let test_originate_with_multiple_tickets () = ~storage ~forges_tickets:true in - let* ticket_diffs, ctxt = ticket_diffs_of_operations ctxt [operation] in + let* ticket_diffs, ctxt = + ticket_diffs_of_operations ctxt ~allow_zero_amount_tickets:true [operation] + in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -806,7 +857,9 @@ let test_originate_with_different_tickets () = ~storage ~forges_tickets:true in - let* ticket_diffs, ctxt = ticket_diffs_of_operations ctxt [operation] in + let* ticket_diffs, ctxt = + ticket_diffs_of_operations ctxt ~allow_zero_amount_tickets:true [operation] + in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -877,7 +930,10 @@ let test_originate_two_contracts_with_different_tickets () = ~forges_tickets:true in let* ticket_diffs, ctxt = - ticket_diffs_of_operations incr [operation1; operations2] + ticket_diffs_of_operations + incr + ~allow_zero_amount_tickets:true + [operation1; operations2] in assert_equal_ticket_token_diffs ctxt @@ -953,7 +1009,10 @@ let test_originate_and_transfer () = [(ticketer, "red", 1); (ticketer, "green", 1); (ticketer, "blue", 1)] in let* ticket_diffs, ctxt = - ticket_diffs_of_operations incr [operation1; operation2] + ticket_diffs_of_operations + incr + ~allow_zero_amount_tickets:true + [operation1; operation2] in assert_equal_ticket_token_diffs ctxt @@ -1024,7 +1083,9 @@ let test_originate_big_map_with_tickets () = ~storage ~forges_tickets:true in - let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = + ticket_diffs_of_operations incr ~allow_zero_amount_tickets:true [operation] + in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -1104,7 +1165,9 @@ let test_transfer_big_map_with_tickets () = ~parameters_ty ~parameters in - let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = + ticket_diffs_of_operations incr ~allow_zero_amount_tickets:true [operation] + in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -1171,7 +1234,9 @@ let test_tx_rollup_deposit_one_ticket () = ~parameters_ty ~parameters in - let* ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs, ctxt = + ticket_diffs_of_operations incr ~allow_zero_amount_tickets:true [operation] + in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ @@ -1185,6 +1250,97 @@ let test_tx_rollup_deposit_one_ticket () = }; ] +(** Test transferring a list of multiple tickets where two of them have zero + amounts. This should work when zero-tickets are enabled. *) +let test_transfer_multiple_zero_tickets () = + let* baker, src, block = init () in + let* ticketer = one_ticketer block in + let* orig_contract, incr = + originate + block + ~src + ~baker + ~script:ticket_list_script + ~storage:"{}" + ~forges_tickets:false + in + let* operation, incr = + transfer_tickets_operation + ~incr + ~src + ~destination:orig_contract + [ + (ticketer, "red", 1); + (ticketer, "blue", 0); + (ticketer, "green", 2); + (ticketer, "red", 0); + (ticketer, "green", 3); + ] + in + let* ticket_diffs, ctxt = + ticket_diffs_of_operations incr ~allow_zero_amount_tickets:true [operation] + in + assert_equal_ticket_token_diffs + ctxt + ~loc:__LOC__ + ticket_diffs + ~expected: + [ + { + ticket_token = string_token ~ticketer "blue"; + total_amount = nat 0; + destinations = [(Destination.Contract orig_contract, nat 0)]; + }; + { + ticket_token = string_token ~ticketer "red"; + total_amount = nat 1; + destinations = [(Destination.Contract orig_contract, nat 1)]; + }; + { + ticket_token = string_token ~ticketer "green"; + total_amount = nat 5; + destinations = [(Destination.Contract orig_contract, nat 5)]; + }; + ] + +(** Test that zero-amount tickets are detected and that an error is yielded + when the [allow_zero_amount_tickets] flag is set to [false]. *) +let test_fail_on_zero_amount_tickets () = + let* baker, src, block = init () in + let* ticketer = one_ticketer block in + let storage = + let ticketer_addr = Contract.to_b58check ticketer in + Printf.sprintf + {| + { Pair %S "red" 1; + Pair %S "blue" 2 ; + Pair %S "green" 3; + Pair %S "red" 0; + Pair %S "red" 4; } + |} + ticketer_addr + ticketer_addr + ticketer_addr + ticketer_addr + ticketer_addr + in + let* _orig_contract, operation, ctxt = + origination_operation + block + ~src + ~baker + ~script:ticket_list_script + ~storage + ~forges_tickets:true + in + assert_fails + ~loc:__LOC__ + ~error:Ticket_scanner.Forbidden_zero_ticket_quantity + (ticket_diffs_of_operations + ctxt + ~allow_zero_amount_tickets:false + [operation]) + let tests = [ Tztest.tztest @@ -1249,7 +1405,15 @@ let tests = `Quick test_transfer_big_map_with_tickets; Tztest.tztest - "Testt tx rollup deposit one ticket" + "Test tx rollup deposit one ticket" `Quick test_tx_rollup_deposit_one_ticket; + Tztest.tztest + "Test transfer multiple zero tickets" + `Quick + test_transfer_multiple_zero_tickets; + Tztest.tztest + "Test fail in zero-amount tickets" + `Quick + test_fail_on_zero_amount_tickets; ] -- GitLab From 44b035c21deeeae2342da8d857fa01bf2d31d47d Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Sun, 12 Jun 2022 09:24:54 +0100 Subject: [PATCH 6/6] Test: ticket-scanner test for zero amount --- .../michelson/test_ticket_scanner.ml | 124 +++++++++++++++--- 1 file changed, 105 insertions(+), 19 deletions(-) diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml index 5ff975e5aaa1..5a3ebfd37126 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml @@ -36,6 +36,26 @@ open Protocol open Alpha_context +let assert_fails ~loc ?error m = + let open Lwt_result_syntax in + let*! res = m in + match res with + | Ok _ -> Stdlib.failwith "Expected failure" + | Error err_res -> ( + match (err_res, error) with + | Environment.Ecoproto_error err' :: _, Some err when err = err' -> + (* Matched exact error. *) + return_unit + | _, Some _ -> + (* Expected a different error. *) + let msg = + Printf.sprintf "Expected a different error at location %s" loc + in + Stdlib.failwith msg + | _, None -> + (* Any error is ok. *) + return ()) + let ( let* ) m f = m >>=? f let wrap m = m >|= Environment.wrap_tzresult @@ -105,7 +125,8 @@ let assert_equals_ex_tickets ctxt ~loc ex_tickets expected = (List.sort String.compare str_tickets) (List.sort String.compare str_tickets_expected) -let tickets_of_value ctxt ~include_lazy ~type_exp ~value_exp = +let tickets_of_value ctxt ~include_lazy ~allow_zero_amount_tickets ~type_exp + ~value_exp = let Script_ir_translator.Ex_ty ty, ctxt = let node = Micheline.root @@ Expr.from_string type_exp in Result.value_f @@ -129,19 +150,31 @@ let tickets_of_value ctxt ~include_lazy ~type_exp ~value_exp = @@ Ticket_scanner.tickets_of_value ctxt ~include_lazy - ~allow_zero_amount_tickets:true + ~allow_zero_amount_tickets ht value -let assert_contains_tickets ctxt ~loc ~include_lazy ~type_exp ~value_exp - expected = +let assert_contains_tickets ctxt ~loc ~include_lazy ~allow_zero_amount_tickets + ~type_exp ~value_exp expected = let* ex_tickets, _ = - tickets_of_value ctxt ~include_lazy ~type_exp ~value_exp + tickets_of_value + ctxt + ~include_lazy + ~allow_zero_amount_tickets + ~type_exp + ~value_exp in assert_equals_ex_tickets ctxt ~loc ex_tickets expected -let assert_fail_non_empty_overlay ctxt ~loc ~include_lazy ~type_exp ~value_exp = - tickets_of_value ctxt ~include_lazy ~type_exp ~value_exp >>= fun res -> +let assert_fail_non_empty_overlay ctxt ~loc ~include_lazy + ~allow_zero_amount_tickets ~type_exp ~value_exp = + tickets_of_value + ctxt + ~include_lazy + ~allow_zero_amount_tickets + ~type_exp + ~value_exp + >>= fun res -> match res with | Error [x] -> let x = Format.kasprintf Fun.id "%a" Error_monad.pp x in @@ -230,6 +263,7 @@ let assert_big_map_int_ticket_string_ref ~loc ~pre_populated ~big_map_exp assert_contains_tickets ctxt ~include_lazy:true + ~allow_zero_amount_tickets:true ~loc ~type_exp:"big_map int (ticket string)" ~value_exp @@ -241,10 +275,49 @@ let assert_fail_non_empty_overlay_with_big_map_ref ~loc ~pre_populated assert_fail_non_empty_overlay ctxt ~include_lazy:true + ~allow_zero_amount_tickets:true ~loc ~type_exp:"big_map int (ticket string)" ~value_exp +let assert_string_tickets ~loc ~include_lazy ~type_exp ~value_exp ~expected = + let* ctxt = new_ctxt () in + let* ex_tickets, ctxt = make_string_tickets ctxt expected in + let contains_zero_amount_tickets = + List.exists (fun (_, _, amount) -> amount = 0) expected + in + let* () = + assert_contains_tickets + ctxt + ~include_lazy + ~allow_zero_amount_tickets:true + ~loc + ~type_exp + ~value_exp + ex_tickets + in + if contains_zero_amount_tickets then + assert_fails + ~loc:__LOC__ + ~error:Ticket_scanner.Forbidden_zero_ticket_quantity + (tickets_of_value + ctxt + ~include_lazy + ~allow_zero_amount_tickets:false + ~type_exp + ~value_exp) + else + (* If there are no zero-amount tickets we still want them to pass with + [allow_zero_amount_tickets] flag set to false. *) + assert_contains_tickets + ctxt + ~include_lazy + ~allow_zero_amount_tickets:false + ~loc + ~type_exp + ~value_exp + ex_tickets + (** Test that the ticket can be extracted from a a single unit ticket *) let test_tickets_in_unit_ticket () = let* ctxt = new_ctxt () in @@ -262,21 +335,11 @@ let test_tickets_in_unit_ticket () = ctxt ~loc:__LOC__ ~include_lazy:false + ~allow_zero_amount_tickets:true ~type_exp ~value_exp [ex_ticket] -let assert_string_tickets ~loc ~include_lazy ~type_exp ~value_exp ~expected = - let* ctxt = new_ctxt () in - let* ex_tickets, ctxt = make_string_tickets ctxt expected in - assert_contains_tickets - ctxt - ~include_lazy - ~loc - ~type_exp - ~value_exp - ex_tickets - (** Test that all tickets can be extracted from a list of tickets *) let test_tickets_in_list () = assert_string_tickets @@ -289,6 +352,7 @@ let test_tickets_in_list () = Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1; Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2; Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 3; + Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "orange" 0; } |} ~expected: @@ -296,6 +360,7 @@ let test_tickets_in_list () = ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", 1); ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "green", 2); ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue", 3); + ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "orange", 0); ] (** Test that all tickets can be extracted from a pair of tickets *) @@ -303,17 +368,19 @@ let test_tickets_in_pair () = assert_string_tickets ~loc:__LOC__ ~include_lazy:false - ~type_exp:"pair (ticket string) (ticket string)" + ~type_exp:"pair (ticket string) (ticket string) (ticket string)" ~value_exp: {| Pair (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1) (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2) + (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 0) |} ~expected: [ ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", 1); ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "green", 2); + ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue", 0); ] (** Test that all tickets from a map can be extracted. *) @@ -327,12 +394,14 @@ let test_tickets_in_map () = { Elt 1 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1); Elt 2 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2); + Elt 3 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 0); } |} ~expected: [ ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", 1); ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "green", 2); + ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue", 0); ] (** Test that all tickets from a big-map with non-empty overlay fails. @@ -345,6 +414,7 @@ let test_tickets_in_big_map () = ctxt ~loc:__LOC__ ~include_lazy:true + ~allow_zero_amount_tickets:false ~type_exp:"big_map int (ticket string)" ~value_exp: {| @@ -366,6 +436,7 @@ let test_tickets_in_big_map_strict_only () = { Elt 1 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1); Elt 2 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2); + Elt 3 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 0); } |} ~expected:[] @@ -380,6 +451,7 @@ let test_tickets_in_list_in_big_map () = ctxt ~loc:__LOC__ ~include_lazy:true + ~allow_zero_amount_tickets:true ~type_exp:"(big_map int (list(ticket string)))" ~value_exp: {| @@ -429,6 +501,16 @@ let test_tickets_in_or_left () = ~value_exp:{| Left (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1) |} ~expected:[("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", 1)] +(** Test that tickets can be extracted from the left side of an or-expression + with zero-amount ticket. *) +let test_tickets_in_or_left_with_zero_amount () = + assert_string_tickets + ~loc:__LOC__ + ~include_lazy:false + ~type_exp:"or (ticket string) int" + ~value_exp:{| Left (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 0) |} + ~expected:[("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", 0)] + (** Test that tickets can be extracted from the right side of an or-expression. *) let test_tickets_in_or_right () = assert_string_tickets @@ -570,6 +652,10 @@ let tests = `Quick test_tickets_in_pair_big_map_and_list_strict_only; Tztest.tztest "Test tickets in or left" `Quick test_tickets_in_or_left; + Tztest.tztest + "Test tickets in or left" + `Quick + test_tickets_in_or_left_with_zero_amount; Tztest.tztest "Test tickets in or right" `Quick test_tickets_in_or_right; Tztest.tztest "Test tickets in empty big-map ref" -- GitLab