From 2fd610958cf87da7565552f311c4da8dfaeb8202 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Fri, 22 Oct 2021 17:13:17 +0100 Subject: [PATCH 1/3] Proto: Add ticket-scanner module --- src/proto_alpha/lib_protocol/TEZOS_PROTOCOL | 2 + src/proto_alpha/lib_protocol/dune.inc | 10 + src/proto_alpha/lib_protocol/ticket_costs.ml | 52 ++ src/proto_alpha/lib_protocol/ticket_costs.mli | 53 ++ .../lib_protocol/ticket_scanner.ml | 515 ++++++++++++++++++ .../lib_protocol/ticket_scanner.mli | 55 ++ 6 files changed, 687 insertions(+) create mode 100644 src/proto_alpha/lib_protocol/ticket_costs.ml create mode 100644 src/proto_alpha/lib_protocol/ticket_costs.mli create mode 100644 src/proto_alpha/lib_protocol/ticket_scanner.ml create mode 100644 src/proto_alpha/lib_protocol/ticket_scanner.mli diff --git a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL index 85885d6ee5d7..fc49da638506 100644 --- a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL +++ b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL @@ -103,6 +103,8 @@ "Script_ir_translator", "Script_cache", "Script_tc_errors_registration", + "Ticket_costs", + "Ticket_scanner", "Script_interpreter_defs", "Script_interpreter", diff --git a/src/proto_alpha/lib_protocol/dune.inc b/src/proto_alpha/lib_protocol/dune.inc index f0f8762649d0..f6d05d24296e 100644 --- a/src/proto_alpha/lib_protocol/dune.inc +++ b/src/proto_alpha/lib_protocol/dune.inc @@ -123,6 +123,8 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end script_ir_translator.mli script_ir_translator.ml script_cache.mli script_cache.ml script_tc_errors_registration.mli script_tc_errors_registration.ml + ticket_costs.mli ticket_costs.ml + ticket_scanner.mli ticket_scanner.ml script_interpreter_defs.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml @@ -240,6 +242,8 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end script_ir_translator.mli script_ir_translator.ml script_cache.mli script_cache.ml script_tc_errors_registration.mli script_tc_errors_registration.ml + ticket_costs.mli ticket_costs.ml + ticket_scanner.mli ticket_scanner.ml script_interpreter_defs.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml @@ -357,6 +361,8 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end script_ir_translator.mli script_ir_translator.ml script_cache.mli script_cache.ml script_tc_errors_registration.mli script_tc_errors_registration.ml + ticket_costs.mli ticket_costs.ml + ticket_scanner.mli ticket_scanner.ml script_interpreter_defs.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml @@ -496,6 +502,8 @@ include Tezos_raw_protocol_alpha.Main Script_ir_translator Script_cache Script_tc_errors_registration + Ticket_costs + Ticket_scanner Script_interpreter_defs Script_interpreter Baking @@ -652,6 +660,8 @@ include Tezos_raw_protocol_alpha.Main script_ir_translator.mli script_ir_translator.ml script_cache.mli script_cache.ml script_tc_errors_registration.mli script_tc_errors_registration.ml + ticket_costs.mli ticket_costs.ml + ticket_scanner.mli ticket_scanner.ml script_interpreter_defs.ml script_interpreter.mli script_interpreter.ml baking.mli baking.ml diff --git a/src/proto_alpha/lib_protocol/ticket_costs.ml b/src/proto_alpha/lib_protocol/ticket_costs.ml new file mode 100644 index 000000000000..72be4eda1a76 --- /dev/null +++ b/src/proto_alpha/lib_protocol/ticket_costs.ml @@ -0,0 +1,52 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Trili Tech, *) +(* *) +(* 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 Alpha_context + +module Constants = struct + module S = Saturation_repr + + (* TODO: Fill in real benchmarked values *) + let cost_contains_tickets_step = S.safe_int 28 + + (* TODO: Fill in real benchmarked values *) + let cost_collect_tickets_step = S.safe_int 360 + + (* TODO: Fill in real benchmarked values *) + let cost_has_tickets_of_ty type_size = S.mul (S.safe_int 20) type_size +end + +let consume_gas_steps ctxt ~step_cost ~num_steps = + let ( * ) = Saturation_repr.mul in + if Compare.Int.(num_steps <= 0) then Ok ctxt + else + let gas = + Gas.atomic_step_cost (step_cost * Saturation_repr.safe_int num_steps) + in + Gas.consume ctxt gas + +let has_tickets_of_ty_cost ty = + Constants.cost_has_tickets_of_ty + Script_typed_ir.(ty_size ty |> Type_size.to_int) diff --git a/src/proto_alpha/lib_protocol/ticket_costs.mli b/src/proto_alpha/lib_protocol/ticket_costs.mli new file mode 100644 index 000000000000..de052916f7de --- /dev/null +++ b/src/proto_alpha/lib_protocol/ticket_costs.mli @@ -0,0 +1,53 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Trili Tech, *) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** This module contains constants and utility functions for gas metering + functions used for extracting and handling tickets for the global ticket + balance table. *) + +module Constants : sig + val cost_contains_tickets_step : Alpha_context.Gas.cost + + val cost_collect_tickets_step : Alpha_context.Gas.cost +end + +(** [consume_gas_steps ctxt ~num_steps] consumes gas corresponding to + a given [num_steps] and [step_cost]. It's useful for paying for gas + upfront where the number of steps can be determined. + + This function is generic and should probably be moved. See issue + https://gitlab.com/tezos/tezos/-/issues/1950. + + *) +val consume_gas_steps : + Alpha_context.t -> + step_cost:Alpha_context.Gas.cost -> + num_steps:int -> + Alpha_context.t tzresult + +(** [has_tickets_of_ty_cost ty] returns the cost of producing a [has_tickets], + used internally in the [Ticket_scanner] module. *) +val has_tickets_of_ty_cost : + 'a Script_typed_ir.ty -> Saturation_repr.may_saturate Saturation_repr.t diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.ml b/src/proto_alpha/lib_protocol/ticket_scanner.ml new file mode 100644 index 000000000000..ae4281f2cfa1 --- /dev/null +++ b/src/proto_alpha/lib_protocol/ticket_scanner.ml @@ -0,0 +1,515 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Trili Tech, *) +(* *) +(* 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 Alpha_context + +(* Impossible error *) +type error += Unsupported_type_invariant_violated + +type error += Unsupported_non_empty_overlay | Unsupported_type_operation + +let () = + register_error_kind + `Branch + ~id:"Unsupported_non_empty_overlay" + ~title:"Unsupported non empty overlay" + ~description:"Unsupported big-map value with non-empty overlay" + ~pp:(fun ppf () -> + Format.fprintf ppf "Unsupported big-map value with non-empty overlay") + Data_encoding.empty + (function Unsupported_non_empty_overlay -> Some () | _ -> None) + (fun () -> Unsupported_non_empty_overlay) ; + register_error_kind + `Branch + ~id:"Unsupported_type_operation" + ~title:"Unsupported type operation" + ~description:"Types embedding operations are not supported" + ~pp:(fun ppf () -> + Format.fprintf ppf "Types embedding operations are not supported") + Data_encoding.empty + (function Unsupported_type_operation -> Some () | _ -> None) + (fun () -> Unsupported_type_operation) + +type ex_ticket = + | Ex_ticket : + 'a Script_typed_ir.comparable_ty * 'a Script_typed_ir.ticket + -> ex_ticket + +module Ticket_inspection = struct + (* TODO: 1951 + Replace with use of meta-data for ['a ty] type. + Once ['a ty] values can be extended with custom meta data, this type + can be removed. + *) + (** + Witness flag for whether a type can be populated by a value containing a + ticket. [False_ht] must be used only when a value of the type cannot + contain a ticket. + + This flag is necessary for avoiding ticket collection (see below) to have + quadratic complexity in the order of: size-of-the-type * size-of-value. + + This type is local to the [Ticket_scanner] module and should not be + exported. + + *) + type 'a has_tickets = + | True_ht : _ Script_typed_ir.ticket has_tickets + | False_ht : _ has_tickets + | Pair_ht : + 'a has_tickets * 'b has_tickets + -> ('a, 'b) Script_typed_ir.pair has_tickets + | Union_ht : + 'a has_tickets * 'b has_tickets + -> ('a, 'b) Script_typed_ir.union has_tickets + | Option_ht : 'a has_tickets -> 'a option has_tickets + | List_ht : 'a has_tickets -> 'a Script_typed_ir.boxed_list has_tickets + | Set_ht : 'k has_tickets -> 'k Script_typed_ir.set has_tickets + | Map_ht : + 'k has_tickets * 'v has_tickets + -> ('k, 'v) Script_typed_ir.map has_tickets + | Big_map_ht : + 'k has_tickets * 'v has_tickets + -> ('k, 'v) Script_typed_ir.big_map has_tickets + + (* Returns whether or not a comparable type embeds tickets. Currently + this function returns [false] for all input. + + The only reason we keep this code is so that in the future, if tickets were + ever to be comparable, the compiler would detect a missing pattern match + case. + + Note that in case tickets are made comparable, this function needs to change + so that constructors like [Union_key] and [Pair_key] are traversed + recursively. + *) + let has_tickets_of_comparable : + type a ret. + a Script_typed_ir.comparable_ty -> (a has_tickets -> ret) -> ret = + fun key_ty k -> + let open Script_typed_ir in + match key_ty with + | Unit_key _ -> (k [@ocaml.tailcall]) False_ht + | Never_key _ -> (k [@ocaml.tailcall]) False_ht + | Int_key _ -> (k [@ocaml.tailcall]) False_ht + | Nat_key _ -> (k [@ocaml.tailcall]) False_ht + | Signature_key _ -> (k [@ocaml.tailcall]) False_ht + | String_key _ -> (k [@ocaml.tailcall]) False_ht + | Bytes_key _ -> (k [@ocaml.tailcall]) False_ht + | Mutez_key _ -> (k [@ocaml.tailcall]) False_ht + | Bool_key _ -> (k [@ocaml.tailcall]) False_ht + | Key_hash_key _ -> (k [@ocaml.tailcall]) False_ht + | Key_key _ -> (k [@ocaml.tailcall]) False_ht + | Timestamp_key _ -> (k [@ocaml.tailcall]) False_ht + | Chain_id_key _ -> (k [@ocaml.tailcall]) False_ht + | Address_key _ -> (k [@ocaml.tailcall]) False_ht + | Pair_key ((_, _), (_, _), _) -> (k [@ocaml.tailcall]) False_ht + | Union_key (_, (_, _), _) -> (k [@ocaml.tailcall]) False_ht + | Option_key (_, _) -> (k [@ocaml.tailcall]) False_ht + + (* Short circuit pairing of two [has_tickets] values. + If neither left nor right branch contains a ticket, [False_ht] is + returned. *) + let pair_has_tickets pair ht1 ht2 = + match (ht1, ht2) with (False_ht, False_ht) -> False_ht | _ -> pair ht1 ht2 + + let map_has_tickets map ht = + match ht with False_ht -> False_ht | _ -> map ht + + type ('a, 'r) continuation = 'a has_tickets -> 'r tzresult + + (* Creates a [has_tickets] type-witness value from the given ['a ty]. + The returned value matches the given shape of the [ty] value, except + it collapses whole branches where no types embed tickets to [False_ht]. + *) + let rec has_tickets_of_ty : + type a ret. a Script_typed_ir.ty -> (a, ret) continuation -> ret tzresult + = + fun ty k -> + let open Script_typed_ir in + match ty with + | Ticket_t _ -> (k [@ocaml.tailcall]) True_ht + | Unit_t _ -> (k [@ocaml.tailcall]) False_ht + | Int_t _ -> (k [@ocaml.tailcall]) False_ht + | Nat_t _ -> (k [@ocaml.tailcall]) False_ht + | Signature_t _ -> (k [@ocaml.tailcall]) False_ht + | String_t _ -> (k [@ocaml.tailcall]) False_ht + | Bytes_t _ -> (k [@ocaml.tailcall]) False_ht + | Mutez_t _ -> (k [@ocaml.tailcall]) False_ht + | Key_hash_t _ -> (k [@ocaml.tailcall]) False_ht + | Key_t _ -> (k [@ocaml.tailcall]) False_ht + | Timestamp_t _ -> (k [@ocaml.tailcall]) False_ht + | Address_t _ -> (k [@ocaml.tailcall]) False_ht + | Bool_t _ -> (k [@ocaml.tailcall]) False_ht + | Pair_t ((ty1, _, _), (ty2, _, _), _) -> + (has_tickets_of_pair [@ocaml.tailcall]) + ty1 + ty2 + ~pair:(fun ht1 ht2 -> Pair_ht (ht1, ht2)) + k + | Union_t ((ty1, _), (ty2, _), _) -> + (has_tickets_of_pair [@ocaml.tailcall]) + ty1 + ty2 + ~pair:(fun ht1 ht2 -> Union_ht (ht1, ht2)) + k + | Lambda_t (_, _, _) -> + (* As of H, closures cannot contain tickets because APPLY requires + a packable type and tickets are not packable. *) + (k [@ocaml.tailcall]) False_ht + | Option_t (ty, _) -> + (has_tickets_of_ty [@ocaml.tailcall]) ty (fun ht -> + let opt_hty = map_has_tickets (fun ht -> Option_ht ht) ht in + (k [@ocaml.tailcall]) opt_hty) + | List_t (ty, _) -> + (has_tickets_of_ty [@ocaml.tailcall]) ty (fun ht -> + let list_hty = map_has_tickets (fun ht -> List_ht ht) ht in + (k [@ocaml.tailcall]) list_hty) + | Set_t (key_ty, _) -> + (has_tickets_of_comparable [@ocaml.tailcall]) key_ty (fun ht -> + let set_hty = map_has_tickets (fun ht -> Set_ht ht) ht in + (k [@ocaml.tailcall]) set_hty) + | Map_t (key_ty, val_ty, _) -> + (has_tickets_of_key_and_value [@ocaml.tailcall]) + key_ty + val_ty + ~pair:(fun ht1 ht2 -> Map_ht (ht1, ht2)) + k + | Big_map_t (key_ty, val_ty, _) -> + (has_tickets_of_key_and_value [@ocaml.tailcall]) + key_ty + val_ty + ~pair:(fun ht1 ht2 -> Big_map_ht (ht1, ht2)) + k + | Contract_t _ -> (k [@ocaml.tailcall]) False_ht + | Sapling_transaction_t _ -> (k [@ocaml.tailcall]) False_ht + | Sapling_state_t _ -> (k [@ocaml.tailcall]) False_ht + | Operation_t _ -> + (* Operations may contain tickets but they should never be passed + why we fail in this case. *) + error Unsupported_type_operation + | Chain_id_t _ -> (k [@ocaml.tailcall]) False_ht + | Never_t _ -> (k [@ocaml.tailcall]) False_ht + | Bls12_381_g1_t _ -> (k [@ocaml.tailcall]) False_ht + | Bls12_381_g2_t _ -> (k [@ocaml.tailcall]) False_ht + | Bls12_381_fr_t _ -> (k [@ocaml.tailcall]) False_ht + | Chest_t _ -> (k [@ocaml.tailcall]) False_ht + | Chest_key_t _ -> (k [@ocaml.tailcall]) False_ht + + and has_tickets_of_pair : + type a b c ret. + a Script_typed_ir.ty -> + b Script_typed_ir.ty -> + pair:(a has_tickets -> b has_tickets -> c has_tickets) -> + (c, ret) continuation -> + ret tzresult = + fun ty1 ty2 ~pair k -> + (has_tickets_of_ty [@ocaml.tailcall]) ty1 (fun ht1 -> + (has_tickets_of_ty [@ocaml.tailcall]) ty2 (fun ht2 -> + (k [@ocaml.tailcall]) (pair_has_tickets pair ht1 ht2))) + + and has_tickets_of_key_and_value : + type k v t ret. + k Script_typed_ir.comparable_ty -> + v Script_typed_ir.ty -> + pair:(k has_tickets -> v has_tickets -> t has_tickets) -> + (t, ret) continuation -> + ret tzresult = + fun key_ty val_ty ~pair k -> + (has_tickets_of_comparable [@ocaml.tailcall]) key_ty (fun ht1 -> + (has_tickets_of_ty [@ocaml.tailcall]) val_ty (fun ht2 -> + (k [@ocaml.tailcall]) (pair_has_tickets pair ht1 ht2))) + + let has_tickets_of_ty ctxt ty = + Gas.consume ctxt (Ticket_costs.has_tickets_of_ty_cost ty) >>? fun ctxt -> + has_tickets_of_ty ty ok >|? fun ht -> (ht, ctxt) +end + +module Ticket_collection = struct + let consume_gas_steps = + Ticket_costs.consume_gas_steps + ~step_cost:Ticket_costs.Constants.cost_collect_tickets_step + + type accumulator = ex_ticket list + + type 'a continuation = + Alpha_context.context -> accumulator -> 'a tzresult Lwt.t + + (* Currently this always returns the original list. + + If comparables are ever extended to support tickets, this function + needs to be modified. In particular constructors like [Option] and [Pair] + would have to recurse on their arguments. *) + + let tickets_of_comparable : + type a ret. + Alpha_context.context -> + a Script_typed_ir.comparable_ty -> + accumulator -> + ret continuation -> + ret tzresult Lwt.t = + fun ctxt comp_ty acc k -> + let open Script_typed_ir in + match comp_ty with + | Unit_key _ -> (k [@ocaml.tailcall]) ctxt acc + | Never_key _ -> (k [@ocaml.tailcall]) ctxt acc + | Int_key _ -> (k [@ocaml.tailcall]) ctxt acc + | Nat_key _ -> (k [@ocaml.tailcall]) ctxt acc + | Signature_key _ -> (k [@ocaml.tailcall]) ctxt acc + | String_key _ -> (k [@ocaml.tailcall]) ctxt acc + | Bytes_key _ -> (k [@ocaml.tailcall]) ctxt acc + | Mutez_key _ -> (k [@ocaml.tailcall]) ctxt acc + | Bool_key _ -> (k [@ocaml.tailcall]) ctxt acc + | Key_hash_key _ -> (k [@ocaml.tailcall]) ctxt acc + | Key_key _ -> (k [@ocaml.tailcall]) ctxt acc + | Timestamp_key _ -> (k [@ocaml.tailcall]) ctxt acc + | Chain_id_key _ -> (k [@ocaml.tailcall]) ctxt acc + | Address_key _ -> (k [@ocaml.tailcall]) ctxt acc + | Pair_key ((_, _), (_, _), _) -> (k [@ocaml.tailcall]) ctxt acc + | Union_key ((_, _), (_, _), _) -> (k [@ocaml.tailcall]) ctxt acc + | Option_key (_, _) -> (k [@ocaml.tailcall]) ctxt acc + + let tickets_of_set : + type a ret. + Alpha_context.context -> + a Script_typed_ir.comparable_ty -> + a Script_typed_ir.set -> + accumulator -> + ret continuation -> + ret tzresult Lwt.t = + fun ctxt key_ty _set acc k -> + consume_gas_steps ctxt ~num_steps:1 >>?= fun ctxt -> + (* This is only invoked to support any future extensions making tickets + comparable. *) + (tickets_of_comparable [@ocaml.tailcall]) ctxt key_ty acc k + + let rec tickets_of_value : + type a ret. + include_lazy:bool -> + Alpha_context.context -> + a Ticket_inspection.has_tickets -> + a Script_typed_ir.ty -> + a -> + accumulator -> + ret continuation -> + ret tzresult Lwt.t = + fun ~include_lazy 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 + | (False_ht, _) -> (k [@ocaml.tailcall]) ctxt acc + | (Pair_ht (hty1, hty2), Pair_t ((ty1, _, _), (ty2, _, _), _)) -> + let (l, r) = x in + (tickets_of_value [@ocaml.tailcall]) + ~include_lazy + ctxt + hty1 + ty1 + l + acc + (fun ctxt acc -> + (tickets_of_value [@ocaml.tailcall]) + ~include_lazy + ctxt + hty2 + ty2 + r + acc + k) + | (Union_ht (htyl, htyr), Union_t ((tyl, _), (tyr, _), _)) -> ( + match x with + | L v -> + (tickets_of_value [@ocaml.tailcall]) + ~include_lazy + ctxt + htyl + tyl + v + acc + k + | R v -> + (tickets_of_value [@ocaml.tailcall]) + ~include_lazy + ctxt + htyr + tyr + v + acc + k) + | (Option_ht el_hty, Option_t (el_ty, _)) -> ( + match x with + | Some x -> + (tickets_of_value [@ocaml.tailcall]) + ~include_lazy + ctxt + el_hty + el_ty + x + acc + k + | None -> (k [@ocaml.tailcall]) ctxt acc) + | (List_ht el_hty, List_t (el_ty, _)) -> + let {elements; _} = x in + (tickets_of_list [@ocaml.tailcall]) + ctxt + ~include_lazy + el_hty + el_ty + elements + acc + k + | (Set_ht _, Set_t (key_ty, _)) -> + (tickets_of_set [@ocaml.tailcall]) ctxt key_ty x acc k + | (Map_ht (_, val_hty), Map_t (key_ty, val_ty, _)) -> + (tickets_of_comparable [@ocaml.tailcall]) + ctxt + key_ty + acc + (fun ctxt acc -> + (tickets_of_map [@ocaml.tailcall]) + ctxt + ~include_lazy + val_hty + val_ty + x + acc + 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 + else (k [@ocaml.tailcall]) ctxt acc + | (True_ht, Ticket_t (comp_ty, _)) -> + (k [@ocaml.tailcall]) ctxt (Ex_ticket (comp_ty, x) :: acc) + | _ -> fail Unsupported_type_invariant_violated + + and tickets_of_list : + type a ret. + Alpha_context.context -> + include_lazy:bool -> + a Ticket_inspection.has_tickets -> + a Script_typed_ir.ty -> + a list -> + accumulator -> + ret continuation -> + ret tzresult Lwt.t = + fun ctxt ~include_lazy 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 + ctxt + el_hty + el_ty + elem + acc + (fun ctxt acc -> + (tickets_of_list [@ocaml.tailcall]) + ~include_lazy + ctxt + el_hty + el_ty + elems + acc + k) + | [] -> (k [@ocaml.tailcall]) ctxt acc + + and tickets_of_map : + type k v ret. + include_lazy:bool -> + Alpha_context.context -> + v Ticket_inspection.has_tickets -> + v 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 (module M) acc k -> + consume_gas_steps ctxt ~num_steps:1 >>?= fun ctxt -> + (* Pay gas for folding over the values *) + consume_gas_steps ctxt ~num_steps:M.size >>?= fun ctxt -> + let values = M.OPS.fold (fun _ v vs -> v :: vs) M.boxed [] in + (tickets_of_list [@ocaml.tailcall]) + ~include_lazy + ctxt + val_hty + val_ty + values + acc + k + + and tickets_of_big_map : + type k v ret. + Alpha_context.context -> + v Ticket_inspection.has_tickets -> + k Script_typed_ir.comparable_ty -> + (k, v) Script_typed_ir.big_map -> + accumulator -> + ret continuation -> + ret tzresult Lwt.t = + fun ctxt + val_hty + key_ty + {Script_typed_ir.id; diff = {map = _; size}; key_type = _; value_type} + acc + k -> + consume_gas_steps ctxt ~num_steps:1 >>?= fun ctxt -> + (* Require empty overlay *) + if Compare.Int.(size > 0) then fail Unsupported_non_empty_overlay + else + (* Traverse the keys for tickets, although currently keys should never + contain any tickets. *) + (tickets_of_comparable [@ocaml.tailcall]) ctxt key_ty acc (fun ctxt acc -> + (* Accumulate tickets from values of the big-map stored in the context *) + match id with + | Some id -> + let accum (values, ctxt) exp = + Script_ir_translator.parse_data + ~legacy:true + ctxt + ~allow_forged:true + value_type + (Micheline.root exp) + >|=? fun (v, ctxt) -> (v :: values, ctxt) + in + Big_map.list_values ctxt id >>=? fun (ctxt, exps) -> + List.fold_left_es accum ([], ctxt) exps >>=? fun (values, ctxt) -> + (tickets_of_list [@ocaml.tailcall]) + ~include_lazy:true + ctxt + val_hty + value_type + values + acc + k + | None -> (k [@ocaml.tailcall]) ctxt acc) + + let tickets_of_value ctxt ~include_lazy ty x = + Ticket_inspection.has_tickets_of_ty ctxt ty >>?= fun (ht, ctxt) -> + tickets_of_value ctxt ~include_lazy ht ty x [] (fun ctxt ex_tickets -> + return (ex_tickets, ctxt)) +end + +let tickets_of_value ctxt = Ticket_collection.tickets_of_value ctxt diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.mli b/src/proto_alpha/lib_protocol/ticket_scanner.mli new file mode 100644 index 000000000000..b5f859a89c4e --- /dev/null +++ b/src/proto_alpha/lib_protocol/ticket_scanner.mli @@ -0,0 +1,55 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Trili Tech, *) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** This module provides an API for extracting tickets of arbitrary types + from an OCaml values, given a type-witness. *) + +(** 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. + - A ticket value of the particular content type. + *) +type ex_ticket = + | Ex_ticket : + 'a Script_typed_ir.comparable_ty * 'a Script_typed_ir.ticket + -> ex_ticket + +(** [tickets_of_value ctxt ~include_lazy ty value] extracts all tickets from the + given shape [ty] and value [value]. The [include_lazy] flag determines whether + or not to traverse lazy structures (values from the context). + In case the [include_lazy] flag is [true], any big-map contained in the value + must have an empty overlay or else an error of type + [Unsupported_non_empty_overlay] is returned. The reason for this restriction + is that we assume that all lazy big-map diffs should be applied before + calling this function. Dealing with non-empty overlays would be possible + in theory, but practically difficult. The challenge is to distinguish + between overlapping keys between the context and the overlay. + *) +val tickets_of_value : + Alpha_context.context -> + include_lazy:bool -> + 'a Script_typed_ir.ty -> + 'a -> + (ex_ticket list * Alpha_context.context) tzresult Lwt.t -- GitLab From abc34ec6676007be88a76a1b5a6b3c391e81d6e7 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Fri, 22 Oct 2021 17:16:07 +0100 Subject: [PATCH 2/3] Test: Assert lists equal helper --- src/proto_alpha/lib_protocol/test/helpers/assert.ml | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/proto_alpha/lib_protocol/test/helpers/assert.ml b/src/proto_alpha/lib_protocol/test/helpers/assert.ml index 52fb6dd8d8c8..f54a7123c440 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/assert.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/assert.ml @@ -165,3 +165,12 @@ let balance_was_credited = balance_was_operated ~operand:Alpha_context.Tez.( +? ) let balance_was_debited = balance_was_operated ~operand:Alpha_context.Tez.( -? ) + +let pp_print_list pp out xs = + let list_pp fmt = + Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@.") fmt + in + Format.fprintf out "[%a]" (list_pp pp) xs + +let assert_equal_list ~loc eq msg pp = + equal ~loc (List.equal eq) msg (pp_print_list pp) -- GitLab From ee295187cec12e8349b05053f81f72e11fe4747f Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Fri, 22 Oct 2021 17:16:33 +0100 Subject: [PATCH 3/3] Test: Test ticket-scanner module --- src/proto_alpha/lib_protocol/test/main.ml | 1 + .../lib_protocol/test/test_ticket_scanner.ml | 593 ++++++++++++++++++ 2 files changed, 594 insertions(+) create mode 100644 src/proto_alpha/lib_protocol/test/test_ticket_scanner.ml diff --git a/src/proto_alpha/lib_protocol/test/main.ml b/src/proto_alpha/lib_protocol/test/main.ml index 4e78ce5d934d..8e9f187df668 100644 --- a/src/proto_alpha/lib_protocol/test/main.ml +++ b/src/proto_alpha/lib_protocol/test/main.ml @@ -70,6 +70,7 @@ let () = ("timelock", Test_timelock.tests); ("script typed ir size", Test_script_typed_ir_size.tests); ("ticket storage", Test_ticket_storage.tests); + ("ticket scanner", Test_ticket_scanner.tests); ("fitness", Test_fitness.tests); ("round", Test_round_repr.tests); ("participation monitoring", Test_participation.tests); diff --git a/src/proto_alpha/lib_protocol/test/test_ticket_scanner.ml b/src/proto_alpha/lib_protocol/test/test_ticket_scanner.ml new file mode 100644 index 000000000000..d83a71677195 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/test_ticket_scanner.ml @@ -0,0 +1,593 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Trili Tech, *) +(* *) +(* 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 (Ticket_scanner) + Invocation: dune exec src/proto_alpha/lib_protocol/test/main.exe -- test "^ticket scanner" + Subject: Ticket scanner tests +*) + +open Protocol +open Alpha_context + +let ( let* ) m f = m >>=? f + +let wrap m = m >|= Environment.wrap_tzresult + +let new_ctxt () = + let* (block, _) = Context.init 1 in + let* incr = Incremental.begin_construction block in + return @@ Incremental.alpha_ctxt incr + +let assert_equal_string_list ~loc msg = + Assert.assert_equal_list ~loc String.equal msg Format.pp_print_string + +let string_list_of_ex_tickets ctxt tickets = + let accum (xs, ctxt) + (Ticket_scanner.Ex_ticket + (cty, {Script_typed_ir.ticketer; contents; amount})) = + let* (x, ctxt) = + wrap + @@ Script_ir_translator.unparse_data + ctxt + Script_ir_translator.Readable + (Script_ir_translator.ty_of_comparable_ty cty) + contents + in + let content = + Format.kasprintf + Fun.id + "%a" + Michelson_v1_printer.print_expr + (Micheline.strip_locations x) + in + let str = + Format.kasprintf + Fun.id + "(%a, %s, %a)" + Contract.pp + ticketer + content + Z.pp_print + (Script_int.to_zint amount) + in + return (str :: xs, ctxt) + in + let* (xs, ctxt) = List.fold_left_es accum ([], ctxt) tickets in + return (List.rev xs, ctxt) + +let make_ex_ticket ctxt ~ticketer ~type_exp ~content_exp ~amount = + let* (Script_ir_translator.Ex_comparable_ty cty, ctxt) = + let node = Micheline.root @@ Expr.from_string type_exp in + wrap @@ Lwt.return @@ Script_ir_translator.parse_comparable_ty ctxt node + in + let* ticketer = wrap @@ Lwt.return @@ Contract.of_b58check ticketer in + let* (contents, ctxt) = + let node = Micheline.root @@ Expr.from_string content_exp in + wrap @@ Script_ir_translator.parse_comparable_data ctxt cty node + in + let amount = Script_int.(abs @@ of_int amount) in + let ticket = Script_typed_ir.{ticketer; contents; amount} in + return (Ticket_scanner.Ex_ticket (cty, ticket), ctxt) + +let assert_equals_ex_tickets ctxt ~loc ex_tickets expected = + let* (str_tickets, ctxt) = string_list_of_ex_tickets ctxt ex_tickets in + let* (str_tickets_expected, _ctxt) = + string_list_of_ex_tickets ctxt expected + in + assert_equal_string_list + ~loc + "Compare with expected tickets" + (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 (Script_ir_translator.Ex_ty ty, ctxt) = + let node = Micheline.root @@ Expr.from_string type_exp in + Result.value_f + ~default:(fun () -> Stdlib.failwith "Failed to parse") + (Script_ir_translator.parse_any_ty ctxt ~legacy:false node) + in + let node = Micheline.root @@ Expr.from_string value_exp in + let* (value, ctxt) = + wrap + @@ Script_ir_translator.parse_data + ctxt + ~legacy:false + ~allow_forged:true + ty + node + in + wrap @@ Ticket_scanner.tickets_of_value ctxt ~include_lazy ty value + +let assert_contains_tickets ctxt ~loc ~include_lazy ~type_exp ~value_exp + expected = + let* (ex_tickets, _) = + tickets_of_value ctxt ~include_lazy ~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 -> + match res with + | Error [x] -> + let x = Format.kasprintf Fun.id "%a" Error_monad.pp x in + Assert.equal + ~loc + String.equal + "" + Format.pp_print_string + "Unsupported big-map value with non-empty overlay" + x + | _ -> failwith "Expected an error at %s" loc + +let make_string_tickets ctxt ticketer_amounts = + List.fold_right_es + (fun (ticketer, content, amount) (tickets, ctxt) -> + let* (ticket, ctxt) = + make_ex_ticket + ctxt + ~ticketer + ~type_exp:"string" + ~content_exp:(Printf.sprintf {|"%s"|} content) + ~amount + in + return (ticket :: tickets, ctxt)) + ticketer_amounts + ([], ctxt) + +let tickets_from_big_map_ref ~pre_populated value_exp = + let* (block, contracts) = Context.init 1 in + let source = WithExceptions.Option.get ~loc:__LOC__ @@ List.hd contracts in + let* (operation, originated) = + Op.origination (B block) source ~script:Op.dummy_script + in + let* block = Block.bake ~operation block in + let* inc = Incremental.begin_construction block in + let ctxt = Incremental.alpha_ctxt inc in + let* (ctxt, big_map_id) = wrap @@ Big_map.fresh ~temporary:false ctxt in + let int_ty_expr = Expr.from_string "int" in + let* (diffs, ctxt) = + let* (updates, ctxt) = + List.fold_left_es + (fun (kvs, ctxt) (key, value) -> + let* (key_hash, ctxt) = + wrap + @@ Script_ir_translator.hash_comparable_data + ctxt + (Script_typed_ir.int_key ~annot:None) + (Script_int_repr.of_int key) + in + return + ( { + Big_map.key = Expr.from_string @@ string_of_int key; + key_hash; + value = Some (Expr.from_string value); + } + :: kvs, + ctxt )) + ([], ctxt) + pre_populated + in + let alloc = + Big_map. + {key_type = int_ty_expr; value_type = Expr.from_string "ticket string"} + in + return + ( [ + Lazy_storage.make + Lazy_storage.Kind.Big_map + big_map_id + (Update {init = Lazy_storage.Alloc alloc; updates}); + ], + ctxt ) + in + let* ctxt = + wrap + @@ Contract.update_script_storage ctxt originated int_ty_expr (Some diffs) + in + let value_exp = + value_exp @@ Z.to_string (Big_map.Id.unparse_to_z big_map_id) + in + return (value_exp, ctxt) + +let assert_big_map_int_ticket_string_ref ~loc ~pre_populated ~big_map_exp + ex_tickets = + let* (value_exp, ctxt) = + tickets_from_big_map_ref ~pre_populated big_map_exp + in + let* (ex_tickets, ctxt) = make_string_tickets ctxt ex_tickets in + assert_contains_tickets + ctxt + ~include_lazy:true + ~loc + ~type_exp:"big_map int (ticket string)" + ~value_exp + ex_tickets + +let assert_fail_non_empty_overlay_with_big_map_ref ~loc ~pre_populated + ~big_map_exp = + let* (value_exp, ctxt) = + tickets_from_big_map_ref ~pre_populated big_map_exp + in + assert_fail_non_empty_overlay + ctxt + ~include_lazy:true + ~loc + ~type_exp:"big_map int (ticket string)" + ~value_exp + +(** Test that the ticket can be extracted from a a single unit ticket *) +let test_tickets_in_unit_ticket () = + let* ctxt = new_ctxt () in + let type_exp = "ticket(unit)" in + let value_exp = {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" Unit 10|} in + let* (ex_ticket, ctxt) = + make_ex_ticket + ctxt + ~ticketer:"KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" + ~type_exp:"unit" + ~content_exp:"Unit" + ~amount:10 + in + assert_contains_tickets + ctxt + ~loc:__LOC__ + ~include_lazy:false + ~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 + ~loc:__LOC__ + ~include_lazy:false + ~type_exp:"list(ticket(string))" + ~value_exp: + {| + { + Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1; + Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2; + Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 3; + } + |} + ~expected: + [ + ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", 1); + ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "green", 2); + ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue", 3); + ] + +(** Test that all tickets can be extracted from a pair of tickets *) +let test_tickets_in_pair () = + assert_string_tickets + ~loc:__LOC__ + ~include_lazy:false + ~type_exp:"pair (ticket string) (ticket string)" + ~value_exp: + {| + Pair + (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1) + (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2) + |} + ~expected: + [ + ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", 1); + ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "green", 2); + ] + +(** Test that all tickets from a map can be extracted. *) +let test_tickets_in_map () = + assert_string_tickets + ~loc:__LOC__ + ~include_lazy:false + ~type_exp:"map int (ticket string)" + ~value_exp: + {| + { + Elt 1 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1); + Elt 2 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2); + } + |} + ~expected: + [ + ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", 1); + ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "green", 2); + ] + +(** Test that all tickets from a big-map with non-empty overlay fails. + If we extend the ticket scanner function to support non-empty overlays + this test needs to be adapted. + *) +let test_tickets_in_big_map () = + let* ctxt = new_ctxt () in + assert_fail_non_empty_overlay + ctxt + ~loc:__LOC__ + ~include_lazy:true + ~type_exp:"big_map int (ticket string)" + ~value_exp: + {| + { + Elt 1 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1); + Elt 2 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2); + } + |} + +(** Test that tickets are not extracted from big-map with [include_lazy] set + to false. *) +let test_tickets_in_big_map_strict_only () = + assert_string_tickets + ~loc:__LOC__ + ~include_lazy:false + ~type_exp:"big_map int (ticket string)" + ~value_exp: + {| + { + Elt 1 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1); + Elt 2 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 2); + } + |} + ~expected:[] + +(** Test that tickets can be extracted from a list of tickets inside a big-map + This fails due to non-empty overlay. If we extend the ticket scanner + function to support non-empty overlays this test needs to be adapted. +*) +let test_tickets_in_list_in_big_map () = + let* ctxt = new_ctxt () in + assert_fail_non_empty_overlay + ctxt + ~loc:__LOC__ + ~include_lazy:true + ~type_exp:"(big_map int (list(ticket string)))" + ~value_exp: + {| + { + Elt 1 { + Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1 ; + Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 1 + }; + Elt 2 { + Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 1 ; + Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "orange" 1 + } + } + |} + +(** Test that tickets can be extracted from a combination of a list and lazy structure + and that only the strict part is considered with [include_lazy] set to fasle *) +let test_tickets_in_pair_big_map_and_list_strict_only () = + assert_string_tickets + ~loc:__LOC__ + ~include_lazy:false + ~type_exp:"pair (big_map int (ticket string)) (list (ticket string))" + ~value_exp: + {| + Pair + { + Elt 1 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1); + Elt 2 (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 1) + } + { + Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 1; + Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "orange" 1 + } + |} + ~expected: + [ + ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue", 1); + ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "orange", 1); + ] + +(** Test that tickets can be extracted from the left side of an or-expression. *) +let test_tickets_in_or_left () = + assert_string_tickets + ~loc:__LOC__ + ~include_lazy:false + ~type_exp:"or (ticket string) int" + ~value_exp:{| Left (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1) |} + ~expected:[("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", 1)] + +(** Test that tickets can be extracted from the right side of an or-expression. *) +let test_tickets_in_or_right () = + assert_string_tickets + ~loc:__LOC__ + ~include_lazy:false + ~type_exp:"or int (ticket string)" + ~value_exp:{| Right (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1) |} + ~expected:[("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", 1)] + +(* + Big maps have three possible representations. Either as a list of key-value + pairs, as an identifier (int), or as a pair of identifier and overrides. + Example values: + + 1) { Elt "bar" True ; Elt "foo" False } + 2) 42 + 3) Pair 42 { Elt "foo" (Some False) } + *) + +(** Test tickets from empty big_map when passed by reference. *) +let test_tickets_in_empty_big_map_ref () = + assert_big_map_int_ticket_string_ref + ~loc:__LOC__ + ~pre_populated:[] + ~big_map_exp:(Printf.sprintf "%s") + [] + +(** Test tickets from non-empty big-map when passed by reference. + Here, tickets are scanned from the context. *) +let test_tickets_in_non_empty_big_map_ref () = + assert_big_map_int_ticket_string_ref + ~loc:__LOC__ + ~pre_populated: + [ + (1, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1|}); + (2, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 1|}); + (3, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 1|}); + ] + ~big_map_exp:(Printf.sprintf "%s") + [ + ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "red", 1); + ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "green", 1); + ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq", "blue", 1); + ] + +(** Test tickets from empty big-map when passed as a pair of identifier + and overrides. Here, the scanned tickets are only contained in the overlay + why ticket-scanning fails. + + If we extend the ticket scanner function to support non-empty overlays + this test needs to be adapted. + *) +let test_tickets_overlay_in_empty_big_map_ref () = + assert_fail_non_empty_overlay_with_big_map_ref + ~loc:__LOC__ + ~pre_populated:[] + ~big_map_exp: + (Printf.sprintf + {|Pair %s { Elt 1 (Some (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1))}|}) + +(** Test tickets from non-empty big-map when passed as a pair of identifier + and overrides. The scanned tickets are contained in the context as well as + in the overlay. Since overlay is non-empty is non-empty, ticket scanning + fails. + + If we extend the ticket scanner function to support non-empty overlays + this test needs to be adapted + *) +let test_tickets_overlay_in_non_empty_in_big_map_ref () = + assert_fail_non_empty_overlay_with_big_map_ref + ~loc:__LOC__ + ~pre_populated: + [ + (1, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1|}); + (2, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 1|}); + (3, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "blue" 1|}); + ] + ~big_map_exp: + (Printf.sprintf + {| Pair + %s + { Elt 4 (Some (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "orange" 1))} + |}) + +(** Test tickets from non-empty big-map when passed as a pair of identifier + and overrides, and where the override replaces an existing ticket. + Ticket scanning fails due to non-empty overlay. + + If we extend the ticket scanner function to support non-empty overlays + this test needs to be adapted. + *) +let test_tickets_replace_overlay_in_non_empty_in_big_map_ref () = + assert_fail_non_empty_overlay_with_big_map_ref + ~loc:__LOC__ + ~pre_populated: + [(1, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1|})] + ~big_map_exp: + (Printf.sprintf + {| Pair + %s + { Elt 1 (Some (Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "green" 1))} + |}) + +(** Test tickets from non-empty big-map when passed as a pair of identifier + and overrides, and where the override removes an existing ticket. + Ticket scanning fails due to non-empty overlay. + + If we extend the ticket scanner function to support non-empty overlays + this test needs to be adapted. + *) +let test_tickets_remove_overlay_in_non_empty_in_big_map_ref () = + assert_fail_non_empty_overlay_with_big_map_ref + ~loc:__LOC__ + ~pre_populated: + [(1, {|Pair "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" "red" 1|})] + ~big_map_exp:(Printf.sprintf {| Pair %s { Elt 1 None} |}) + +let tests = + [ + Tztest.tztest + "Test tickets in unit ticket" + `Quick + test_tickets_in_unit_ticket; + Tztest.tztest "Test tickets in list" `Quick test_tickets_in_list; + Tztest.tztest "Test tickets in pair" `Quick test_tickets_in_pair; + Tztest.tztest "Test tickets in map" `Quick test_tickets_in_map; + Tztest.tztest "Test tickets in big map" `Quick test_tickets_in_big_map; + Tztest.tztest + "Test tickets in big map with include lazy set to false" + `Quick + test_tickets_in_big_map_strict_only; + Tztest.tztest + "Test tickets in list in big map" + `Quick + test_tickets_in_list_in_big_map; + Tztest.tztest + "Test tickets in a pair of big-map and list with include lazy set to \ + false" + `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 right" `Quick test_tickets_in_or_right; + Tztest.tztest + "Test tickets in empty big-map ref" + `Quick + test_tickets_overlay_in_empty_big_map_ref; + Tztest.tztest + "Test tickets in big-map ref" + `Quick + test_tickets_in_empty_big_map_ref; + Tztest.tztest + "Test tickets in non-empty big-map ref" + `Quick + test_tickets_in_non_empty_big_map_ref; + Tztest.tztest + "Test tickets in non-empty big-map ref with overlay" + `Quick + test_tickets_overlay_in_non_empty_in_big_map_ref; + Tztest.tztest + "Test tickets replace existing value from overlay" + `Quick + test_tickets_replace_overlay_in_non_empty_in_big_map_ref; + Tztest.tztest + "Test tickets remove existing value from overlay" + `Quick + test_tickets_remove_overlay_in_non_empty_in_big_map_ref; + ] -- GitLab