diff --git a/docs/protocols/alpha.rst b/docs/protocols/alpha.rst index 9fc5d41f1bae90577a16c90b692f32678557cabb..a5d3140961319408fb432e461ce4ddd88c1806d1 100644 --- a/docs/protocols/alpha.rst +++ b/docs/protocols/alpha.rst @@ -30,6 +30,10 @@ It requires protocol environment V7, compared to V6 for Kathmandu. - Introduce an Array module, making a subset of Stdlib.Array available to the protocol (MR :gl:`!6042`) +- Introduce an Q module, making a subset of Zarith.Q available to the + protocol (MR :gl:`!6042`) + + Smart Contract Optimistic Rollups (ongoing) ------------------------------------------- @@ -116,6 +120,14 @@ Minor Changes (Proposals and Ballot), and move them to ``Validate_errors``. (MR :gl:`!5828`) +- Replace `acceptable_passes` by `acceptable_pass` that returns an + optional integer instead of a list of at most one element. (MR + :gl:`!6092`) + +- Removed `relative_position_within_block`. (MR :gl:`!6092`) + +- New function `compare_operations` which defines a total ordering + relation. (MR :gl:`!6092`) Internal -------- diff --git a/src/bin_client/test/proto_test_injection/main.ml b/src/bin_client/test/proto_test_injection/main.ml index 678788ba69ca8a31b230c5d00c9e241ebe95fd0d..e856e9ce8842232caabdf4399027efd32ee2f38f 100644 --- a/src/bin_client/test/proto_test_injection/main.ml +++ b/src/bin_client/test/proto_test_injection/main.ml @@ -62,9 +62,9 @@ let max_operation_data_length = 42 let validation_passes = [] -let acceptable_passes _op = [] +let compare_operations _ _ = 0 -let relative_position_within_block _ _ = 0 +let acceptable_pass _ = Some 0 type validation_state = {context : Context.t; fitness : Int64.t} diff --git a/src/lib_protocol_environment/environment_V0.ml b/src/lib_protocol_environment/environment_V0.ml index 17d0152a5438663686d1170c624c914a621c08e1..dc576b5930b1a956d5f8e9025ff8da4325d65148 100644 --- a/src/lib_protocol_environment/environment_V0.ml +++ b/src/lib_protocol_environment/environment_V0.ml @@ -823,7 +823,7 @@ struct end module Lift (P : Updater.PROTOCOL) = struct - include IgnoreCaches (Environment_protocol_T.V0toV6 (LiftV0 (P))) + include IgnoreCaches (Environment_protocol_T.V0toV7 (LiftV0 (P))) let set_log_message_consumer _ = () diff --git a/src/lib_protocol_environment/environment_V1.ml b/src/lib_protocol_environment/environment_V1.ml index 1be710e6eed3d17b7ad56e2590edad3045cbd7c5..085d0ede03c0953133daadcc91ed16eb69c46ce6 100644 --- a/src/lib_protocol_environment/environment_V1.ml +++ b/src/lib_protocol_environment/environment_V1.ml @@ -1024,7 +1024,7 @@ struct end module Lift (P : Updater.PROTOCOL) = struct - include IgnoreCaches (Environment_protocol_T.V0toV6 (LiftV1 (P))) + include IgnoreCaches (Environment_protocol_T.V0toV7 (LiftV1 (P))) let set_log_message_consumer _ = () diff --git a/src/lib_protocol_environment/environment_V2.ml b/src/lib_protocol_environment/environment_V2.ml index e4f8073db4545b55cf1e7fd8a6db06362fc8b23b..7eed8d436ae4794df5df3ee54c42497f783ca062 100644 --- a/src/lib_protocol_environment/environment_V2.ml +++ b/src/lib_protocol_environment/environment_V2.ml @@ -1019,7 +1019,7 @@ struct end module Lift (P : Updater.PROTOCOL) = struct - include IgnoreCaches (Environment_protocol_T.V0toV6 (LiftV2 (P))) + include IgnoreCaches (Environment_protocol_T.V0toV7 (LiftV2 (P))) let set_log_message_consumer _ = () diff --git a/src/lib_protocol_environment/environment_V3.ml b/src/lib_protocol_environment/environment_V3.ml index 892fd72546b681448d95cf91bb9b828f0d05c316..74ac6ececda1fe5229f6ff9776b9243261f71a72 100644 --- a/src/lib_protocol_environment/environment_V3.ml +++ b/src/lib_protocol_environment/environment_V3.ml @@ -1238,6 +1238,12 @@ struct wrap_tzresult r let set_log_message_consumer f = Logging.logging_function := Some f + + let compare_operations (_, op) (_, op') = + relative_position_within_block op op' + + let acceptable_pass op = + match acceptable_passes op with [n] -> Some n | _ -> None end class ['chain, 'block] proto_rpc_context (t : Tezos_rpc.RPC_context.t) diff --git a/src/lib_protocol_environment/environment_V4.ml b/src/lib_protocol_environment/environment_V4.ml index 9c8d0e2cb9a91abae7a5f1b6789a44f029334b8d..90cb9a248958ea82444ecb74927014d96afd4012 100644 --- a/src/lib_protocol_environment/environment_V4.ml +++ b/src/lib_protocol_environment/environment_V4.ml @@ -1255,6 +1255,12 @@ struct wrap_tzresult r let set_log_message_consumer f = Logging.logging_function := Some f + + let compare_operations (_, op) (_, op') = + relative_position_within_block op op' + + let acceptable_pass op = + match acceptable_passes op with [n] -> Some n | _ -> None end class ['chain, 'block] proto_rpc_context (t : Tezos_rpc.RPC_context.t) diff --git a/src/lib_protocol_environment/environment_V5.ml b/src/lib_protocol_environment/environment_V5.ml index f412112ca93f8eae94798491cdab1355004e58c1..371ca9d9762707bd2bf45cb41d6f27451fe8a2f2 100644 --- a/src/lib_protocol_environment/environment_V5.ml +++ b/src/lib_protocol_environment/environment_V5.ml @@ -1232,6 +1232,12 @@ struct wrap_tzresult r let set_log_message_consumer f = Logging.logging_function := Some f + + let compare_operations (_, op) (_, op') = + relative_position_within_block op op' + + let acceptable_pass op = + match acceptable_passes op with [n] -> Some n | _ -> None end class ['chain, 'block] proto_rpc_context (t : Tezos_rpc.RPC_context.t) diff --git a/src/lib_protocol_environment/environment_V6.ml b/src/lib_protocol_environment/environment_V6.ml index 271e3d5bcf6316daa40698217c5cb58690176fe5..4fd7eaab2e4770d2fdd9c182861a8cbde532e044 100644 --- a/src/lib_protocol_environment/environment_V6.ml +++ b/src/lib_protocol_environment/environment_V6.ml @@ -1323,6 +1323,12 @@ struct wrap_tzresult r let set_log_message_consumer f = Logging.logging_function := Some f + + let compare_operations (_, op) (_, op') = + relative_position_within_block op op' + + let acceptable_pass op = + match acceptable_passes op with [n] -> Some n | _ -> None end class ['chain, 'block] proto_rpc_context (t : Tezos_rpc.RPC_context.t) diff --git a/src/lib_protocol_environment/environment_V7.ml b/src/lib_protocol_environment/environment_V7.ml index f3285c370d788444940487a8b4961b9b77f32649..b014ffa624f60b91512201f870b9a820d201a7ca 100644 --- a/src/lib_protocol_environment/environment_V7.ml +++ b/src/lib_protocol_environment/environment_V7.ml @@ -84,6 +84,7 @@ module type T = sig and type Micheline.canonical_location = Micheline.canonical_location and type 'a Micheline.canonical = 'a Micheline.canonical and type Z.t = Z.t + and type Q.t = Q.t and type ('a, 'b) Micheline.node = ('a, 'b) Micheline.node and type Data_encoding.json_schema = Data_encoding.json_schema and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t @@ -250,6 +251,7 @@ struct end module Z = Z + module Q = Q module Lwt = Lwt module Data_encoding = struct @@ -1067,7 +1069,7 @@ struct let activate = Context.set_protocol module type PROTOCOL = - Environment_protocol_T_V6.T + Environment_protocol_T_V7.T with type context := Context.t and type cache_value := Environment_context.Context.cache_value and type cache_key := Environment_context.Context.cache_key diff --git a/src/lib_protocol_environment/environment_V7.mli b/src/lib_protocol_environment/environment_V7.mli index c4d676636cbfbcec66637aff8ff4253cf042f073..0a32edac794ef0aec4e08cad7f57ab18b446826b 100644 --- a/src/lib_protocol_environment/environment_V7.mli +++ b/src/lib_protocol_environment/environment_V7.mli @@ -84,6 +84,7 @@ module type T = sig and type Micheline.canonical_location = Micheline.canonical_location and type 'a Micheline.canonical = 'a Micheline.canonical and type Z.t = Z.t + and type Q.t = Q.t and type ('a, 'b) Micheline.node = ('a, 'b) Micheline.node and type Data_encoding.json_schema = Data_encoding.json_schema and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t diff --git a/src/lib_protocol_environment/environment_protocol_T.ml b/src/lib_protocol_environment/environment_protocol_T.ml index 2a40362037e7901c89b424b0643ce95479164acf..7b92a18ebc658ff621a02287f0140087b86ab526 100644 --- a/src/lib_protocol_environment/environment_protocol_T.ml +++ b/src/lib_protocol_environment/environment_protocol_T.ml @@ -49,18 +49,18 @@ open Environment_context environment ([module type Vx_T]). If you want to mock this module type, see {!Environment_protocol_T_test}. *) -module type T = Environment_protocol_T_V6.T +module type T = Environment_protocol_T_V7.T (* Documentation for this interface may be found in module type [PROTOCOL] of [sigs/v6/updater.mli]. *) -module V0toV6 +module V0toV7 (E : Environment_protocol_T_V0.T with type context := Context.t and type quota := quota and type validation_result := validation_result and type rpc_context := rpc_context and type 'a tzresult := 'a Error_monad.tzresult) : - Environment_protocol_T_V6.T + Environment_protocol_T_V7.T with type context := Context.t and type quota := quota and type validation_result := validation_result @@ -79,8 +79,10 @@ module V0toV6 let finalize_block vs _ = E.finalize_block vs - (* Add backwards compatibility shadowing here *) - let relative_position_within_block = compare_operations + let compare_operations (_, op) (_, op') = compare_operations op op' + + let acceptable_pass op = + match acceptable_passes op with [n] -> Some n | _ -> None let value_of_key ~chain_id:_ ~predecessor_context:_ ~predecessor_timestamp:_ ~predecessor_level:_ ~predecessor_fitness:_ ~predecessor:_ ~timestamp:_ = diff --git a/src/lib_protocol_environment/environment_protocol_T_V7.ml b/src/lib_protocol_environment/environment_protocol_T_V7.ml new file mode 100644 index 0000000000000000000000000000000000000000..95c488248ba87e0b74e50cff74d37093fe7d5cc0 --- /dev/null +++ b/src/lib_protocol_environment/environment_protocol_T_V7.ml @@ -0,0 +1,142 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2018 Nomadic Labs. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(* Documentation for this interface can be found in + module type [PROTOCOL] of [sigs/v3/updater.mli]. *) + +module type T = sig + type context + + type quota + + type validation_result + + type rpc_context + + type 'a tzresult + + val max_block_length : int + + val max_operation_data_length : int + + val validation_passes : quota list + + type block_header_data + + val block_header_data_encoding : block_header_data Data_encoding.t + + type block_header = { + shell : Block_header.shell_header; + protocol_data : block_header_data; + } + + type block_header_metadata + + val block_header_metadata_encoding : block_header_metadata Data_encoding.t + + type operation_data + + type operation_receipt + + type operation = { + shell : Operation.shell_header; + protocol_data : operation_data; + } + + val operation_data_encoding : operation_data Data_encoding.t + + val operation_receipt_encoding : operation_receipt Data_encoding.t + + val operation_data_and_receipt_encoding : + (operation_data * operation_receipt) Data_encoding.t + + val acceptable_pass : operation -> int option + + val compare_operations : + Operation_hash.t * operation -> Operation_hash.t * operation -> int + + type validation_state + + val begin_partial_application : + chain_id:Chain_id.t -> + ancestor_context:context -> + predecessor_timestamp:Time.Protocol.t -> + predecessor_fitness:Fitness.t -> + block_header -> + validation_state tzresult Lwt.t + + val begin_application : + chain_id:Chain_id.t -> + predecessor_context:context -> + predecessor_timestamp:Time.Protocol.t -> + predecessor_fitness:Fitness.t -> + block_header -> + validation_state tzresult Lwt.t + + val begin_construction : + chain_id:Chain_id.t -> + predecessor_context:context -> + predecessor_timestamp:Time.Protocol.t -> + predecessor_level:Int32.t -> + predecessor_fitness:Fitness.t -> + predecessor:Block_hash.t -> + timestamp:Time.Protocol.t -> + ?protocol_data:block_header_data -> + unit -> + validation_state tzresult Lwt.t + + val apply_operation : + validation_state -> + operation -> + (validation_state * operation_receipt) tzresult Lwt.t + + val finalize_block : + validation_state -> + Block_header.shell_header option -> + (validation_result * block_header_metadata) tzresult Lwt.t + + val rpc_services : rpc_context RPC_directory.t + + val init : + Chain_id.t -> + context -> + Block_header.shell_header -> + validation_result tzresult Lwt.t + + type cache_value + + type cache_key + + val value_of_key : + chain_id:Chain_id.t -> + predecessor_context:context -> + predecessor_timestamp:Time.Protocol.t -> + predecessor_level:Int32.t -> + predecessor_fitness:Fitness.t -> + predecessor:Block_hash.t -> + timestamp:Time.Protocol.t -> + (cache_key -> cache_value tzresult Lwt.t) tzresult Lwt.t +end diff --git a/src/lib_protocol_environment/environment_protocol_T_test.ml b/src/lib_protocol_environment/environment_protocol_T_test.ml index 750b6b8978fece37300722bd99e8abb79c72f085..fb7206ebcd01f765fcb53df16ba1b1f50ab05893 100644 --- a/src/lib_protocol_environment/environment_protocol_T_test.ml +++ b/src/lib_protocol_environment/environment_protocol_T_test.ml @@ -76,9 +76,9 @@ module Mock_all_unit : ~predecessor_hash:_ ~cache:_ _ = assert false - let relative_position_within_block _ = assert false + let compare_operations _ = assert false - let acceptable_passes _ = assert false + let acceptable_pass _ = assert false let operation_data_and_receipt_encoding = Data_encoding.conv (Fun.const ()) (Fun.const ((), ())) Data_encoding.unit diff --git a/src/lib_protocol_environment/sigs/v7.in.ml b/src/lib_protocol_environment/sigs/v7.in.ml index 639529d9ae72d2138750cdc536f588851a591f17..0b091a3b9cefc93cdae48f08153dda54db3e79e1 100644 --- a/src/lib_protocol_environment/sigs/v7.in.ml +++ b/src/lib_protocol_environment/sigs/v7.in.ml @@ -27,6 +27,8 @@ module type T = sig module Z : [%sig "v7/z.mli"] + module Q : [%sig "v7/q.mli"] + module Lwt : [%sig "v7/lwt.mli"] module Data_encoding : [%sig "v7/data_encoding.mli"] diff --git a/src/lib_protocol_environment/sigs/v7.ml b/src/lib_protocol_environment/sigs/v7.ml index 4d6725b31caae89c5512c76c56047fb1d7b01799..38e596ae410775a8ca87eddd56d3bf213a287c51 100644 --- a/src/lib_protocol_environment/sigs/v7.ml +++ b/src/lib_protocol_environment/sigs/v7.ml @@ -2834,6 +2834,278 @@ end # 28 "v7.in.ml" + module Q : sig +# 1 "v7/q.mli" +(** + Rationals. + + This modules builds arbitrary precision rationals on top of arbitrary + integers from module Z. + + + This file is part of the Zarith library + http://forge.ocamlcore.org/projects/zarith . + It is distributed under LGPL 2 licensing, with static linking exception. + See the LICENSE file included in the distribution. + + Copyright (c) 2010-2011 Antoine Miné, Abstraction project. + Abstraction is part of the LIENS (Laboratoire d'Informatique de l'ENS), + a joint laboratory by: + CNRS (Centre national de la recherche scientifique, France), + ENS (École normale supérieure, Paris, France), + INRIA Rocquencourt (Institut national de recherche en informatique, France). + + *) + +(** {1 Types} *) + +type t = { + num: Z.t; (** Numerator. *) + den: Z.t; (** Denominator, >= 0 *) + } +(** A rational is represented as a pair numerator/denominator, reduced to + have a non-negative denominator and no common factor. + This form is canonical (enabling polymorphic equality and hashing). + The representation allows three special numbers: [inf] (1/0), [-inf] (-1/0) + and [undef] (0/0). + *) + +(** {1 Construction} *) + +val make: Z.t -> Z.t -> t +(** [make num den] constructs a new rational equal to [num]/[den]. + It takes care of putting the rational in canonical form. + *) + +val zero: t +val one: t +val minus_one:t +(** 0, 1, -1. *) + +val inf: t +(** 1/0. *) + +val minus_inf: t +(** -1/0. *) + +val undef: t +(** 0/0. *) + +val of_bigint: Z.t -> t +val of_int: int -> t +val of_int32: int32 -> t +val of_int64: int64 -> t +(** Conversions from various integer types. *) + +val of_ints: int -> int -> t +(** Conversion from an [int] numerator and an [int] denominator. *) + + + +val of_string: string -> t +(** Converts a string to a rational. Plain integers, [/] separated + integer ratios (with optional sign), decimal point and scientific + notations are understood. + Additionally, the special [inf], [-inf], and [undef] are + recognized (they can also be typeset respectively as [1/0], [-1/0], + [0/0]). *) + + +(** {1 Inspection} *) + +val num: t -> Z.t +(** Get the numerator. *) + +val den: t -> Z.t +(** Get the denominator. *) + + +(** {1 Testing} *) + +type kind = + | ZERO (** 0 *) + | INF (** infinity, i.e. 1/0 *) + | MINF (** minus infinity, i.e. -1/0 *) + | UNDEF (** undefined, i.e., 0/0 *) + | NZERO (** well-defined, non-infinity, non-zero number *) +(** Rationals can be categorized into different kinds, depending mainly on + whether the numerator and/or denominator is null. + *) + +val classify: t -> kind +(** Determines the kind of a rational. *) + +val is_real: t -> bool +(** Whether the argument is non-infinity and non-undefined. *) + +val sign: t -> int +(** Returns 1 if the argument is positive (including inf), -1 if it is + negative (including -inf), and 0 if it is null or undefined. + *) + +val compare: t -> t -> int +(** [compare x y] compares [x] to [y] and returns 1 if [x] is strictly + greater that [y], -1 if it is strictly smaller, and 0 if they are + equal. + This is a total ordering. + Infinities are ordered in the natural way, while undefined is considered + the smallest of all: undef = undef < -inf <= -inf < x < inf <= inf. + This is consistent with OCaml's handling of floating-point infinities + and NaN. + + OCaml's polymorphic comparison will NOT return a result consistent with + the ordering of rationals. + *) + +val equal: t -> t -> bool +(** Equality testing. + Unlike [compare], this follows IEEE semantics: [undef] <> [undef]. + *) + +val min: t -> t -> t +(** Returns the smallest of its arguments. *) + +val max: t -> t -> t +(** Returns the largest of its arguments. *) + +val leq: t -> t -> bool +(** Less than or equal. [leq undef undef] resturns false. *) + +val geq: t -> t -> bool +(** Greater than or equal. [leq undef undef] resturns false. *) + +val lt: t -> t -> bool +(** Less than (not equal). *) + +val gt: t -> t -> bool +(** Greater than (not equal). *) + + +(** {1 Conversions} *) + +val to_bigint: t -> Z.t +val to_int: t -> int +val to_int32: t -> int32 +val to_int64: t -> int64 +(** Convert to integer by truncation. + Raises a [Divide_by_zero] if the argument is an infinity or undefined. + Raises a [Z.Overflow] if the result does not fit in the destination + type. +*) + +val to_string: t -> string +(** Converts to human-readable, base-10, [/]-separated rational. *) + +(** {1 Arithmetic operations} *) + +(** + In all operations, the result is [undef] if one argument is [undef]. + Other operations can return [undef]: such as [inf]-[inf], [inf]*0, 0/0. + *) + +val neg: t -> t +(** Negation. *) + +val abs: t -> t +(** Absolute value. *) + +val add: t -> t -> t +(** Addition. *) + +val sub: t -> t -> t +(** Subtraction. We have [sub x y] = [add x (neg y)]. *) + +val mul: t -> t -> t +(** Multiplication. *) + +val inv: t -> t +(** Inverse. + Note that [inv 0] is defined, and equals [inf]. + *) + +val div: t -> t -> t +(** Division. + We have [div x y] = [mul x (inv y)], and [inv x] = [div one x]. + *) + +val mul_2exp: t -> int -> t +(** [mul_2exp x n] multiplies [x] by 2 to the power of [n]. *) + +val div_2exp: t -> int -> t +(** [div_2exp x n] divides [x] by 2 to the power of [n]. *) + + +(** {1 Printing} *) + +val pp_print: Format.formatter -> t -> unit +(** Prints the argument on the specified formatter. + Also intended to be used as [%a] format printer in [Format.printf]. + *) + + +(** {1 Prefix and infix operators} *) + +(** + Classic prefix and infix [int] operators are redefined on [t]. +*) + +val (~-): t -> t +(** Negation [neg]. *) + +val (~+): t -> t +(** Identity. *) + +val (+): t -> t -> t +(** Addition [add]. *) + +val (-): t -> t -> t +(** Subtraction [sub]. *) + +val ( * ): t -> t -> t +(** Multiplication [mul]. *) + +val (/): t -> t -> t +(** Division [div]. *) + +val (lsl): t -> int -> t +(** Multiplication by a power of two [mul_2exp]. *) + +val (asr): t -> int -> t +(** Division by a power of two [shift_right]. *) + +val (~$): int -> t +(** Conversion from [int]. *) + +val (//): int -> int -> t +(** Creates a rational from two [int]s. *) + +val (~$$): Z.t -> t +(** Conversion from [Z.t]. *) + +val (///): Z.t -> Z.t -> t +(** Creates a rational from two [Z.t]. *) + +val (=): t -> t -> bool +(** Same as [equal]. *) + +val (<): t -> t -> bool +(** Same as [lt]. *) + +val (>): t -> t -> bool +(** Same as [gt]. *) + +val (<=): t -> t -> bool +(** Same as [leq]. *) + +val (>=): t -> t -> bool +(** Same as [geq]. *) + +val (<>): t -> t -> bool +(** [a <> b] is equivalent to [not (equal a b)]. *) +end +# 30 "v7.in.ml" + + module Lwt : sig # 1 "v7/lwt.mli" (* This file is part of Lwt, released under the MIT license. See LICENSE.md for @@ -3143,7 +3415,7 @@ val return_error : 'e -> ((_, 'e) result) t @since Lwt 2.6.0 *) end -# 30 "v7.in.ml" +# 32 "v7.in.ml" module Data_encoding : sig @@ -4620,7 +4892,7 @@ module Binary : sig val to_string_exn : ?buffer_size:int -> 'a encoding -> 'a -> string end end -# 32 "v7.in.ml" +# 34 "v7.in.ml" module Raw_hashes : sig @@ -4662,7 +4934,7 @@ val sha3_256 : bytes -> bytes val sha3_512 : bytes -> bytes end -# 34 "v7.in.ml" +# 36 "v7.in.ml" module Compare : sig @@ -4805,6 +5077,9 @@ module Bytes : S with type t = bytes (** [Z] is a comparison module for Zarith numbers. *) module Z : S with type t = Z.t +(** [Q] is a comparison module for Zarith rationals. *) +module Q : S with type t = Q.t + (** {2 Type constructors} Provided the functor argument(s) are compatible with the polymorphic @@ -4940,7 +5215,7 @@ let compare (foo_a, bar_a) (foo_b, bar_b) = *) val or_else : int -> (unit -> int) -> int end -# 36 "v7.in.ml" +# 38 "v7.in.ml" module Time : sig @@ -4994,7 +5269,7 @@ val rfc_encoding : t Data_encoding.t val pp_hum : Format.formatter -> t -> unit end -# 38 "v7.in.ml" +# 40 "v7.in.ml" module TzEndian : sig @@ -5060,7 +5335,7 @@ val get_uint16_string : string -> int -> int val set_uint16 : bytes -> int -> int -> unit end -# 40 "v7.in.ml" +# 42 "v7.in.ml" module Bits : sig @@ -5097,7 +5372,7 @@ end The behaviour is unspecified if [x < 0].*) val numbits : int -> int end -# 42 "v7.in.ml" +# 44 "v7.in.ml" module Equality_witness : sig @@ -5165,7 +5440,7 @@ val eq : 'a t -> 'b t -> ('a, 'b) eq option (** [hash id] returns a hash for [id]. *) val hash : 'a t -> int end -# 44 "v7.in.ml" +# 46 "v7.in.ml" module FallbackArray : sig @@ -5255,7 +5530,7 @@ val fold : ('b -> 'a -> 'b) -> 'a t -> 'b -> 'b filled. *) val fold_map : ('b -> 'a -> 'b * 'c) -> 'a t -> 'b -> 'c -> 'b * 'c t end -# 46 "v7.in.ml" +# 48 "v7.in.ml" module Error_monad : sig @@ -5737,7 +6012,7 @@ module Lwt_tzresult_syntax : sig ('a * 'b, 'error trace) result Lwt.t end end -# 48 "v7.in.ml" +# 50 "v7.in.ml" open Error_monad @@ -5864,7 +6139,7 @@ val iter_ep : them is. *) val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t end -# 52 "v7.in.ml" +# 54 "v7.in.ml" module List : sig @@ -7196,7 +7471,7 @@ val exists_ep : 'a list -> (bool, 'error Error_monad.trace) result Lwt.t end -# 54 "v7.in.ml" +# 56 "v7.in.ml" module Array : sig @@ -7306,7 +7581,7 @@ val fast_sort : [`You_cannot_sort_arrays_in_the_protocol] module Floatarray : sig end end -# 56 "v7.in.ml" +# 58 "v7.in.ml" module Set : sig @@ -7455,7 +7730,7 @@ end module Make (Ord : Compare.COMPARABLE) : S with type elt = Ord.t end -# 58 "v7.in.ml" +# 60 "v7.in.ml" module Map : sig @@ -7624,7 +7899,7 @@ end module Make (Ord : Compare.COMPARABLE) : S with type key = Ord.t end -# 60 "v7.in.ml" +# 62 "v7.in.ml" module Option : sig @@ -7772,7 +8047,7 @@ val catch : ?catch_only:(exn -> bool) -> (unit -> 'a) -> 'a option val catch_s : ?catch_only:(exn -> bool) -> (unit -> 'a Lwt.t) -> 'a option Lwt.t end -# 62 "v7.in.ml" +# 64 "v7.in.ml" module Result : sig @@ -7938,7 +8213,7 @@ val catch_f : val catch_s : ?catch_only:(exn -> bool) -> (unit -> 'a Lwt.t) -> ('a, exn) result Lwt.t end -# 64 "v7.in.ml" +# 66 "v7.in.ml" module RPC_arg : sig @@ -8008,7 +8283,7 @@ type ('a, 'b) eq = Eq : ('a, 'a) eq val eq : 'a arg -> 'b arg -> ('a, 'b) eq option end -# 66 "v7.in.ml" +# 68 "v7.in.ml" module RPC_path : sig @@ -8064,7 +8339,7 @@ val add_final_args : val ( /:* ) : ('prefix, 'params) path -> 'a RPC_arg.t -> ('prefix, 'params * 'a list) path end -# 68 "v7.in.ml" +# 70 "v7.in.ml" module RPC_query : sig @@ -8136,7 +8411,7 @@ exception Invalid of string val parse : 'a query -> untyped -> 'a end -# 70 "v7.in.ml" +# 72 "v7.in.ml" module RPC_service : sig @@ -8213,7 +8488,7 @@ val put_service : ('prefix, 'params) RPC_path.t -> ([`PUT], 'prefix, 'params, 'query, 'input, 'output) service end -# 72 "v7.in.ml" +# 74 "v7.in.ml" module RPC_answer : sig @@ -8274,7 +8549,7 @@ val not_found : 'o t Lwt.t val fail : error list -> 'a t Lwt.t end -# 74 "v7.in.ml" +# 76 "v7.in.ml" module RPC_directory : sig @@ -8539,7 +8814,7 @@ val register_dynamic_directory : ('a -> 'a directory Lwt.t) -> 'prefix directory end -# 76 "v7.in.ml" +# 78 "v7.in.ml" module Base58 : sig @@ -8604,7 +8879,7 @@ val check_encoded_prefix : 'a encoding -> string -> int -> unit not start with a registered prefix. *) val decode : string -> data option end -# 78 "v7.in.ml" +# 80 "v7.in.ml" module S : sig @@ -9022,7 +9297,7 @@ module type PVSS = sig val reconstruct : Clear_share.t list -> int list -> Public_key.t end end -# 80 "v7.in.ml" +# 82 "v7.in.ml" module Blake2B : sig @@ -9087,7 +9362,7 @@ end module Make (Register : Register) (Name : PrefixedName) : S.HASH end -# 82 "v7.in.ml" +# 84 "v7.in.ml" module Bls12_381 : sig @@ -9125,7 +9400,7 @@ module G2 : S.CURVE with type Scalar.t = Fr.t val pairing_check : (G1.t * G2.t) list -> bool end -# 84 "v7.in.ml" +# 86 "v7.in.ml" module Bls_signature : sig @@ -9221,7 +9496,7 @@ val verify : pk -> Bytes.t -> signature -> bool val aggregate_verify : (pk * Bytes.t) list -> signature -> bool end -# 86 "v7.in.ml" +# 88 "v7.in.ml" module Ed25519 : sig @@ -9255,7 +9530,7 @@ end include S.SIGNATURE with type watermark := bytes end -# 88 "v7.in.ml" +# 90 "v7.in.ml" module Secp256k1 : sig @@ -9289,7 +9564,7 @@ end include S.SIGNATURE with type watermark := bytes end -# 90 "v7.in.ml" +# 92 "v7.in.ml" module P256 : sig @@ -9323,7 +9598,7 @@ end include S.SIGNATURE with type watermark := bytes end -# 92 "v7.in.ml" +# 94 "v7.in.ml" module Chain_id : sig @@ -9355,7 +9630,7 @@ end include S.HASH end -# 94 "v7.in.ml" +# 96 "v7.in.ml" module Signature : sig @@ -9407,7 +9682,7 @@ include and type Public_key.t = public_key and type watermark := watermark end -# 96 "v7.in.ml" +# 98 "v7.in.ml" module Block_hash : sig @@ -9440,7 +9715,7 @@ end (** Blocks hashes / IDs. *) include S.HASH end -# 98 "v7.in.ml" +# 100 "v7.in.ml" module Operation_hash : sig @@ -9473,7 +9748,7 @@ end (** Operations hashes / IDs. *) include S.HASH end -# 100 "v7.in.ml" +# 102 "v7.in.ml" module Operation_list_hash : sig @@ -9506,7 +9781,7 @@ end (** Blocks hashes / IDs. *) include S.MERKLE_TREE with type elt = Operation_hash.t end -# 102 "v7.in.ml" +# 104 "v7.in.ml" module Operation_list_list_hash : sig @@ -9539,7 +9814,7 @@ end (** Blocks hashes / IDs. *) include S.MERKLE_TREE with type elt = Operation_list_hash.t end -# 104 "v7.in.ml" +# 106 "v7.in.ml" module Protocol_hash : sig @@ -9572,7 +9847,7 @@ end (** Protocol hashes / IDs. *) include S.HASH end -# 106 "v7.in.ml" +# 108 "v7.in.ml" module Context_hash : sig @@ -9625,7 +9900,7 @@ end type version = Version.t end -# 108 "v7.in.ml" +# 110 "v7.in.ml" module Pvss_secp256k1 : sig @@ -9659,7 +9934,7 @@ end include S.PVSS end -# 110 "v7.in.ml" +# 112 "v7.in.ml" module Sapling : sig @@ -9807,7 +10082,7 @@ module Verification : sig val final_check : t -> UTXO.transaction -> string -> bool end end -# 112 "v7.in.ml" +# 114 "v7.in.ml" module Timelock : sig @@ -9866,7 +10141,7 @@ val open_chest : chest -> chest_key -> time:int -> opening_result Used for gas accounting*) val get_plaintext_size : chest -> int end -# 114 "v7.in.ml" +# 116 "v7.in.ml" module Vdf : sig @@ -9954,7 +10229,7 @@ val prove : discriminant -> challenge -> difficulty -> result * proof @raise Invalid_argument when inputs are invalid *) val verify : discriminant -> challenge -> difficulty -> result -> proof -> bool end -# 116 "v7.in.ml" +# 118 "v7.in.ml" module Micheline : sig @@ -10014,7 +10289,7 @@ val annotations : ('l, 'p) node -> string list val strip_locations : (_, 'p) node -> 'p canonical end -# 118 "v7.in.ml" +# 120 "v7.in.ml" module Block_header : sig @@ -10071,7 +10346,7 @@ type t = {shell : shell_header; protocol_data : bytes} include S.HASHABLE with type t := t and type hash := Block_hash.t end -# 120 "v7.in.ml" +# 122 "v7.in.ml" module Bounded : sig @@ -10220,7 +10495,7 @@ module Int8 (B : BOUNDS with type ocaml_type := int) : module Uint8 (B : BOUNDS with type ocaml_type := int) : S with type ocaml_type := int end -# 122 "v7.in.ml" +# 124 "v7.in.ml" module Fitness : sig @@ -10254,7 +10529,7 @@ end compared in a lexicographical order (longer list are greater). *) include S.T with type t = bytes list end -# 124 "v7.in.ml" +# 126 "v7.in.ml" module Operation : sig @@ -10298,7 +10573,7 @@ type t = {shell : shell_header; proto : bytes} include S.HASHABLE with type t := t and type hash := Operation_hash.t end -# 126 "v7.in.ml" +# 128 "v7.in.ml" module Context : sig @@ -10935,7 +11210,7 @@ module Cache : and type key = cache_key and type value = cache_value end -# 128 "v7.in.ml" +# 130 "v7.in.ml" module Updater : sig @@ -11066,32 +11341,39 @@ module type PROTOCOL = sig val operation_data_and_receipt_encoding : (operation_data * operation_receipt) Data_encoding.t - (** [acceptable_passes op] lists the validation passes in which the - input operation [op] can appear. For instance, it results in - [[0]] if [op] only belongs to the first pass. An answer of [[]] - means that the [op] is ill-formed and cannot be included at - all in a block. *) - val acceptable_passes : operation -> int list - - (** [relative_position_within_block op1 op2] provides a partial and - strict order of operations within a block. It is intended to be - used as an argument to {!List.sort} (and other sorting/ordering - functions) to arrange a set of operations into a sequence, the - order of which is valid for the protocol. - - A negative (respectively, positive) results means that [op1] - should appear before (and, respectively, after) [op2] in a - block. This function does not provide a total ordering on the - operations: a result of [0] entails that the protocol does not - impose any preferences to the order in which [op1] and [op2] - should be included in a block. - - {b Caveat Emptor!} [relative_position_within_block o1 o2 = 0] - does NOT imply that [o1] is equal to [o2] in any way. - Consequently, it {e MUST NOT} be used as a [compare] component of - an {!Stdlib.Map.OrderedType}, or any such collection which relies - on a total comparison function. *) - val relative_position_within_block : operation -> operation -> int + (** [acceptable_pass op] gives the validation pass in which the + input operation [op] can appear. For instance, it results in + [Some 0] if [op] only belongs to the first pass. When [op] is + ill-formed, [acceptable_pass op] returns [None]. *) + val acceptable_pass : operation -> int option + + (** [compare_operations (oph1,op1) (oph2,op2)] defines a total + ordering relation on valid operations. + + The following requirements must be satisfied: [oph1] is the + [Operation.hash.p1], [oph2] is [Operation.hash op2] and that + [op1] and [op2] are valid in the same context. + + [compare_operations (oph1,op1) (oph2,op2) = 0] happens only if + [Operation_hash.compare oph1 oph2 = 0], meaning [op1 = op2] only + when [op1] and [op2] are structurally identical. + + Two operations of different validation_passes are compared in the + reverse order of their [validation_pass]: the one with the + smaller [validation_pass] is compared as being the greater. + + When belonging to the same validation_pass, two operations + comparison depends on their static parameters. An abstract weight + is computed for each operation based on its static parameters. + When two operations' weights are compared as equal, + [compare_operation (oph1,op1) (oph2,op2)] is + [Operation_hash.compare oph1 oph2]. + + [compare_operations] can be used as a [compare] component of an + {!Stdlib.Map.OrderedType}, or any such collection which relies on + a total comparison function. *) + val compare_operations : + Operation_hash.t * operation -> Operation_hash.t * operation -> int (** A functional state that is transmitted through the steps of a block validation sequence: it can be created by any of the @@ -11240,7 +11522,7 @@ end not complete until [init] in invoked. *) val activate : Context.t -> Protocol_hash.t -> Context.t Lwt.t end -# 130 "v7.in.ml" +# 132 "v7.in.ml" module RPC_context : sig @@ -11395,7 +11677,7 @@ val make_opt_call3 : 'i -> 'o option shell_tzresult Lwt.t end -# 132 "v7.in.ml" +# 134 "v7.in.ml" module Wasm_2_0_0 : sig @@ -11448,7 +11730,7 @@ module Make val get_info : Tree.tree -> info Lwt.t end end -# 134 "v7.in.ml" +# 136 "v7.in.ml" module Plonk : sig @@ -11516,7 +11798,7 @@ val verify_multi_circuits : proof -> bool end -# 136 "v7.in.ml" +# 138 "v7.in.ml" module Dal : sig @@ -11622,6 +11904,6 @@ val verify_segment : [> `Degree_exceeds_srs_length of string | `Segment_index_out_of_range] ) Result.t end -# 138 "v7.in.ml" +# 140 "v7.in.ml" end diff --git a/src/lib_protocol_environment/sigs/v7/.ocamlformat-ignore b/src/lib_protocol_environment/sigs/v7/.ocamlformat-ignore index 346b16039207cf08b6155a77be701fd18ca69f8a..a74c80b875acfb807154360443349a4010645fe5 100644 --- a/src/lib_protocol_environment/sigs/v7/.ocamlformat-ignore +++ b/src/lib_protocol_environment/sigs/v7/.ocamlformat-ignore @@ -15,3 +15,4 @@ s.mli set.mli string.mli z.mli +q.mli diff --git a/src/lib_protocol_environment/sigs/v7/compare.mli b/src/lib_protocol_environment/sigs/v7/compare.mli index 61d756f56afc7f080e7565535bf4aad42475e4ed..22e295139c47994f904090d7d9843f33e2b0de9c 100644 --- a/src/lib_protocol_environment/sigs/v7/compare.mli +++ b/src/lib_protocol_environment/sigs/v7/compare.mli @@ -136,6 +136,9 @@ module Bytes : S with type t = bytes (** [Z] is a comparison module for Zarith numbers. *) module Z : S with type t = Z.t +(** [Q] is a comparison module for Zarith rationals. *) +module Q : S with type t = Q.t + (** {2 Type constructors} Provided the functor argument(s) are compatible with the polymorphic diff --git a/src/lib_protocol_environment/sigs/v7/q.mli b/src/lib_protocol_environment/sigs/v7/q.mli new file mode 100644 index 0000000000000000000000000000000000000000..6524a34a5a4abf260d1e2319d2b5726b132d945e --- /dev/null +++ b/src/lib_protocol_environment/sigs/v7/q.mli @@ -0,0 +1,266 @@ +(** + Rationals. + + This modules builds arbitrary precision rationals on top of arbitrary + integers from module Z. + + + This file is part of the Zarith library + http://forge.ocamlcore.org/projects/zarith . + It is distributed under LGPL 2 licensing, with static linking exception. + See the LICENSE file included in the distribution. + + Copyright (c) 2010-2011 Antoine Miné, Abstraction project. + Abstraction is part of the LIENS (Laboratoire d'Informatique de l'ENS), + a joint laboratory by: + CNRS (Centre national de la recherche scientifique, France), + ENS (École normale supérieure, Paris, France), + INRIA Rocquencourt (Institut national de recherche en informatique, France). + + *) + +(** {1 Types} *) + +type t = { + num: Z.t; (** Numerator. *) + den: Z.t; (** Denominator, >= 0 *) + } +(** A rational is represented as a pair numerator/denominator, reduced to + have a non-negative denominator and no common factor. + This form is canonical (enabling polymorphic equality and hashing). + The representation allows three special numbers: [inf] (1/0), [-inf] (-1/0) + and [undef] (0/0). + *) + +(** {1 Construction} *) + +val make: Z.t -> Z.t -> t +(** [make num den] constructs a new rational equal to [num]/[den]. + It takes care of putting the rational in canonical form. + *) + +val zero: t +val one: t +val minus_one:t +(** 0, 1, -1. *) + +val inf: t +(** 1/0. *) + +val minus_inf: t +(** -1/0. *) + +val undef: t +(** 0/0. *) + +val of_bigint: Z.t -> t +val of_int: int -> t +val of_int32: int32 -> t +val of_int64: int64 -> t +(** Conversions from various integer types. *) + +val of_ints: int -> int -> t +(** Conversion from an [int] numerator and an [int] denominator. *) + + + +val of_string: string -> t +(** Converts a string to a rational. Plain integers, [/] separated + integer ratios (with optional sign), decimal point and scientific + notations are understood. + Additionally, the special [inf], [-inf], and [undef] are + recognized (they can also be typeset respectively as [1/0], [-1/0], + [0/0]). *) + + +(** {1 Inspection} *) + +val num: t -> Z.t +(** Get the numerator. *) + +val den: t -> Z.t +(** Get the denominator. *) + + +(** {1 Testing} *) + +type kind = + | ZERO (** 0 *) + | INF (** infinity, i.e. 1/0 *) + | MINF (** minus infinity, i.e. -1/0 *) + | UNDEF (** undefined, i.e., 0/0 *) + | NZERO (** well-defined, non-infinity, non-zero number *) +(** Rationals can be categorized into different kinds, depending mainly on + whether the numerator and/or denominator is null. + *) + +val classify: t -> kind +(** Determines the kind of a rational. *) + +val is_real: t -> bool +(** Whether the argument is non-infinity and non-undefined. *) + +val sign: t -> int +(** Returns 1 if the argument is positive (including inf), -1 if it is + negative (including -inf), and 0 if it is null or undefined. + *) + +val compare: t -> t -> int +(** [compare x y] compares [x] to [y] and returns 1 if [x] is strictly + greater that [y], -1 if it is strictly smaller, and 0 if they are + equal. + This is a total ordering. + Infinities are ordered in the natural way, while undefined is considered + the smallest of all: undef = undef < -inf <= -inf < x < inf <= inf. + This is consistent with OCaml's handling of floating-point infinities + and NaN. + + OCaml's polymorphic comparison will NOT return a result consistent with + the ordering of rationals. + *) + +val equal: t -> t -> bool +(** Equality testing. + Unlike [compare], this follows IEEE semantics: [undef] <> [undef]. + *) + +val min: t -> t -> t +(** Returns the smallest of its arguments. *) + +val max: t -> t -> t +(** Returns the largest of its arguments. *) + +val leq: t -> t -> bool +(** Less than or equal. [leq undef undef] resturns false. *) + +val geq: t -> t -> bool +(** Greater than or equal. [leq undef undef] resturns false. *) + +val lt: t -> t -> bool +(** Less than (not equal). *) + +val gt: t -> t -> bool +(** Greater than (not equal). *) + + +(** {1 Conversions} *) + +val to_bigint: t -> Z.t +val to_int: t -> int +val to_int32: t -> int32 +val to_int64: t -> int64 +(** Convert to integer by truncation. + Raises a [Divide_by_zero] if the argument is an infinity or undefined. + Raises a [Z.Overflow] if the result does not fit in the destination + type. +*) + +val to_string: t -> string +(** Converts to human-readable, base-10, [/]-separated rational. *) + +(** {1 Arithmetic operations} *) + +(** + In all operations, the result is [undef] if one argument is [undef]. + Other operations can return [undef]: such as [inf]-[inf], [inf]*0, 0/0. + *) + +val neg: t -> t +(** Negation. *) + +val abs: t -> t +(** Absolute value. *) + +val add: t -> t -> t +(** Addition. *) + +val sub: t -> t -> t +(** Subtraction. We have [sub x y] = [add x (neg y)]. *) + +val mul: t -> t -> t +(** Multiplication. *) + +val inv: t -> t +(** Inverse. + Note that [inv 0] is defined, and equals [inf]. + *) + +val div: t -> t -> t +(** Division. + We have [div x y] = [mul x (inv y)], and [inv x] = [div one x]. + *) + +val mul_2exp: t -> int -> t +(** [mul_2exp x n] multiplies [x] by 2 to the power of [n]. *) + +val div_2exp: t -> int -> t +(** [div_2exp x n] divides [x] by 2 to the power of [n]. *) + + +(** {1 Printing} *) + +val pp_print: Format.formatter -> t -> unit +(** Prints the argument on the specified formatter. + Also intended to be used as [%a] format printer in [Format.printf]. + *) + + +(** {1 Prefix and infix operators} *) + +(** + Classic prefix and infix [int] operators are redefined on [t]. +*) + +val (~-): t -> t +(** Negation [neg]. *) + +val (~+): t -> t +(** Identity. *) + +val (+): t -> t -> t +(** Addition [add]. *) + +val (-): t -> t -> t +(** Subtraction [sub]. *) + +val ( * ): t -> t -> t +(** Multiplication [mul]. *) + +val (/): t -> t -> t +(** Division [div]. *) + +val (lsl): t -> int -> t +(** Multiplication by a power of two [mul_2exp]. *) + +val (asr): t -> int -> t +(** Division by a power of two [shift_right]. *) + +val (~$): int -> t +(** Conversion from [int]. *) + +val (//): int -> int -> t +(** Creates a rational from two [int]s. *) + +val (~$$): Z.t -> t +(** Conversion from [Z.t]. *) + +val (///): Z.t -> Z.t -> t +(** Creates a rational from two [Z.t]. *) + +val (=): t -> t -> bool +(** Same as [equal]. *) + +val (<): t -> t -> bool +(** Same as [lt]. *) + +val (>): t -> t -> bool +(** Same as [gt]. *) + +val (<=): t -> t -> bool +(** Same as [leq]. *) + +val (>=): t -> t -> bool +(** Same as [geq]. *) + +val (<>): t -> t -> bool +(** [a <> b] is equivalent to [not (equal a b)]. *) diff --git a/src/lib_protocol_environment/sigs/v7/updater.mli b/src/lib_protocol_environment/sigs/v7/updater.mli index 1339de69b90ac8fcc92eaabaa7f3ecf7dd3b52cc..641c5d83eac11f1f52b8456835a3406ff93f4f98 100644 --- a/src/lib_protocol_environment/sigs/v7/updater.mli +++ b/src/lib_protocol_environment/sigs/v7/updater.mli @@ -124,32 +124,39 @@ module type PROTOCOL = sig val operation_data_and_receipt_encoding : (operation_data * operation_receipt) Data_encoding.t - (** [acceptable_passes op] lists the validation passes in which the - input operation [op] can appear. For instance, it results in - [[0]] if [op] only belongs to the first pass. An answer of [[]] - means that the [op] is ill-formed and cannot be included at - all in a block. *) - val acceptable_passes : operation -> int list - - (** [relative_position_within_block op1 op2] provides a partial and - strict order of operations within a block. It is intended to be - used as an argument to {!List.sort} (and other sorting/ordering - functions) to arrange a set of operations into a sequence, the - order of which is valid for the protocol. - - A negative (respectively, positive) results means that [op1] - should appear before (and, respectively, after) [op2] in a - block. This function does not provide a total ordering on the - operations: a result of [0] entails that the protocol does not - impose any preferences to the order in which [op1] and [op2] - should be included in a block. - - {b Caveat Emptor!} [relative_position_within_block o1 o2 = 0] - does NOT imply that [o1] is equal to [o2] in any way. - Consequently, it {e MUST NOT} be used as a [compare] component of - an {!Stdlib.Map.OrderedType}, or any such collection which relies - on a total comparison function. *) - val relative_position_within_block : operation -> operation -> int + (** [acceptable_pass op] gives the validation pass in which the + input operation [op] can appear. For instance, it results in + [Some 0] if [op] only belongs to the first pass. When [op] is + ill-formed, [acceptable_pass op] returns [None]. *) + val acceptable_pass : operation -> int option + + (** [compare_operations (oph1,op1) (oph2,op2)] defines a total + ordering relation on valid operations. + + The following requirements must be satisfied: [oph1] is the + [Operation.hash.p1], [oph2] is [Operation.hash op2] and that + [op1] and [op2] are valid in the same context. + + [compare_operations (oph1,op1) (oph2,op2) = 0] happens only if + [Operation_hash.compare oph1 oph2 = 0], meaning [op1 = op2] only + when [op1] and [op2] are structurally identical. + + Two operations of different validation_passes are compared in the + reverse order of their [validation_pass]: the one with the + smaller [validation_pass] is compared as being the greater. + + When belonging to the same validation_pass, two operations + comparison depends on their static parameters. An abstract weight + is computed for each operation based on its static parameters. + When two operations' weights are compared as equal, + [compare_operation (oph1,op1) (oph2,op2)] is + [Operation_hash.compare oph1 oph2]. + + [compare_operations] can be used as a [compare] component of an + {!Stdlib.Map.OrderedType}, or any such collection which relies on + a total comparison function. *) + val compare_operations : + Operation_hash.t * operation -> Operation_hash.t * operation -> int (** A functional state that is transmitted through the steps of a block validation sequence: it can be created by any of the diff --git a/src/lib_shell/block_directory.ml b/src/lib_shell/block_directory.ml index cc989a3dbd960cfb04a6706454d850bc43765c3a..b39c4bfa0a869ee7d1d1fe674a556c2516050f4a 100644 --- a/src/lib_shell/block_directory.ml +++ b/src/lib_shell/block_directory.ml @@ -615,20 +615,27 @@ let build_raw_rpc_directory (module Proto : Block_services.PROTO) let operations = List.map (fun operations -> + let operations = + List.map + (fun op -> + let proto = + Data_encoding.Binary.to_bytes_exn + Next_proto.operation_data_encoding + op.Next_proto.protocol_data + in + (op, {Operation.shell = op.shell; proto})) + operations + in let operations = if q#sort_operations then - List.sort Next_proto.relative_position_within_block operations + List.sort + (fun (op, ops) (op', ops') -> + let oph, oph' = (Operation.hash ops, Operation.hash ops') in + Next_proto.compare_operations (oph, op) (oph', op')) + operations else operations in - List.map - (fun op -> - let proto = - Data_encoding.Binary.to_bytes_exn - Next_proto.operation_data_encoding - op.Next_proto.protocol_data - in - {Operation.shell = op.shell; proto}) - operations) + List.map snd operations) p.operations in let* bv = diff --git a/src/lib_shell_services/block_validator_errors.ml b/src/lib_shell_services/block_validator_errors.ml index 9e48b7bfe0d2783e3c363223787c386178796228..daff109909e8f569bdc7b82c27235fa0580adad8 100644 --- a/src/lib_shell_services/block_validator_errors.ml +++ b/src/lib_shell_services/block_validator_errors.ml @@ -47,7 +47,7 @@ type block_error = | Unallowed_pass of { operation : Operation_hash.t; pass : int; - allowed_pass : int list; + allowed_pass : int option; } | Cannot_parse_block_header | Economic_protocol_error @@ -190,7 +190,7 @@ let block_error_encoding = (req "error" (constant "invalid_pass")) (req "operation" Operation_hash.encoding) (req "pass" uint8) - (req "allowed_pass" (list uint8))) + (req "allowed_pass" (option uint8))) (function | Unallowed_pass {operation; pass; allowed_pass} -> Some ((), operation, pass, allowed_pass) @@ -303,7 +303,9 @@ let pp_block_error ppf = function Operation_hash.pp_short operation pass - Format.(pp_print_list pp_print_int) + (fun fmt -> function + | None -> Format.fprintf fmt "None" + | Some i -> Format.pp_print_int fmt i) allowed_pass | Cannot_parse_block_header -> Format.fprintf ppf "Failed to parse the block header." diff --git a/src/lib_shell_services/block_validator_errors.mli b/src/lib_shell_services/block_validator_errors.mli index 4e976a287ff3de4adf5bf870ed4f78610dd2701b..81464f6a9289db7fe1ec2a0a63199f491b362576 100644 --- a/src/lib_shell_services/block_validator_errors.mli +++ b/src/lib_shell_services/block_validator_errors.mli @@ -47,7 +47,7 @@ type block_error = | Unallowed_pass of { operation : Operation_hash.t; pass : int; - allowed_pass : int list; + allowed_pass : int option; } | Cannot_parse_block_header | Economic_protocol_error diff --git a/src/lib_stdlib/compare.ml b/src/lib_stdlib/compare.ml index 78b288bcacc937eb395ef0e4b4e8a80f34544cf8..96bcd6345184a4bded4773814087e34fd017389a 100644 --- a/src/lib_stdlib/compare.ml +++ b/src/lib_stdlib/compare.ml @@ -245,6 +245,8 @@ module Z = struct let min = Z.min end +module Q = Q + module List_length_with = struct let ( = ) l i = Stdlib.List.compare_length_with l i = 0 diff --git a/src/lib_stdlib/compare.mli b/src/lib_stdlib/compare.mli index 2d5b2916e63064c2c25d91274e1357bf367c9197..424b2709a4722164986dbafe3648538ab044774c 100644 --- a/src/lib_stdlib/compare.mli +++ b/src/lib_stdlib/compare.mli @@ -138,6 +138,9 @@ module Bytes : S with type t = bytes (** [Z] is a comparison module for Zarith numbers. *) module Z : S with type t = Z.t +(** [Q] is a comparison module for Zarith-based rational numbers. *) +module Q : S with type t = Q.t + (** {2 Type constructors} Provided the functor argument(s) are compatible with the polymorphic diff --git a/src/lib_validation/block_validation.ml b/src/lib_validation/block_validation.ml index 4472d1e2397bb785a30033eb7b9233e703b36bbc..9ff2100efdb7cda59787ecbd76cd5002cf28d34f 100644 --- a/src/lib_validation/block_validation.ml +++ b/src/lib_validation/block_validation.ml @@ -402,10 +402,15 @@ module Make (Proto : Registered_protocol.T) = struct (invalid_block block_hash (Cannot_parse_operation op_hash)) | Some protocol_data -> let op = {Proto.shell = op.shell; protocol_data} in - let allowed_pass = Proto.acceptable_passes op in + let allowed_pass = Proto.acceptable_pass op in + let is_pass_consistent = + match allowed_pass with + | None -> false + | Some n -> Int.equal pass n + in let* () = fail_unless - (List.mem ~equal:Int.equal pass allowed_pass) + is_pass_consistent (invalid_block block_hash (Unallowed_pass {operation = op_hash; pass; allowed_pass})) diff --git a/src/proto_alpha/lib_delegate/operation_pool.ml b/src/proto_alpha/lib_delegate/operation_pool.ml index 12de099b1458f621899b1200a3e0ebb7e11cbd8b..7e0a7612054e446b008c291c4546fbb377c8ed99 100644 --- a/src/proto_alpha/lib_delegate/operation_pool.ml +++ b/src/proto_alpha/lib_delegate/operation_pool.ml @@ -159,26 +159,20 @@ let pp_ordered_pool fmt {consensus; votes; anonymous; managers} = (List.length anonymous) (List.length managers) -(* Hypothesis : we suppose [List.length Protocol.Main.validation_passes = 4] *) -let consensus_index = 0 - -let votes_index = 1 - -let anonymous_index = 2 - -let managers_index = 3 - let classify op = - (* Hypothesis: acceptable passes returns a size at most 1 list *) - match Main.acceptable_passes op with - | [pass] -> - if pass = consensus_index then `Consensus + (* Hypothesis: acceptable passes on an ill-formed operation returns + None. *) + let pass = Main.acceptable_pass op in + match pass with + | None -> `Bad + | Some pass -> + let open Operation_repr in + if pass = consensus_pass then `Consensus (* TODO filter outdated consensus ops ? *) - else if pass = votes_index then `Votes - else if pass = anonymous_index then `Anonymous - else if pass = managers_index then `Managers + else if pass = voting_pass then `Votes + else if pass = anonymous_pass then `Anonymous + else if pass = manager_pass then `Managers else `Bad - | _ -> `Bad let add_operation_to_pool add classify pool operation = match classify operation with diff --git a/src/proto_alpha/lib_delegate/operation_pool.mli b/src/proto_alpha/lib_delegate/operation_pool.mli index 1f366c633abec5f21ba1a288f92d0f5e645d8c9e..4586eef4814ca622ed102ece0036e94dafd8cbd4 100644 --- a/src/proto_alpha/lib_delegate/operation_pool.mli +++ b/src/proto_alpha/lib_delegate/operation_pool.mli @@ -26,14 +26,6 @@ open Protocol open Alpha_context -val consensus_index : int - -val votes_index : int - -val anonymous_index : int - -val managers_index : int - module Operation_set : Set.S with type elt = packed_operation (** Generic base type for pools *) diff --git a/src/proto_alpha/lib_delegate/operation_selection.ml b/src/proto_alpha/lib_delegate/operation_selection.ml index 7747a09a8aa26e0c75afa856dbcabbbe2b2861d5..a658661df026589db7ffb88d4b2b797ab9da7f68 100644 --- a/src/proto_alpha/lib_delegate/operation_selection.ml +++ b/src/proto_alpha/lib_delegate/operation_selection.ml @@ -30,13 +30,13 @@ module Events = Baking_events.Selection let quota = Main.validation_passes -let consensus_quota = Stdlib.List.nth quota Operation_pool.consensus_index +let consensus_quota = Stdlib.List.nth quota Operation_repr.consensus_pass -let votes_quota = Stdlib.List.nth quota Operation_pool.votes_index +let votes_quota = Stdlib.List.nth quota Operation_repr.voting_pass -let anonymous_quota = Stdlib.List.nth quota Operation_pool.anonymous_index +let anonymous_quota = Stdlib.List.nth quota Operation_repr.anonymous_pass -let managers_quota = Stdlib.List.nth quota Operation_pool.managers_index +let managers_quota = Stdlib.List.nth quota Operation_repr.manager_pass type prioritized_manager = { op : Prioritized_operation.t; diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index b031481dd8b2251376f2fbd3307e7b4bdb88a652..01986e45060ec5ef803e83f44ebf66f724681cfe 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -1345,6 +1345,9 @@ module Seed : sig (** See {!Seed_storage.update_seed}. *) val update_seed : context -> vdf_solution -> context tzresult Lwt.t + (** See {!Seed_repr.compare_vdf_solution}. *) + val compare_vdf_solution : vdf_solution -> vdf_solution -> int + val compute_randao : context -> context tzresult Lwt.t val cycle_end : @@ -4252,7 +4255,9 @@ module Operation : sig val hash_packed : packed_operation -> Operation_hash.t - val acceptable_passes : packed_operation -> int list + val acceptable_pass : packed_operation -> int option + + val compare_by_passes : packed_operation -> packed_operation -> int type error += Missing_signature (* `Permanent *) @@ -4262,6 +4267,11 @@ module Operation : sig val pack : 'kind operation -> packed_operation + val compare : + Operation_hash.t * packed_operation -> + Operation_hash.t * packed_operation -> + int + type ('a, 'b) eq = Eq : ('a, 'a) eq val equal : 'a operation -> 'b operation -> ('a, 'b) eq option diff --git a/src/proto_alpha/lib_protocol/main.ml b/src/proto_alpha/lib_protocol/main.ml index 0ebdce77cddd3bd91c8d5180ca17cf7aa1a8f013..c18b87c7e9e6ba945d9e2c7dcb247ed80310e903 100644 --- a/src/proto_alpha/lib_protocol/main.ml +++ b/src/proto_alpha/lib_protocol/main.ml @@ -62,7 +62,7 @@ type operation = Alpha_context.packed_operation = { protocol_data : operation_data; } -let acceptable_passes = Alpha_context.Operation.acceptable_passes +let acceptable_pass = Alpha_context.Operation.acceptable_pass let max_block_length = Alpha_context.Block_header.max_header_length @@ -426,23 +426,26 @@ let apply_operation_with_mode mode ctxt chain_id data op_count operation let apply_operation ({mode; chain_id; ctxt; op_count; _} as data) (operation : Alpha_context.packed_operation) = match mode with - | Partial_application _ - when not - (List.exists - (Compare.Int.equal 0) - (Alpha_context.Operation.acceptable_passes operation)) -> - (* Multipass validation only considers operations in pass 0. *) - let op_count = op_count + 1 in - return ({data with ctxt; op_count}, No_operation_metadata) - | Partial_application {payload_producer; _} -> - apply_operation_with_mode - Apply.Application - ctxt - chain_id - data - op_count - operation - ~payload_producer + | Partial_application {payload_producer; _} -> ( + match acceptable_pass operation with + | None -> + (* Only occurs with Failing_noop *) + fail Validate_errors.Failing_noop_error + | Some n -> + (* Multipass validation only considers operations in + consensus pass. *) + if Compare.Int.(n = Operation_repr.consensus_pass) then + apply_operation_with_mode + Apply.Application + ctxt + chain_id + data + op_count + operation + ~payload_producer + else + let op_count = op_count + 1 in + return ({data with ctxt; op_count}, No_operation_metadata)) | Application {payload_producer; _} -> apply_operation_with_mode Apply.Application @@ -682,60 +685,8 @@ let finalize_block migration_balance_updates op_count -let relative_position_within_block op1 op2 = - let open Alpha_context in - let (Operation_data op1) = op1.protocol_data in - let (Operation_data op2) = op2.protocol_data in - match (op1.contents, op2.contents) with - | Single (Preendorsement _), Single (Preendorsement _) -> 0 - | Single (Preendorsement _), _ -> -1 - | _, Single (Preendorsement _) -> 1 - | Single (Endorsement _), Single (Endorsement _) -> 0 - | Single (Endorsement _), _ -> -1 - | _, Single (Endorsement _) -> 1 - | Single (Dal_slot_availability _), Single (Dal_slot_availability _) -> 0 - | Single (Dal_slot_availability _), _ -> -1 - | _, Single (Dal_slot_availability _) -> 1 - | Single (Seed_nonce_revelation _), Single (Seed_nonce_revelation _) -> 0 - | _, Single (Seed_nonce_revelation _) -> 1 - | Single (Seed_nonce_revelation _), _ -> -1 - | Single (Vdf_revelation _), Single (Vdf_revelation _) -> 0 - | _, Single (Vdf_revelation _) -> 1 - | Single (Vdf_revelation _), _ -> -1 - | ( Single (Double_preendorsement_evidence _), - Single (Double_preendorsement_evidence _) ) -> - 0 - | _, Single (Double_preendorsement_evidence _) -> 1 - | Single (Double_preendorsement_evidence _), _ -> -1 - | ( Single (Double_endorsement_evidence _), - Single (Double_endorsement_evidence _) ) -> - 0 - | _, Single (Double_endorsement_evidence _) -> 1 - | Single (Double_endorsement_evidence _), _ -> -1 - | Single (Double_baking_evidence _), Single (Double_baking_evidence _) -> 0 - | _, Single (Double_baking_evidence _) -> 1 - | Single (Double_baking_evidence _), _ -> -1 - | Single (Activate_account _), Single (Activate_account _) -> 0 - | _, Single (Activate_account _) -> 1 - | Single (Activate_account _), _ -> -1 - | Single (Proposals _), Single (Proposals _) -> 0 - | _, Single (Proposals _) -> 1 - | Single (Proposals _), _ -> -1 - | Single (Ballot _), Single (Ballot _) -> 0 - | _, Single (Ballot _) -> 1 - | Single (Ballot _), _ -> -1 - | Single (Failing_noop _), Single (Failing_noop _) -> 0 - | _, Single (Failing_noop _) -> 1 - | Single (Failing_noop _), _ -> -1 - (* Manager operations with smaller counter are pre-validated first. *) - | Single (Manager_operation op1), Single (Manager_operation op2) -> - Z.compare op1.counter op2.counter - | Cons (Manager_operation op1, _), Single (Manager_operation op2) -> - Z.compare op1.counter op2.counter - | Single (Manager_operation op1), Cons (Manager_operation op2, _) -> - Z.compare op1.counter op2.counter - | Cons (Manager_operation op1, _), Cons (Manager_operation op2, _) -> - Z.compare op1.counter op2.counter +let compare_operations (oph1, op1) (oph2, op2) = + Alpha_context.Operation.compare (oph1, op1) (oph2, op2) let init chain_id ctxt block_header = let level = block_header.Block_header.level in diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index d68a6f95e893b34c2a06589cdafae995ddbcbda0..614f47a44e2900dd754ca2ef3eb0cdf7c949b12e 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -1798,23 +1798,45 @@ let raw ({shell; protocol_data} : _ operation) = in {Operation.shell; proto} -let acceptable_passes (op : packed_operation) = +(** Each operation belongs to a validation pass that is an integer + abstracting its priority in a block. Except Failing_noop. *) + +let consensus_pass = 0 + +let voting_pass = 1 + +let anonymous_pass = 2 + +let manager_pass = 3 + +(** [acceptable_pass op] returns either the validation_pass of [op] + when defines and None when [op] is [Failing_noop]. *) +let acceptable_pass (op : packed_operation) = let (Operation_data protocol_data) = op.protocol_data in match protocol_data.contents with - | Single (Failing_noop _) -> [] - | Single (Preendorsement _) -> [0] - | Single (Endorsement _) -> [0] - | Single (Dal_slot_availability _) -> [0] - | Single (Proposals _) -> [1] - | Single (Ballot _) -> [1] - | Single (Seed_nonce_revelation _) -> [2] - | Single (Vdf_revelation _) -> [2] - | Single (Double_endorsement_evidence _) -> [2] - | Single (Double_preendorsement_evidence _) -> [2] - | Single (Double_baking_evidence _) -> [2] - | Single (Activate_account _) -> [2] - | Single (Manager_operation _) -> [3] - | Cons (Manager_operation _, _ops) -> [3] + | Single (Failing_noop _) -> None + | Single (Preendorsement _) -> Some consensus_pass + | Single (Endorsement _) -> Some consensus_pass + | Single (Dal_slot_availability _) -> Some consensus_pass + | Single (Proposals _) -> Some voting_pass + | Single (Ballot _) -> Some voting_pass + | Single (Seed_nonce_revelation _) -> Some anonymous_pass + | Single (Vdf_revelation _) -> Some anonymous_pass + | Single (Double_endorsement_evidence _) -> Some anonymous_pass + | Single (Double_preendorsement_evidence _) -> Some anonymous_pass + | Single (Double_baking_evidence _) -> Some anonymous_pass + | Single (Activate_account _) -> Some anonymous_pass + | Single (Manager_operation _) -> Some manager_pass + | Cons (Manager_operation _, _ops) -> Some manager_pass + +(** [compare_by_passes] orders two operations in the reverse order of + their acceptable passes. *) +let compare_by_passes op1 op2 = + match (acceptable_pass op1, acceptable_pass op2) with + | Some op1_pass, Some op2_pass -> Compare.Int.compare op2_pass op1_pass + | None, Some _ -> -1 + | Some _, None -> 1 + | None, None -> 0 type error += Invalid_signature (* `Permanent *) @@ -2039,3 +2061,557 @@ let equal : type a b. a operation -> b operation -> (a, b) eq option = equal_contents_kind_list op1.protocol_data.contents op2.protocol_data.contents + +(** {2 Comparing operations} *) + +(** Precondition: both operations are [valid]. Hence, it is possible + to compare them without any state representation. *) + +(** {3 Operation passes} *) + +type consensus_pass_type + +type voting_pass_type + +type anonymous_pass_type + +type manager_pass_type + +type noop_pass_type + +type _ pass = + | Consensus : consensus_pass_type pass + | Voting : voting_pass_type pass + | Anonymous : anonymous_pass_type pass + | Manager : manager_pass_type pass + | Noop : noop_pass_type pass + +(** Pass comparison. *) +let compare_inner_pass : type a b. a pass -> b pass -> int = + fun pass1 pass2 -> + match (pass1, pass2) with + | Consensus, (Voting | Anonymous | Manager | Noop) -> 1 + | (Voting | Anonymous | Manager | Noop), Consensus -> -1 + | Voting, (Anonymous | Manager | Noop) -> 1 + | (Anonymous | Manager | Noop), Voting -> -1 + | Anonymous, (Manager | Noop) -> 1 + | (Manager | Noop), Anonymous -> -1 + | Manager, Noop -> 1 + | Noop, Manager -> -1 + | Consensus, Consensus + | Voting, Voting + | Anonymous, Anonymous + | Manager, Manager + | Noop, Noop -> + 0 + +(** {3 Operation weights} *) + +(** [round_infos] is the pair of a [level] convert into {!int32} and + [round] convert into an {!int}. + + By convention, if the [round] is from an operation round that + failed to convert in a {!int}, the value of [round] is (-1). *) +type round_infos = {level : int32; round : int} + +(** [endorsement_infos] is the pair of a {!round_infos} and a [slot] + convert into an {!int}. *) +type endorsement_infos = {round : round_infos; slot : int} + +(** [double_baking_infos] is the pair of a {!round_infos} and a + {!block_header} hash. *) +type double_baking_infos = {round : round_infos; bh_hash : Block_hash.t} + +(** Compute a {!round_infos} from a {consensus_content} of a valid + operation. Hence, the [round] must convert in {!int}. + + Precondition: [c] comes from a valid operation. The [round] from a + valid operation should succeed to convert in {!int}. Hence, for the + unreachable path where the convertion failed, we put (-1) as + [round] value. *) +let round_infos_from_consensus_content (c : consensus_content) = + let level = Raw_level_repr.to_int32 c.level in + match Round_repr.to_int c.round with + | Ok round -> {level; round} + | Error _ -> {level; round = -1} + +(** Compute a {!endorsement_infos} from a {!consensus_content}. It is + used to compute the weight of {!Endorsement} and {!Preendorsement}. + + Precondition: [c] comes from a valid operation. The {!Endorsement} + or {!Preendorsement} is valid, so its [round] must succeed to + convert into an {!int}. Hence, for the unreachable path where the + convertion fails, we put (-1) as [round] value (see + {!round_infos_from_consensus_content}). *) +let endorsement_infos_from_consensus_content (c : consensus_content) = + let slot = Slot_repr.to_int c.slot in + let round = round_infos_from_consensus_content c in + {round; slot} + +(** Compute a {!double_baking_infos} and a {!Block_header_repr.hash} + from a {!Block_header_repr.t}. It is used to compute the weight of + a {!Double_baking_evidence}. + + Precondition: [bh] comes from a valid operation. The + {!Double_baking_envidence} is valid, so its fitness from its first + denounced block header must succeed, and the round from this + fitness must convert in a {!int}. Hence, for the unreachable paths + where either the convertion fails or the fitness is not + retrievable, we put (-1) as [round] value. *) +let consensus_infos_and_hash_from_block_header (bh : Block_header_repr.t) = + let level = bh.shell.level in + let bh_hash = Block_header_repr.hash bh in + let round = + match Fitness_repr.from_raw bh.shell.fitness with + | Ok bh_fitness -> ( + match Round_repr.to_int (Fitness_repr.round bh_fitness) with + | Ok round -> {level; round} + | Error _ -> {level; round = -1}) + | Error _ -> {level; round = -1} + in + {round; bh_hash} + +(** The weight of an operation. + + Given an operation, its [weight] carries on static information that + is used to compare it to an operation of the same pass. + Operation weight are defined by validation pass. + + The [weight] of an {!Endorsement} or {!Preendorsement} depends on + its {!endorsement_infos}. + + The [weight] of a {!Dal_slot_availability} depends on the pair of + the size of its bitset, {!Dal_endorsement_repr.t}, and the + signature of its endorser {! Signature.Public_key_hash.t}. + + The [weight] of a voting operation depends on the pair of its + [period] and [source]. + + The [weight] of a {!Vdf_revelation} depends on its [solution]. + + The [weight] of a {!Seed_nonce_revelation} depends on its [level] + converted in {!int32}. + + The [weight] of a {!Double_preendorsement} or + {!Double_endorsement} depends on the [level] and [round] of their + first denounciated operations. The [level] and [round] are wrapped + in a {!round_infos}. + + The [weight] of a {!Double_baking} depends on the [level], [round] + and [hash] of its first denounciated block_header. the [level] and + [round] are wrapped in a {!double_baking_infos}. + + The [weight] of an {!Activate_account} depends on its public key + hash. + + The [weight] of {!Manager_operation} depends on its [fee] and + [gas_limit] ratio expressed in {!Q.t}. *) +type _ weight = + | Weight_endorsement : endorsement_infos -> consensus_pass_type weight + | Weight_preendorsement : endorsement_infos -> consensus_pass_type weight + | Weight_dal_slot_availability : + int * Signature.Public_key_hash.t + -> consensus_pass_type weight + | Weight_proposals : + int32 * Signature.Public_key_hash.t + -> voting_pass_type weight + | Weight_ballot : + int32 * Signature.Public_key_hash.t + -> voting_pass_type weight + | Weight_seed_nonce_revelation : int32 -> anonymous_pass_type weight + | Weight_vdf_revelation : Seed_repr.vdf_solution -> anonymous_pass_type weight + | Weight_double_preendorsement : round_infos -> anonymous_pass_type weight + | Weight_double_endorsement : round_infos -> anonymous_pass_type weight + | Weight_double_baking : double_baking_infos -> anonymous_pass_type weight + | Weight_activate_account : + Ed25519.Public_key_hash.t + -> anonymous_pass_type weight + | Weight_manager : Q.t * Signature.public_key_hash -> manager_pass_type weight + | Weight_noop : noop_pass_type weight + +(** The weight of an operation is the pair of its pass and weight. *) +type operation_weight = W : 'pass pass * 'pass weight -> operation_weight + +(** The {!weight} of a batch of {!Manager_operation} depends on the + sum of all [fee] and the sum of all [gas_limit]. + + Precondition: [op] is a valid manager operation: its sum + of accumulated [fee] must succeed. Hence, in the unreachable path where + the [fee] sum fails, we put [Tez_repr.zero] as its value. *) +let cumulate_fee_and_gas_of_manager : + type kind. + kind Kind.manager contents_list -> + Tez_repr.t * Gas_limit_repr.Arith.integral = + fun op -> + let add_without_error acc y = + match Tez_repr.(acc +? y) with + | Ok v -> v + | Error _ -> (* This cannot happen *) acc + in + let rec loop : + type kind. 'a -> 'b -> kind Kind.manager contents_list -> 'a * 'b = + fun fees_acc gas_limit_acc -> function + | Single (Manager_operation {fee; gas_limit; _}) -> + let total_fees = add_without_error fees_acc fee in + let total_gas_limit = + Gas_limit_repr.Arith.add gas_limit_acc gas_limit + in + (total_fees, total_gas_limit) + | Cons (Manager_operation {fee; gas_limit; _}, manops) -> + let fees_acc = add_without_error fees_acc fee in + let gas_limit_acc = Gas_limit_repr.Arith.add gas_limit gas_limit_acc in + loop fees_acc gas_limit_acc manops + in + loop Tez_repr.zero Gas_limit_repr.Arith.zero op + +(** The {!weight} of a {!Manager_operation} as well as a batch of + operations is the ratio in {!int64} between its [fee] and + [gas_limit] as computed by + {!cumulate_fee_and_gas_of_manager} converted in {!Q.t}. + We assume that the manager operation valid, thus its gas limit can + never be zero. We treat this case the same as gas_limit = 1 for the + sake of simplicity. +*) +let weight_manager : + type kind. + kind Kind.manager contents_list -> Q.t * Signature.public_key_hash = + fun op -> + let fee, glimit = cumulate_fee_and_gas_of_manager op in + let source = + match op with + | Cons (Manager_operation {source; _}, _) -> source + | Single (Manager_operation {source; _}) -> source + in + let fee_f = Q.of_int64 (Tez_repr.to_mutez fee) in + if Gas_limit_repr.Arith.(glimit = Gas_limit_repr.Arith.zero) then + (fee_f, source) + else + let gas_f = Q.of_bigint (Gas_limit_repr.Arith.integral_to_z glimit) in + (Q.(fee_f / gas_f), source) + +(** Computing the {!operation_weight} of an operation. [weight_of + (Failing_noop _)] is unreachable, for completness we define a + Weight_noop which carrries no information. *) +let weight_of : packed_operation -> operation_weight = + fun op -> + let (Operation_data protocol_data) = op.protocol_data in + match protocol_data.contents with + | Single (Failing_noop _) -> W (Noop, Weight_noop) + | Single (Preendorsement consensus_content) -> + W + ( Consensus, + Weight_preendorsement + (endorsement_infos_from_consensus_content consensus_content) ) + | Single (Endorsement consensus_content) -> + W + ( Consensus, + Weight_endorsement + (endorsement_infos_from_consensus_content consensus_content) ) + | Single (Dal_slot_availability (endorser, endorsements)) -> + W + ( Consensus, + Weight_dal_slot_availability + (Dal_endorsement_repr.occupied_size_in_bits endorsements, endorser) + ) + | Single (Proposals {period; source; _}) -> + W (Voting, Weight_proposals (period, source)) + | Single (Ballot {period; source; _}) -> + W (Voting, Weight_ballot (period, source)) + | Single (Seed_nonce_revelation {level; _}) -> + W (Anonymous, Weight_seed_nonce_revelation (Raw_level_repr.to_int32 level)) + | Single (Vdf_revelation {solution}) -> + W (Anonymous, Weight_vdf_revelation solution) + | Single (Double_endorsement_evidence {op1; _}) -> ( + match op1.protocol_data.contents with + | Single (Endorsement consensus_content) -> + W + ( Anonymous, + Weight_double_endorsement + (round_infos_from_consensus_content consensus_content) )) + | Single (Double_preendorsement_evidence {op1; _}) -> ( + match op1.protocol_data.contents with + | Single (Preendorsement consensus_content) -> + W + ( Anonymous, + Weight_double_preendorsement + (round_infos_from_consensus_content consensus_content) )) + | Single (Double_baking_evidence {bh1; _}) -> + let double_baking_infos = + consensus_infos_and_hash_from_block_header bh1 + in + W (Anonymous, Weight_double_baking double_baking_infos) + | Single (Activate_account {id; _}) -> + W (Anonymous, Weight_activate_account id) + | Single (Manager_operation _) as ops -> + let manweight, src = weight_manager ops in + W (Manager, Weight_manager (manweight, src)) + | Cons (Manager_operation _, _) as ops -> + let manweight, src = weight_manager ops in + W (Manager, Weight_manager (manweight, src)) + +(** {3 Comparisons of operations {!weight}} *) + +(** {4 Helpers} *) + +(** compare a pair of elements in lexicographic order. *) +let compare_pair_in_lexico_order ~cmp_fst ~cmp_snd (a1, b1) (a2, b2) = + let resa = cmp_fst a1 a2 in + if Compare.Int.(resa <> 0) then resa else cmp_snd b1 b2 + +(** compare in reverse order. *) +let compare_reverse (cmp : 'a -> 'a -> int) a b = cmp b a + +(** {4 Comparison of {!consensus_infos}} *) + +(** Two {!round_infos} compares as the pair of [level, round] in + lexicographic order: the one with the greater [level] being the + greater [round_infos]. When levels are the same, the one with the + greater [round] being the better. + + The greater {!round_infos} is the farther to the current state + when part of the weight of a valid consensus operation. + + The best {!round_infos} is the nearer to the current state when + part of the weight of a valid denunciation. + + In both case, that is the greater according to the lexicographic + order. + + Precondition: the {!round_infos} are from valid operation. They + have been computed by either {!round_infos_from_consensus_content} + or {!consensus_infos_and_hash_from_block_header}. Both input + parameter from valid operations and put (-1) to the [round] in the + unreachable path where the original round fails to convert in + {!int}. *) +let compare_round_infos infos1 infos2 = + compare_pair_in_lexico_order + ~cmp_fst:Compare.Int32.compare + ~cmp_snd:Compare.Int.compare + (infos1.level, infos1.round) + (infos2.level, infos2.round) + +(** When comparing {!Endorsement} to {!Preendorsement} or + {!Double_endorsement_evidence} to {!Double_preendorsement}, in case + of {!round_infos} equality, the position is relevant to compute the + order. *) +type prioritized_position = Nopos | Fstpos | Sndpos + +(** Comparison of two {!round_infos} with priority in case of + {!round_infos} equality. *) +let compare_round_infos_with_prioritized_position ~prioritized_position infos1 + infos2 = + let cmp = compare_round_infos infos1 infos2 in + if Compare.Int.(cmp <> 0) then cmp + else match prioritized_position with Fstpos -> 1 | Sndpos -> -1 | Nopos -> 0 + +(** When comparing consensus operation with {!endorsement_infos}, in + case of equality of their {!round_infos}, either they are of the + same kind and their [slot] have to be compared in the reverse + order, otherwise the {!Endorsement} is better and + [prioritized_position] gives its position. *) +let compare_prioritized_position_or_slot ~prioritized_position = + match prioritized_position with + | Nopos -> compare_reverse Compare.Int.compare + | Fstpos -> fun _ _ -> 1 + | Sndpos -> fun _ _ -> -1 + +(** Two {!endorsement_infos} are compared by their {!round_infos}. + When their {!round_infos} are equal, they are compared according to + their priority or their [slot], see + {!compare_prioritized_position_or_slot} for more details. *) +let compare_endorsement_infos ~prioritized_position (infos1 : endorsement_infos) + (infos2 : endorsement_infos) = + compare_pair_in_lexico_order + ~cmp_fst:compare_round_infos + ~cmp_snd:(compare_prioritized_position_or_slot ~prioritized_position) + (infos1.round, infos1.slot) + (infos2.round, infos2.slot) + +(** Two {!double_baking_infos} are compared as their {!round_infos}. + When their {!round_infos} are equal, they are compared as the + hashes of their first denounced block header. *) +let compare_baking_infos infos1 infos2 = + compare_pair_in_lexico_order + ~cmp_fst:compare_round_infos + ~cmp_snd:Block_hash.compare + (infos1.round, infos1.bh_hash) + (infos2.round, infos2.bh_hash) + +(** Two valid {!Dal_slot_availability} are compared in the + lexicographic order of their pairs of bitsets size and endorser + hash. *) +let compare_dal_slot_availability (endorsements1, endorser1) + (endorsements2, endorser2) = + compare_pair_in_lexico_order + ~cmp_fst:Compare.Int.compare + ~cmp_snd:Signature.Public_key_hash.compare + (endorsements1, endorser1) + (endorsements2, endorser2) + +(** {4 Comparison of valid operations of the same validation pass} *) + +(** {5 Comparison of valid consensus operations} *) + +(** Comparing consensus operations by their [weight] uses the + comparison on {!endorsement_infos} for {!Endorsement} and + {!Preendorsement}: see {!endorsement_infos} for more details. + + {!Dal_slot_availability} is smaller than the other kinds of + consensus operations. Two valid {!Dal_slot_availability} are + compared by {!compare_dal_slot_availability}. *) +let compare_consensus_weight w1 w2 = + match (w1, w2) with + | Weight_endorsement infos1, Weight_endorsement infos2 -> + compare_endorsement_infos ~prioritized_position:Nopos infos1 infos2 + | Weight_preendorsement infos1, Weight_preendorsement infos2 -> + compare_endorsement_infos ~prioritized_position:Nopos infos1 infos2 + | Weight_endorsement infos1, Weight_preendorsement infos2 -> + compare_endorsement_infos ~prioritized_position:Fstpos infos1 infos2 + | Weight_preendorsement infos1, Weight_endorsement infos2 -> + compare_endorsement_infos ~prioritized_position:Sndpos infos1 infos2 + | ( Weight_dal_slot_availability (size1, endorser1), + Weight_dal_slot_availability (size2, endorser2) ) -> + compare_dal_slot_availability (size1, endorser1) (size2, endorser2) + | ( Weight_dal_slot_availability _, + (Weight_endorsement _ | Weight_preendorsement _) ) -> + -1 + | ( (Weight_endorsement _ | Weight_preendorsement _), + Weight_dal_slot_availability _ ) -> + 1 + +(** {5 Comparison of valid voting operations} *) + +(** Two valid voting operations of the same kind are compared in the + lexicographic order of their pair of [period] and [source]. When + compared to each other, the {!Proposals} is better. *) +let compare_vote_weight w1 w2 = + let cmp i1 source1 i2 source2 = + compare_pair_in_lexico_order + (i1, source1) + (i2, source2) + ~cmp_fst:Compare.Int32.compare + ~cmp_snd:Signature.Public_key_hash.compare + in + match (w1, w2) with + | Weight_proposals (i1, source1), Weight_proposals (i2, source2) -> + cmp i1 source1 i2 source2 + | Weight_ballot (i1, source1), Weight_ballot (i2, source2) -> + cmp i1 source1 i2 source2 + | Weight_ballot _, Weight_proposals _ -> -1 + | Weight_proposals _, Weight_ballot _ -> 1 + +(** {5 Comparison of valid anonymous operations} *) + +(** Comparing two {!Double_endorsement_evidence}, or two + {!Double_preendorsement_evidence}, or comparing them to each other + is comparing their {!round_infos}, see {!compare_round_infos} for + more details. + + Comparing two {!Double_baking_evidence} is comparing as their + {!double_baking_infos}, see {!compare_double_baking_infos} for more + details. + + Two {!Seed_nonce_revelation} are compared by their [level]. + + Two {!Vdf_revelation} are compared by their [solution]. + + Two {!Activate_account} are compared as their [id]. + + When comparing different kind of anonymous operations, the order is + as follows: {!Double_preendorsement_evidence} > + {!Double_endorsement_evidence} > {!Double_baking_evidence} > + {!Vdf_revelation} > {!Seed_nonce_revelation} > {!Activate_account}. + *) +let compare_anonymous_weight w1 w2 = + match (w1, w2) with + | Weight_double_preendorsement infos1, Weight_double_preendorsement infos2 -> + compare_round_infos infos1 infos2 + | Weight_double_preendorsement infos1, Weight_double_endorsement infos2 -> + compare_round_infos_with_prioritized_position + ~prioritized_position:Fstpos + infos1 + infos2 + | Weight_double_endorsement infos1, Weight_double_preendorsement infos2 -> + compare_round_infos_with_prioritized_position + ~prioritized_position:Sndpos + infos1 + infos2 + | Weight_double_endorsement infos1, Weight_double_endorsement infos2 -> + compare_round_infos infos1 infos2 + | ( ( Weight_double_baking _ | Weight_seed_nonce_revelation _ + | Weight_vdf_revelation _ | Weight_activate_account _ ), + (Weight_double_preendorsement _ | Weight_double_endorsement _) ) -> + -1 + | ( (Weight_double_preendorsement _ | Weight_double_endorsement _), + ( Weight_double_baking _ | Weight_seed_nonce_revelation _ + | Weight_vdf_revelation _ | Weight_activate_account _ ) ) -> + 1 + | Weight_double_baking infos1, Weight_double_baking infos2 -> + compare_baking_infos infos1 infos2 + | ( ( Weight_seed_nonce_revelation _ | Weight_vdf_revelation _ + | Weight_activate_account _ ), + Weight_double_baking _ ) -> + -1 + | ( Weight_double_baking _, + ( Weight_seed_nonce_revelation _ | Weight_vdf_revelation _ + | Weight_activate_account _ ) ) -> + 1 + | Weight_vdf_revelation solution1, Weight_vdf_revelation solution2 -> + Seed_repr.compare_vdf_solution solution1 solution2 + | ( (Weight_seed_nonce_revelation _ | Weight_activate_account _), + Weight_vdf_revelation _ ) -> + -1 + | ( Weight_vdf_revelation _, + (Weight_seed_nonce_revelation _ | Weight_activate_account _) ) -> + 1 + | Weight_seed_nonce_revelation l1, Weight_seed_nonce_revelation l2 -> + Compare.Int32.compare l1 l2 + | Weight_activate_account _, Weight_seed_nonce_revelation _ -> -1 + | Weight_seed_nonce_revelation _, Weight_activate_account _ -> 1 + | Weight_activate_account pkh1, Weight_activate_account pkh2 -> + Ed25519.Public_key_hash.compare pkh1 pkh2 + +(** {5 Comparison of valid {!Manager_operation}} *) + +(** Two {!Manager_operation} are compared in the lexicographic order + of their pair of their [fee]/[gas] ratio -- as computed by + {!weight_manager} -- and their [source]. *) +let compare_manager_weight weight1 weight2 = + match (weight1, weight2) with + | Weight_manager (manweight1, source1), Weight_manager (manweight2, source2) + -> + compare_pair_in_lexico_order + (manweight1, source1) + (manweight2, source2) + ~cmp_fst:Compare.Q.compare + ~cmp_snd:Signature.Public_key_hash.compare + +(** Two {!operation_weight} are compared by their [pass], see + {!compare_inner_pass} for more details. When they have the same + [pass], they are compared by their [weight]. *) +let compare_operation_weight w1 w2 = + match (w1, w2) with + | W (Consensus, w1), W (Consensus, w2) -> compare_consensus_weight w1 w2 + | W (Voting, w1), W (Voting, w2) -> compare_vote_weight w1 w2 + | W (Anonymous, w1), W (Anonymous, w2) -> compare_anonymous_weight w1 w2 + | W (Manager, w1), W (Manager, w2) -> compare_manager_weight w1 w2 + | W (pass1, _), W (pass2, _) -> compare_inner_pass pass1 pass2 + +(** {3 Compare two valid operations} *) + +(** Two valid operations are compared as their {!operation_weight}, + see {!compare_operation_weight} for more details. + + When they are equal according to their {!operation_weight} comparison, they + compare as their hash. + Hence, [compare] returns [0] only when the hashes of both operations are + equal. + + Preconditions: [oph1] is the hash of [op1]; [oph2] the one of [op2]; and + [op1] and [op2] are both valid. *) +let compare (oph1, op1) (oph2, op2) = + let cmp_h = Operation_hash.(compare oph1 oph2) in + if Compare.Int.(cmp_h = 0) then 0 + else + let cmp = compare_operation_weight (weight_of op1) (weight_of op2) in + if Compare.Int.(cmp = 0) then cmp_h else cmp diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index 5131ca50357ac445a184a12dbf135536d57f4618..47fcf49c13136b4d2e25502697dc8e64e753c3a9 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -604,7 +604,91 @@ val hash : _ operation -> Operation_hash.t val hash_packed : packed_operation -> Operation_hash.t -val acceptable_passes : packed_operation -> int list +(** Each operation belongs to a validation pass that is an integer + abstracting its priority in a block. Except Failing_noop. *) + +(** The validation pass of consensus operations. *) +val consensus_pass : int + +(** The validation pass of voting operations. *) +val voting_pass : int + +(** The validation pass of anonymous operations. *) +val anonymous_pass : int + +(** The validation pass of anonymous operations. *) +val manager_pass : int + +(** [acceptable_pass op] returns either the validation_pass of [op] + when defines and None when [op] is [Failing_noop]. *) +val acceptable_pass : packed_operation -> int option + +(** [compare_by_passes] orders two operations in the reverse order of + their acceptable passes. *) +val compare_by_passes : packed_operation -> packed_operation -> int + +(** [compare (oph1,op1) (oph2,op2)] defines a total ordering relation + on operations. + + The following requirements must be satisfied: [oph1] is the + [Operation.hash op1], [oph2] is [Operation.hash op2], and that + [op1] and [op2] are valid in the same context. + + [compare (oph1,op1) (oph2,op2) = 0] happens only if + [Operation_hash.compare oph1 oph2 = 0], meaning when [op1] and + [op2] are structurally identical. + + Two valid operations of different [validation_pass] are compared + according to {!acceptable_passes}: the one with the smaller pass + being the greater. + + Two valid operations of the same [validation_pass] are compared + according to a [weight], computed thanks to their static + information. + + The global order is as follows: + + {!Endorsement} and {!Preendorsement} > {!Dal_slot_availability} > + {!Proposals} > {!Ballot} > {!Double_preendorsement_evidence} > + {!Double_endorsement_evidence} > {!Double_baking_evidence} > + {!Vdf_revelation} > {!Seed_nonce_revelation} > {!Activate_account} + > {!Manager_operation}. + + {!Endorsement} and {!Preendorsement} are compared by the pair of + their [level] and [round] such as the farther to the current state + [level] and [round] is greater;e.g. the greater pair in + lexicographic order being the better. When equal and both + operations being of the same kind, we compare their [slot]: the + The smaller begin the better; assuming that the more an endorser has + slots, the smaller is its smaller [slot]. When the pair is equal + and comparing an {!Endorsement] to a {!Preendorsement}, the + {!Endorsement} is better. + + Two {!Dal_slot_availability} are compared in the lexicographic + order of the pair of their number of endorsed slots as available + and their endorsers. + + Two voting operations are compared in the lexicographic order of + the pair of their [period] and [source]. A {!Proposals} is better + than a {!Ballot}. + + Two denunciations of the same kind are compared such as the farther + to the current state the better. For {!Double_baking_evidence} + in the case of equality, they are compared by the hashes of their first + denounced block_header. + + Two {!Vdf_revelation} are compared as their [solution]. + + Two {!Seed_nonce_relevation} are compared as their [level]. + + Two {!Activate_account} are compared as their [id]. + + Two {!Manager_operation} are compared in the lexicographic order of + the pair of their [fee]/[gas_limit] ratios and [source]. *) +val compare : + Operation_hash.t * packed_operation -> + Operation_hash.t * packed_operation -> + int type error += Missing_signature (* `Permanent *) diff --git a/src/proto_alpha/lib_protocol/seed_repr.ml b/src/proto_alpha/lib_protocol/seed_repr.ml index dac874d51e223dc2a72b5e64e18a7dc14354784b..2149807533e3a02c37cb5cab016829725a9e608e 100644 --- a/src/proto_alpha/lib_protocol/seed_repr.ml +++ b/src/proto_alpha/lib_protocol/seed_repr.ml @@ -258,3 +258,10 @@ let seed_status_encoding = let to_bool = function RANDAO_seed -> false | VDF_seed -> true in let of_bool t = if t then VDF_seed else RANDAO_seed in Data_encoding.conv to_bool of_bool Data_encoding.bool + +let compare_vdf_solution solution solution' = + let result, _ = solution in + let result', _ = solution' in + Compare.Bytes.compare + (Vdf.result_to_bytes result) + (Vdf.result_to_bytes result') diff --git a/src/proto_alpha/lib_protocol/seed_repr.mli b/src/proto_alpha/lib_protocol/seed_repr.mli index 9816c1e98c298c16e77c0270b942c80b7ad36306..343e8405ba84a53903711c29c4fc1464a80ce948 100644 --- a/src/proto_alpha/lib_protocol/seed_repr.mli +++ b/src/proto_alpha/lib_protocol/seed_repr.mli @@ -51,6 +51,10 @@ type vdf_solution = Vdf.result * Vdf.proof val pp_solution : Format.formatter -> vdf_solution -> unit +(** Compare only the first element of two vdf_solution, that are + of [Vdf.result]. *) +val compare_vdf_solution : vdf_solution -> vdf_solution -> int + val generate_vdf_setup : seed_discriminant:seed -> seed_challenge:seed -> vdf_setup diff --git a/src/proto_alpha/lib_protocol/test/helpers/block.ml b/src/proto_alpha/lib_protocol/test/helpers/block.ml index 9e41417caef8cb2e3862d105edcaffecc9fac123..b0cbcd5e536b3b889abf656f5e96c2fd61040696 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/block.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/block.ml @@ -180,9 +180,9 @@ module Forge = struct let t = Array.make validation_passes_len [] in List.iter (fun (op : packed_operation) -> - List.iter - (fun pass -> t.(pass) <- op :: t.(pass)) - (Main.acceptable_passes op)) + match Main.acceptable_pass op with + | None -> () + | Some pass -> t.(pass) <- op :: t.(pass)) operations ; let t = Array.map List.rev t in Array.to_list t diff --git a/src/proto_alpha/lib_protocol/test/helpers/operation_generator.ml b/src/proto_alpha/lib_protocol/test/helpers/operation_generator.ml new file mode 100644 index 0000000000000000000000000000000000000000..723a30400d2b028ec4d716c1bd635adfaa7c7eed --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/helpers/operation_generator.ml @@ -0,0 +1,932 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Protocol +open Alpha_context +module Random = Random.State + +type random_state = {seed : int; rnd_state : Random.t} + +let choose_list_element random_state l = + Stdlib.List.nth l (Random.int random_state.rnd_state (List.length l)) + +let consensus_pass = `PConsensus + +let anonymous_pass = `PAnonymous + +let vote_pass = `PVote + +let manager_pass = `PManager + +let all_passes = [`PConsensus; `PAnonymous; `PVote; `PManager] + +let consensus_kinds = [`KPreendorsement; `KEndorsement; `KDal_slot] + +let anonymous_kinds = + [ + `KSeed_nonce_revelation; + `KVdf_revelation; + `KDouble_endorsement; + `KDouble_preendorsement; + `KDouble_baking; + `KActivate_account; + ] + +let vote_kinds = [`KProposals; `KBallot] + +(* N.b. we do not consider Failing_noop as those will never be valid. *) +let manager_kinds = + [ + `KReveal; + `KTransaction; + `KOrigination; + `KDelegation; + `KSet_deposits_limit; + `KIncrease_paid_storage; + `KRegister_global_constant; + `KTx_rollup_origination; + `KTx_rollup_submit_batch; + `KTx_rollup_commit; + `KTx_rollup_return_bond; + `KTx_rollup_finalize_commitment; + `KTx_rollup_remove_commitment; + `KTx_rollup_rejection; + `KTx_rollup_dispatch_tickets; + `KTransfer_ticket; + `KDal_publish_slot_header; + `KSc_rollup_originate; + `KSc_rollup_add_messages; + `KSc_rollup_cement; + `KSc_rollup_publish; + `KSc_rollup_refute; + `KSc_rollup_timeout; + `KSc_rollup_execute_outbox_message; + `KSc_rollup_recover_bond; + `KSc_rollup_dal_slot_subscribe; + ] + +let pass_to_operation_kinds = function + | `PConsensus -> consensus_kinds + | `PVote -> vote_kinds + | `PAnonymous -> anonymous_kinds + | `PManager -> [`KManager] + +let pp_kind fmt k = + Format.fprintf + fmt + "%s" + (match k with + | `KPreendorsement -> "KPreendorsement" + | `KEndorsement -> "KEndorsement" + | `KDal_slot -> "KDal_slot" + | `KSeed_nonce_revelation -> "KSeed_nonce_revelation" + | `KVdf_revelation -> "KVdf_revelation" + | `KDouble_endorsement -> "KDouble_endorsement" + | `KDouble_preendorsement -> "KDouble_preendorsement" + | `KDouble_baking -> "KDouble_baking" + | `KActivate_account -> "KActivate_account" + | `KProposals -> "KProposals" + | `KBallot -> "KBallot" + | `KManager -> "KManager") + +let block_hashes = + List.map + Block_hash.of_b58check_exn + [ + "BLbcVY1kYiKQy2MJJfoHJMN2xRk5QPG1PEKWMDSyW2JMxBsMmiL"; + "BLFhLKqQQn32Cc9QXqtEqysYqWNCowNKaypVHP5zEyZcywbXcHo"; + "BLuurCvGmNPTzXSnGCpcFPy5h8A49PwH2LnfAWBnp5R1qv5czwe"; + ] + +let random_shell random_state : Tezos_base.Operation.shell_header = + {branch = choose_list_element random_state block_hashes} + +let random_slot random_state = + choose_list_element random_state [100; 200; 300] + |> Slot.of_int_do_not_use_except_for_parameters + +let random_level random_state = + choose_list_element random_state [10l; 20l; 30l] |> Raw_level.of_int32 + |> function + | Ok v -> v + | Error _ -> assert false + +let random_round random_state = + choose_list_element random_state [0l; 1l; 2l] |> Round.of_int32 |> function + | Ok v -> v + | Error _ -> assert false + +let payload_hashes = + List.map + Block_payload_hash.of_b58check_exn + [ + "vh2gWcSUUhJBwvjx4vS7JN5ioMVWpHCSK6W2MKNPr5dn6NUdfFDQ"; + "vh1p1VzeYjZLEW6WDqdTwVy354KEmGCDgPmagEKcLN4NT4X58mNk"; + "vh2TyrWeZ2dydEy9ZjmvrjQvyCs5sdHZPypcZrXDUSM1tNuPermf"; + ] + +let random_payload_hash random_state = + choose_list_element random_state payload_hashes + +let generate_consensus_content random_state : consensus_content = + let slot = random_slot random_state in + let level = random_level random_state in + let round = random_round random_state in + let block_payload_hash = random_payload_hash random_state in + {slot; level; round; block_payload_hash} + +let signatures = + List.map + Signature.of_b58check_exn + [ + "sigaNsiye7D8dJHKSQZBwDbS2aQNXipDP7bw8uQnMgnaXi5pcnoPZRKXrDeFRx4FjWJD2xfyUA9CuBXhwPHhVs7LxkL4vT32"; + "sigvtPBMQvk2DgNtu3AKFU1ZRsagGxsoiZVQyQhJNEojReBY2vE5sDwt3H7Mh8RMe27QHBjemxqhMVVszZqpNsdDux6KAELX"; + "sighje7pEbUUwGtJ4GTP7uzMZe5SFz6dRRC3BvZBHnrRHnc47WHGnVdfiscHPMek7esmj7saTuj54QBWy3SezyA2EGbHkmW5"; + ] + +let random_signature random_state = + Some (choose_list_element random_state signatures) + +let pkhs = + List.map + Signature.Public_key_hash.of_b58check_exn + [ + "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"; + "tz1b7tUupMgCNw2cCLpKTkSD1NZzB5TkP2sv"; + "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU"; + ] + +let random_pkh random_state = choose_list_element random_state pkhs + +let pks = + List.map + Signature.Public_key.of_b58check_exn + [ + "edpkuSLWfVU1Vq7Jg9FucPyKmma6otcMHac9zG4oU1KMHSTBpJuGQ2"; + "edpkv8EUUH68jmo3f7Um5PezmfGrRF24gnfLpH3sVNwJnV5bVCxL2n"; + "edpkuFrRoDSEbJYgxRtLx2ps82UdaYc1WwfS9sE11yhauZt5DgCHbU"; + ] + +let random_pk random_state = choose_list_element random_state pks + +let random_fee random_state = + choose_list_element random_state [Tez.zero; Tez.one_cent; Tez.one] + +let random_amount random_state = + choose_list_element random_state [Tez.zero; Tez.one_cent; Tez.one] + +let random_amount_in_bytes random_state = + choose_list_element random_state [Z.zero; Z.one; Z.of_int 100] + +let contract_hashes = + List.map + Contract_hash.of_b58check_exn + [ + "KT1WvzYHCNBvDSdwafTHv7nJ1dWmZ8GCYuuC"; + "KT1NkWx47WzJeHCSyB62WjLtFn4tRf3uXBur"; + "KT1RJ6PbjHpwc3M5rw5s2Nbmefwbuwbdxton"; + ] + +let random_contract_hash random_state = + choose_list_element random_state contract_hashes + +let random_contract random_state = + if Random.bool random_state.rnd_state then + Contract.Implicit (random_pkh random_state) + else + let contract_hash = random_contract_hash random_state in + Contract.Originated contract_hash + +let random_contract_hash random_state = + choose_list_element random_state contract_hashes + +let counters = List.map Z.of_int [123; 456; 789] + +let random_counter random_state = choose_list_element random_state counters + +let random_gas_limit random_state = + choose_list_element + random_state + Gas.Arith.[zero; integral_of_int_exn 1_000; integral_of_int_exn 10_000] + +let random_storage_limit random_state = + choose_list_element random_state Z.[zero; of_int 1_000; of_int 10_000] + +let block_headers = + let bh1 = + {json|{ "level": 2, "proto": 1, "predecessor": "BLbcVY1kYiKQy2MJJfoHJMN2xRk5QPG1PEKWMDSyW2JMxBsMmiL", "timestamp": "2022-08-08T11:16:30Z", "validation_pass": 4, "operations_hash": "LLoa7bxRTKaQN2bLYoitYB6bU2DvLnBAqrVjZcvJ364cTcX2PZYKU", "fitness": [ "02", "00000002", "", "ffffffff", "00000001" ], "context": "CoUvpF8XBUfz3w9CJumt4ZKGZkrcdcfs1Qdrrd1ZeFij64E1QCud", "payload_hash": "vh2TyrWeZ2dydEy9ZjmvrjQvyCs5sdHZPypcZrXDUSM1tNuPermf", "payload_round": 1, "proof_of_work_nonce": "62de1e0d00000000", "liquidity_baking_toggle_vote": "pass", "signature": "sigaXGo4DWsZwo1SvbKCp2hLgE5jcwd61Ufkc3iMt3sXy3NBj9jticuJKJnRhyH2ZPJQMwEuDqQTgZgoK5xRH6HeF7YxLb4u" }|json} + in + let bh2 = + {json|{ "level": 3, "proto": 1, "predecessor": "BLAUNUbzKHgA4DYQEXCbxY73wdE2roGAzvJJbFp8dQe62Ekpada", "timestamp": "2022-08-08T11:16:32Z", "validation_pass": 4, "operations_hash": "LLoaWjBX8Cm8DVpoLNtm7FPNnxUdL6Dakq122pVfNHYaf2rE9GQXi", "fitness": [ "02", "00000003", "", "fffffffe", "00000000" ], "context": "CoUtWowJUqXwMm4pbR1jjyFfVRHqRHGs6bYVDaaByvbmULoAND2x", "payload_hash": "vh1p1VzeYjZLEW6WDqdTwVy354KEmGCDgPmagEKcLN4NT4X58mNk", "payload_round": 0, "proof_of_work_nonce": "62de1e0d00000000", "liquidity_baking_toggle_vote": "pass", "signature": "sigVqWWE7BPuxHqPWiVRmzQ1eMZZAPAxGJ94ytY2sjV8Y1Z4QH1F2bPGZS1ZeWDbqmcppPPFobRpi7wNasQ17Mm9CFGKag2t" }|json} + in + let bh3 = + {json|{ "level": 4, "proto": 1, "predecessor": "BLuurCvGmNPTzXSnGCpcFPy5h8A49PwH2LnfAWBnp5R1qv5czwe", "timestamp": "2022-08-08T11:16:33Z", "validation_pass": 4, "operations_hash": "LLoaf8AANzyNxhk715zykDrwG5Bpqw6FsZLWWNp2Dcm3ewFrcc3Wc", "fitness": [ "02", "00000004", "", "ffffffff", "00000000" ], "context": "CoVzxEBMDhxpGVxrguik6r5qVogJBFyhuvwm2KZBcsmvqhekPiwL", "payload_hash": "vh2gWcSUUhJBwvjx4vS7JN5ioMVWpHCSK6W2MKNPr5dn6NUdfFDQ", "payload_round": 0, "proof_of_work_nonce": "62de1e0d00000000", "seed_nonce_hash": "nceV3VjdHp1yk6uqcQicQBxLJY1AfWvLSabQpqnpiqkC1q2tS35EN", "liquidity_baking_toggle_vote": "pass", "signature": "sigijumaDLSQwjh2AKK7af1VcEDsZsRwbweL8hF176puhHy3ySVocNCbrwPqJLiQP8EbqY5YL6z6b1vDaw12h8MQU2Rh4SW1" }|json} + in + List.map + (fun s -> + let open Data_encoding.Json in + from_string s |> function + | Ok json -> destruct Alpha_context.Block_header.encoding json + | Error _ -> assert false) + [bh1; bh2; bh3] + +let random_block_header random_state = + choose_list_element random_state block_headers + +let nonces = + List.map + (fun i -> + let b = Bytes.create 32 in + Bytes.set_int8 b 0 i ; + Alpha_context.Nonce.of_bytes b |> function + | Ok v -> v + | Error _ -> assert false) + [1; 2; 3] + +let random_nonce random_state = choose_list_element random_state nonces + +let random_option f random_state = + if Random.bool random_state.rnd_state then Some (f random_state) else None + +let tx_rollups = + List.filter_map + Tx_rollup.of_b58check_opt + [ + "txr1hFmPcr5y1P2xTm7W2y1sfjLLCUdzCZGvg"; + "txr1jux4nZWf8ToGZc4ojLBbT538BBTTSiJUD"; + "txr1TAFTENC2YACvoMDrpJHCbdvdfSSjcjEjc"; + ] + +let random_tx_rollup random_state = choose_list_element random_state tx_rollups + +let sc_rollups = + List.map + Sc_rollup.Address.of_b58check_exn + [ + "scr1FPSu51gGtyv9S5HqDqXeH16DJviJ9qpr6"; + "scr1U39BVdpVQun1QjjiXfd3XgoBKcenWt5sb"; + "scr1Kqqbvust2adJMtSu2V4fcd49oQHug4BLb"; + ] + +let random_sc_rollup random_state = choose_list_element random_state sc_rollups + +let protos = + List.map + (fun s -> Protocol_hash.of_b58check_exn s) + [ + "ProtoALphaALphaALphaALphaALphaALphaALpha61322gcLUGH"; + "ProtoALphaALphaALphaALphaALphaALphaALphabc2a7ebx6WB"; + "ProtoALphaALphaALphaALphaALphaALphaALpha84efbeiF6cm"; + "ProtoALphaALphaALphaALphaALphaALphaALpha91249Z65tWS"; + "ProtoALphaALphaALphaALphaALphaALphaALpha537f5h25LnN"; + "ProtoALphaALphaALphaALphaALphaALphaALpha5c8fefgDYkr"; + "ProtoALphaALphaALphaALphaALphaALphaALpha3f31feSSarC"; + "ProtoALphaALphaALphaALphaALphaALphaALphabe31ahnkxSC"; + "ProtoALphaALphaALphaALphaALphaALphaALphabab3bgRb7zQ"; + "ProtoALphaALphaALphaALphaALphaALphaALphaf8d39cctbpk"; + "ProtoALphaALphaALphaALphaALphaALphaALpha3b981byuYxD"; + "ProtoALphaALphaALphaALphaALphaALphaALphaa116bccYowi"; + "ProtoALphaALphaALphaALphaALphaALphaALphacce68eHqboj"; + "ProtoALphaALphaALphaALphaALphaALphaALpha225c7YrWwR7"; + "ProtoALphaALphaALphaALphaALphaALphaALpha58743cJL6FG"; + "ProtoALphaALphaALphaALphaALphaALphaALphac91bcdvmJFR"; + "ProtoALphaALphaALphaALphaALphaALphaALpha1faaadhV7oW"; + "ProtoALphaALphaALphaALphaALphaALphaALpha98232gD94QJ"; + "ProtoALphaALphaALphaALphaALphaALphaALpha9d1d8cijvAh"; + "ProtoALphaALphaALphaALphaALphaALphaALphaeec52dKF6Gx"; + "ProtoALphaALphaALphaALphaALphaALphaALpha841f2cQqajX"; + ] + +let random_proto random_state = choose_list_element random_state protos + +let generate_op random_state (gen_op : random_state -> 'kind contents_list) : + 'kind operation = + let shell = random_shell random_state in + let signature = random_signature random_state in + let contents = gen_op random_state in + let protocol_data = {contents; signature} in + {shell; protocol_data} + +let generate_preendorsement random_state = + let gen random_state = + Single (Preendorsement (generate_consensus_content random_state)) + in + generate_op random_state gen + +let generate_endorsement random_state : Kind.endorsement Operation.t = + let gen random_state = + Single (Endorsement (generate_consensus_content random_state)) + in + generate_op random_state gen + +let generate_dal_slot random_state : Kind.dal_slot_availability Operation.t = + let gen random_state = + let pkh = random_pkh random_state in + let dal_endorsement = Dal.Endorsement.empty in + Single (Dal_slot_availability (pkh, dal_endorsement)) + in + generate_op random_state gen + +let generate_seed_nonce_revelation random_state : + Kind.seed_nonce_revelation Operation.t = + let gen random_state = + let level = random_level random_state in + let nonce = random_nonce random_state in + Single (Seed_nonce_revelation {level; nonce}) + in + generate_op random_state gen + +let vdf_solutions = + let open Environment.Vdf in + let opt_assert = function Some v -> v | None -> assert false in + List.map + (fun i -> + let b = Bytes.create form_size_bytes in + Bytes.set_int8 b 0 i ; + let result = result_of_bytes_opt b |> opt_assert in + let proof = proof_of_bytes_opt b |> opt_assert in + (result, proof)) + [1; 2; 3] + +let random_vdf_solution random_state = + choose_list_element random_state vdf_solutions + +let generate_vdf_revelation random_state : Kind.vdf_revelation Operation.t = + let gen random_state = + let solution = random_vdf_solution random_state in + Single (Vdf_revelation {solution}) + in + generate_op random_state gen + +let generate_double_preendorsement random_state : + Kind.double_preendorsement_evidence Operation.t = + let gen random_state = + let op1 = generate_preendorsement random_state in + let op2 = generate_preendorsement random_state in + Single (Double_preendorsement_evidence {op1; op2}) + in + generate_op random_state gen + +let generate_double_endorsement random_state : + Kind.double_endorsement_evidence Operation.t = + let gen random_state = + let op1 = generate_endorsement random_state in + let op2 = generate_endorsement random_state in + Single (Double_endorsement_evidence {op1; op2}) + in + generate_op random_state gen + +let generate_double_baking random_state : + Kind.double_baking_evidence Operation.t = + let gen random_state = + let bh1 = random_block_header random_state in + let bh2 = random_block_header random_state in + Single (Double_baking_evidence {bh1; bh2}) + in + generate_op random_state gen + +let generate_manager_aux : + type kind. + public_key_hash option -> + random_state -> + (random_state -> kind manager_operation) -> + kind Kind.manager contents = + fun opt_source random_state gen_op -> + let source = + match opt_source with + | None -> random_pkh random_state + | Some source -> source + in + let fee = random_fee random_state in + let counter = random_counter random_state in + let operation = gen_op random_state in + let gas_limit = random_gas_limit random_state in + let storage_limit = random_storage_limit random_state in + Manager_operation {source; fee; counter; operation; gas_limit; storage_limit} + +let generate_manager random_state + (gen_op : random_state -> 'kind manager_operation) : + 'kind Kind.manager Operation.t = + let source = Some (random_pkh random_state) in + let shell = random_shell random_state in + let signature = random_signature random_state in + let contents = Single (generate_manager_aux source random_state gen_op) in + let protocol_data = {contents; signature} in + {shell; protocol_data} + +let generate_managers random_state gen_ops = + let source = Some (random_pkh random_state) in + let ops_as_single = + List.map + (fun gen_op -> Contents (generate_manager_aux source random_state gen_op)) + gen_ops + in + Operation.of_list ops_as_single + +let generate_reveal random_state : Kind.reveal Kind.manager Operation.t = + let gen random_state = Reveal (random_pk random_state) in + generate_manager random_state gen + +let generate_transaction random_state = + let gen_trans random_state = + let amount = random_amount random_state in + let parameters = Script.unit_parameter in + let entrypoint = Entrypoint.default in + let destination = random_contract random_state in + Transaction {amount; parameters; entrypoint; destination} + in + generate_manager random_state gen_trans + +let generate_origination random_state : + Kind.origination Kind.manager Operation.t = + let gen_origination random_state = + let delegate = None in + let script = Script.{code = unit_parameter; storage = unit_parameter} in + let credit = random_amount random_state in + Origination {delegate; script; credit} + in + generate_manager random_state gen_origination + +let generate_delegation random_state : Kind.delegation Kind.manager Operation.t + = + let gen_delegation random_state = + let delegate = random_option random_pkh random_state in + Delegation delegate + in + generate_manager random_state gen_delegation + +let generate_set_deposits_limit random_state : + Kind.set_deposits_limit Kind.manager Operation.t = + let gen_set_deposits_limit random_state = + let amount_opt = random_option random_amount random_state in + Set_deposits_limit amount_opt + in + generate_manager random_state gen_set_deposits_limit + +let generate_increase_paid_storage random_state : + Kind.increase_paid_storage Kind.manager Operation.t = + let gen_increase_paid_storage random_state = + let amount_in_bytes = random_amount_in_bytes random_state in + let destination = random_contract_hash random_state in + Increase_paid_storage {amount_in_bytes; destination} + in + generate_manager random_state gen_increase_paid_storage + +let generate_register_global_constant random_state : + Kind.register_global_constant Kind.manager Operation.t = + let gen_register_global_constant _ = + let value = Script_repr.lazy_expr (Expr.from_string "Pair 1 2") in + Register_global_constant {value} + in + generate_manager random_state gen_register_global_constant + +let generate_tx_rollup_origination random_state : + Kind.tx_rollup_origination Kind.manager Operation.t = + let gen_tx_orig _ = Tx_rollup_origination in + generate_manager random_state gen_tx_orig + +let generate_tx_rollup_submit_batch random_state : + Kind.tx_rollup_submit_batch Kind.manager Operation.t = + let gen_tx_submit random_state = + let tx_rollup = random_tx_rollup random_state in + let content = "batch" in + let burn_limit = None in + Tx_rollup_submit_batch {tx_rollup; content; burn_limit} + in + generate_manager random_state gen_tx_submit + +let generate_tx_rollup_commit random_state : + Kind.tx_rollup_commit Kind.manager Operation.t = + let gen_tx_commit random_state = + let tx_rollup = random_tx_rollup random_state in + let commitment : Tx_rollup_commitment.Full.t = + { + level = Tx_rollup_level.root; + messages = []; + predecessor = None; + inbox_merkle_root = Tx_rollup_inbox.Merkle.merklize_list []; + } + in + Tx_rollup_commit {tx_rollup; commitment} + in + generate_manager random_state gen_tx_commit + +let generate_tx_rollup_return_bond random_state : + Kind.tx_rollup_return_bond Kind.manager Operation.t = + let gen_tx_return_bd random_state = + let tx_rollup = random_tx_rollup random_state in + Tx_rollup_return_bond {tx_rollup} + in + generate_manager random_state gen_tx_return_bd + +let generate_tx_finalize_commitment random_state : + Kind.tx_rollup_finalize_commitment Kind.manager Operation.t = + let gen_tx_finalize random_state = + let tx_rollup = random_tx_rollup random_state in + Tx_rollup_finalize_commitment {tx_rollup} + in + generate_manager random_state gen_tx_finalize + +let generate_tx_rollup_remove_commitment random_state : + Kind.tx_rollup_remove_commitment Kind.manager Operation.t = + let gen_tx_remove random_state = + let tx_rollup = random_tx_rollup random_state in + Tx_rollup_remove_commitment {tx_rollup} + in + generate_manager random_state gen_tx_remove + +let generate_tx_rollup_rejection random_state : + Kind.tx_rollup_rejection Kind.manager Operation.t = + let gen_tx_rejection random_state = + let tx_rollup = random_tx_rollup random_state in + let message, _ = Tx_rollup_message.make_batch "" in + let message_hash = Tx_rollup_message_hash.hash_uncarbonated message in + let message_path = + match Tx_rollup_inbox.Merkle.compute_path [message_hash] 0 with + | Ok message_path -> message_path + | _ -> raise (Invalid_argument "Single_message_inbox.message_path") + in + let proof : Tx_rollup_l2_proof.t = + { + version = 1; + before = `Value Tx_rollup_message_result.empty_l2_context_hash; + after = `Value Context_hash.zero; + state = Seq.empty; + } + in + let previous_message_result : Tx_rollup_message_result.t = + { + context_hash = Tx_rollup_message_result.empty_l2_context_hash; + withdraw_list_hash = Tx_rollup_withdraw_list_hash.empty; + } + in + let level = Tx_rollup_level.root in + let message_result_hash = Tx_rollup_message_result_hash.zero in + let message_result_path = Tx_rollup_commitment.Merkle.dummy_path in + let previous_message_result_path = Tx_rollup_commitment.Merkle.dummy_path in + let message_position = 0 in + Tx_rollup_rejection + { + tx_rollup; + level; + message; + message_position; + message_path; + message_result_hash; + message_result_path; + previous_message_result; + previous_message_result_path; + proof; + } + in + generate_manager random_state gen_tx_rejection + +let generate_tx_dispatch_tickets random_state : + Kind.tx_rollup_dispatch_tickets Kind.manager Operation.t = + let gen_tx_dispatch random_state = + let tx_rollup = random_tx_rollup random_state in + let source = random_pkh random_state in + let contract = random_contract random_state in + let level = Tx_rollup_level.root in + let message_index = 0 in + let message_result_path = Tx_rollup_commitment.Merkle.dummy_path in + let context_hash = Context_hash.zero in + let reveal = + Tx_rollup_reveal. + { + contents = Script.lazy_expr (Expr.from_string "1"); + ty = Script.lazy_expr (Expr.from_string "nat"); + ticketer = contract; + amount = Tx_rollup_l2_qty.of_int64_exn 10L; + claimer = source; + } + in + let tickets_info = [reveal] in + Tx_rollup_dispatch_tickets + { + tx_rollup; + level; + context_hash; + message_index; + message_result_path; + tickets_info; + } + in + generate_manager random_state gen_tx_dispatch + +let generate_transfer_ticket random_state : + Kind.transfer_ticket Kind.manager Operation.t = + let gen_transfer_ticket random_state = + let contents = Script.lazy_expr (Expr.from_string "1") in + let ty = Script.lazy_expr (Expr.from_string "nat") in + let ticketer = random_contract random_state in + let destination = random_contract random_state in + let amount = random_counter random_state in + let entrypoint = Entrypoint.default in + Transfer_ticket {contents; ty; ticketer; amount; destination; entrypoint} + in + generate_manager random_state gen_transfer_ticket + +let generate_dal_publish_slot_header random_state : + Kind.dal_publish_slot_header Kind.manager Operation.t = + let gen_dal_publish _ = + let level = Alpha_context.Raw_level.of_int32_exn Int32.zero in + let index = Alpha_context.Dal.Slot_index.zero in + let header = Alpha_context.Dal.Slot.zero in + let slot = Alpha_context.Dal.Slot.{level; index; header} in + Dal_publish_slot_header {slot} + in + generate_manager random_state gen_dal_publish + +let generate_sc_rollup_originate random_state : + Kind.sc_rollup_originate Kind.manager Operation.t = + let gen_sc_originate _ = + let kind = Sc_rollup.Kind.Example_arith in + let boot_sector = "" in + let parameters_ty = Script.lazy_expr (Expr.from_string "1") in + let origination_proof = + Lwt_main.run (Sc_rollup_helpers.origination_proof ~boot_sector kind) + in + Sc_rollup_originate {kind; boot_sector; origination_proof; parameters_ty} + in + generate_manager random_state gen_sc_originate + +let generate_sc_rollup_add_messages random_state : + Kind.sc_rollup_add_messages Kind.manager Operation.t = + let gen_sc_add_messages random_state = + let rollup = random_sc_rollup random_state in + let messages = [] in + Sc_rollup_add_messages {rollup; messages} + in + generate_manager random_state gen_sc_add_messages + +let sc_dummy_commitment = + let number_of_ticks = + match Sc_rollup.Number_of_ticks.of_value 3000L with + | None -> assert false + | Some x -> x + in + Sc_rollup.Commitment. + { + predecessor = Sc_rollup.Commitment.Hash.zero; + inbox_level = Raw_level.of_int32_exn Int32.zero; + number_of_ticks; + compressed_state = Sc_rollup.State_hash.zero; + } + +let generate_sc_rollup_cement random_state : + Kind.sc_rollup_cement Kind.manager Operation.t = + let gen_sc_cement random_state = + let rollup = random_sc_rollup random_state in + let commitment = + Sc_rollup.Commitment.hash_uncarbonated sc_dummy_commitment + in + Sc_rollup_cement {rollup; commitment} + in + generate_manager random_state gen_sc_cement + +let generate_sc_rollup_publish random_state : + Kind.sc_rollup_publish Kind.manager Operation.t = + let gen_sc_publish random_state = + let rollup = random_sc_rollup random_state in + let commitment = sc_dummy_commitment in + Sc_rollup_publish {rollup; commitment} + in + generate_manager random_state gen_sc_publish + +let generate_sc_rollup_refute random_state : + Kind.sc_rollup_refute Kind.manager Operation.t = + let gen random_state = + let opponent = random_pkh random_state in + let rollup = random_sc_rollup random_state in + let refutation : Sc_rollup.Game.refutation option = + Some {choice = Sc_rollup.Tick.initial; step = Dissection []} + in + Sc_rollup_refute {rollup; opponent; refutation} + in + generate_manager random_state gen + +let generate_sc_rollup_timeout random_state : + Kind.sc_rollup_timeout Kind.manager Operation.t = + let gen random_state = + let source = random_pkh random_state in + let rollup = random_sc_rollup random_state in + let staker = random_pkh random_state in + let stakers = Sc_rollup.Game.Index.make source staker in + Sc_rollup_timeout {rollup; stakers} + in + generate_manager random_state gen + +let generate_sc_rollup_execute_outbox_message random_state : + Kind.sc_rollup_execute_outbox_message Kind.manager Operation.t = + let gen random_state = + let rollup = random_sc_rollup random_state in + let cemented_commitment = + Sc_rollup.Commitment.hash_uncarbonated sc_dummy_commitment + in + let output_proof = "" in + Sc_rollup_execute_outbox_message {rollup; cemented_commitment; output_proof} + in + generate_manager random_state gen + +let generate_sc_rollup_recover_bond random_state : + Kind.sc_rollup_recover_bond Kind.manager Operation.t = + let gen random_state = + let sc_rollup = random_sc_rollup random_state in + Sc_rollup_recover_bond {sc_rollup} + in + generate_manager random_state gen + +let generate_sc_rollup_dal_slot_subscribe random_state : + Kind.sc_rollup_dal_slot_subscribe Kind.manager Operation.t = + let gen random_state = + let rollup = random_sc_rollup random_state in + let slot_index = Alpha_context.Dal.Slot_index.zero in + Sc_rollup_dal_slot_subscribe {rollup; slot_index} + in + generate_manager random_state gen + +let codes = + List.filter_map + Blinded_public_key_hash.activation_code_of_hex + [ + "41f98b15efc63fa893d61d7d6eee4a2ce9427ac4"; + "411dfef031eeecc506de71c9df9f8e44297cf5ba"; + "08d7d355bc3391d12d140780b39717d9f46fcf87"; + ] + +let random_code random_state = choose_list_element random_state codes + +let generate_activate_account random_state : Kind.activate_account Operation.t = + let gen random_state = + let id = + random_pkh random_state |> function + | Ed25519 pkh -> pkh + | _ -> assert false + in + let activation_code = random_code random_state in + Single (Activate_account {id; activation_code}) + in + generate_op random_state gen + +let random_period random_state = choose_list_element random_state [0l; 1l; 2l] + +let generate_proposals random_state : Kind.proposals Operation.t = + let gen random_state = + let source = random_pkh random_state in + let period = random_period random_state in + let proposals = [] in + Single (Proposals {source; period; proposals}) + in + generate_op random_state gen + +let generate_ballot random_state : Kind.ballot Operation.t = + let gen random_state = + let source = random_pkh random_state in + let period = random_period random_state in + let proposal = random_proto random_state in + let ballot = Vote.Pass in + Single (Ballot {source; period; proposal; ballot}) + in + generate_op random_state gen + +let generate_manager_operation batch_size random_state = + let l = + Stdlib.List.init batch_size (fun _ -> + choose_list_element random_state manager_kinds) + in + let packed_manager_ops = + List.map + (function + | `KReveal -> generate_reveal random_state |> Operation.pack + | `KTransaction -> generate_transaction random_state |> Operation.pack + | `KOrigination -> generate_origination random_state |> Operation.pack + | `KSet_deposits_limit -> + generate_set_deposits_limit random_state |> Operation.pack + | `KIncrease_paid_storage -> + generate_increase_paid_storage random_state |> Operation.pack + | `KDelegation -> generate_delegation random_state |> Operation.pack + | `KRegister_global_constant -> + generate_register_global_constant random_state |> Operation.pack + | `KTx_rollup_origination -> + generate_tx_rollup_origination random_state |> Operation.pack + | `KTransfer_ticket -> + generate_transfer_ticket random_state |> Operation.pack + | `KDal_publish_slot_header -> + generate_dal_publish_slot_header random_state |> Operation.pack + | `KTx_rollup_submit_batch -> + generate_tx_rollup_submit_batch random_state |> Operation.pack + | `KTx_rollup_commit -> + generate_tx_rollup_commit random_state |> Operation.pack + | `KTx_rollup_return_bond -> + generate_tx_rollup_return_bond random_state |> Operation.pack + | `KTx_rollup_finalize_commitment -> + generate_tx_finalize_commitment random_state |> Operation.pack + | `KTx_rollup_remove_commitment -> + generate_tx_rollup_remove_commitment random_state |> Operation.pack + | `KTx_rollup_rejection -> + generate_tx_rollup_rejection random_state |> Operation.pack + | `KTx_rollup_dispatch_tickets -> + generate_tx_dispatch_tickets random_state |> Operation.pack + | `KSc_rollup_originate -> + generate_sc_rollup_originate random_state |> Operation.pack + | `KSc_rollup_add_messages -> + generate_sc_rollup_add_messages random_state |> Operation.pack + | `KSc_rollup_cement -> + generate_sc_rollup_cement random_state |> Operation.pack + | `KSc_rollup_publish -> + generate_sc_rollup_publish random_state |> Operation.pack + | `KSc_rollup_refute -> + generate_sc_rollup_refute random_state |> Operation.pack + | `KSc_rollup_timeout -> + generate_sc_rollup_timeout random_state |> Operation.pack + | `KSc_rollup_execute_outbox_message -> + generate_sc_rollup_execute_outbox_message random_state + |> Operation.pack + | `KSc_rollup_recover_bond -> + generate_sc_rollup_recover_bond random_state |> Operation.pack + | `KSc_rollup_dal_slot_subscribe -> + generate_sc_rollup_dal_slot_subscribe random_state |> Operation.pack) + l + in + let first_op = Stdlib.List.hd packed_manager_ops in + let unpacked_operations = + List.map + (function + | {Alpha_context.protocol_data = Operation_data {contents; _}; _} -> ( + match Contents_list contents with + | Contents_list (Single o) -> Contents o + | Contents_list + (Cons (Manager_operation {operation = Reveal _; _}, Single o)) + -> + Contents o + | _ -> assert false)) + packed_manager_ops + in + let contents_list = + List.fold_left + (fun acc -> function + | Contents (Manager_operation m) -> + Contents (Manager_operation m) :: acc + | x -> x :: acc) + [] + unpacked_operations + |> List.rev + in + let (Contents_list contents_list) = + match Operation.of_list contents_list with Ok v -> v | _ -> assert false + in + let signature = + match first_op.protocol_data with + | Operation_data {signature; _} -> signature + in + let protocol_data = {contents = contents_list; signature} in + Operation.pack {shell = first_op.shell; protocol_data} + +let generate_operation random_state = + let pass = choose_list_element random_state all_passes in + let kind = choose_list_element random_state (pass_to_operation_kinds pass) in + let packed_operation = + match kind with + | `KPreendorsement -> generate_preendorsement random_state |> Operation.pack + | `KEndorsement -> generate_endorsement random_state |> Operation.pack + | `KDal_slot -> generate_dal_slot random_state |> Operation.pack + | `KSeed_nonce_revelation -> + generate_seed_nonce_revelation random_state |> Operation.pack + | `KVdf_revelation -> generate_vdf_revelation random_state |> Operation.pack + | `KDouble_endorsement -> + generate_double_endorsement random_state |> Operation.pack + | `KDouble_preendorsement -> + generate_double_preendorsement random_state |> Operation.pack + | `KDouble_baking -> generate_double_baking random_state |> Operation.pack + | `KActivate_account -> + generate_activate_account random_state |> Operation.pack + | `KProposals -> generate_proposals random_state |> Operation.pack + | `KBallot -> generate_ballot random_state |> Operation.pack + | `KManager -> + let batch_size = 1 + Random.int random_state.rnd_state 3 in + generate_manager_operation batch_size random_state + in + (kind, (Operation.hash_packed packed_operation, packed_operation)) diff --git a/src/proto_alpha/lib_protocol/test/unit/main.ml b/src/proto_alpha/lib_protocol/test/unit/main.ml index 21fbb6db3e51317f8be37112acb6046729f4c450..767372e1d70cdf9ca4663d029088defa72f6d88c 100644 --- a/src/proto_alpha/lib_protocol/test/unit/main.ml +++ b/src/proto_alpha/lib_protocol/test/unit/main.ml @@ -83,5 +83,6 @@ let () = Test_sc_rollup_management_protocol.tests; Unit_test.spec "Bond_id_repr.ml" Test_bond_id_repr.tests; Unit_test.spec "zk rollup storage" Test_zk_rollup_storage.tests; + Unit_test.spec "compare operations" Test_compare_operations.tests; ] |> Lwt_main.run diff --git a/src/proto_alpha/lib_protocol/test/unit/test_compare_operations.ml b/src/proto_alpha/lib_protocol/test/unit/test_compare_operations.ml new file mode 100644 index 0000000000000000000000000000000000000000..6f7fc26fca510f2903a993657de406cabe2ffcee --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/unit/test_compare_operations.ml @@ -0,0 +1,120 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: Protocol (Operation compare) + Invocation: dune exec src/proto_alpha/lib_protocol/test/unit/main.exe \ + -- test "\[Unit\] compare operations" + Subject: Valid operations Comparison +*) + +open Protocol +open Alpha_context +open Operation_generator +open Lwt_result_syntax + +let () = Stdlib.Random.self_init () + +(** A strict order has an equality predicate that is symmetric, + reflexive and transitive and an lt (and gt) predicates that is + antisymmetric and transitive. + + Testing that Operation.compare is a strict order on + operations is then testing that it is symmetric, transitive and + reflexive, when Operation.compare x y = 0; that it is transitive + when Operation.compare x y = -1 and Operation.compare x y = -1; and + that Operation.compare x y = - (Operation.compare y x) when differ + from 0. *) +let eq_sym op1 op2 = + if Operation.compare op1 op2 = 0 then assert (Operation.compare op2 op1 = 0) + +let eq_refl op = assert (Operation.compare op op = 0) + +let eq_trans op1 op2 op3 = + if Operation.compare op1 op2 = 0 && Operation.compare op2 op3 = 0 then + assert (Operation.compare op1 op3 = 0) + +let lt_antisym op1 op2 = + if Operation.compare op1 op2 = -1 then assert (Operation.compare op2 op1 = 1) + +let lt_trans op1 op2 op3 = + if Operation.compare op1 op2 = -1 && Operation.compare op2 op3 = -1 then + assert (Operation.compare op1 op3 = -1) + +let gt_trans op1 op2 op3 = + if Operation.compare op1 op2 = 1 && Operation.compare op2 op3 = 1 then + assert (Operation.compare op1 op3 = 1) + +let gt_antisym op1 op2 = + if Operation.compare op1 op2 = 1 then assert (Operation.compare op2 op1 = -1) + +(** Testing that Operation.compare is a strict order on operations. *) +let strorder op1 op2 op3 = + eq_sym op1 op2 ; + eq_refl op1 ; + eq_trans op1 op2 op3 ; + lt_antisym op1 op2 ; + lt_trans op1 op2 op3 ; + gt_trans op1 op2 op3 ; + gt_antisym op1 op2 + +let run ?seed n = + assert (n >= 0) ; + let seed = + match seed with Some s -> s | None -> Stdlib.Random.int (1 lsl 29) + in + Format.printf "Starting fuzzing with seed: %d@." seed ; + let random_state = {seed; rnd_state = Random.make [|seed|]} in + let rec loop = function + | 0 -> () + | n' -> + (try + let k1, op1 = generate_operation random_state in + let k2, op2 = generate_operation random_state in + let k3, op3 = generate_operation random_state in + try strorder op1 op2 op3 + with exn -> + Format.eprintf + "%a vs. %a vs. %a@." + pp_kind + k1 + pp_kind + k2 + pp_kind + k3 ; + raise exn + with Failure _ -> ()) ; + loop (pred n') + in + loop n + +let test_compare () = + run 1_000_000 ; + return_unit + +let tests = + Tztest. + [tztest "Compare operations is a strict total order." `Slow test_compare] diff --git a/src/proto_demo_counter/lib_protocol/main.ml b/src/proto_demo_counter/lib_protocol/main.ml index cf8694b8dd41d1844b0598b62490504928f050af..3516885a7fa5243a515a63eadfca9eef00ec7270 100644 --- a/src/proto_demo_counter/lib_protocol/main.ml +++ b/src/proto_demo_counter/lib_protocol/main.ml @@ -29,7 +29,7 @@ let max_operation_data_length = 100 let validation_passes = Updater.[{max_size = 1000; max_op = None}] -let acceptable_passes _op = [0] +let acceptable_pass _op = Some 0 type block_header_data = Header.t @@ -195,7 +195,7 @@ let init _chain_id context block_header = last_allowed_fork_level = block_header.level; } -let relative_position_within_block _ _ = 0 +let compare_operations _ _ = 0 type Context.Cache.value += Demo of int diff --git a/src/proto_demo_noops/lib_protocol/main.ml b/src/proto_demo_noops/lib_protocol/main.ml index 467f8f8eebe4b1cd875afbad53115929e0f40905..81e453503235bf20da3914a2bf64fdfe9cd0464b 100644 --- a/src/proto_demo_noops/lib_protocol/main.ml +++ b/src/proto_demo_noops/lib_protocol/main.ml @@ -29,7 +29,7 @@ let max_operation_data_length = 0 let validation_passes = [] -let acceptable_passes _op = [] +let acceptable_pass _op = None type block_header_data = string @@ -64,7 +64,7 @@ type operation = { protocol_data : operation_data; } -let relative_position_within_block _ _ = 0 +let compare_operations _ _ = 0 type validation_state = {context : Context.t; fitness : Fitness.t}