diff --git a/manifest/main.ml b/manifest/main.ml index c21158c1a7d2be39089b0dfce9a3da447b2bb0c1..ad7a8b6d6c6cda6a5cbaec88cce10ce0a447daba 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -5226,6 +5226,11 @@ let _octez_shell_tests = "test_prevalidator_classification"; "test_prevalidator_classification_operations"; "test_prevalidator_pending_operations"; + "legacy_test_prevalidation"; + "legacy_test_prevalidation_t"; + "legacy_test_prevalidator_classification"; + "legacy_test_prevalidator_classification_operations"; + "legacy_test_prevalidator_pending_operations"; "test_peer_validator"; ] ~path:"src/lib_shell/test" diff --git a/src/lib_shell/legacy_prevalidation.ml b/src/lib_shell/legacy_prevalidation.ml new file mode 100644 index 0000000000000000000000000000000000000000..ed2a872ffe9aaa16ff6fa4240bb0d769c7576e5e --- /dev/null +++ b/src/lib_shell/legacy_prevalidation.ml @@ -0,0 +1,317 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2020 Metastate AG *) +(* Copyright (c) 2018-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. *) +(* *) +(*****************************************************************************) + +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the implementation of the legacy mempool, + which is compatible with Kathmandu and therefore usable on Mainnet. + + This file should be removed once Lima has been activated on Mainnet. + + When you modify this file, consider whether you should also change + the files that implement the more recent mempool for Lima and newer + protocols. *) + +open Validation_errors + +type 'protocol_operation operation = { + hash : Operation_hash.t; + raw : Operation.t; + protocol : 'protocol_operation; + count_successful_prechecks : int; +} + +type error += Endorsement_branch_not_live + +let () = + register_error_kind + `Permanent + ~id:"legacy_prevalidation.endorsement_branch_not_live" + ~title:"Endorsement branch not live" + ~description:"Endorsement's branch is not in the live blocks" + ~pp:(fun ppf () -> + Format.fprintf ppf "Endorsement's branch is not in the live blocks") + Data_encoding.(empty) + (function Endorsement_branch_not_live -> Some () | _ -> None) + (fun () -> Endorsement_branch_not_live) + +module type CHAIN_STORE = sig + type chain_store + + val context : + chain_store -> + Store.Block.t -> + Tezos_protocol_environment.Context.t tzresult Lwt.t + + val chain_id : chain_store -> Chain_id.t +end + +module type T = sig + type protocol_operation + + type operation_receipt + + type validation_state + + type chain_store + + type t + + val parse : + Operation_hash.t -> Operation.t -> protocol_operation operation tzresult + + val increment_successful_precheck : + protocol_operation operation -> protocol_operation operation + + val create : + chain_store -> + predecessor:Store.Block.t -> + live_operations:Operation_hash.Set.t -> + timestamp:Time.Protocol.t -> + unit -> + t tzresult Lwt.t + + type result = + | Applied of t * operation_receipt + | Branch_delayed of tztrace + | Branch_refused of tztrace + | Refused of tztrace + | Outdated of tztrace + + val apply_operation : t -> protocol_operation operation -> result Lwt.t + + val validation_state : t -> validation_state + + val set_validation_state : t -> validation_state -> t + + val pp_result : Format.formatter -> result -> unit + + module Internal_for_tests : sig + val to_applied : + t -> (protocol_operation operation * operation_receipt) list + end +end + +(** Doesn't depend on heavy [Registered_protocol.T] for testability. *) +let safe_binary_of_bytes (encoding : 'a Data_encoding.t) (bytes : bytes) : + 'a tzresult = + let open Result_syntax in + match Data_encoding.Binary.of_bytes_opt encoding bytes with + | None -> tzfail Parse_error + | Some protocol_data -> return protocol_data + +module MakeAbstract + (Chain_store : CHAIN_STORE) + (Proto : Tezos_protocol_environment.PROTOCOL) : + T + with type protocol_operation = Proto.operation + and type operation_receipt = Proto.operation_receipt + and type validation_state = Proto.validation_state + and type chain_store = Chain_store.chain_store = struct + type protocol_operation = Proto.operation + + type operation_receipt = Proto.operation_receipt + + type validation_state = Proto.validation_state + + type chain_store = Chain_store.chain_store + + type t = { + validation_state : validation_state; + application_state : Proto.application_state; + applied : (protocol_operation operation * Proto.operation_receipt) list; + live_operations : Operation_hash.Set.t; + } + + type result = + | Applied of t * Proto.operation_receipt + | Branch_delayed of tztrace + | Branch_refused of tztrace + | Refused of tztrace + | Outdated of tztrace + + let parse_unsafe (proto : bytes) : Proto.operation_data tzresult = + safe_binary_of_bytes Proto.operation_data_encoding proto + + let parse hash (raw : Operation.t) = + let open Result_syntax in + let size = Data_encoding.Binary.length Operation.encoding raw in + if size > Proto.max_operation_data_length then + tzfail (Oversized_operation {size; max = Proto.max_operation_data_length}) + else + let+ protocol_data = parse_unsafe raw.proto in + { + hash; + raw; + protocol = {Proto.shell = raw.Operation.shell; protocol_data}; + (* When an operation is parsed, we assume that it has never been + successfully prechecked. *) + count_successful_prechecks = 0; + } + + let increment_successful_precheck op = + (* We avoid {op with ...} to get feedback from the compiler if the record + type is extended/modified in the future. *) + { + hash = op.hash; + raw = op.raw; + protocol = op.protocol; + count_successful_prechecks = op.count_successful_prechecks + 1; + } + + let create chain_store ~predecessor ~live_operations ~timestamp () = + (* The prevalidation module receives input from the system byt handles + protocol values. It translates timestamps here. *) + let open Lwt_result_syntax in + let* predecessor_context = Chain_store.context chain_store predecessor in + let predecessor_hash = Store.Block.hash predecessor in + let*! predecessor_context = + Block_validation.update_testchain_status + predecessor_context + ~predecessor_hash + timestamp + in + let chain_id = Chain_store.chain_id chain_store in + let mode = Proto.Partial_construction {predecessor_hash; timestamp} in + let predecessor = (Store.Block.header predecessor).shell in + let* validation_state = + Proto.begin_validation + predecessor_context + chain_id + mode + ~predecessor + ~cache:`Lazy + in + let* application_state = + Proto.begin_application + predecessor_context + chain_id + mode + ~predecessor + ~cache:`Lazy + in + return {validation_state; application_state; applied = []; live_operations} + + let apply_operation pv op = + let open Lwt_syntax in + if Operation_hash.Set.mem op.hash pv.live_operations then + (* As of November 2021, it is dubious that this case can happen. + If it can, it is more likely to be because of a consensus operation; + hence the returned error. *) + Lwt.return (Outdated [Endorsement_branch_not_live]) + else + let+ r = + protect (fun () -> + let open Lwt_result_syntax in + let* validation_state = + Proto.validate_operation pv.validation_state op.hash op.protocol + in + let* application_state, receipt = + Proto.apply_operation pv.application_state op.hash op.protocol + in + return (validation_state, application_state, receipt)) + in + match r with + | Ok (validation_state, application_state, receipt) -> ( + let pv = + { + validation_state; + application_state; + applied = (op, receipt) :: pv.applied; + live_operations = + Operation_hash.Set.add op.hash pv.live_operations; + } + in + match + Data_encoding.Binary.( + of_bytes_exn + Proto.operation_receipt_encoding + (to_bytes_exn Proto.operation_receipt_encoding receipt)) + with + | receipt -> Applied (pv, receipt) + | exception exn -> + Refused + [Validation_errors.Cannot_serialize_operation_metadata; Exn exn] + ) + | Error trace -> ( + match classify_trace trace with + | Branch -> Branch_refused trace + | Permanent -> Refused trace + | Temporary -> Branch_delayed trace + | Outdated -> Outdated trace) + + let validation_state {validation_state; _} = validation_state + + let set_validation_state t validation_state = {t with validation_state} + + let pp_result ppf = + let open Format in + function + | Applied _ -> pp_print_string ppf "applied" + | Branch_delayed err -> fprintf ppf "branch delayed (%a)" pp_print_trace err + | Branch_refused err -> fprintf ppf "branch refused (%a)" pp_print_trace err + | Refused err -> fprintf ppf "refused (%a)" pp_print_trace err + | Outdated err -> fprintf ppf "outdated (%a)" pp_print_trace err + + module Internal_for_tests = struct + let to_applied {applied; _} = applied + end +end + +module Production_chain_store : + CHAIN_STORE with type chain_store = Store.chain_store = struct + type chain_store = Store.chain_store + + let context = Store.Block.context + + let chain_id = Store.Chain.chain_id +end + +module Make (Proto : Tezos_protocol_environment.PROTOCOL) : + T + with type protocol_operation = Proto.operation + and type operation_receipt = Proto.operation_receipt + and type validation_state = Proto.validation_state + and type chain_store = Production_chain_store.chain_store = + MakeAbstract (Production_chain_store) (Proto) + +module Internal_for_tests = struct + let to_raw {raw; _} = raw + + let hash_of {hash; _} = hash + + let make_operation op oph data = + (* When we build an operation, we assume that it has never been + successfully prechecked. *) + {hash = oph; raw = op; protocol = data; count_successful_prechecks = 0} + + let safe_binary_of_bytes = safe_binary_of_bytes + + module type CHAIN_STORE = CHAIN_STORE + + module Make = MakeAbstract +end diff --git a/src/lib_shell/legacy_prevalidation.mli b/src/lib_shell/legacy_prevalidation.mli new file mode 100644 index 0000000000000000000000000000000000000000..95dd3dd6d844c580d5da83c882a72a03784e0ac5 --- /dev/null +++ b/src/lib_shell/legacy_prevalidation.mli @@ -0,0 +1,199 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2018-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. *) +(* *) +(*****************************************************************************) + +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the implementation of the legacy mempool, + which is compatible with Kathmandu and therefore usable on Mainnet. + + This file should be removed once Lima has been activated on Mainnet. + + When you modify this file, consider whether you should also change + the files that implement the more recent mempool for Lima and newer + protocols. *) + +(** A newly received block is validated by replaying locally the block + creation, applying each operation and its finalization to ensure their + consistency. This module is stateless and creates and manipulates the + prevalidation_state. *) + +type 'protocol_operation operation = private { + hash : Operation_hash.t; (** Hash of an operation. *) + raw : Operation.t; + (** Raw representation of an operation (from the point view of the + shell). *) + protocol : 'protocol_operation; + (** Economic protocol specific data of an operation. It is the + unserialized representation of [raw.protocol_data]. For + convenience, the type associated to this type may be [unit] if we + do not have deserialized the operation yet. *) + count_successful_prechecks : int; + (** This field provides an under-approximation for the number of times + the operation has been successfully prechecked. It is an + under-approximation because if the operation is e.g., parsed more than + once, or is prechecked in other modes, this flag is not globally + updated. *) +} + +module type T = sig + (** Similar to the same type in the protocol, + see {!Tezos_protocol_environment.PROTOCOL.operation} *) + type protocol_operation + + (** Similar to the same type in the protocol, + see {!Tezos_protocol_environment.PROTOCOL} *) + type operation_receipt + + (** Similar to the same type in the protocol, + see {!Tezos_protocol_environment.PROTOCOL} *) + type validation_state + + (** The type implemented by {!Tezos_store.Store.chain_store} in + production, and mocked in tests *) + type chain_store + + (** The type used internally by this module. Created by {!create} and + then passed back and possibly updated by {!apply_operation}. *) + type t + + (** [parse hash op] reads a usual {!Operation.t} and lifts it to the + type {!protocol_operation} used by this module. This function is in the + {!tzresult} monad, because it can return the following errors: + + - {!Validation_errors.Oversized_operation} if the size of the operation + data within [op] is too large (to protect against DoS attacks), and + - {!Validation_errors.Parse_error} if serialized data cannot be parsed. *) + val parse : + Operation_hash.t -> Operation.t -> protocol_operation operation tzresult + + (** [increment_successful_precheck op] increments the field + [count_successful_prechecks] of the given operation [op]. It is supposed + to be called after each successful precheck of a given operation [op], + and nowhere else. Overflow is unlikely to occur in practice, as the + counter grows very slowly and the number of prechecks is bounded. *) + val increment_successful_precheck : + protocol_operation operation -> protocol_operation operation + + (** Creates a new prevalidation context w.r.t. the protocol associated with + the predecessor block. *) + val create : + chain_store -> + predecessor:Store.Block.t -> + live_operations:Operation_hash.Set.t -> + timestamp:Time.Protocol.t -> + unit -> + t tzresult Lwt.t + + (** Values returned by {!create}. They are obtained from the result + of the protocol [apply_operation] function and the classification of + errors. *) + type result = + | Applied of t * operation_receipt + | Branch_delayed of tztrace + | Branch_refused of tztrace + | Refused of tztrace + | Outdated of tztrace + + (** [apply_operation t op] calls the protocol [apply_operation] function + and handles possible errors, hereby yielding a classification *) + val apply_operation : t -> protocol_operation operation -> result Lwt.t + + (** [validation_state t] returns the subset of [t] corresponding + to the type {!validation_state} of the protocol. *) + val validation_state : t -> validation_state + + (** Updates the subset of [t] corresponding to the type + {!validation_state} of the protocol. *) + val set_validation_state : t -> validation_state -> t + + val pp_result : Format.formatter -> result -> unit + + module Internal_for_tests : sig + (** Returns operations for which {!apply_operation} returned [Applied _] + so far. *) + val to_applied : + t -> (protocol_operation operation * operation_receipt) list + end +end + +(** How-to obtain an instance of this module's main module type: {!T} *) +module Make : functor (Proto : Tezos_protocol_environment.PROTOCOL) -> + T + with type protocol_operation = Proto.operation + and type operation_receipt = Proto.operation_receipt + and type validation_state = Proto.validation_state + and type chain_store = Store.chain_store + +(**/**) + +module Internal_for_tests : sig + (** Returns the {!Operation.t} underlying an {!operation} *) + val to_raw : _ operation -> Operation.t + + (** The hash of an {!operation} *) + val hash_of : _ operation -> Operation_hash.t + + (** A constructor for the [operation] datatype. It by-passes the + checks done by the [parse] function. *) + val make_operation : Operation.t -> Operation_hash.t -> 'a -> 'a operation + + (** [safe_binary_of_bytes encoding bytes] parses [bytes] using [encoding]. + Any error happening during parsing becomes {!Parse_error}. + + If one day the functor's signature is simplified, tests could use + [parse_unsafe] directly rather than relying on this function to + replace [Proto.operation_data_encoding]. *) + val safe_binary_of_bytes : 'a Data_encoding.t -> bytes -> 'a tzresult + + module type CHAIN_STORE = sig + (** The [chain_store] type. Implemented by + {!Tezos_store.Store.chain_store} in production and mocked in + tests *) + type chain_store + + (** [context store block] checkouts and returns the context of [block] *) + val context : + chain_store -> + Store.Block.t -> + Tezos_protocol_environment.Context.t tzresult Lwt.t + + (** [chain_id store] returns the {!Chain_id.t} to which [store] + corresponds *) + val chain_id : chain_store -> Chain_id.t + end + + (** A variant of [Make] above that is parameterized by {!CHAIN_STORE}, + for mocking purposes. *) + module Make : functor + (Chain_store : CHAIN_STORE) + (Proto : Tezos_protocol_environment.PROTOCOL) + -> + T + with type protocol_operation = Proto.operation + and type operation_receipt = Proto.operation_receipt + and type validation_state = Proto.validation_state + and type chain_store = Chain_store.chain_store +end diff --git a/src/lib_shell/legacy_prevalidator_classification.ml b/src/lib_shell/legacy_prevalidator_classification.ml new file mode 100644 index 0000000000000000000000000000000000000000..73235679b8e65c6a1ba55fce8b79348d93b07acf --- /dev/null +++ b/src/lib_shell/legacy_prevalidator_classification.ml @@ -0,0 +1,547 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021-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. *) +(* *) +(*****************************************************************************) + +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the implementation of the legacy mempool, + which is compatible with Kathmandu and therefore usable on Mainnet. + + This file should be removed once Lima has been activated on Mainnet. + + When you modify this file, consider whether you should also change + the files that implement the more recent mempool for Lima and newer + protocols. *) + +module Prevalidation = Legacy_prevalidation + +module Event = struct + let section = ["legacy_prevalidator_classification"] + + include Internal_event.Simple + + let predecessor_less_block = + declare_1 + ~section + ~name:"predecessor_less_block" + ~msg:"Observing that a parent of block {blk_h} has no predecessor" + ~level:Warning + ("blk_h", Block_hash.encoding) +end + +type error_classification = + [ `Branch_delayed of tztrace + | `Branch_refused of tztrace + | `Refused of tztrace + | `Outdated of tztrace ] + +type classification = [`Applied | `Prechecked | error_classification] + +module Map = Operation_hash.Map +module Sized_map = Tezos_base.Sized.MakeSizedMap (Map) + +(** This type wraps together: + + - a bounded ring of keys (size book-keeping) + - a regular (unbounded) map of key/values (efficient read) + + All operations must maintain integrity between the 2! +*) +type 'protocol_data bounded_map = { + ring : Operation_hash.t Ringo.Ring.t; + mutable map : ('protocol_data Prevalidation.operation * error list) Map.t; +} + +let map bounded_map = bounded_map.map + +let cardinal bounded_map = Ringo.Ring.length bounded_map.ring + +(** [mk_empty_bounded_map ring_size] returns a {!bounded_map} whose ring + holds at most [ring_size] values. {!Invalid_argument} is raised + if [ring_size <= 0]. *) +let mk_empty_bounded_map ring_size = + {ring = Ringo.Ring.create ring_size; map = Map.empty} + +type parameters = { + map_size_limit : int; + on_discarded_operation : Operation_hash.t -> unit; +} + +(** Note that [applied] and [in_mempool] are intentionally unbounded. + See the mli for detailed documentation. + All operations must maintain the invariant about [in_mempool] + described in the mli. *) +type 'protocol_data t = { + parameters : parameters; + refused : 'protocol_data bounded_map; + outdated : 'protocol_data bounded_map; + branch_refused : 'protocol_data bounded_map; + branch_delayed : 'protocol_data bounded_map; + mutable applied_rev : 'protocol_data Prevalidation.operation list; + mutable prechecked : 'protocol_data Prevalidation.operation Sized_map.t; + mutable unparsable : Operation_hash.Set.t; + mutable in_mempool : + ('protocol_data Prevalidation.operation * classification) Map.t; +} + +let create parameters = + { + parameters; + refused = mk_empty_bounded_map parameters.map_size_limit; + outdated = mk_empty_bounded_map parameters.map_size_limit; + branch_refused = mk_empty_bounded_map parameters.map_size_limit; + branch_delayed = mk_empty_bounded_map parameters.map_size_limit; + prechecked = Sized_map.empty; + unparsable = Operation_hash.Set.empty; + in_mempool = Map.empty; + applied_rev = []; + } + +let is_empty + { + (* All fields are intentionaly mentioned, so that we get a warning + when we add a field. This will force to think whether this + function needs to be updated or not. *) + parameters = _; + refused = _; + outdated = _; + branch_refused = _; + branch_delayed = _; + prechecked = _; + applied_rev = _; + unparsable; + in_mempool; + } = + (* By checking only [in_mempool] here, we rely on the invariant that + [in_mempool] is the union of all other fields (see the MLI for + detailed documentation of this invariant) except unparsable + operations which are not classified yet. *) + Map.is_empty in_mempool && Operation_hash.Set.is_empty unparsable + +let set_of_bounded_map bounded_map = + Map.fold + (fun oph _ acc -> Operation_hash.Set.add oph acc) + bounded_map.map + Operation_hash.Set.empty + +let flush (classes : 'protocol_data t) ~handle_branch_refused = + let remove_map_from_in_mempool map = + classes.in_mempool <- + Map.fold + (fun oph _ mempool -> Map.remove oph mempool) + map + classes.in_mempool + in + let remove_list_from_in_mempool list = + classes.in_mempool <- + List.fold_left + (fun mempool op -> Map.remove op.Prevalidation.hash mempool) + classes.in_mempool + list + in + if handle_branch_refused then ( + remove_map_from_in_mempool classes.branch_refused.map ; + Ringo.Ring.clear classes.branch_refused.ring ; + classes.branch_refused.map <- Map.empty) ; + remove_map_from_in_mempool classes.branch_delayed.map ; + Ringo.Ring.clear classes.branch_delayed.ring ; + classes.branch_delayed.map <- Map.empty ; + remove_list_from_in_mempool classes.applied_rev ; + classes.applied_rev <- [] ; + remove_map_from_in_mempool (Sized_map.to_map classes.prechecked) ; + classes.unparsable <- Operation_hash.Set.empty ; + classes.prechecked <- Sized_map.empty + +let is_in_mempool oph classes = Map.find oph classes.in_mempool + +let is_known_unparsable oph classes = + Operation_hash.Set.mem oph classes.unparsable + +(* Removing an operation is currently used for operations which are + banned (this can only be achieved by the adminstrator of the + node). However, removing an operation which is applied invalidates + the classification of all the operations. Hence, the + classifications of all the operations should be reset. Currently, + this is not enforced by the function and has to be done by the + caller. + + Later on, it would be probably better if this function returns a + set of pending operations instead. *) +let remove oph classes = + match Map.find oph classes.in_mempool with + | None -> None + | Some (op, classification) -> + (classes.in_mempool <- Map.remove oph classes.in_mempool ; + match classification with + | `Refused _ -> classes.refused.map <- Map.remove oph classes.refused.map + | `Outdated _ -> + classes.outdated.map <- Map.remove oph classes.outdated.map + | `Branch_refused _ -> + classes.branch_refused.map <- + Map.remove oph classes.branch_refused.map + | `Branch_delayed _ -> + classes.branch_delayed.map <- + Map.remove oph classes.branch_delayed.map + | `Prechecked -> + classes.prechecked <- Sized_map.remove oph classes.prechecked + | `Applied -> + classes.applied_rev <- + List.filter + (fun op -> Operation_hash.(op.Prevalidation.hash <> oph)) + classes.applied_rev) ; + Some (op, classification) + +let handle_applied oph op classes = + classes.applied_rev <- op :: classes.applied_rev ; + classes.in_mempool <- Map.add oph (op, `Applied) classes.in_mempool + +let handle_prechecked oph op classes = + classes.prechecked <- Sized_map.add oph op classes.prechecked ; + classes.in_mempool <- Map.add oph (op, `Prechecked) classes.in_mempool + +(* 1. Add the operation to the ring underlying the corresponding + error map class. + + 2a. If the ring is full, remove the discarded operation from the + map and the [in_mempool] set, and calls the callback with the + discarded operation. + + 2b. If the operation is [Refused], call the callback with it, as + the operation is discarded. In this case it means the operation + should not be propagated. It is still stored in a bounded map for + the [pending_operations] RPC. + + 3. Add the operation to the underlying map. + + 4. Add the operation to the [in_mempool] set. *) +let handle_error oph op classification classes = + let bounded_map, tztrace = + match classification with + | `Branch_refused tztrace -> (classes.branch_refused, tztrace) + | `Branch_delayed tztrace -> (classes.branch_delayed, tztrace) + | `Refused tztrace -> (classes.refused, tztrace) + | `Outdated tztrace -> (classes.outdated, tztrace) + in + Ringo.Ring.add_and_return_erased bounded_map.ring oph + |> Option.iter (fun e -> + bounded_map.map <- Map.remove e bounded_map.map ; + classes.parameters.on_discarded_operation e ; + classes.in_mempool <- Map.remove e classes.in_mempool) ; + (match classification with + | `Refused _ | `Outdated _ -> classes.parameters.on_discarded_operation oph + | `Branch_delayed _ | `Branch_refused _ -> ()) ; + bounded_map.map <- Map.add oph (op, tztrace) bounded_map.map ; + let classification : classification = (classification :> classification) in + classes.in_mempool <- Map.add oph (op, classification) classes.in_mempool + +let add_unparsable oph classes = + classes.unparsable <- Operation_hash.Set.add oph classes.unparsable ; + classes.parameters.on_discarded_operation oph + +let add classification op classes = + match classification with + | `Applied -> handle_applied op.Prevalidation.hash op classes + | `Prechecked -> handle_prechecked op.Prevalidation.hash op classes + | (`Branch_refused _ | `Branch_delayed _ | `Refused _ | `Outdated _) as + classification -> + handle_error op.Prevalidation.hash op classification classes + +let to_map ~applied ~prechecked ~branch_delayed ~branch_refused ~refused + ~outdated classes : 'protocol_data Prevalidation.operation Map.t = + let ( +> ) accum to_add = + let merge_fun _k accum_v_opt to_add_v_opt = + match (accum_v_opt, to_add_v_opt) with + | Some accum_v, None -> Some accum_v + | None, Some (to_add_v, _err) -> Some to_add_v + | Some _accum_v, Some (to_add_v, _err) -> + (* This case should not happen, because the different classes + should be disjoint. However, if this invariant is broken, + it is not critical, hence we do not raise an error. + Because such part of the code is quite technical and + the invariant is not critical, + we don't advertise the node administrator either (no log). *) + Some to_add_v + | None, None -> None + in + Map.merge merge_fun accum to_add + in + Map.union + (fun _oph op _ -> Some op) + (if prechecked then Sized_map.to_map classes.prechecked else Map.empty) + @@ (if applied then + List.to_seq classes.applied_rev + |> Seq.map (fun op -> (op.Prevalidation.hash, op)) + |> Map.of_seq + else Map.empty) + +> (if branch_delayed then classes.branch_delayed.map else Map.empty) + +> (if branch_refused then classes.branch_refused.map else Map.empty) + +> (if refused then classes.refused.map else Map.empty) + +> if outdated then classes.outdated.map else Map.empty + +type 'block block_tools = { + hash : 'block -> Block_hash.t; + operations : 'block -> Operation.t list list; + all_operation_hashes : 'block -> Operation_hash.t list list; +} + +type 'block chain_tools = { + clear_or_cancel : Operation_hash.t -> unit; + inject_operation : Operation_hash.t -> Operation.t -> unit Lwt.t; + new_blocks : + from_block:'block -> to_block:'block -> ('block * 'block list) Lwt.t; + read_predecessor_opt : 'block -> 'block option Lwt.t; +} + +(* There's detailed documentation in the mli *) +let handle_live_operations ~classes ~(block_store : 'block block_tools) + ~(chain : 'block chain_tools) ~(from_branch : 'block) ~(to_branch : 'block) + ~(is_branch_alive : Block_hash.t -> bool) + ~(parse : + Operation_hash.t -> + Operation.t -> + 'protocol_data Prevalidation.operation option) old_mempool = + let open Lwt_syntax in + let rec pop_block ancestor (block : 'block) mempool = + let hash = block_store.hash block in + if Block_hash.equal hash ancestor then Lwt.return mempool + else + let operations = block_store.operations block in + let* mempool = + List.fold_left_s + (List.fold_left_s (fun mempool op -> + let oph = Operation.hash op in + let+ () = chain.inject_operation oph op in + match parse oph op with + | None -> + (* There are hidden invariants between the shell and + the economic protocol which should ensure this will + (almost) never happen in practice: + + 1. Decoding/encoding an operation only depends + on the protocol and not the current context. + + 2. It is not possible to have a reorganisation + where one branch is using one protocol and another + branch on another protocol. + + 3. Ok, actually there might be one case using + [user_activated_upgrades] where this could happen, + but this is quite rare. + + If this happens, we classifies an operation as + unparsable and it is ok. *) + add_unparsable oph classes ; + mempool + | Some parsed_op -> Operation_hash.Map.add oph parsed_op mempool)) + mempool + operations + in + let* o = chain.read_predecessor_opt block in + match o with + | None -> + (* Can this happen? If yes, there's nothing more to pop anyway, + so returning the accumulator. It's not the mempool that + should crash, should this case happen. *) + let+ () = Event.(emit predecessor_less_block ancestor) in + mempool + | Some predecessor -> + (* This is a tailcall, which is nice; that is why we annotate + here. But it is not required for the code to be correct. + Given the maximum size of possible reorgs, even if the call + was not tail recursive; we wouldn't reach the runtime's stack + limit. *) + (pop_block [@tailcall]) ancestor predecessor mempool + in + let push_block mempool block = + let operations = block_store.all_operation_hashes block in + List.iter (List.iter chain.clear_or_cancel) operations ; + List.fold_left + (List.fold_left (fun mempool h -> Operation_hash.Map.remove h mempool)) + mempool + operations + in + let* ancestor, path = + chain.new_blocks ~from_block:from_branch ~to_block:to_branch + in + let+ mempool = + pop_block (block_store.hash ancestor) from_branch old_mempool + in + let new_mempool = List.fold_left push_block mempool path in + let new_mempool, outdated = + Map.partition + (fun _oph op -> + is_branch_alive op.Prevalidation.raw.Operation.shell.branch) + new_mempool + in + Map.iter (fun oph _op -> chain.clear_or_cancel oph) outdated ; + new_mempool + +let recycle_operations ~from_branch ~to_branch ~live_blocks ~classes ~parse + ~pending ~(block_store : 'block block_tools) ~(chain : 'block chain_tools) + ~handle_branch_refused = + let open Lwt_syntax in + let+ pending = + handle_live_operations + ~classes + ~block_store + ~chain + ~from_branch + ~to_branch + ~is_branch_alive:(fun branch -> Block_hash.Set.mem branch live_blocks) + ~parse + (Map.union + (fun _key v _ -> Some v) + (to_map + ~applied:true + ~prechecked:true + ~branch_delayed:true + ~branch_refused:handle_branch_refused + ~refused:false + ~outdated:false + classes) + pending) + in + (* Non parsable operations that were previously included in a block + will be removed by the call to [flush]. However, as explained in + [handle_live_operations] it should never happen in practice. *) + flush classes ~handle_branch_refused ; + pending + +module Internal_for_tests = struct + (** [copy_bounded_map bm] returns a deep copy of [bm] *) + let copy_bounded_map (bm : 'protocol_data bounded_map) : + 'protocol_data bounded_map = + let copy_ring (ring : Operation_hash.t Ringo.Ring.t) = + let result = Ringo.Ring.capacity ring |> Ringo.Ring.create in + List.iter (Ringo.Ring.add result) (Ringo.Ring.elements ring) ; + result + in + {map = bm.map; ring = copy_ring bm.ring} + + let copy (t : 'protocol_data t) : 'protocol_data t = + (* Code could be shorter by doing a functional update thanks to + the 'with' keyword. We rather list all the fields, so that + the compiler emits a warning when a field is added. *) + { + parameters = t.parameters; + refused = copy_bounded_map t.refused; + outdated = copy_bounded_map t.outdated; + branch_refused = copy_bounded_map t.branch_refused; + branch_delayed = copy_bounded_map t.branch_delayed; + applied_rev = t.applied_rev; + prechecked = t.prechecked; + unparsable = t.unparsable; + in_mempool = t.in_mempool; + } + + let[@coverage off] bounded_map_pp ppf bounded_map = + bounded_map.map |> Map.bindings + |> List.map (fun (key, _value) -> key) + |> Format.fprintf ppf "%a" (Format.pp_print_list Operation_hash.pp) + + let[@coverage off] pp ppf + { + parameters; + refused; + outdated; + branch_refused; + branch_delayed; + applied_rev; + prechecked; + unparsable; + in_mempool; + } = + let applied_pp ppf applied = + applied + |> List.map (fun op -> op.Prevalidation.hash) + |> Format.fprintf ppf "%a" (Format.pp_print_list Operation_hash.pp) + in + let in_mempool_pp ppf in_mempool = + in_mempool |> Map.bindings |> List.map fst + |> Format.fprintf ppf "%a" (Format.pp_print_list Operation_hash.pp) + in + let prechecked_pp ppf prechecked = + prechecked |> Sized_map.bindings |> List.map fst + |> Format.fprintf ppf "%a" (Format.pp_print_list Operation_hash.pp) + in + let unparsable_pp ppf unparsable = + unparsable |> Operation_hash.Set.elements + |> Format.fprintf ppf "%a" (Format.pp_print_list Operation_hash.pp) + in + Format.fprintf + ppf + "Map_size_limit:@.%i@.On discarded operation: \ + @.Refused:%a@.Outdated:%a@.Branch refused:@.%a@.Branch \ + delayed:@.%a@.Applied:@.%a@.Prechecked:@.%a@.Unparsable:@.%a@.In \ + Mempool:@.%a" + parameters.map_size_limit + bounded_map_pp + refused + bounded_map_pp + outdated + bounded_map_pp + branch_refused + bounded_map_pp + branch_delayed + applied_pp + applied_rev + prechecked_pp + prechecked + unparsable_pp + unparsable + in_mempool_pp + in_mempool + + let set_of_bounded_map = set_of_bounded_map + + let[@coverage off] pp_t_sizes pp t = + let show_bounded_map name bounded_map = + Format.sprintf + "%s map: %d, %s ring: %d" + name + (Map.cardinal bounded_map.map) + name + (Ringo.Ring.length bounded_map.ring) + in + let show_map name (map : 'a Sized_map.t) = + Format.sprintf "%s map: %d" name (Sized_map.cardinal map) + in + Format.fprintf + pp + "map_size_limit: %d\n%s\n%s\n%s\n%s\n%sapplied_rev: %d\nin_mempool: %d" + t.parameters.map_size_limit + (show_bounded_map "refused" t.refused) + (show_bounded_map "outdated" t.outdated) + (show_bounded_map "branch_refused" t.branch_refused) + (show_bounded_map "branch_delayed" t.branch_delayed) + (show_map "prechecked" t.prechecked) + (List.length t.applied_rev) + (Map.cardinal t.in_mempool) + + let to_map = to_map + + let flush = flush + + let handle_live_operations = handle_live_operations +end diff --git a/src/lib_shell/legacy_prevalidator_classification.mli b/src/lib_shell/legacy_prevalidator_classification.mli new file mode 100644 index 0000000000000000000000000000000000000000..de4b005df959bb23d89937f26a5fe212e011d2b8 --- /dev/null +++ b/src/lib_shell/legacy_prevalidator_classification.mli @@ -0,0 +1,335 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021-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. *) +(* *) +(*****************************************************************************) + +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the implementation of the legacy mempool, + which is compatible with Kathmandu and therefore usable on Mainnet. + + This file should be removed once Lima has been activated on Mainnet. + + When you modify this file, consider whether you should also change + the files that implement the more recent mempool for Lima and newer + protocols. *) + +module Prevalidation := Legacy_prevalidation + +(** Classifications which correspond to errors *) +type error_classification = + [ `Branch_delayed of tztrace + | `Branch_refused of tztrace + | `Refused of tztrace + | `Outdated of tztrace ] + +(** Classification of an operation in the mempool *) +type classification = [`Applied | `Prechecked | error_classification] + +type 'protocol_data bounded_map + +(** [map bounded_map] gets the underling map of the [bounded_map]. *) +val map : + 'protocol_data bounded_map -> + ('protocol_data Prevalidation.operation * tztrace) Operation_hash.Map.t + +(** [cardinal bounded_map] gets the cardinal of the underling map of the [bounded_map] *) +val cardinal : 'protocol_data bounded_map -> int + +type parameters = { + map_size_limit : int; + on_discarded_operation : Operation_hash.t -> unit; +} + +module Sized_map : + Tezos_base.Sized.SizedMap + with type 'a map := 'a Operation_hash.Map.t + and type key = Operation_hash.t + +(** Invariants ensured by this module, provided that the caller does + not {!add} an operation which is already present in [t]: + + - The field [in_mempool] is the set of all operation hashes + present in fields: [refused; branch_refused; branch_delayed; + prechecked; applied]. + + - An operation cannot be at the same time in two of the following + fields: [refused; branch_refused; branch_delayed; prechecked; + applied]. + + Note: unparsable operations are handled in a different way because + they cannot be handled as a [Prevalidation.operation] since this + datatype requires an operation to be parsable. Hence, unparsable + operations are handled differently. In particular, unparsable + operations are removed on flush. + + Note: We could always enforce these invariants by checking in + {!add} whether the operation is already present. However, this + would make the behavior of {!add} less predictable, so we do not + think this to be an improvement from the point of view of the + caller. *) +type 'protocol_data t = private { + parameters : parameters; + refused : 'protocol_data bounded_map; + outdated : 'protocol_data bounded_map; + branch_refused : 'protocol_data bounded_map; + branch_delayed : 'protocol_data bounded_map; + mutable applied_rev : 'protocol_data Prevalidation.operation list; + mutable prechecked : 'protocol_data Prevalidation.operation Sized_map.t; + mutable unparsable : Operation_hash.Set.t; + mutable in_mempool : + ('protocol_data Prevalidation.operation * classification) + Operation_hash.Map.t; +} + +(** [create parameters] returns an empty {!t} whose bounded maps hold + at most [parameters.map_size_limit] values. The + [on_discarded_operation] is called when a new operation is added + and an old one is discarded because the limit was reached. + + {!Invalid_argument} is raised if [ring_size] is [0] or less. + *) +val create : parameters -> 'protocol_data t + +(** [is_empty t] returns [true] iff [t] doesn't contain any operation. *) +val is_empty : 'protocol_data t -> bool + +(** [is_in_mempool oph classes] indicates whether [oph] is present + in field [in_mempool] of [classes]. It returns the corresponding + operation and its classification if present, and None otherwise. *) +val is_in_mempool : + Operation_hash.t -> + 'protocol_data t -> + ('protocol_data Prevalidation.operation * classification) option + +(** [is_known_unparsable oph] returns [true] if the [oph] is + associated to an operation which is known to be unparsable. [false] + otherwise. *) +val is_known_unparsable : Operation_hash.t -> 'protocol_data t -> bool + +(** [remove oph classes] removes operation of hash [oph] from all + fields of [classes]. If the [oph] was classified as [Applied], the + function is in [O(n)] with [n] being the length of + [classes.applied]. Otherwise, the function is [O(log n)] with [n] + the number of operations in the corresponding class. + + If [oph] was found, its classification as well as the operation it + was bound to are returned. If [oph] was not found, [None] + is returned. + + {b Warning:} If an operation is removed from the [applied] field, + this may invalidate the classification of all the other operations. + It is left to the caller to restore a consistent state. *) +val remove : + Operation_hash.t -> + 'protocol_data t -> + ('protocol_data Prevalidation.operation * classification) option + +(** [add ~notify classification op classes] adds the operation [op] + classified as [classification] to the classifier [classes]. The + [classes.parameters.on_discarded_operation] callback is called for + any operation discarded in this process. Currently, an operation is + discarded in the following cases: + + - the corresponding error class field is full. In that case, the + new operation is added to the class, and the removed one is + discarded. + + - an operation is classified as [Refused]. + + Note that a [Refused] operation may thus be passed twice to + [on_discarded_operation]: as soon as it is added, and if it is + removed because the [classes.refused] bounded map is full. + + As a summary: + + - [Applied] and [Prechecked] are never discarded + + - [Branch_refused] and [Branch_delayed] are discarded 0 or 1 time + (if the corresponding bounded_map is full) + + - [Refused] is discarded 1 or 2 times (if the corresponding + bounded_map is full) *) +val add : + classification -> + 'protocol_data Prevalidation.operation -> + 'protocol_data t -> + unit + +(** [add_unparsable oph classes] adds [oph] as an unparsable + operation. [unparsable] operations are removed automatically by the + [recycle_operations] function. [on_discard_operation] is also + called on those operations. *) +val add_unparsable : Operation_hash.t -> 'protocol_data t -> unit + +(** Functions to query data on a polymorphic block-like type ['block]. *) +type 'block block_tools = { + hash : 'block -> Block_hash.t; (** The hash of a block *) + operations : 'block -> Operation.t list list; + (** The list of operations of a block ordered by their validation pass *) + all_operation_hashes : 'block -> Operation_hash.t list list; + (** The list of hashes of operations of a block ordered by their + validation pass. Could be implemented + using {!operations} but this lets an alternative implementation + to be provided. *) +} + +(** A wrapper over chain-related modules, to make client code easier to + emulate, and hence to test *) +type 'block chain_tools = { + clear_or_cancel : Operation_hash.t -> unit; + (** Removes the operation from the distributed database. *) + inject_operation : Operation_hash.t -> Operation.t -> unit Lwt.t; + (** Puts the operation in the distributed database. Returns [false] if + the [hash] is already in the distributed database *) + new_blocks : + from_block:'block -> to_block:'block -> ('block * 'block list) Lwt.t; + (** [new_blocks ~from_block ~to_block] returns a pair [(ancestor, + path)], where [ancestor] is the common ancestor of [from_block] + and [to_block] and where [path] is the chain from [ancestor] + (excluded) to [to_block] (included). + + @raise assert failure when the two provided blocks do not belong + to the same [chain]. *) + read_predecessor_opt : 'block -> 'block option Lwt.t; + (** [read_predecessor_opt block] returns + the direct predecessor of [block] or [None] if it cannot + be found. *) +} + +(** [recycle_operations] returns the new pending operations when + a reorganisation or a head update occurs. Returned operations come from: + + 1. operations in [from_branch] that are NOT in [to_branch], + 2. operations in the relevant classes of [classification] + 3. operations the [pending] map + + This function guarantees that the branch of all returned operations + is in [live_blocks] ([live_blocks] acts as a filter). + + Operation which where included in [from_branch] and which are NOT in + [to_branch] need to be parsed again using the [parse] argument. If the + parsing fails those operations are just dropped. This may happen if those + operations comes from another protocol. + + See also {!Internal_for_tests.handle_live_operations}. *) +val recycle_operations : + from_branch:'block -> + to_branch:'block -> + live_blocks:Block_hash.Set.t -> + classes:'protocol_data t -> + parse: + (Operation_hash.t -> + Operation.t -> + 'protocol_data Prevalidation.operation option) -> + pending:'protocol_data Prevalidation.operation Operation_hash.Map.t -> + block_store:'block block_tools -> + chain:'block chain_tools -> + handle_branch_refused:bool -> + 'protocol_data Prevalidation.operation Operation_hash.Map.t Lwt.t + +(**/**) + +module Internal_for_tests : sig + val pp : Format.formatter -> 'protocol_data t -> unit + + val bounded_map_pp : Format.formatter -> 'protocol_data bounded_map -> unit + + (** Returns a deep copy of the input [t], so that mutating the one + doesn't affect the other. *) + val copy : 'protocol_data t -> 'protocol_data t + + (** [set_of_bounded_map m] returns all the operation hashes in [m]. *) + val set_of_bounded_map : 'protocol_data bounded_map -> Operation_hash.Set.t + + (** [pp_t_sizes t] prints the [map_size_limit] parameter of [t] + and the sizes of its fields (number of elements in the map and + in the ring of [bounded_map] / length of list / cardinal of set). *) + val pp_t_sizes : Format.formatter -> 'protocol_data t -> unit + + (** [map applied branch_delayed branch_refused refused t] + returns the pairs [(operation_hash, operation)] contained in [t]. + Fields of [t] are included according to the value of the corresponding + named argument. *) + val to_map : + applied:bool -> + prechecked:bool -> + branch_delayed:bool -> + branch_refused:bool -> + refused:bool -> + outdated:bool -> + 'protocol_data t -> + 'protocol_data Prevalidation.operation Operation_hash.Map.t + + (** [flush classes ~handle_branch_refused] partially resets [classes]: + - fields [applied_rev], [branch_delayed] and [unparsable] are emptied; + - field [branch_refused] is emptied iff [handle_branch_refused] is [true]; + - field [refused] is left unchanged, to avoid revalidating operations that + will never be valid; + - field [outdated] is left unchanged. + Also updates field [in_mempool] to maintain the corresponding invariant + of {!t}. *) + val flush : 'protocol_data t -> handle_branch_refused:bool -> unit + + (** [handle_live_operations chain_db from_branch to_branch is_branch_alive parse + old_mempool] returns the operations from: + + 1. [old_mempool], + 2. [from_branch] that are NOT in [to_branch], + + for the subset of these operations whose branch is up-to-date according + to [is_branch_alive] (operations that are not alive are cleared). + + Returned operations can be considered pending afterwards and + are eligible to be propagated. On the other hand, all operations + from [ancestor] to [to_branch] are cleared and won't be propagated. + + Most general case: + to_branch ┐ + / │ + from_branch . ├ path + \ / │ + . . ┘ + \ / + ancestor + + Increment the head case: + + to_branch = path + | + from_branch = ancestor + *) + val handle_live_operations : + classes:'protocol_data t -> + block_store:'block block_tools -> + chain:'block chain_tools -> + from_branch:'block -> + to_branch:'block -> + is_branch_alive:(Block_hash.t -> bool) -> + parse: + (Operation_hash.t -> + Operation.t -> + 'protocol_data Prevalidation.operation option) -> + 'protocol_data Prevalidation.operation Operation_hash.Map.t -> + 'protocol_data Prevalidation.operation Operation_hash.Map.t Lwt.t +end diff --git a/src/lib_shell/legacy_prevalidator_internal.ml b/src/lib_shell/legacy_prevalidator_internal.ml new file mode 100644 index 0000000000000000000000000000000000000000..943c28c19b126dee69910ebabe4cf72936d4e36d --- /dev/null +++ b/src/lib_shell/legacy_prevalidator_internal.ml @@ -0,0 +1,1731 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2018-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. *) +(* *) +(*****************************************************************************) + +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the implementation of the legacy mempool, + which is compatible with Kathmandu and therefore usable on Mainnet. + + This file should be removed once Lima has been activated on Mainnet. + + When you modify this file, consider whether you should also change + the files that implement the more recent mempool for Lima and newer + protocols. *) + +open Prevalidator_internal_common +open Prevalidator_worker_state +module Events = Prevalidator_events +module Classification = Legacy_prevalidator_classification +module Prevalidation = Legacy_prevalidation + +(** This module encapsulates pending operations to maintain them in two + different data structure and avoid coslty repetitive convertions when + handling batches in [classify_pending_operations]. *) +module Pending_ops = Legacy_prevalidator_pending_operations + +(** Module encapsulating some types that are used both in production + and in tests. Having them in a module makes it possible to + [include] this module in {!Internal_for_tests} below and avoid + code duplication. + + The raison d'etre of these records of functions is to be able to use + alternative implementations of all functions in tests. + + The purpose of the {!Tools.tools} record is to abstract away from {!Store.chain_store}. + Under the hood [Store.chain_store] requires an Irmin store on disk, + which makes it impractical for fast testing: every test would need + to create a temporary folder on disk which doesn't scale well. + + The purpose of the {!Tools.worker_tools} record is to abstract away + from the {!Worker} implementation. This implementation is overkill + for testing: we don't need asynchronicity and concurrency in our + pretty basic existing tests. Having this abstraction allows to get + away with a much simpler state machine model of execution and + to have simpler test setup. *) +module Tools = struct + (** Functions provided by {!Distributed_db} and {!Store.chain_store} + that are used in various places of the mempool. Gathered here so that we can test + the mempool without requiring a full-fledged [Distributed_db]/[Store.Chain_store]. *) + type 'prevalidation_t tools = { + advertise_current_head : mempool:Mempool.t -> Store.Block.t -> unit; + (** [advertise_current_head mempool head] sends a + [Current_head (chain_id, head_header, mempool)] message to all known + active peers for the chain being considered. *) + chain_tools : Store.Block.t Classification.chain_tools; + (** Lower-level tools provided by {!Prevalidator_classification} *) + create : + predecessor:Store.Block.t -> + live_operations:Operation_hash.Set.t -> + timestamp:Time.Protocol.t -> + unit -> + 'prevalidation_t tzresult Lwt.t; + (** Creates a new prevalidation context w.r.t. the protocol associated to the + predecessor block. *) + fetch : + ?peer:P2p_peer.Id.t -> + ?timeout:Time.System.Span.t -> + Operation_hash.t -> + Operation.t tzresult Lwt.t; + (** [fetch ?peer ?timeout oph] returns the value when it is known. + It can fail with [Requester.Timeout] if [timeout] is provided and the value + isn't known before the timeout expires. It can fail with [Requester.Cancel] if + the request is canceled. *) + read_block : Block_hash.t -> Store.Block.t tzresult Lwt.t; + (** [read_block bh] tries to read the block [bh] from the chain store. *) + send_get_current_head : ?peer:P2p_peer_id.t -> unit -> unit; + (** [send_get_current_head ?peer ()] sends a [Get_Current_head] + to a given peer, or to all known active peers for the chain considered. + Expected answer is a [Get_current_head] message *) + set_mempool : head:Block_hash.t -> Mempool.t -> unit tzresult Lwt.t; + (** [set_mempool ~head mempool] sets the [mempool] of + the [chain_store] of the chain considered. Does nothing if [head] differs + from current_head which might happen when a new head concurrently arrives just + before this operation is being called. *) + } + + (** Abstraction over services implemented in production by {!Worker} + but implemented differently in tests. + + Also see the enclosing module documentation as to why we have this record. *) + type worker_tools = { + push_request : + (unit, Empty.t) Prevalidator_worker_state.Request.t -> bool Lwt.t; + (** Adds a message to the queue. *) + push_request_now : + (unit, Empty.t) Prevalidator_worker_state.Request.t -> unit; + (** Adds a message to the queue immediately. *) + } +end + +type 'a parameters = { + limits : Shell_limits.prevalidator_limits; + tools : 'a Tools.tools; +} + +(** The type needed for the implementation of [Make] below, but + * which is independent from the protocol. *) +type ('protocol_data, 'a) types_state_shell = { + classification : 'protocol_data Classification.t; + parameters : 'a parameters; + mutable predecessor : Store.Block.t; + mutable timestamp : Time.System.t; + mutable live_blocks : Block_hash.Set.t; + mutable live_operations : Operation_hash.Set.t; + mutable fetching : Operation_hash.Set.t; + mutable pending : 'protocol_data Pending_ops.t; + mutable mempool : Mempool.t; + mutable advertisement : [`Pending of Mempool.t | `None]; + mutable banned_operations : Operation_hash.Set.t; + worker : Tools.worker_tools; +} + +let metrics = Shell_metrics.Mempool.init ["legacy_mempool"] + +(** The concrete production instance of {!block_tools} *) +let block_tools : Store.Block.t Classification.block_tools = + { + hash = Store.Block.hash; + operations = Store.Block.operations; + all_operation_hashes = Store.Block.all_operation_hashes; + } + +(** How to create an instance of {!chain_tools} from a {!Distributed_db.chain_db}. *) +let mk_chain_tools (chain_db : Distributed_db.chain_db) : + Store.Block.t Classification.chain_tools = + let open Lwt_syntax in + let new_blocks ~from_block ~to_block = + let chain_store = Distributed_db.chain_store chain_db in + Store.Chain_traversal.new_blocks chain_store ~from_block ~to_block + in + let read_predecessor_opt block = + let chain_store = Distributed_db.chain_store chain_db in + Store.Block.read_predecessor_opt chain_store block + in + let inject_operation oph op = + let* _ = Distributed_db.inject_operation chain_db oph op in + Lwt.return_unit + in + { + clear_or_cancel = Distributed_db.Operation.clear_or_cancel chain_db; + inject_operation; + new_blocks; + read_predecessor_opt; + } + +(** Module type used both in production and in tests. *) +module type S = sig + (** Type instantiated by {!Filter.Mempool.state}. *) + type filter_state + + (** Type instantiated by {!Filter.Mempool.config}. *) + type filter_config + + (** Similar to the type [operation] from the protocol, + see {!Tezos_protocol_environment.PROTOCOL} *) + type protocol_operation + + (** Type instantiated by {!Prevalidation.t} *) + type prevalidation_t + + type types_state = { + shell : (protocol_operation, prevalidation_t) types_state_shell; + mutable filter_state : filter_state; + (** Internal state of the filter in the plugin *) + mutable validation_state : prevalidation_t tzresult; + mutable operation_stream : + (Classification.classification + * protocol_operation Prevalidation.operation) + Lwt_watcher.input; + mutable rpc_directory : types_state RPC_directory.t lazy_t; + mutable filter_config : filter_config; + lock : Lwt_mutex.t; + } + + (** This function fetches an operation if it is not already handled + as defined by [already_handled] below. The implementation makes + sure to fetch an operation at most once, modulo operations + lost because of bounded buffers becoming full. + + This function is an intruder to this module type. It just happens + that it is needed both by internals of the implementation of {!S} + and by the internals of the implementation of {!T}; so it needs + to be exposed here. *) + val may_fetch_operation : + (protocol_operation, prevalidation_t) types_state_shell -> + P2p_peer_id.t option -> + Operation_hash.t -> + unit Lwt.t + + (** The function called after every call to a function of {!API}. *) + val handle_unprocessed : types_state -> unit Lwt.t + + (** The inner API of the mempool i.e. functions called by the worker + when an individual request arrives. These functions are the + most high-level ones that we test. All these [on_*] functions + correspond to a single event. Possible + sequences of calls to this API are always of the form: + + on_*; handle_unprocessed; on_*; handle_unprocessed; ... *) + module Requests : sig + val on_advertise : _ types_state_shell -> unit + + val on_arrived : + types_state -> + Operation_hash.t -> + Operation.t -> + (unit, Empty.t) result Lwt.t + + val on_ban : types_state -> Operation_hash.t -> unit tzresult Lwt.t + + val on_flush : + handle_branch_refused:bool -> + types_state -> + Store.Block.t -> + Block_hash.Set.t -> + Operation_hash.Set.t -> + unit tzresult Lwt.t + + val on_inject : + types_state -> force:bool -> Operation.t -> unit tzresult Lwt.t + + val on_notify : + _ types_state_shell -> P2p_peer_id.t -> Mempool.t -> unit Lwt.t + end +end + +(** A functor for obtaining the testable part of this file (see + the instantiation of this functor in {!Internal_for_tests} at the + end of this file). Contrary to the production-only functor {!Make} below, + this functor doesn't assume a specific chain store implementation, + which is the crux for having it easily unit-testable. *) +module Make_s + (Filter : Shell_plugin.FILTER) + (Prevalidation_t : Prevalidation.T + with type validation_state = + Filter.Proto.validation_state + and type protocol_operation = Filter.Proto.operation + and type operation_receipt = + Filter.Proto.operation_receipt) : + S + with type filter_state = Filter.Mempool.state + and type filter_config = Filter.Mempool.config + and type protocol_operation = Filter.Proto.operation + and type prevalidation_t = Prevalidation_t.t = struct + type filter_state = Filter.Mempool.state + + type filter_config = Filter.Mempool.config + + type protocol_operation = Filter.Proto.operation + + type prevalidation_t = Prevalidation_t.t + + type 'operation_data operation = 'operation_data Prevalidation.operation + + type types_state = { + shell : (protocol_operation, prevalidation_t) types_state_shell; + mutable filter_state : filter_state; + mutable validation_state : prevalidation_t tzresult; + mutable operation_stream : + (Classification.classification + * protocol_operation Prevalidation.operation) + Lwt_watcher.input; + mutable rpc_directory : types_state RPC_directory.t lazy_t; + mutable filter_config : filter_config; + lock : Lwt_mutex.t; + } + + (* This function is in [Lwt] only for logging. *) + let already_handled ~origin shell oph = + let open Lwt_syntax in + if Operation_hash.Set.mem oph shell.banned_operations then + let+ () = Events.(emit ban_operation_encountered) (origin, oph) in + true + else + Lwt.return + (Pending_ops.mem oph shell.pending + || Operation_hash.Set.mem oph shell.fetching + || Operation_hash.Set.mem oph shell.live_operations + || Classification.is_in_mempool oph shell.classification <> None + || Classification.is_known_unparsable oph shell.classification) + + let advertise (shell : ('operation_data, _) types_state_shell) mempool = + let open Lwt_syntax in + match shell.advertisement with + | `Pending {Mempool.known_valid; pending} -> + shell.advertisement <- + `Pending + { + known_valid = known_valid @ mempool.Mempool.known_valid; + pending = Operation_hash.Set.union pending mempool.pending; + } + | `None -> + shell.advertisement <- `Pending mempool ; + Lwt.dont_wait + (fun () -> + let* () = Lwt_unix.sleep advertisement_delay in + shell.worker.push_request_now Advertise ; + Lwt.return_unit) + (fun exc -> + Format.eprintf "Uncaught exception: %s\n%!" (Printexc.to_string exc)) + + (* Each classified operation should be notified exactly ONCE for a + given stream. Operations which cannot be parsed are not notified. *) + let handle_classification + ~(notifier : + Classification.classification -> + protocol_operation Prevalidation.operation -> + unit) shell (op, kind) = + Classification.add kind op shell.classification ; + notifier kind op + + let mk_notifier operation_stream classification op = + (* This callback is safe encapsulation-wise, because it depends + on an "harmless" field of [types_state_shell]: [operation_stream] *) + Lwt_watcher.notify operation_stream (classification, op) + + let pre_filter shell ~filter_config ~filter_state ~validation_state ~notifier + (parsed_op : protocol_operation operation) : + [Pending_ops.priority | `Drop] Lwt.t = + let open Lwt_syntax in + let validation_state_before = + Option.map + Prevalidation_t.validation_state + (Option.of_result validation_state) + in + let+ v = + Filter.Mempool.pre_filter + ~filter_state + ?validation_state_before + filter_config + parsed_op.protocol + in + match v with + | (`Branch_delayed _ | `Branch_refused _ | `Refused _ | `Outdated _) as errs + -> + handle_classification ~notifier shell (parsed_op, errs) ; + `Drop + | `Passed_prefilter priority -> (priority :> [Pending_ops.priority | `Drop]) + + let post_filter ~filter_config ~filter_state ~validation_state_before + ~validation_state_after op receipt = + Filter.Mempool.post_filter + filter_config + ~filter_state + ~validation_state_before + ~validation_state_after + (op, receipt) + + let set_mempool shell mempool = + shell.mempool <- mempool ; + shell.parameters.tools.set_mempool + ~head:(Store.Block.hash shell.predecessor) + shell.mempool + + let remove_from_advertisement oph = function + | `Pending mempool -> `Pending (Mempool.remove oph mempool) + | `None -> `None + + (* This function retrieves an old/replaced operation and reclassifies it as + [replacement_classification]. Note that we don't need to re-flush the + mempool, as this function is only called in precheck mode. + + The operation is expected to be (a) parsable and (b) in the "prechecked" + class. So, we softly handle the situations where the operation is + unparsable or not found in any class in case this invariant is broken + for some reason. + *) + let reclassify_replaced_manager_op old_hash shell + (replacement_classification : [< Classification.error_classification]) = + shell.advertisement <- + remove_from_advertisement old_hash shell.advertisement ; + match Classification.remove old_hash shell.classification with + | Some (op, _class) -> + [(op, (replacement_classification :> Classification.classification))] + | None -> + (* This case should not happen. *) + shell.parameters.tools.chain_tools.clear_or_cancel old_hash ; + [] + + let precheck ~disable_precheck ~filter_config ~filter_state + ~validation_state:prevalidation_t (op : protocol_operation operation) = + let open Lwt_syntax in + let validation_state = Prevalidation_t.validation_state prevalidation_t in + if disable_precheck then Lwt.return `Undecided + else + let+ v = + Filter.Mempool.precheck + filter_config + ~filter_state + ~validation_state + ~nb_successful_prechecks:op.count_successful_prechecks + op.hash + op.protocol + in + match v with + | `Passed_precheck (filter_state, validation_state, replacement) -> + (* The [precheck] optimization triggers: no need to call the + protocol [apply_operation]. *) + let prevalidation_t = + Prevalidation_t.set_validation_state + prevalidation_t + validation_state + in + let new_op = Prevalidation_t.increment_successful_precheck op in + `Passed_precheck (filter_state, prevalidation_t, new_op, replacement) + | (`Branch_delayed _ | `Branch_refused _ | `Refused _ | `Outdated _) as + errs -> + (* Note that we don't need to distinguish some failure cases + of [Filter.Mempool.precheck], hence grouping them under `Fail. *) + `Fail errs + | `Undecided -> + (* The caller will need to call the protocol's [apply_operation] + function. *) + `Undecided + + (* [classify_operation shell filter_config filter_state validation_state + mempool op oph] allows to determine the class of a given operation. + + Once it's parsed, the operation is prechecked and/or applied in the current + filter/validation state to determine if it could be included in a block on + top of the current head or not. If yes, the operation is accumulated in + the given [mempool]. + + The function returns a tuple + [(filter_state, validation_state, mempool, to_handle)], where: + - [filter_state] is the (possibly) updated filter_state, + - [validation_state] is the (possibly) updated validation_state, + - [mempool] is the (possibly) updated mempool, + - [to_handle] contains the given operation and its classification, and all + operations whose classes are changed/impacted by this classification + (eg. in case of operation replacement). + *) + let classify_operation shell ~filter_config ~filter_state ~validation_state + mempool op : + (filter_state + * prevalidation_t + * Mempool.t + * (protocol_operation operation * Classification.classification) trace) + Lwt.t = + let open Lwt_syntax in + let* v = + let* v = + precheck + ~disable_precheck:shell.parameters.limits.disable_precheck + ~filter_config + ~filter_state + ~validation_state + op + in + match v with + | `Fail errs -> + (* Precheck rejected the operation *) + Lwt.return_error errs + | `Passed_precheck (filter_state, validation_state, new_op, replacement) + -> + (* Precheck succeeded *) + let to_handle = + match replacement with + | `No_replace -> [(new_op, `Prechecked)] + | `Replace (old_oph, replacement_classification) -> + (* Precheck succeeded, but an old operation is replaced *) + let to_replace = + reclassify_replaced_manager_op + old_oph + shell + replacement_classification + in + (new_op, `Prechecked) :: to_replace + in + Lwt.return_ok (filter_state, validation_state, to_handle) + | `Undecided -> ( + (* Precheck was not able to classify *) + let* v = Prevalidation_t.apply_operation validation_state op in + match v with + | Applied (new_validation_state, receipt) -> ( + (* Apply succeeded, call post_filter *) + let* v = + post_filter + ~filter_config + ~filter_state + ~validation_state_before: + (Prevalidation_t.validation_state validation_state) + ~validation_state_after: + (Prevalidation_t.validation_state new_validation_state) + op.protocol + receipt + in + match v with + | `Passed_postfilter new_filter_state -> + (* Post_filter ok, accept operation *) + Lwt.return_ok + (new_filter_state, new_validation_state, [(op, `Applied)]) + | `Refused _ as op_class -> + (* Post_filter refused the operation *) + Lwt.return_error op_class) + (* Apply rejected the operation *) + | Branch_delayed e -> Lwt.return_error (`Branch_delayed e) + | Branch_refused e -> Lwt.return_error (`Branch_refused e) + | Refused e -> Lwt.return_error (`Refused e) + | Outdated e -> Lwt.return_error (`Outdated e)) + in + match v with + | Error err_class -> + Lwt.return (filter_state, validation_state, mempool, [(op, err_class)]) + | Ok (f_state, v_state, to_handle) -> + let mempool = Mempool.cons_valid op.hash mempool in + Lwt.return (f_state, v_state, mempool, to_handle) + + (* Classify pending operations into either: [Refused | + Branch_delayed | Branch_refused | Applied | Outdated]. + To ensure fairness with other worker requests, classification of + operations is done by batch of [operation_batch_size] operations. + + This function ensures the following invariants: + + - If an operation is classified, it is not part of the [pending] + map + + - A classified operation is part of the [in_mempool] set + + - A classified operation is part only of one of the following + classes: [Branch_refused, Branch_delayed, Refused, Applied] + + Moreover, this function ensures that only each newly classified + operations are advertised to the remote peers. However, if a peer + requests our mempool, we advertise all our classified operations and + all our pending operations. *) + let classify_pending_operations ~notifier shell filter_config filter_state + state = + let open Lwt_syntax in + let* r = + Pending_ops.fold_es + (fun _prio + oph + op + (acc_filter_state, acc_validation_state, acc_mempool, limit) -> + if limit <= 0 then + (* Using Error as an early-return mechanism *) + Lwt.return_error + (acc_filter_state, acc_validation_state, acc_mempool) + else ( + shell.pending <- Pending_ops.remove oph shell.pending ; + let+ new_filter_state, new_validation_state, new_mempool, to_handle + = + classify_operation + shell + ~filter_config + ~filter_state:acc_filter_state + ~validation_state:acc_validation_state + acc_mempool + op + in + List.iter (handle_classification ~notifier shell) to_handle ; + Ok (new_filter_state, new_validation_state, new_mempool, limit - 1))) + shell.pending + ( filter_state, + state, + Mempool.empty, + shell.parameters.limits.operations_batch_size ) + in + match r with + | Error (filter_state, state, advertised_mempool) -> + (* Early return after iteration limit was reached *) + let* (_was_pushed : bool) = + shell.worker.push_request Request.Leftover + in + Lwt.return (filter_state, state, advertised_mempool) + | Ok (filter_state, state, advertised_mempool, _) -> + Lwt.return (filter_state, state, advertised_mempool) + + let update_advertised_mempool_fields pv_shell delta_mempool = + let open Lwt_syntax in + if Mempool.is_empty delta_mempool then Lwt.return_unit + else + (* We only advertise newly classified operations. *) + let mempool_to_advertise = + Mempool. + {delta_mempool with known_valid = List.rev delta_mempool.known_valid} + in + advertise pv_shell mempool_to_advertise ; + let our_mempool = + let prechecked_hashes = + (* Outputs hashes in "decreasing" order which should not matter *) + Classification.Sized_map.fold + (fun x _ acc -> x :: acc) + pv_shell.classification.prechecked + [] + in + { + (* FIXME: https://gitlab.com/tezos/tezos/-/issues/2065 + This field does not only contain valid operation *) + Mempool.known_valid = + List.fold_left + (fun acc op -> op.Prevalidation.hash :: acc) + prechecked_hashes + pv_shell.classification.applied_rev; + pending = Pending_ops.hashes pv_shell.pending; + } + in + let* _res = set_mempool pv_shell our_mempool in + Lwt.pause () + + let handle_unprocessed pv = + let open Lwt_syntax in + let notifier = mk_notifier pv.operation_stream in + match pv.validation_state with + | Error err -> + (* At the time this comment was written (26/05/21), this is dead + code since [Proto.begin_construction] cannot fail. *) + Pending_ops.iter + (fun _prio _oph op -> + handle_classification ~notifier pv.shell (op, `Branch_delayed err)) + pv.shell.pending ; + pv.shell.pending <- Pending_ops.empty ; + Lwt.return_unit + | Ok state -> + if Pending_ops.is_empty pv.shell.pending then Lwt.return_unit + else + let* () = Events.(emit processing_operations) () in + let* filter_state, validation_state, delta_mempool = + classify_pending_operations + ~notifier + pv.shell + pv.filter_config + pv.filter_state + state + in + pv.filter_state <- filter_state ; + pv.validation_state <- Ok validation_state ; + update_advertised_mempool_fields pv.shell delta_mempool + + (* This function fetches one operation through the + [distributed_db]. On errors, we emit an event and proceed as + usual. *) + let fetch_operation (shell : ('operation_data, _) types_state_shell) ?peer oph + = + let open Lwt_syntax in + let+ () = Events.(emit fetching_operation) oph in + let* r = + shell.parameters.tools.fetch + ~timeout:shell.parameters.limits.operation_timeout + ?peer + oph + in + match r with + | Ok op -> + shell.worker.push_request_now (Arrived (oph, op)) ; + Lwt.return_unit + | Error (Distributed_db.Operation.Canceled _ :: _) -> + Events.(emit operation_included) oph + | Error _ -> + (* This may happen if the peer timed out for example. *) + Events.(emit operation_not_fetched) oph + + (* This function fetches an operation if it is not already handled + by the mempool. To ensure we fetch at most a given operation, + we record it in the [pv.fetching] field. + + Invariant: This function should be the only one to modify this + field. + + Invariant: To ensure, there is no leak, we ensure that when the + promise [p] is terminated, we remove the operation from the + fetching operations. This is to ensure that if an error + happened, we can still fetch this operation in the future. *) + let may_fetch_operation (shell : ('operation_data, _) types_state_shell) peer + oph = + let open Lwt_syntax in + let origin = + match peer with Some peer -> Events.Peer peer | None -> Leftover + in + let* already_handled = already_handled ~origin shell oph in + if not already_handled then + ignore + (Lwt.finalize + (fun () -> + shell.fetching <- Operation_hash.Set.add oph shell.fetching ; + fetch_operation shell ?peer oph) + (fun () -> + shell.fetching <- Operation_hash.Set.remove oph shell.fetching ; + Lwt.return_unit)) ; + Lwt.return_unit + + (** Module containing functions that are the internal transitions + of the mempool. These functions are called by the {!Worker} when + an event arrives. *) + module Requests = struct + let on_arrived (pv : types_state) oph op : (unit, Empty.t) result Lwt.t = + let open Lwt_syntax in + let* already_handled = + already_handled ~origin:Events.Arrived pv.shell oph + in + if already_handled then return_ok_unit + else + match Prevalidation_t.parse oph op with + | Error _ -> + let* () = Events.(emit unparsable_operation) oph in + Classification.add_unparsable oph pv.shell.classification ; + return_ok_unit + | Ok parsed_op -> ( + let* v = + pre_filter + pv.shell + ~filter_config:pv.filter_config + ~filter_state:pv.filter_state + ~validation_state:pv.validation_state + ~notifier:(mk_notifier pv.operation_stream) + parsed_op + in + match v with + | `Drop -> return_ok_unit + | (`High | `Medium | `Low _) as prio -> + if + not + (Block_hash.Set.mem + op.Operation.shell.branch + pv.shell.live_blocks) + then ( + pv.shell.parameters.tools.chain_tools.clear_or_cancel oph ; + return_ok_unit) + else ( + (* TODO: https://gitlab.com/tezos/tezos/-/issues/1723 + Should this have an influence on the peer's score ? *) + pv.shell.pending <- + Pending_ops.add parsed_op prio pv.shell.pending ; + return_ok_unit)) + + let on_inject (pv : types_state) ~force op = + let open Lwt_result_syntax in + let oph = Operation.hash op in + (* Currently, an injection is always done with the highest priority, because: + - We want to process and propagate the injected operations fast, + - We don't want to call prefilter to get the priority. + But, this may change in the future + *) + let prio = `High in + let*! already_handled = + already_handled ~origin:Events.Injected pv.shell oph + in + if already_handled then + (* FIXME: https://gitlab.com/tezos/tezos/-/issues/1722 + Is this an error? *) + return_unit + else + match Prevalidation_t.parse oph op with + | Error err -> + failwith + "Invalid operation %a: %a." + Operation_hash.pp + oph + Error_monad.pp_print_trace + err + | Ok parsed_op -> ( + if force then ( + let*! () = + pv.shell.parameters.tools.chain_tools.inject_operation oph op + in + pv.shell.pending <- + Pending_ops.add parsed_op prio pv.shell.pending ; + return_unit) + else if + not + (Block_hash.Set.mem + op.Operation.shell.branch + pv.shell.live_blocks) + then + failwith + "Operation %a is branched on a block %a which is too old" + Operation_hash.pp + oph + Block_hash.pp + op.Operation.shell.branch + else + let*? validation_state = + Result.bind_error pv.validation_state (fun err -> + error_with + "%s, in function [on_inject], the [validation_state] \ + contains the following error:@\n\ + %a" + __LOC__ + Error_monad.pp_print_top_error_of_trace + err) + in + let notifier = mk_notifier pv.operation_stream in + let*! filter_state, validation_state, delta_mempool, to_handle = + classify_operation + pv.shell + ~filter_config:pv.filter_config + ~filter_state:pv.filter_state + ~validation_state + Mempool.empty + parsed_op + in + let op_status = + (* to_handle contains the given operation and its classification, and + all operations whose classes are changed/impacted by this + classification (eg. in case of operation replacement). Here, we + retrieve the classification of our operation. *) + List.find_opt + (function + | ({hash; _} : protocol_operation operation), _ -> + Operation_hash.equal hash oph) + to_handle + in + match op_status with + | Some (_h, (`Applied | `Prechecked)) -> + (* TODO: https://gitlab.com/tezos/tezos/-/issues/2294 + In case of `Passed_precheck_with_replace, we may want to only do + the injection/replacement if a flag `replace` is set to true + in the injection query. *) + let*! () = + pv.shell.parameters.tools.chain_tools.inject_operation + oph + op + in + (* Call handle & update_advertised_mempool only if op is accepted *) + List.iter (handle_classification ~notifier pv.shell) to_handle ; + pv.filter_state <- filter_state ; + pv.validation_state <- Ok validation_state ; + (* Note that in this case, we may advertise an operation and bypass + the prioritirization strategy. *) + let*! v = + update_advertised_mempool_fields pv.shell delta_mempool + in + return v + | Some + ( _h, + ( `Branch_delayed e + | `Branch_refused e + | `Refused e + | `Outdated e ) ) -> + Lwt.return + @@ error_with + "Error while applying operation %a:@ %a" + Operation_hash.pp + oph + pp_print_trace + e + | None -> + (* This case should not happen *) + failwith + "Unexpected error while injecting operation %a. Operation \ + not found after classifying it." + Operation_hash.pp + oph) + + let on_notify (shell : ('operation_data, _) types_state_shell) peer mempool + = + let open Lwt_syntax in + let may_fetch_operation = may_fetch_operation shell (Some peer) in + let* () = List.iter_s may_fetch_operation mempool.Mempool.known_valid in + Seq.iter_s + may_fetch_operation + (Operation_hash.Set.to_seq mempool.Mempool.pending) + + let on_flush ~handle_branch_refused pv new_predecessor new_live_blocks + new_live_operations = + let open Lwt_result_syntax in + let old_predecessor = pv.shell.predecessor in + pv.shell.predecessor <- new_predecessor ; + pv.shell.live_blocks <- new_live_blocks ; + pv.shell.live_operations <- new_live_operations ; + Lwt_watcher.shutdown_input pv.operation_stream ; + pv.operation_stream <- Lwt_watcher.create_input () ; + let timestamp_system = Tezos_base.Time.System.now () in + pv.shell.timestamp <- timestamp_system ; + let timestamp = Time.System.to_protocol timestamp_system in + let*! validation_state = + pv.shell.parameters.tools.create + ~predecessor:new_predecessor + ~live_operations:new_live_operations + ~timestamp + () + in + pv.validation_state <- validation_state ; + let* filter_state = + Filter.Mempool.on_flush + pv.filter_config + pv.filter_state + ?validation_state: + (Option.map + Prevalidation_t.validation_state + (Option.of_result validation_state)) + ~predecessor:(Store.Block.header new_predecessor) + () + in + pv.filter_state <- filter_state ; + let*! new_pending_operations = + Classification.recycle_operations + ~from_branch:old_predecessor + ~to_branch:new_predecessor + ~live_blocks:new_live_blocks + ~parse:(fun oph op -> Result.to_option (Prevalidation_t.parse oph op)) + ~classes:pv.shell.classification + ~pending:(Pending_ops.operations pv.shell.pending) + ~block_store:block_tools + ~chain:pv.shell.parameters.tools.chain_tools + ~handle_branch_refused + in + (* Could be implemented as Operation_hash.Map.filter_s which + does not exist for the moment. *) + let*! new_pending_operations, nb_pending = + Operation_hash.Map.fold_s + (fun _oph op (pending, nb_pending) -> + let*! v = + pre_filter + pv.shell + ~filter_config:pv.filter_config + ~filter_state:pv.filter_state + ~validation_state:pv.validation_state + ~notifier:(mk_notifier pv.operation_stream) + op + in + match v with + | `Drop -> Lwt.return (pending, nb_pending) + | (`High | `Medium | `Low _) as prio -> + (* Here, an operation injected in this node with `High priority will + now get its approriate priority. *) + Lwt.return (Pending_ops.add op prio pending, nb_pending + 1)) + new_pending_operations + (Pending_ops.empty, 0) + in + let*! () = Events.(emit operations_to_reclassify) nb_pending in + pv.shell.pending <- new_pending_operations ; + set_mempool pv.shell Mempool.empty + + let on_advertise (shell : ('protocol_data, _) types_state_shell) = + match shell.advertisement with + | `None -> + () (* May happen if nothing to advertise since last advertisement. *) + | `Pending mempool -> + shell.advertisement <- `None ; + (* In this case, mempool is not empty, but let's avoid advertising + empty mempools in case this invariant is broken. *) + if not (Mempool.is_empty mempool) then + shell.parameters.tools.advertise_current_head + ~mempool + shell.predecessor + + (* If [flush_if_prechecked] is [true], removing a prechecked + operation triggers a flush of the mempool. Because flushing may + be costly this should be done only when the action is triggered + locally by the user. This allows a better UX if the user bans a + prechecked operation so that a branch delayed operation becomes + [applied] again. *) + let remove ~flush_if_prechecked pv oph = + let open Lwt_result_syntax in + pv.shell.parameters.tools.chain_tools.clear_or_cancel oph ; + pv.shell.advertisement <- + remove_from_advertisement oph pv.shell.advertisement ; + pv.shell.banned_operations <- + Operation_hash.Set.add oph pv.shell.banned_operations ; + match Classification.remove oph pv.shell.classification with + | None -> + pv.shell.pending <- Pending_ops.remove oph pv.shell.pending ; + pv.shell.fetching <- Operation_hash.Set.remove oph pv.shell.fetching ; + return_unit + | Some (_op, classification) -> ( + match (classification, flush_if_prechecked) with + | `Prechecked, true | `Applied, _ -> + (* Modifying the list of operations classified as [Applied] + might change the classification of all the operations in + the mempool. Hence if the removed operation has been + applied we flush the mempool to force the + reclassification of all the operations except the one + removed. *) + let+ () = + on_flush + ~handle_branch_refused:false + pv + pv.shell.predecessor + pv.shell.live_blocks + pv.shell.live_operations + in + pv.shell.pending <- Pending_ops.remove oph pv.shell.pending + | `Branch_delayed _, _ + | `Branch_refused _, _ + | `Refused _, _ + | `Outdated _, _ + | `Prechecked, false -> + pv.filter_state <- + Filter.Mempool.remove ~filter_state:pv.filter_state oph ; + return_unit) + + let on_ban pv oph_to_ban = + pv.shell.banned_operations <- + Operation_hash.Set.add oph_to_ban pv.shell.banned_operations ; + remove ~flush_if_prechecked:true pv oph_to_ban + end +end + +module type ARG = sig + val limits : Shell_limits.prevalidator_limits + + val chain_db : Distributed_db.chain_db + + val chain_id : Chain_id.t +end + +module Name = struct + include Name + + let base = ["legacy_prevalidator"] +end + +module WorkerGroup = Worker.MakeGroup (Name) (Prevalidator_worker_state.Request) + +(** The functor that is not tested, in other words used only in production. + This functor's code is not tested (contrary to functor {!Make_s} above), + because it hardcodes a dependency to [Store.chain_store] in its instantiation + of type [chain_store]. This is what makes the code of this functor + not testable for the moment, because [Store.chain_store] has poor + testing capabilities. + + Note that, because this functor [include]s {!Make_s}, it is a + strict extension of [Make_s]. *) +module Make + (Filter : Shell_plugin.FILTER) + (Arg : ARG) + (Prevalidation_t : Prevalidation.T + with type validation_state = + Filter.Proto.validation_state + and type protocol_operation = Filter.Proto.operation + and type operation_receipt = + Filter.Proto.operation_receipt + and type chain_store = Store.chain_store) : T = struct + module S = Make_s (Filter) (Prevalidation_t) + open S + + type types_state = S.types_state + + let get_rpc_directory pv = pv.rpc_directory + + let name = (Arg.chain_id, Filter.Proto.hash) + + module Types = struct + type state = types_state + + type parameters = Shell_limits.prevalidator_limits * Distributed_db.chain_db + end + + module Worker : + Worker.T + with type Name.t = Name.t + and type ('a, 'b) Request.t = ('a, 'b) Request.t + and type Request.view = Request.view + and type Types.state = Types.state + and type Types.parameters = Types.parameters = + WorkerGroup.MakeWorker (Types) + + open Types + + type worker = Worker.infinite Worker.queue Worker.t + + (** Returns a json describing the prevalidator's [filter_config]. + The boolean [include_default] ([true] by default) indicates + whether the json should include the fields which have a value + equal to their default value. *) + let get_filter_config_json ?(include_default = true) pv = + let include_default_fields = if include_default then `Always else `Never in + Data_encoding.Json.construct + ~include_default_fields + Filter.Mempool.config_encoding + pv.filter_config + + let build_rpc_directory w = + lazy + (let open Lwt_result_syntax in + let dir : state RPC_directory.t ref = ref RPC_directory.empty in + let module Proto_services = + Block_services.Make (Filter.Proto) (Filter.Proto) + in + dir := + RPC_directory.register + !dir + (Proto_services.S.Mempool.get_filter RPC_path.open_root) + (fun pv params () -> + return + (get_filter_config_json + ~include_default:params#include_default + pv)) ; + dir := + RPC_directory.register + !dir + (Proto_services.S.Mempool.set_filter RPC_path.open_root) + (fun pv () obj -> + let open Lwt_syntax in + let* () = + try + let config = + Data_encoding.Json.destruct Filter.Mempool.config_encoding obj + in + pv.filter_config <- config ; + Lwt.return_unit + with _ -> Events.(emit invalid_mempool_filter_configuration) () + in + return_ok (get_filter_config_json pv)) ; + (* Ban an operation (from its given hash): remove it from the + mempool if present. Add it to the set pv.banned_operations + to prevent it from being fetched/processed/injected in the + future. + Note: If the baker has already received the operation, then + it's necessary to restart it manually to flush the operation + from it. *) + dir := + RPC_directory.register + !dir + (Proto_services.S.Mempool.ban_operation RPC_path.open_root) + (fun _pv () oph -> + let open Lwt_result_syntax in + let*! r = Worker.Queue.push_request_and_wait w (Request.Ban oph) in + match r with + | Error (Closed None) -> fail [Worker_types.Terminated] + | Error (Closed (Some errs)) -> fail errs + | Error (Request_error err) -> fail err + | Error (Any exn) -> fail [Exn exn] + | Ok () -> return_unit) ; + (* Unban an operation (from its given hash): remove it from the + set pv.banned_operations (nothing happens if it was not banned). *) + dir := + RPC_directory.register + !dir + (Proto_services.S.Mempool.unban_operation RPC_path.open_root) + (fun pv () oph -> + pv.shell.banned_operations <- + Operation_hash.Set.remove oph pv.shell.banned_operations ; + return_unit) ; + (* Unban all operations: clear the set pv.banned_operations. *) + dir := + RPC_directory.register + !dir + (Proto_services.S.Mempool.unban_all_operations RPC_path.open_root) + (fun pv () () -> + pv.shell.banned_operations <- Operation_hash.Set.empty ; + return_unit) ; + dir := + RPC_directory.gen_register + !dir + (Proto_services.S.Mempool.pending_operations RPC_path.open_root) + (fun pv params () -> + let map_op_error oph (op, error) acc = + op.Prevalidation.protocol |> fun res -> + Operation_hash.Map.add oph (res, error) acc + in + let applied = + if params#applied then + List.rev_map + (fun op -> (op.Prevalidation.hash, op.Prevalidation.protocol)) + pv.shell.classification.applied_rev + else [] + in + let filter f map = + Operation_hash.Map.fold f map Operation_hash.Map.empty + in + let refused = + if params#refused then + filter + map_op_error + (Classification.map pv.shell.classification.refused) + else Operation_hash.Map.empty + in + let outdated = + if params#outdated then + filter + map_op_error + (Classification.map pv.shell.classification.outdated) + else Operation_hash.Map.empty + in + let branch_refused = + if params#branch_refused then + filter + map_op_error + (Classification.map pv.shell.classification.branch_refused) + else Operation_hash.Map.empty + in + let branch_delayed = + if params#branch_delayed then + filter + map_op_error + (Classification.map pv.shell.classification.branch_delayed) + else Operation_hash.Map.empty + in + let unprocessed = + Pending_ops.fold + (fun _prio oph op acc -> + Operation_hash.Map.add oph op.protocol acc) + pv.shell.pending + Operation_hash.Map.empty + in + (* FIXME https://gitlab.com/tezos/tezos/-/issues/2250 + + We merge prechecked operation with applied operation + so that the encoding of the RPC does not need to be + changed. Once prechecking will be done by the protocol + and not the plugin, we will change the encoding to + reflect that. *) + let prechecked_with_applied = + if params#applied then + Classification.Sized_map.fold + (fun oph op acc -> (oph, op.Prevalidation.protocol) :: acc) + pv.shell.classification.prechecked + applied + else applied + in + let pending_operations = + { + Proto_services.Mempool.applied = prechecked_with_applied; + refused; + outdated; + branch_refused; + branch_delayed; + unprocessed; + } + in + Proto_services.Mempool.pending_operations_version_dispatcher + ~version:params#version + pending_operations) ; + dir := + RPC_directory.register + !dir + (Proto_services.S.Mempool.request_operations RPC_path.open_root) + (fun pv t () -> + pv.shell.parameters.tools.send_get_current_head ?peer:t#peer_id () ; + return_unit) ; + dir := + RPC_directory.gen_register + !dir + (Proto_services.S.Mempool.monitor_operations RPC_path.open_root) + (fun pv params () -> + Lwt_mutex.with_lock pv.lock @@ fun () -> + let op_stream, stopper = + Lwt_watcher.create_stream pv.operation_stream + in + (* Convert ops *) + let fold_op hash (Prevalidation.{protocol; _}, error) acc = + (hash, protocol, error) :: acc + in + (* First call : retrieve the current set of op from the mempool *) + let applied = + if params#applied then + List.map + (fun op -> (op.Prevalidation.hash, op.protocol, [])) + pv.shell.classification.applied_rev + else [] + in + (* FIXME https://gitlab.com/tezos/tezos/-/issues/2250 + + For the moment, applied and prechecked operations are + handled the same way for the user point of view. *) + let prechecked = + if params#applied then + Classification.Sized_map.fold + (fun hash op acc -> + (hash, op.Prevalidation.protocol, []) :: acc) + pv.shell.classification.prechecked + [] + else [] + in + let refused = + if params#refused then + Operation_hash.Map.fold + fold_op + (Classification.map pv.shell.classification.refused) + [] + else [] + in + let branch_refused = + if params#branch_refused then + Operation_hash.Map.fold + fold_op + (Classification.map pv.shell.classification.branch_refused) + [] + else [] + in + let branch_delayed = + if params#branch_delayed then + Operation_hash.Map.fold + fold_op + (Classification.map pv.shell.classification.branch_delayed) + [] + else [] + in + let outdated = + if params#outdated then + Operation_hash.Map.fold + fold_op + (Classification.map pv.shell.classification.outdated) + [] + else [] + in + let current_mempool = + List.concat_map + (List.map (function + | hash, op, [] -> ((hash, op), None) + | hash, op, errors -> ((hash, op), Some errors))) + [ + applied; + prechecked; + refused; + branch_refused; + branch_delayed; + outdated; + ] + in + let current_mempool = ref (Some current_mempool) in + let filter_result = function + | `Prechecked | `Applied -> params#applied + | `Refused _ -> params#refused + | `Outdated _ -> params#outdated + | `Branch_refused _ -> params#branch_refused + | `Branch_delayed _ -> params#branch_delayed + in + let rec next () = + let open Lwt_syntax in + match !current_mempool with + | Some mempool -> + current_mempool := None ; + Lwt.return_some mempool + | None -> ( + let* o = Lwt_stream.get op_stream in + match o with + | Some (kind, op) when filter_result kind -> + let errors = + match kind with + | `Prechecked | `Applied -> None + | `Branch_delayed errors + | `Branch_refused errors + | `Refused errors + | `Outdated errors -> + Some errors + in + Lwt.return_some + [(Prevalidation.(op.hash, op.protocol), errors)] + | Some _ -> next () + | None -> Lwt.return_none) + in + let shutdown () = Lwt_watcher.shutdown stopper in + RPC_answer.return_stream {next; shutdown}) ; + !dir) + + (** Module implementing the events at the {!Worker} level. Contrary + to {!Requests}, these functions depend on [Worker]. *) + module Handlers = struct + type self = worker + + let on_request : + type r request_error. + worker -> + (r, request_error) Request.t -> + (r, request_error) result Lwt.t = + fun w request -> + let open Lwt_result_syntax in + Prometheus.Counter.inc_one metrics.worker_counters.worker_request_count ; + let pv = Worker.state w in + let post_processing : + (r, request_error) result Lwt.t -> (r, request_error) result Lwt.t = + fun r -> + let open Lwt_syntax in + let* () = handle_unprocessed pv in + r + in + post_processing + @@ + match request with + | Request.Flush (hash, event, live_blocks, live_operations) -> + Requests.on_advertise pv.shell ; + (* TODO: https://gitlab.com/tezos/tezos/-/issues/1727 + Rebase the advertisement instead. *) + let* block = pv.shell.parameters.tools.read_block hash in + let handle_branch_refused = + Chain_validator_worker_state.( + match event with + | Head_increment | Ignored_head -> false + | Branch_switch -> true) + in + Lwt_mutex.with_lock pv.lock + @@ fun () : (r, error trace) result Lwt.t -> + Requests.on_flush + ~handle_branch_refused + pv + block + live_blocks + live_operations + | Request.Notify (peer, mempool) -> + let*! () = Requests.on_notify pv.shell peer mempool in + return_unit + | Request.Leftover -> + (* unprocessed ops are handled just below *) + return_unit + | Request.Inject {op; force} -> Requests.on_inject pv ~force op + | Request.Arrived (oph, op) -> Requests.on_arrived pv oph op + | Request.Advertise -> + Requests.on_advertise pv.shell ; + return_unit + | Request.Ban oph -> Requests.on_ban pv oph + + let on_close w = + let pv = Worker.state w in + Operation_hash.Set.iter + pv.shell.parameters.tools.chain_tools.clear_or_cancel + pv.shell.fetching ; + Lwt.return_unit + + let mk_tools (chain_db : Distributed_db.chain_db) : + prevalidation_t Tools.tools = + let advertise_current_head ~mempool bh = + Distributed_db.Advertise.current_head chain_db ~mempool bh + in + let chain_tools = mk_chain_tools chain_db in + let create ~predecessor ~live_operations ~timestamp = + let chain_store = Distributed_db.chain_store chain_db in + Prevalidation_t.create + chain_store + ~predecessor + ~live_operations + ~timestamp + in + let fetch ?peer ?timeout oph = + Distributed_db.Operation.fetch chain_db ?timeout ?peer oph () + in + let read_block bh = + let chain_store = Distributed_db.chain_store chain_db in + Store.Block.read_block chain_store bh + in + let send_get_current_head ?peer () = + Distributed_db.Request.current_head chain_db ?peer () + in + let set_mempool ~head mempool = + let chain_store = Distributed_db.chain_store chain_db in + Store.Chain.set_mempool chain_store ~head mempool + in + { + advertise_current_head; + chain_tools; + create; + fetch; + read_block; + send_get_current_head; + set_mempool; + } + + let mk_worker_tools w : Tools.worker_tools = + let push_request r = Worker.Queue.push_request w r in + let push_request_now r = Worker.Queue.push_request_now w r in + {push_request; push_request_now} + + type launch_error = error trace + + let on_launch w _ (limits, chain_db) : (state, launch_error) result Lwt.t = + let open Lwt_result_syntax in + let chain_store = Distributed_db.chain_store chain_db in + let*! predecessor = Store.Chain.current_head chain_store in + let predecessor_header = Store.Block.header predecessor in + let*! mempool = Store.Chain.mempool chain_store in + let*! live_blocks, live_operations = + Store.Chain.live_blocks chain_store + in + let timestamp_system = Tezos_base.Time.System.now () in + let timestamp = Time.System.to_protocol timestamp_system in + let*! validation_state = + Prevalidation_t.create + chain_store + ~predecessor + ~timestamp + ~live_operations + () + in + let fetching = + List.fold_left + (fun s h -> Operation_hash.Set.add h s) + Operation_hash.Set.empty + mempool.known_valid + in + let classification_parameters = + Classification. + { + map_size_limit = limits.Shell_limits.max_refused_operations; + on_discarded_operation = + Distributed_db.Operation.clear_or_cancel chain_db; + } + in + let classification = Classification.create classification_parameters in + let parameters = {limits; tools = mk_tools chain_db} in + let shell = + { + classification; + parameters; + predecessor; + timestamp = timestamp_system; + live_blocks; + live_operations; + mempool = Mempool.empty; + fetching; + pending = Pending_ops.empty; + advertisement = `None; + banned_operations = Operation_hash.Set.empty; + worker = mk_worker_tools w; + } + in + Shell_metrics.Mempool.set_applied_collector (fun () -> + List.length shell.classification.applied_rev |> float_of_int) ; + Shell_metrics.Mempool.set_prechecked_collector (fun () -> + Classification.Sized_map.cardinal shell.classification.prechecked + |> float_of_int) ; + Shell_metrics.Mempool.set_refused_collector (fun () -> + Classification.cardinal shell.classification.refused |> float_of_int) ; + Shell_metrics.Mempool.set_branch_refused_collector (fun () -> + Classification.cardinal shell.classification.branch_refused + |> float_of_int) ; + Shell_metrics.Mempool.set_branch_delayed_collector (fun () -> + Classification.cardinal shell.classification.branch_delayed + |> float_of_int) ; + Shell_metrics.Mempool.set_outdated_collector (fun () -> + Classification.cardinal shell.classification.outdated |> float_of_int) ; + Shell_metrics.Mempool.set_unprocessed_collector (fun () -> + Pending_ops.cardinal shell.pending |> float_of_int) ; + + let* filter_state = + Filter.Mempool.init + Filter.Mempool.default_config + ?validation_state: + (Option.map + Prevalidation_t.validation_state + (Option.of_result validation_state)) + ~predecessor:predecessor_header + () + in + let pv = + { + shell; + validation_state; + filter_state; + operation_stream = Lwt_watcher.create_input (); + rpc_directory = build_rpc_directory w; + filter_config = + (* TODO: https://gitlab.com/tezos/tezos/-/issues/1725 + initialize from config file *) + Filter.Mempool.default_config; + lock = Lwt_mutex.create (); + } + in + let*! () = + Seq.iter_s + (may_fetch_operation pv.shell None) + (Operation_hash.Set.to_seq fetching) + in + return pv + + let on_error (type a b) _w st (request : (a, b) Request.t) (errs : b) : + unit tzresult Lwt.t = + Prometheus.Counter.inc_one metrics.worker_counters.worker_error_count ; + let open Lwt_syntax in + match request with + | Request.(Inject _) as r -> + let* () = Events.(emit request_failed) (Request.view r, st, errs) in + return_ok_unit + | Request.Notify _ -> ( match errs with _ -> .) + | Request.Leftover -> ( match errs with _ -> .) + | Request.Arrived _ -> ( match errs with _ -> .) + | Request.Advertise -> ( match errs with _ -> .) + | Request.Flush _ -> + let request_view = Request.view request in + let* () = Events.(emit request_failed) (request_view, st, errs) in + Lwt.return_error errs + | Request.Ban _ -> + let request_view = Request.view request in + let* () = Events.(emit request_failed) (request_view, st, errs) in + Lwt.return_error errs + + let on_completion _w r _ st = + Prometheus.Counter.inc_one metrics.worker_counters.worker_completion_count ; + match Request.view r with + | Request.View (Flush _) | View (Inject _) | View (Ban _) -> + Events.(emit request_completed_notice) (Request.view r, st) + | View (Notify _) | View Leftover | View (Arrived _) | View Advertise -> + Events.(emit request_completed_debug) (Request.view r, st) + + let on_no_request _ = Lwt.return_unit + end + + let table = Worker.create_table Queue + + (* NOTE: we register a single worker for each instantiation of this Make + * functor (and thus a single worker for the single instantiation of Worker). + * Whilst this is somewhat abusing the intended purpose of worker, it is part + * of a transition plan to a one-worker-per-peer architecture. *) + let worker_promise = + Worker.launch table name (Arg.limits, Arg.chain_db) (module Handlers) + + let worker = + lazy + (match Lwt.state worker_promise with + | Lwt.Return (Ok worker) -> worker + | Lwt.Return (Error _) | Lwt.Fail _ | Lwt.Sleep -> assert false) +end + +let make limits chain_db chain_id (module Filter : Shell_plugin.FILTER) : t = + let module Prevalidation_t = Prevalidation.Make (Filter.Proto) in + let module Prevalidator = + Make + (Filter) + (struct + let limits = limits + + let chain_db = chain_db + + let chain_id = chain_id + end) + (Prevalidation_t) + in + (module Prevalidator : T) + +module Internal_for_tests = struct + include Tools + + type nonrec ('a, 'b) types_state_shell = ('a, 'b) types_state_shell + + let mk_types_state_shell ~(predecessor : Store.Block.t) ~(tools : 'a tools) + ~(worker : worker_tools) : (_, 'a) types_state_shell = + let parameters = + {limits = Shell_limits.default_prevalidator_limits; tools} + in + let c_parameters : Classification.parameters = + {map_size_limit = 32; on_discarded_operation = Fun.const ()} + in + let advertisement = `None in + let banned_operations = Operation_hash.Set.empty in + let classification = Classification.create c_parameters in + let fetching = Operation_hash.Set.empty in + let mempool = Mempool.empty in + let live_blocks = Block_hash.Set.empty in + let live_operations = Operation_hash.Set.empty in + let pending = Pending_ops.empty in + let timestamp = Tezos_base.Time.System.now () in + { + advertisement; + banned_operations; + classification; + fetching; + live_blocks; + live_operations; + mempool; + parameters; + pending; + predecessor; + timestamp; + worker; + } + + module Make + (Filter : Shell_plugin.FILTER) + (Prevalidation_t : Prevalidation.T + with type validation_state = + Filter.Proto.validation_state + and type protocol_operation = Filter.Proto.operation + and type operation_receipt = + Filter.Proto.operation_receipt) = + struct + module Internal = Make_s (Filter) (Prevalidation_t) + + type nonrec types_state = Internal.types_state + + let mk_types_state + ~(shell : + ( Prevalidation_t.protocol_operation, + Prevalidation_t.t ) + types_state_shell) ~(validation_state : Prevalidation_t.t) : + types_state Lwt.t = + let open Lwt_syntax in + let filter_config = Filter.Mempool.default_config in + let predecessor = Store.Block.header shell.predecessor in + let* r = Filter.Mempool.init filter_config ~predecessor () in + match r with + | Error err -> + let err_string = + Format.asprintf "%a" Error_monad.pp_print_trace err + in + let* () = Lwt_io.eprintf "%s" err_string in + assert false + | Ok filter_state -> + Lwt.return + Internal. + { + shell; + filter_config; + filter_state; + lock = Lwt_mutex.create (); + operation_stream = Lwt_watcher.create_input (); + rpc_directory = Lazy.from_fun (fun () -> assert false); + validation_state = Ok validation_state; + } + + let to_shell (t : types_state) = t.shell + + let handle_unprocessed = Internal.handle_unprocessed + + module Requests = Internal.Requests + end +end diff --git a/src/lib_shell/legacy_prevalidator_internal.mli b/src/lib_shell/legacy_prevalidator_internal.mli new file mode 100644 index 0000000000000000000000000000000000000000..e5cd07ff3a0de8f8278917dd7094b6c9e60fcfe6 --- /dev/null +++ b/src/lib_shell/legacy_prevalidator_internal.mli @@ -0,0 +1,151 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2018-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. *) +(* *) +(*****************************************************************************) + +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the implementation of the legacy mempool, + which is compatible with Kathmandu and therefore usable on Mainnet. + + This file should be removed once Lima has been activated on Mainnet. + + When you modify this file, consider whether you should also change + the files that implement the more recent mempool for Lima and newer + protocols. *) + +(** Create a prevalidator instance for a specific protocol + ([Filter.Proto] where [module Filter : Shell_plugin.FILTER]). + + The protocol must be Kathmandu (environment V6) or an older + version. For more recent protocols, use + {!Prevalidator_internal.make} instead. + + This function is wrapped in {!Prevalidator.create}. *) +val make : + Shell_limits.prevalidator_limits -> + Distributed_db.chain_db -> + Chain_id.t -> + (module Shell_plugin.FILTER) -> + Prevalidator_internal_common.t + +(**/**) + +module Internal_for_tests : sig + (** Documented in the ml file, because this is only exported for tests. *) + type 'prevalidation_t tools = { + advertise_current_head : mempool:Mempool.t -> Store.Block.t -> unit; + chain_tools : Store.Block.t Legacy_prevalidator_classification.chain_tools; + create : + predecessor:Store.Block.t -> + live_operations:Operation_hash.Set.t -> + timestamp:Time.Protocol.t -> + unit -> + 'prevalidation_t tzresult Lwt.t; + fetch : + ?peer:P2p_peer.Id.t -> + ?timeout:Time.System.Span.t -> + Operation_hash.t -> + Operation.t tzresult Lwt.t; + read_block : Block_hash.t -> Store.Block.t tzresult Lwt.t; + send_get_current_head : ?peer:P2p_peer_id.t -> unit -> unit; + set_mempool : head:Block_hash.t -> Mempool.t -> unit tzresult Lwt.t; + } + + (** Documented in the ml file, because this is only exported for tests. *) + type worker_tools = { + push_request : + (unit, Empty.t) Prevalidator_worker_state.Request.t -> bool Lwt.t; + push_request_now : + (unit, Empty.t) Prevalidator_worker_state.Request.t -> unit; + } + + (** The corresponding internal type of the mempool (see {!Prevalidator.S}), + that is independent from the protocol. *) + type ('a, 'b) types_state_shell + + (** Create a pristine value of {!type_state_shell} *) + val mk_types_state_shell : + predecessor:Store.Block.t -> + tools:'prevalidation_t tools -> + worker:worker_tools -> + ('protocol_data, 'prevalidation_t) types_state_shell + + module Make + (Filter : Shell_plugin.FILTER) + (Prevalidation_t : Legacy_prevalidation.T + with type validation_state = + Filter.Proto.validation_state + and type protocol_operation = Filter.Proto.operation + and type operation_receipt = + Filter.Proto.operation_receipt) : sig + (** The corresponding internal type of the mempool (see {!Prevalidator.S}), + that depends on the protocol *) + type types_state + + (** Create a pristine value of {!type_state} *) + val mk_types_state : + shell: + ( Prevalidation_t.protocol_operation, + Prevalidation_t.t ) + types_state_shell -> + validation_state:Prevalidation_t.t -> + types_state Lwt.t + + (** [to_shell pv] returns the shell part of [pv] *) + val to_shell : + types_state -> + (Prevalidation_t.protocol_operation, Prevalidation_t.t) types_state_shell + + (** Documented in the ml file. *) + val handle_unprocessed : types_state -> unit Lwt.t + + (** Documented in the ml file (as are all the functions of this module) *) + module Requests : sig + val on_advertise : _ types_state_shell -> unit + + val on_arrived : + types_state -> + Operation_hash.t -> + Operation.t -> + (unit, Empty.t) result Lwt.t + + val on_ban : types_state -> Operation_hash.t -> unit tzresult Lwt.t + + val on_flush : + handle_branch_refused:bool -> + types_state -> + Store.Block.t -> + Block_hash.Set.t -> + Operation_hash.Set.t -> + unit tzresult Lwt.t + + val on_inject : + types_state -> force:bool -> Operation.t -> unit tzresult Lwt.t + + val on_notify : + _ types_state_shell -> P2p_peer_id.t -> Mempool.t -> unit Lwt.t + end + end +end diff --git a/src/lib_shell/legacy_prevalidator_pending_operations.ml b/src/lib_shell/legacy_prevalidator_pending_operations.ml new file mode 100644 index 0000000000000000000000000000000000000000..86939ff274e0235820232c3a799119d08d24ccc9 --- /dev/null +++ b/src/lib_shell/legacy_prevalidator_pending_operations.ml @@ -0,0 +1,145 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2018-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. *) +(* *) +(*****************************************************************************) + +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the implementation of the legacy mempool, + which is compatible with Kathmandu and therefore usable on Mainnet. + + This file should be removed once Lima has been activated on Mainnet. + + When you modify this file, consider whether you should also change + the files that implement the more recent mempool for Lima and newer + protocols. *) + +module Prevalidation = Legacy_prevalidation + +(* Ordering is important, as it is used below in map keys comparison *) +type priority = [`High | `Medium | `Low of Q.t list] + +module Priority_map : Map.S with type key = priority = Map.Make (struct + type t = priority + + module CompareListQ = Compare.List (Q) + + let compare_low_prio p1 p2 = + (* A higher priority operation should appear before in the map. So we use + the pointwise comparison of p2 and p1 *) + CompareListQ.compare p2 p1 + + let compare p1 p2 = + (* - Explicit comparison, `High is smaller, + - Avoid fragile patterns in case the type is extended in the future *) + match (p1, p2) with + | `High, `High | `Medium, `Medium -> 0 + | `Low p1, `Low p2 -> compare_low_prio p1 p2 + | `High, (`Low _ | `Medium) -> -1 + | (`Low _ | `Medium), `High -> 1 + | `Low _, `Medium -> 1 + | `Medium, `Low _ -> -1 +end) + +module Map = Operation_hash.Map +module Sized_set = Tezos_base.Sized.MakeSizedSet (Operation_hash.Set) + +(* + The type below is used for representing pending operations data of the + prevalidator. The functions of this module (should) maintain the + following invariants: + 1 - Union (preimage(pending(prio))) = hashes, for each prio in dom(pending) + 2 - preimage (priority_of) = hashes + 3 - image(priority_of) = preimage (pending) + 4 - map in pending(priority) => map <> empty +*) +type 'a t = { + (* The main map *) + pending : 'a Prevalidation.operation Map.t Priority_map.t; + (* Used for advertising *) + hashes : Sized_set.t; + (* We need to remember the priority of each hash, to be used when removing + without providing the priority *) + priority_of : priority Map.t; +} + +let empty = + { + pending = Priority_map.empty; + hashes = Sized_set.empty; + priority_of = Map.empty; + } + +let is_empty {pending = _; priority_of = _; hashes} = Sized_set.is_empty hashes + +let hashes {pending = _; priority_of = _; hashes} = Sized_set.to_set hashes + +let operations {pending; priority_of = _; hashes = _} = + (* Build a flag map [oph -> op] from pending. Needed when re-cycling + operations *) + Priority_map.fold + (fun _prio -> Map.union (fun _ _ b -> Some b)) + pending + Map.empty + +let mem oph {hashes; priority_of = _; pending = _} = Sized_set.mem oph hashes + +let get_priority_map prio pending = + match Priority_map.find prio pending with None -> Map.empty | Some mp -> mp + +let add op prio {pending; hashes; priority_of} = + let oph = op.Prevalidation.hash in + let mp = get_priority_map prio pending |> Map.add oph op in + { + pending = Priority_map.add prio mp pending; + hashes = Sized_set.add oph hashes; + priority_of = Map.add oph prio priority_of; + } + +let remove oph ({pending; hashes; priority_of} as t) = + match Map.find oph priority_of with + | None -> t + | Some prio -> + let mp = get_priority_map prio pending |> Map.remove oph in + { + pending = + (if Map.is_empty mp then Priority_map.remove prio pending + else Priority_map.add prio mp pending); + hashes = Sized_set.remove oph hashes; + priority_of = Map.remove oph priority_of; + } + +let cardinal {pending = _; hashes; priority_of = _} = Sized_set.cardinal hashes + +let fold_es f {pending; hashes = _; priority_of = _} acc = + Priority_map.fold_es + (fun prio mp acc -> Map.fold_es (f prio) mp acc) + pending + acc + +let fold f {pending; hashes = _; priority_of = _} acc = + Priority_map.fold (fun prio mp acc -> Map.fold (f prio) mp acc) pending acc + +let iter f {pending; hashes = _; priority_of = _} = + Priority_map.iter (fun prio mp -> Map.iter (f prio) mp) pending diff --git a/src/lib_shell/legacy_prevalidator_pending_operations.mli b/src/lib_shell/legacy_prevalidator_pending_operations.mli new file mode 100644 index 0000000000000000000000000000000000000000..e1b2504cb2d04a64075a5e9ca03a6e4246e65e97 --- /dev/null +++ b/src/lib_shell/legacy_prevalidator_pending_operations.mli @@ -0,0 +1,144 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2018-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. *) +(* *) +(*****************************************************************************) + +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the implementation of the legacy mempool, + which is compatible with Kathmandu and therefore usable on Mainnet. + + This file should be removed once Lima has been activated on Mainnet. + + When you modify this file, consider whether you should also change + the files that implement the more recent mempool for Lima and newer + protocols. *) + +module Prevalidation := Legacy_prevalidation + +(** The priority of a pending operation. + + A priority is attached to each pending operation. *) +type priority = [`High | `Medium | `Low of Q.t list] + +(** + This type is used for data representing pending operations of the + prevalidator. Any iterator on this structure will process operations with + [`High] priority first, followed by [`Medium] and finally [`Low] priority. *) +type 'protocol_data t + +module Sized_set : + Tezos_base.Sized.SizedSet with type set := Operation_hash.Set.t + +(** The empty structure of pending operations. *) +val empty : 'protocol_data t + +(** [hashes p] returns the set of hashes contained in [p] *) +val hashes : 'protocol_data t -> Operation_hash.Set.t + +(** [operations p] returns the Map of bindings [oph -> op] contained in [p] *) +val operations : + 'protocol_data t -> + 'protocol_data Prevalidation.operation Operation_hash.Map.t + +(** [is_empty p] returns [true] if [p] has operations, [false] otherwise. *) +val is_empty : 'protocol_data t -> bool + +(** [mem oph p] returns [true] if [oph] is found in [p], [false] otherwise. + + Complexity is O(log(n)), where n is the number of operations (hashes) in the + structure. +*) +val mem : Operation_hash.t -> 'protocol_data t -> bool + +(** [add oph op p prio] records the operation [op] whose hash is [oph] and whose + priority is [prio] in [p]. + + Complexity is O(log(n)), where n is the number of operations (hashes) in the + structure. + + It is unspecified behaviour to call this function with a hash ([oph]) which + is already recorded in the data-structure ([p]). It is your responsibility + as the caller of the function to ensure this. +*) +val add : + 'protocol_data Prevalidation.operation -> + priority -> + 'protocol_data t -> + 'protocol_data t + +(** [remove oph op p] removes the binding [oph] from [p]. + + Complexity is O(log(n)), where n is the number of operations (hashes) in the + structure. +*) +val remove : Operation_hash.t -> 'protocol_data t -> 'protocol_data t + +(** [cardinal p] returns the number of operations (hashes) in [p]. + + Complexity is O(n), where n is the number of operations (hashes) in the + structure. +*) +val cardinal : 'protocol_data t -> int + +(** [fold f p acc] applies the function [f] on every binding [oph] |-> [op] of + priority [prio] in [p]. The [acc] is passed to and (possibly) updated by + every call to [f]. + + We iterate on operations with `High priority first, then on those with `Low + priority. For operations with the same priority, the iteration order is + defined [Operation_hash.compare] function (operations with small hashes are + processed first). +*) +val fold : + (priority -> + Operation_hash.t -> + 'protocol_data Prevalidation.operation -> + 'a -> + 'a) -> + 'protocol_data t -> + 'a -> + 'a + +(** [iter f p] is similar to [fold] where [acc] is unit *) +val iter : + (priority -> + Operation_hash.t -> + 'protocol_data Prevalidation.operation -> + unit) -> + 'protocol_data t -> + unit + +(** [fold_es f p acc] is the Lwt version of [fold], except that [fold_es] + returns wihtout iterating over all the elements of the list as soon as a + value [Error e] is returned by [f] *) +val fold_es : + (priority -> + Operation_hash.t -> + 'protocol_data Prevalidation.operation -> + 'a -> + ('a, 'b) result Lwt.t) -> + 'protocol_data t -> + 'a -> + ('a, 'b) result Lwt.t diff --git a/src/lib_shell/prevalidation.ml b/src/lib_shell/prevalidation.ml index 443b6b9b69621cc85179b3edeb05bcb8e18a1f46..e6ec0a0386d8cc6b76a3c343f62704226375da1f 100644 --- a/src/lib_shell/prevalidation.ml +++ b/src/lib_shell/prevalidation.ml @@ -3,7 +3,7 @@ (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) (* Copyright (c) 2020 Metastate AG *) -(* Copyright (c) 2018-2021 Nomadic Labs, *) +(* Copyright (c) 2018-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"),*) @@ -25,6 +25,16 @@ (* *) (*****************************************************************************) +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the implementation of the new mempool, which + uses features of the protocol that only exist since Lima. + + When you modify this file, consider whether you should also change + the files that implement the legacy mempool for Kathmandu. They all + start with the "legacy" prefix and will be removed when Lima is + activated on Mainnet. *) + open Validation_errors type 'protocol_operation operation = { diff --git a/src/lib_shell/prevalidation.mli b/src/lib_shell/prevalidation.mli index 12e20f9ddaeb8282c10be23e4a2ecf764f09fef9..9a918ece4b036b5113b7ea0ccba11e8811fba23d 100644 --- a/src/lib_shell/prevalidation.mli +++ b/src/lib_shell/prevalidation.mli @@ -2,7 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2018-2021 Nomadic Labs, *) +(* Copyright (c) 2018-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"),*) @@ -24,6 +24,16 @@ (* *) (*****************************************************************************) +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the implementation of the new mempool, which + uses features of the protocol that only exist since Lima. + + When you modify this file, consider whether you should also change + the files that implement the legacy mempool for Kathmandu. They all + start with the "legacy" prefix and will be removed when Lima is + activated on Mainnet. *) + (** A newly received block is validated by replaying locally the block creation, applying each operation and its finalization to ensure their consistency. This module is stateless and creates and manipulates the diff --git a/src/lib_shell/prevalidator.ml b/src/lib_shell/prevalidator.ml index 89b926372e749fbd6845135745d22332b999fc54..956f3362eb44dda0ad1bb0754e18d2bd91d3eaf7 100644 --- a/src/lib_shell/prevalidator.ml +++ b/src/lib_shell/prevalidator.ml @@ -24,1627 +24,8 @@ (* *) (*****************************************************************************) +include Prevalidator_internal_common open Prevalidator_worker_state -module Events = Prevalidator_events - -(* Minimal delay between two mempool advertisements *) -let advertisement_delay = 0.1 - -module Name = struct - type t = Chain_id.t * Protocol_hash.t - - let encoding = Data_encoding.tup2 Chain_id.encoding Protocol_hash.encoding - - let base = ["prevalidator"] - - let pp fmt (chain_id, proto_hash) = - Format.fprintf - fmt - "%a:%a" - Chain_id.pp_short - chain_id - Protocol_hash.pp_short - proto_hash - - let equal (c1, p1) (c2, p2) = - Chain_id.equal c1 c2 && Protocol_hash.equal p1 p2 -end - -module Classification = Prevalidator_classification - -(** This module encapsulates pending operations to maintain them in two - different data structure and avoid coslty repetitive convertions when - handling batches in [classify_pending_operations]. *) -module Pending_ops = Prevalidator_pending_operations - -(** Module encapsulating some types that are used both in production - and in tests. Having them in a module makes it possible to - [include] this module in {!Internal_for_tests} below and avoid - code duplication. - - The raison d'etre of these records of functions is to be able to use - alternative implementations of all functions in tests. - - The purpose of the {!Tools.tools} record is to abstract away from {!Store.chain_store}. - Under the hood [Store.chain_store] requires an Irmin store on disk, - which makes it impractical for fast testing: every test would need - to create a temporary folder on disk which doesn't scale well. - - The purpose of the {!Tools.worker_tools} record is to abstract away - from the {!Worker} implementation. This implementation is overkill - for testing: we don't need asynchronicity and concurrency in our - pretty basic existing tests. Having this abstraction allows to get - away with a much simpler state machine model of execution and - to have simpler test setup. *) -module Tools = struct - (** Functions provided by {!Distributed_db} and {!Store.chain_store} - that are used in various places of the mempool. Gathered here so that we can test - the mempool without requiring a full-fledged [Distributed_db]/[Store.Chain_store]. *) - type 'prevalidation_t tools = { - advertise_current_head : mempool:Mempool.t -> Store.Block.t -> unit; - (** [advertise_current_head mempool head] sends a - [Current_head (chain_id, head_header, mempool)] message to all known - active peers for the chain being considered. *) - chain_tools : Store.Block.t Classification.chain_tools; - (** Lower-level tools provided by {!Prevalidator_classification} *) - create : - predecessor:Store.Block.t -> - live_operations:Operation_hash.Set.t -> - timestamp:Time.Protocol.t -> - unit -> - 'prevalidation_t tzresult Lwt.t; - (** Creates a new prevalidation context w.r.t. the protocol associated to the - predecessor block. *) - fetch : - ?peer:P2p_peer.Id.t -> - ?timeout:Time.System.Span.t -> - Operation_hash.t -> - Operation.t tzresult Lwt.t; - (** [fetch ?peer ?timeout oph] returns the value when it is known. - It can fail with [Requester.Timeout] if [timeout] is provided and the value - isn't known before the timeout expires. It can fail with [Requester.Cancel] if - the request is canceled. *) - read_block : Block_hash.t -> Store.Block.t tzresult Lwt.t; - (** [read_block bh] tries to read the block [bh] from the chain store. *) - send_get_current_head : ?peer:P2p_peer_id.t -> unit -> unit; - (** [send_get_current_head ?peer ()] sends a [Get_Current_head] - to a given peer, or to all known active peers for the chain considered. - Expected answer is a [Get_current_head] message *) - set_mempool : head:Block_hash.t -> Mempool.t -> unit tzresult Lwt.t; - (** [set_mempool ~head mempool] sets the [mempool] of - the [chain_store] of the chain considered. Does nothing if [head] differs - from current_head which might happen when a new head concurrently arrives just - before this operation is being called. *) - } - - (** Abstraction over services implemented in production by {!Worker} - but implemented differently in tests. - - Also see the enclosing module documentation as to why we have this record. *) - type worker_tools = { - push_request : - (unit, Empty.t) Prevalidator_worker_state.Request.t -> bool Lwt.t; - (** Adds a message to the queue. *) - push_request_now : - (unit, Empty.t) Prevalidator_worker_state.Request.t -> unit; - (** Adds a message to the queue immediately. *) - } -end - -type 'a parameters = { - limits : Shell_limits.prevalidator_limits; - tools : 'a Tools.tools; -} - -(** The type needed for the implementation of [Make] below, but - * which is independent from the protocol. *) -type ('protocol_data, 'a) types_state_shell = { - classification : 'protocol_data Classification.t; - parameters : 'a parameters; - mutable predecessor : Store.Block.t; - mutable timestamp : Time.System.t; - mutable live_blocks : Block_hash.Set.t; - mutable live_operations : Operation_hash.Set.t; - mutable fetching : Operation_hash.Set.t; - mutable pending : 'protocol_data Pending_ops.t; - mutable mempool : Mempool.t; - mutable advertisement : [`Pending of Mempool.t | `None]; - mutable banned_operations : Operation_hash.Set.t; - worker : Tools.worker_tools; -} - -let metrics = Shell_metrics.Mempool.init ["mempool"] - -(** The concrete production instance of {!block_tools} *) -let block_tools : Store.Block.t Classification.block_tools = - { - hash = Store.Block.hash; - operations = Store.Block.operations; - all_operation_hashes = Store.Block.all_operation_hashes; - } - -(** How to create an instance of {!chain_tools} from a {!Distributed_db.chain_db}. *) -let mk_chain_tools (chain_db : Distributed_db.chain_db) : - Store.Block.t Classification.chain_tools = - let open Lwt_syntax in - let new_blocks ~from_block ~to_block = - let chain_store = Distributed_db.chain_store chain_db in - Store.Chain_traversal.new_blocks chain_store ~from_block ~to_block - in - let read_predecessor_opt block = - let chain_store = Distributed_db.chain_store chain_db in - Store.Block.read_predecessor_opt chain_store block - in - let inject_operation oph op = - let* _ = Distributed_db.inject_operation chain_db oph op in - Lwt.return_unit - in - { - clear_or_cancel = Distributed_db.Operation.clear_or_cancel chain_db; - inject_operation; - new_blocks; - read_predecessor_opt; - } - -(** Module type used both in production and in tests. *) -module type S = sig - (** Type instantiated by {!Filter.Mempool.state}. *) - type filter_state - - (** Type instantiated by {!Filter.Mempool.config}. *) - type filter_config - - (** Similar to the type [operation] from the protocol, - see {!Tezos_protocol_environment.PROTOCOL} *) - type protocol_operation - - (** Type instantiated by {!Prevalidation.t} *) - type prevalidation_t - - type types_state = { - shell : (protocol_operation, prevalidation_t) types_state_shell; - mutable filter_state : filter_state; - (** Internal state of the filter in the plugin *) - mutable validation_state : prevalidation_t tzresult; - mutable operation_stream : - (Classification.classification - * protocol_operation Prevalidation.operation) - Lwt_watcher.input; - mutable rpc_directory : types_state RPC_directory.t lazy_t; - mutable filter_config : filter_config; - lock : Lwt_mutex.t; - } - - (** This function fetches an operation if it is not already handled - as defined by [already_handled] below. The implementation makes - sure to fetch an operation at most once, modulo operations - lost because of bounded buffers becoming full. - - This function is an intruder to this module type. It just happens - that it is needed both by internals of the implementation of {!S} - and by the internals of the implementation of {!T}; so it needs - to be exposed here. *) - val may_fetch_operation : - (protocol_operation, prevalidation_t) types_state_shell -> - P2p_peer_id.t option -> - Operation_hash.t -> - unit Lwt.t - - (** The function called after every call to a function of {!API}. *) - val handle_unprocessed : types_state -> unit Lwt.t - - (** The inner API of the mempool i.e. functions called by the worker - when an individual request arrives. These functions are the - most high-level ones that we test. All these [on_*] functions - correspond to a single event. Possible - sequences of calls to this API are always of the form: - - on_*; handle_unprocessed; on_*; handle_unprocessed; ... *) - module Requests : sig - val on_advertise : _ types_state_shell -> unit - - val on_arrived : - types_state -> - Operation_hash.t -> - Operation.t -> - (unit, Empty.t) result Lwt.t - - val on_ban : types_state -> Operation_hash.t -> unit tzresult Lwt.t - - val on_flush : - handle_branch_refused:bool -> - types_state -> - Store.Block.t -> - Block_hash.Set.t -> - Operation_hash.Set.t -> - unit tzresult Lwt.t - - val on_inject : - types_state -> force:bool -> Operation.t -> unit tzresult Lwt.t - - val on_notify : - _ types_state_shell -> P2p_peer_id.t -> Mempool.t -> unit Lwt.t - end -end - -(** Module type used exclusively in production. *) -module type T = sig - include S - - val name : Name.t - - module Types : Worker_intf.TYPES with type state = types_state - - module Worker : - Worker.T - with type ('a, 'b) Request.t = ('a, 'b) Request.t - and type Request.view = Request.view - and type Types.state = types_state - - type worker = Worker.infinite Worker.queue Worker.t - - val worker : worker Lazy.t -end - -type t = (module T) - -(** A functor for obtaining the testable part of this file (see - the instantiation of this functor in {!Internal_for_tests} at the - end of this file). Contrary to the production-only functor {!Make} below, - this functor doesn't assume a specific chain store implementation, - which is the crux for having it easily unit-testable. *) -module Make_s - (Filter : Shell_plugin.FILTER) - (Prevalidation_t : Prevalidation.T - with type validation_state = - Filter.Proto.validation_state - and type protocol_operation = Filter.Proto.operation - and type operation_receipt = - Filter.Proto.operation_receipt) : - S - with type filter_state = Filter.Mempool.state - and type filter_config = Filter.Mempool.config - and type protocol_operation = Filter.Proto.operation - and type prevalidation_t = Prevalidation_t.t = struct - type filter_state = Filter.Mempool.state - - type filter_config = Filter.Mempool.config - - type protocol_operation = Filter.Proto.operation - - type prevalidation_t = Prevalidation_t.t - - type 'operation_data operation = 'operation_data Prevalidation.operation - - type types_state = { - shell : (protocol_operation, prevalidation_t) types_state_shell; - mutable filter_state : filter_state; - mutable validation_state : prevalidation_t tzresult; - mutable operation_stream : - (Classification.classification - * protocol_operation Prevalidation.operation) - Lwt_watcher.input; - mutable rpc_directory : types_state RPC_directory.t lazy_t; - mutable filter_config : filter_config; - lock : Lwt_mutex.t; - } - - (* This function is in [Lwt] only for logging. *) - let already_handled ~origin shell oph = - let open Lwt_syntax in - if Operation_hash.Set.mem oph shell.banned_operations then - let+ () = Events.(emit ban_operation_encountered) (origin, oph) in - true - else - Lwt.return - (Pending_ops.mem oph shell.pending - || Operation_hash.Set.mem oph shell.fetching - || Operation_hash.Set.mem oph shell.live_operations - || Classification.is_in_mempool oph shell.classification <> None - || Classification.is_known_unparsable oph shell.classification) - - let advertise (shell : ('operation_data, _) types_state_shell) mempool = - let open Lwt_syntax in - match shell.advertisement with - | `Pending {Mempool.known_valid; pending} -> - shell.advertisement <- - `Pending - { - known_valid = known_valid @ mempool.Mempool.known_valid; - pending = Operation_hash.Set.union pending mempool.pending; - } - | `None -> - shell.advertisement <- `Pending mempool ; - Lwt.dont_wait - (fun () -> - let* () = Lwt_unix.sleep advertisement_delay in - shell.worker.push_request_now Advertise ; - Lwt.return_unit) - (fun exc -> - Format.eprintf "Uncaught exception: %s\n%!" (Printexc.to_string exc)) - - (* Each classified operation should be notified exactly ONCE for a - given stream. Operations which cannot be parsed are not notified. *) - let handle_classification - ~(notifier : - Classification.classification -> - protocol_operation Prevalidation.operation -> - unit) shell (op, kind) = - Classification.add kind op shell.classification ; - notifier kind op - - let mk_notifier operation_stream classification op = - (* This callback is safe encapsulation-wise, because it depends - on an "harmless" field of [types_state_shell]: [operation_stream] *) - Lwt_watcher.notify operation_stream (classification, op) - - let pre_filter shell ~filter_config ~filter_state ~validation_state ~notifier - (parsed_op : protocol_operation operation) : - [Pending_ops.priority | `Drop] Lwt.t = - let open Lwt_syntax in - let validation_state_before = - Option.map - Prevalidation_t.validation_state - (Option.of_result validation_state) - in - let+ v = - Filter.Mempool.pre_filter - ~filter_state - ?validation_state_before - filter_config - parsed_op.protocol - in - match v with - | (`Branch_delayed _ | `Branch_refused _ | `Refused _ | `Outdated _) as errs - -> - handle_classification ~notifier shell (parsed_op, errs) ; - `Drop - | `Passed_prefilter priority -> (priority :> [Pending_ops.priority | `Drop]) - - let post_filter ~filter_config ~filter_state ~validation_state_before - ~validation_state_after op receipt = - Filter.Mempool.post_filter - filter_config - ~filter_state - ~validation_state_before - ~validation_state_after - (op, receipt) - - let set_mempool shell mempool = - shell.mempool <- mempool ; - shell.parameters.tools.set_mempool - ~head:(Store.Block.hash shell.predecessor) - shell.mempool - - let remove_from_advertisement oph = function - | `Pending mempool -> `Pending (Mempool.remove oph mempool) - | `None -> `None - - (* This function retrieves an old/replaced operation and reclassifies it as - [replacement_classification]. Note that we don't need to re-flush the - mempool, as this function is only called in precheck mode. - - The operation is expected to be (a) parsable and (b) in the "prechecked" - class. So, we softly handle the situations where the operation is - unparsable or not found in any class in case this invariant is broken - for some reason. - *) - let reclassify_replaced_manager_op old_hash shell - (replacement_classification : [< Classification.error_classification]) = - shell.advertisement <- - remove_from_advertisement old_hash shell.advertisement ; - match Classification.remove old_hash shell.classification with - | Some (op, _class) -> - [(op, (replacement_classification :> Classification.classification))] - | None -> - (* This case should not happen. *) - shell.parameters.tools.chain_tools.clear_or_cancel old_hash ; - [] - - let precheck ~disable_precheck ~filter_config ~filter_state - ~validation_state:prevalidation_t (op : protocol_operation operation) = - let open Lwt_syntax in - let validation_state = Prevalidation_t.validation_state prevalidation_t in - if disable_precheck then Lwt.return `Undecided - else - let+ v = - Filter.Mempool.precheck - filter_config - ~filter_state - ~validation_state - ~nb_successful_prechecks:op.count_successful_prechecks - op.hash - op.protocol - in - match v with - | `Passed_precheck (filter_state, validation_state, replacement) -> - (* The [precheck] optimization triggers: no need to call the - protocol [apply_operation]. *) - let prevalidation_t = - Prevalidation_t.set_validation_state - prevalidation_t - validation_state - in - let new_op = Prevalidation_t.increment_successful_precheck op in - `Passed_precheck (filter_state, prevalidation_t, new_op, replacement) - | (`Branch_delayed _ | `Branch_refused _ | `Refused _ | `Outdated _) as - errs -> - (* Note that we don't need to distinguish some failure cases - of [Filter.Mempool.precheck], hence grouping them under `Fail. *) - `Fail errs - | `Undecided -> - (* The caller will need to call the protocol's [apply_operation] - function. *) - `Undecided - - (* [classify_operation shell filter_config filter_state validation_state - mempool op oph] allows to determine the class of a given operation. - - Once it's parsed, the operation is prechecked and/or applied in the current - filter/validation state to determine if it could be included in a block on - top of the current head or not. If yes, the operation is accumulated in - the given [mempool]. - - The function returns a tuple - [(filter_state, validation_state, mempool, to_handle)], where: - - [filter_state] is the (possibly) updated filter_state, - - [validation_state] is the (possibly) updated validation_state, - - [mempool] is the (possibly) updated mempool, - - [to_handle] contains the given operation and its classification, and all - operations whose classes are changed/impacted by this classification - (eg. in case of operation replacement). - *) - let classify_operation shell ~filter_config ~filter_state ~validation_state - mempool op : - (filter_state - * prevalidation_t - * Mempool.t - * (protocol_operation operation * Classification.classification) trace) - Lwt.t = - let open Lwt_syntax in - let* v = - let* v = - precheck - ~disable_precheck:shell.parameters.limits.disable_precheck - ~filter_config - ~filter_state - ~validation_state - op - in - match v with - | `Fail errs -> - (* Precheck rejected the operation *) - Lwt.return_error errs - | `Passed_precheck (filter_state, validation_state, new_op, replacement) - -> - (* Precheck succeeded *) - let to_handle = - match replacement with - | `No_replace -> [(new_op, `Prechecked)] - | `Replace (old_oph, replacement_classification) -> - (* Precheck succeeded, but an old operation is replaced *) - let to_replace = - reclassify_replaced_manager_op - old_oph - shell - replacement_classification - in - (new_op, `Prechecked) :: to_replace - in - Lwt.return_ok (filter_state, validation_state, to_handle) - | `Undecided -> ( - (* Precheck was not able to classify *) - let* v = Prevalidation_t.apply_operation validation_state op in - match v with - | Applied (new_validation_state, receipt) -> ( - (* Apply succeeded, call post_filter *) - let* v = - post_filter - ~filter_config - ~filter_state - ~validation_state_before: - (Prevalidation_t.validation_state validation_state) - ~validation_state_after: - (Prevalidation_t.validation_state new_validation_state) - op.protocol - receipt - in - match v with - | `Passed_postfilter new_filter_state -> - (* Post_filter ok, accept operation *) - Lwt.return_ok - (new_filter_state, new_validation_state, [(op, `Applied)]) - | `Refused _ as op_class -> - (* Post_filter refused the operation *) - Lwt.return_error op_class) - (* Apply rejected the operation *) - | Branch_delayed e -> Lwt.return_error (`Branch_delayed e) - | Branch_refused e -> Lwt.return_error (`Branch_refused e) - | Refused e -> Lwt.return_error (`Refused e) - | Outdated e -> Lwt.return_error (`Outdated e)) - in - match v with - | Error err_class -> - Lwt.return (filter_state, validation_state, mempool, [(op, err_class)]) - | Ok (f_state, v_state, to_handle) -> - let mempool = Mempool.cons_valid op.hash mempool in - Lwt.return (f_state, v_state, mempool, to_handle) - - (* Classify pending operations into either: [Refused | - Branch_delayed | Branch_refused | Applied | Outdated]. - To ensure fairness with other worker requests, classification of - operations is done by batch of [operation_batch_size] operations. - - This function ensures the following invariants: - - - If an operation is classified, it is not part of the [pending] - map - - - A classified operation is part of the [in_mempool] set - - - A classified operation is part only of one of the following - classes: [Branch_refused, Branch_delayed, Refused, Applied] - - Moreover, this function ensures that only each newly classified - operations are advertised to the remote peers. However, if a peer - requests our mempool, we advertise all our classified operations and - all our pending operations. *) - let classify_pending_operations ~notifier shell filter_config filter_state - state = - let open Lwt_syntax in - let* r = - Pending_ops.fold_es - (fun _prio - oph - op - (acc_filter_state, acc_validation_state, acc_mempool, limit) -> - if limit <= 0 then - (* Using Error as an early-return mechanism *) - Lwt.return_error - (acc_filter_state, acc_validation_state, acc_mempool) - else ( - shell.pending <- Pending_ops.remove oph shell.pending ; - let+ new_filter_state, new_validation_state, new_mempool, to_handle - = - classify_operation - shell - ~filter_config - ~filter_state:acc_filter_state - ~validation_state:acc_validation_state - acc_mempool - op - in - List.iter (handle_classification ~notifier shell) to_handle ; - Ok (new_filter_state, new_validation_state, new_mempool, limit - 1))) - shell.pending - ( filter_state, - state, - Mempool.empty, - shell.parameters.limits.operations_batch_size ) - in - match r with - | Error (filter_state, state, advertised_mempool) -> - (* Early return after iteration limit was reached *) - let* (_was_pushed : bool) = - shell.worker.push_request Request.Leftover - in - Lwt.return (filter_state, state, advertised_mempool) - | Ok (filter_state, state, advertised_mempool, _) -> - Lwt.return (filter_state, state, advertised_mempool) - - let update_advertised_mempool_fields pv_shell delta_mempool = - let open Lwt_syntax in - if Mempool.is_empty delta_mempool then Lwt.return_unit - else - (* We only advertise newly classified operations. *) - let mempool_to_advertise = - Mempool. - {delta_mempool with known_valid = List.rev delta_mempool.known_valid} - in - advertise pv_shell mempool_to_advertise ; - let our_mempool = - let prechecked_hashes = - (* Outputs hashes in "decreasing" order which should not matter *) - Classification.Sized_map.fold - (fun x _ acc -> x :: acc) - pv_shell.classification.prechecked - [] - in - { - (* FIXME: https://gitlab.com/tezos/tezos/-/issues/2065 - This field does not only contain valid operation *) - Mempool.known_valid = - List.fold_left - (fun acc op -> op.Prevalidation.hash :: acc) - prechecked_hashes - pv_shell.classification.applied_rev; - pending = Pending_ops.hashes pv_shell.pending; - } - in - let* _res = set_mempool pv_shell our_mempool in - Lwt.pause () - - let handle_unprocessed pv = - let open Lwt_syntax in - let notifier = mk_notifier pv.operation_stream in - match pv.validation_state with - | Error err -> - (* At the time this comment was written (26/05/21), this is dead - code since [Proto.begin_construction] cannot fail. *) - Pending_ops.iter - (fun _prio _oph op -> - handle_classification ~notifier pv.shell (op, `Branch_delayed err)) - pv.shell.pending ; - pv.shell.pending <- Pending_ops.empty ; - Lwt.return_unit - | Ok state -> - if Pending_ops.is_empty pv.shell.pending then Lwt.return_unit - else - let* () = Events.(emit processing_operations) () in - let* filter_state, validation_state, delta_mempool = - classify_pending_operations - ~notifier - pv.shell - pv.filter_config - pv.filter_state - state - in - pv.filter_state <- filter_state ; - pv.validation_state <- Ok validation_state ; - update_advertised_mempool_fields pv.shell delta_mempool - - (* This function fetches one operation through the - [distributed_db]. On errors, we emit an event and proceed as - usual. *) - let fetch_operation (shell : ('operation_data, _) types_state_shell) ?peer oph - = - let open Lwt_syntax in - let+ () = Events.(emit fetching_operation) oph in - let* r = - shell.parameters.tools.fetch - ~timeout:shell.parameters.limits.operation_timeout - ?peer - oph - in - match r with - | Ok op -> - shell.worker.push_request_now (Arrived (oph, op)) ; - Lwt.return_unit - | Error (Distributed_db.Operation.Canceled _ :: _) -> - Events.(emit operation_included) oph - | Error _ -> - (* This may happen if the peer timed out for example. *) - Events.(emit operation_not_fetched) oph - - (* This function fetches an operation if it is not already handled - by the mempool. To ensure we fetch at most a given operation, - we record it in the [pv.fetching] field. - - Invariant: This function should be the only one to modify this - field. - - Invariant: To ensure, there is no leak, we ensure that when the - promise [p] is terminated, we remove the operation from the - fetching operations. This is to ensure that if an error - happened, we can still fetch this operation in the future. *) - let may_fetch_operation (shell : ('operation_data, _) types_state_shell) peer - oph = - let open Lwt_syntax in - let origin = - match peer with Some peer -> Events.Peer peer | None -> Leftover - in - let* already_handled = already_handled ~origin shell oph in - if not already_handled then - ignore - (Lwt.finalize - (fun () -> - shell.fetching <- Operation_hash.Set.add oph shell.fetching ; - fetch_operation shell ?peer oph) - (fun () -> - shell.fetching <- Operation_hash.Set.remove oph shell.fetching ; - Lwt.return_unit)) ; - Lwt.return_unit - - (** Module containing functions that are the internal transitions - of the mempool. These functions are called by the {!Worker} when - an event arrives. *) - module Requests = struct - let on_arrived (pv : types_state) oph op : (unit, Empty.t) result Lwt.t = - let open Lwt_syntax in - let* already_handled = - already_handled ~origin:Events.Arrived pv.shell oph - in - if already_handled then return_ok_unit - else - match Prevalidation_t.parse oph op with - | Error _ -> - let* () = Events.(emit unparsable_operation) oph in - Prevalidator_classification.add_unparsable - oph - pv.shell.classification ; - return_ok_unit - | Ok parsed_op -> ( - let* v = - pre_filter - pv.shell - ~filter_config:pv.filter_config - ~filter_state:pv.filter_state - ~validation_state:pv.validation_state - ~notifier:(mk_notifier pv.operation_stream) - parsed_op - in - match v with - | `Drop -> return_ok_unit - | (`High | `Medium | `Low _) as prio -> - if - not - (Block_hash.Set.mem - op.Operation.shell.branch - pv.shell.live_blocks) - then ( - pv.shell.parameters.tools.chain_tools.clear_or_cancel oph ; - return_ok_unit) - else ( - (* TODO: https://gitlab.com/tezos/tezos/-/issues/1723 - Should this have an influence on the peer's score ? *) - pv.shell.pending <- - Pending_ops.add parsed_op prio pv.shell.pending ; - return_ok_unit)) - - let on_inject (pv : types_state) ~force op = - let open Lwt_result_syntax in - let oph = Operation.hash op in - (* Currently, an injection is always done with the highest priority, because: - - We want to process and propagate the injected operations fast, - - We don't want to call prefilter to get the priority. - But, this may change in the future - *) - let prio = `High in - let*! already_handled = - already_handled ~origin:Events.Injected pv.shell oph - in - if already_handled then - (* FIXME: https://gitlab.com/tezos/tezos/-/issues/1722 - Is this an error? *) - return_unit - else - match Prevalidation_t.parse oph op with - | Error err -> - failwith - "Invalid operation %a: %a." - Operation_hash.pp - oph - Error_monad.pp_print_trace - err - | Ok parsed_op -> ( - if force then ( - let*! () = - pv.shell.parameters.tools.chain_tools.inject_operation oph op - in - pv.shell.pending <- - Pending_ops.add parsed_op prio pv.shell.pending ; - return_unit) - else if - not - (Block_hash.Set.mem - op.Operation.shell.branch - pv.shell.live_blocks) - then - failwith - "Operation %a is branched on a block %a which is too old" - Operation_hash.pp - oph - Block_hash.pp - op.Operation.shell.branch - else - let*? validation_state = pv.validation_state in - let notifier = mk_notifier pv.operation_stream in - let*! filter_state, validation_state, delta_mempool, to_handle = - classify_operation - pv.shell - ~filter_config:pv.filter_config - ~filter_state:pv.filter_state - ~validation_state - Mempool.empty - parsed_op - in - let op_status = - (* to_handle contains the given operation and its classification, and - all operations whose classes are changed/impacted by this - classification (eg. in case of operation replacement). Here, we - retrieve the classification of our operation. *) - List.find_opt - (function - | ({hash; _} : protocol_operation operation), _ -> - Operation_hash.equal hash oph) - to_handle - in - match op_status with - | Some (_h, (`Applied | `Prechecked)) -> - (* TODO: https://gitlab.com/tezos/tezos/-/issues/2294 - In case of `Passed_precheck_with_replace, we may want to only do - the injection/replacement if a flag `replace` is set to true - in the injection query. *) - let*! () = - pv.shell.parameters.tools.chain_tools.inject_operation - oph - op - in - (* Call handle & update_advertised_mempool only if op is accepted *) - List.iter (handle_classification ~notifier pv.shell) to_handle ; - pv.filter_state <- filter_state ; - pv.validation_state <- Ok validation_state ; - (* Note that in this case, we may advertise an operation and bypass - the prioritirization strategy. *) - let*! v = - update_advertised_mempool_fields pv.shell delta_mempool - in - return v - | Some - ( _h, - ( `Branch_delayed e - | `Branch_refused e - | `Refused e - | `Outdated e ) ) -> - Lwt.return - @@ error_with - "Error while applying operation %a:@ %a" - Operation_hash.pp - oph - pp_print_trace - e - | None -> - (* This case should not happen *) - failwith - "Unexpected error while injecting operation %a. Operation \ - not found after classifying it." - Operation_hash.pp - oph) - - let on_notify (shell : ('operation_data, _) types_state_shell) peer mempool - = - let open Lwt_syntax in - let may_fetch_operation = may_fetch_operation shell (Some peer) in - let* () = List.iter_s may_fetch_operation mempool.Mempool.known_valid in - Seq.iter_s - may_fetch_operation - (Operation_hash.Set.to_seq mempool.Mempool.pending) - - let on_flush ~handle_branch_refused pv new_predecessor new_live_blocks - new_live_operations = - let open Lwt_result_syntax in - let old_predecessor = pv.shell.predecessor in - pv.shell.predecessor <- new_predecessor ; - pv.shell.live_blocks <- new_live_blocks ; - pv.shell.live_operations <- new_live_operations ; - Lwt_watcher.shutdown_input pv.operation_stream ; - pv.operation_stream <- Lwt_watcher.create_input () ; - let timestamp_system = Tezos_base.Time.System.now () in - pv.shell.timestamp <- timestamp_system ; - let timestamp = Time.System.to_protocol timestamp_system in - let*! validation_state = - pv.shell.parameters.tools.create - ~predecessor:new_predecessor - ~live_operations:new_live_operations - ~timestamp - () - in - pv.validation_state <- validation_state ; - let* filter_state = - Filter.Mempool.on_flush - pv.filter_config - pv.filter_state - ?validation_state: - (Option.map - Prevalidation_t.validation_state - (Option.of_result validation_state)) - ~predecessor:(Store.Block.header new_predecessor) - () - in - pv.filter_state <- filter_state ; - let*! new_pending_operations = - Classification.recycle_operations - ~from_branch:old_predecessor - ~to_branch:new_predecessor - ~live_blocks:new_live_blocks - ~parse:(fun oph op -> Result.to_option (Prevalidation_t.parse oph op)) - ~classes:pv.shell.classification - ~pending:(Pending_ops.operations pv.shell.pending) - ~block_store:block_tools - ~chain:pv.shell.parameters.tools.chain_tools - ~handle_branch_refused - in - (* Could be implemented as Operation_hash.Map.filter_s which - does not exist for the moment. *) - let*! new_pending_operations, nb_pending = - Operation_hash.Map.fold_s - (fun _oph op (pending, nb_pending) -> - let*! v = - pre_filter - pv.shell - ~filter_config:pv.filter_config - ~filter_state:pv.filter_state - ~validation_state:pv.validation_state - ~notifier:(mk_notifier pv.operation_stream) - op - in - match v with - | `Drop -> Lwt.return (pending, nb_pending) - | (`High | `Medium | `Low _) as prio -> - (* Here, an operation injected in this node with `High priority will - now get its approriate priority. *) - Lwt.return (Pending_ops.add op prio pending, nb_pending + 1)) - new_pending_operations - (Pending_ops.empty, 0) - in - let*! () = Events.(emit operations_to_reclassify) nb_pending in - pv.shell.pending <- new_pending_operations ; - set_mempool pv.shell Mempool.empty - - let on_advertise (shell : ('protocol_data, _) types_state_shell) = - match shell.advertisement with - | `None -> - () (* May happen if nothing to advertise since last advertisement. *) - | `Pending mempool -> - shell.advertisement <- `None ; - (* In this case, mempool is not empty, but let's avoid advertising - empty mempools in case this invariant is broken. *) - if not (Mempool.is_empty mempool) then - shell.parameters.tools.advertise_current_head - ~mempool - shell.predecessor - - (* If [flush_if_prechecked] is [true], removing a prechecked - operation triggers a flush of the mempool. Because flushing may - be costly this should be done only when the action is triggered - locally by the user. This allows a better UX if the user bans a - prechecked operation so that a branch delayed operation becomes - [applied] again. *) - let remove ~flush_if_prechecked pv oph = - let open Lwt_result_syntax in - pv.shell.parameters.tools.chain_tools.clear_or_cancel oph ; - pv.shell.advertisement <- - remove_from_advertisement oph pv.shell.advertisement ; - pv.shell.banned_operations <- - Operation_hash.Set.add oph pv.shell.banned_operations ; - match Classification.remove oph pv.shell.classification with - | None -> - pv.shell.pending <- Pending_ops.remove oph pv.shell.pending ; - pv.shell.fetching <- Operation_hash.Set.remove oph pv.shell.fetching ; - return_unit - | Some (_op, classification) -> ( - match (classification, flush_if_prechecked) with - | `Prechecked, true | `Applied, _ -> - (* Modifying the list of operations classified as [Applied] - might change the classification of all the operations in - the mempool. Hence if the removed operation has been - applied we flush the mempool to force the - reclassification of all the operations except the one - removed. *) - let+ () = - on_flush - ~handle_branch_refused:false - pv - pv.shell.predecessor - pv.shell.live_blocks - pv.shell.live_operations - in - pv.shell.pending <- Pending_ops.remove oph pv.shell.pending - | `Branch_delayed _, _ - | `Branch_refused _, _ - | `Refused _, _ - | `Outdated _, _ - | `Prechecked, false -> - pv.filter_state <- - Filter.Mempool.remove ~filter_state:pv.filter_state oph ; - return_unit) - - let on_ban pv oph_to_ban = - pv.shell.banned_operations <- - Operation_hash.Set.add oph_to_ban pv.shell.banned_operations ; - remove ~flush_if_prechecked:true pv oph_to_ban - end -end - -module type ARG = sig - val limits : Shell_limits.prevalidator_limits - - val chain_db : Distributed_db.chain_db - - val chain_id : Chain_id.t -end - -module WorkerGroup = Worker.MakeGroup (Name) (Prevalidator_worker_state.Request) - -(** The functor that is not tested, in other words used only in production. - This functor's code is not tested (contrary to functor {!Make_s} above), - because it hardcodes a dependency to [Store.chain_store] in its instantiation - of type [chain_store]. This is what makes the code of this functor - not testable for the moment, because [Store.chain_store] has poor - testing capabilities. - - Note that, because this functor [include]s {!Make_s}, it is a - strict extension of [Make_s]. *) -module Make - (Filter : Shell_plugin.FILTER) - (Arg : ARG) - (Prevalidation_t : Prevalidation.T - with type validation_state = - Filter.Proto.validation_state - and type protocol_operation = Filter.Proto.operation - and type operation_receipt = - Filter.Proto.operation_receipt - and type chain_store = Store.chain_store) : - T with type prevalidation_t = Prevalidation_t.t = struct - include Make_s (Filter) (Prevalidation_t) - - let name = (Arg.chain_id, Filter.Proto.hash) - - module Types = struct - type state = types_state - - type parameters = Shell_limits.prevalidator_limits * Distributed_db.chain_db - end - - module Worker : - Worker.T - with type Name.t = Name.t - and type ('a, 'b) Request.t = ('a, 'b) Request.t - and type Request.view = Request.view - and type Types.state = Types.state - and type Types.parameters = Types.parameters = - WorkerGroup.MakeWorker (Types) - - open Types - - type worker = Worker.infinite Worker.queue Worker.t - - (** Returns a json describing the prevalidator's [filter_config]. - The boolean [include_default] ([true] by default) indicates - whether the json should include the fields which have a value - equal to their default value. *) - let get_filter_config_json ?(include_default = true) pv = - let include_default_fields = if include_default then `Always else `Never in - Data_encoding.Json.construct - ~include_default_fields - Filter.Mempool.config_encoding - pv.filter_config - - let build_rpc_directory w = - lazy - (let open Lwt_result_syntax in - let dir : state RPC_directory.t ref = ref RPC_directory.empty in - let module Proto_services = - Block_services.Make (Filter.Proto) (Filter.Proto) - in - dir := - RPC_directory.register - !dir - (Proto_services.S.Mempool.get_filter RPC_path.open_root) - (fun pv params () -> - return - (get_filter_config_json - ~include_default:params#include_default - pv)) ; - dir := - RPC_directory.register - !dir - (Proto_services.S.Mempool.set_filter RPC_path.open_root) - (fun pv () obj -> - let open Lwt_syntax in - let* () = - try - let config = - Data_encoding.Json.destruct Filter.Mempool.config_encoding obj - in - pv.filter_config <- config ; - Lwt.return_unit - with _ -> Events.(emit invalid_mempool_filter_configuration) () - in - return_ok (get_filter_config_json pv)) ; - (* Ban an operation (from its given hash): remove it from the - mempool if present. Add it to the set pv.banned_operations - to prevent it from being fetched/processed/injected in the - future. - Note: If the baker has already received the operation, then - it's necessary to restart it manually to flush the operation - from it. *) - dir := - RPC_directory.register - !dir - (Proto_services.S.Mempool.ban_operation RPC_path.open_root) - (fun _pv () oph -> - let open Lwt_result_syntax in - let*! r = Worker.Queue.push_request_and_wait w (Request.Ban oph) in - match r with - | Error (Closed None) -> fail [Worker_types.Terminated] - | Error (Closed (Some errs)) -> fail errs - | Error (Request_error err) -> fail err - | Error (Any exn) -> fail [Exn exn] - | Ok () -> return_unit) ; - (* Unban an operation (from its given hash): remove it from the - set pv.banned_operations (nothing happens if it was not banned). *) - dir := - RPC_directory.register - !dir - (Proto_services.S.Mempool.unban_operation RPC_path.open_root) - (fun pv () oph -> - pv.shell.banned_operations <- - Operation_hash.Set.remove oph pv.shell.banned_operations ; - return_unit) ; - (* Unban all operations: clear the set pv.banned_operations. *) - dir := - RPC_directory.register - !dir - (Proto_services.S.Mempool.unban_all_operations RPC_path.open_root) - (fun pv () () -> - pv.shell.banned_operations <- Operation_hash.Set.empty ; - return_unit) ; - dir := - RPC_directory.gen_register - !dir - (Proto_services.S.Mempool.pending_operations RPC_path.open_root) - (fun pv params () -> - let map_op_error oph (op, error) acc = - op.Prevalidation.protocol |> fun res -> - Operation_hash.Map.add oph (res, error) acc - in - let applied = - if params#applied then - List.rev_map - (fun op -> (op.Prevalidation.hash, op.Prevalidation.protocol)) - pv.shell.classification.applied_rev - else [] - in - let filter f map = - Operation_hash.Map.fold f map Operation_hash.Map.empty - in - let refused = - if params#refused then - filter - map_op_error - (Classification.map pv.shell.classification.refused) - else Operation_hash.Map.empty - in - let outdated = - if params#outdated then - filter - map_op_error - (Classification.map pv.shell.classification.outdated) - else Operation_hash.Map.empty - in - let branch_refused = - if params#branch_refused then - filter - map_op_error - (Classification.map pv.shell.classification.branch_refused) - else Operation_hash.Map.empty - in - let branch_delayed = - if params#branch_delayed then - filter - map_op_error - (Classification.map pv.shell.classification.branch_delayed) - else Operation_hash.Map.empty - in - let unprocessed = - Pending_ops.fold - (fun _prio oph op acc -> - Operation_hash.Map.add oph op.protocol acc) - pv.shell.pending - Operation_hash.Map.empty - in - (* FIXME https://gitlab.com/tezos/tezos/-/issues/2250 - - We merge prechecked operation with applied operation - so that the encoding of the RPC does not need to be - changed. Once prechecking will be done by the protocol - and not the plugin, we will change the encoding to - reflect that. *) - let prechecked_with_applied = - if params#applied then - Classification.Sized_map.fold - (fun oph op acc -> (oph, op.Prevalidation.protocol) :: acc) - pv.shell.classification.prechecked - applied - else applied - in - let pending_operations = - { - Proto_services.Mempool.applied = prechecked_with_applied; - refused; - outdated; - branch_refused; - branch_delayed; - unprocessed; - } - in - Proto_services.Mempool.pending_operations_version_dispatcher - ~version:params#version - pending_operations) ; - dir := - RPC_directory.register - !dir - (Proto_services.S.Mempool.request_operations RPC_path.open_root) - (fun pv t () -> - pv.shell.parameters.tools.send_get_current_head ?peer:t#peer_id () ; - return_unit) ; - dir := - RPC_directory.gen_register - !dir - (Proto_services.S.Mempool.monitor_operations RPC_path.open_root) - (fun pv params () -> - Lwt_mutex.with_lock pv.lock @@ fun () -> - let op_stream, stopper = - Lwt_watcher.create_stream pv.operation_stream - in - (* Convert ops *) - let fold_op hash (Prevalidation.{protocol; _}, error) acc = - (hash, protocol, error) :: acc - in - (* First call : retrieve the current set of op from the mempool *) - let applied = - if params#applied then - List.map - (fun op -> (op.Prevalidation.hash, op.protocol, [])) - pv.shell.classification.applied_rev - else [] - in - (* FIXME https://gitlab.com/tezos/tezos/-/issues/2250 - - For the moment, applied and prechecked operations are - handled the same way for the user point of view. *) - let prechecked = - if params#applied then - Classification.Sized_map.fold - (fun hash op acc -> - (hash, op.Prevalidation.protocol, []) :: acc) - pv.shell.classification.prechecked - [] - else [] - in - let refused = - if params#refused then - Operation_hash.Map.fold - fold_op - (Classification.map pv.shell.classification.refused) - [] - else [] - in - let branch_refused = - if params#branch_refused then - Operation_hash.Map.fold - fold_op - (Classification.map pv.shell.classification.branch_refused) - [] - else [] - in - let branch_delayed = - if params#branch_delayed then - Operation_hash.Map.fold - fold_op - (Classification.map pv.shell.classification.branch_delayed) - [] - else [] - in - let outdated = - if params#outdated then - Operation_hash.Map.fold - fold_op - (Classification.map pv.shell.classification.outdated) - [] - else [] - in - let current_mempool = - List.concat_map - (List.map (function - | hash, op, [] -> ((hash, op), None) - | hash, op, errors -> ((hash, op), Some errors))) - [ - applied; - prechecked; - refused; - branch_refused; - branch_delayed; - outdated; - ] - in - let current_mempool = ref (Some current_mempool) in - let filter_result = function - | `Prechecked | `Applied -> params#applied - | `Refused _ -> params#refused - | `Outdated _ -> params#outdated - | `Branch_refused _ -> params#branch_refused - | `Branch_delayed _ -> params#branch_delayed - in - let rec next () = - let open Lwt_syntax in - match !current_mempool with - | Some mempool -> - current_mempool := None ; - Lwt.return_some mempool - | None -> ( - let* o = Lwt_stream.get op_stream in - match o with - | Some (kind, op) when filter_result kind -> - let errors = - match kind with - | `Prechecked | `Applied -> None - | `Branch_delayed errors - | `Branch_refused errors - | `Refused errors - | `Outdated errors -> - Some errors - in - Lwt.return_some - [(Prevalidation.(op.hash, op.protocol), errors)] - | Some _ -> next () - | None -> Lwt.return_none) - in - let shutdown () = Lwt_watcher.shutdown stopper in - RPC_answer.return_stream {next; shutdown}) ; - !dir) - - (** Module implementing the events at the {!Worker} level. Contrary - to {!Requests}, these functions depend on [Worker]. *) - module Handlers = struct - type self = worker - - let on_request : - type r request_error. - worker -> - (r, request_error) Request.t -> - (r, request_error) result Lwt.t = - fun w request -> - let open Lwt_result_syntax in - Prometheus.Counter.inc_one metrics.worker_counters.worker_request_count ; - let pv = Worker.state w in - let post_processing : - (r, request_error) result Lwt.t -> (r, request_error) result Lwt.t = - fun r -> - let open Lwt_syntax in - let* () = handle_unprocessed pv in - r - in - post_processing - @@ - match request with - | Request.Flush (hash, event, live_blocks, live_operations) -> - Requests.on_advertise pv.shell ; - (* TODO: https://gitlab.com/tezos/tezos/-/issues/1727 - Rebase the advertisement instead. *) - let* block = pv.shell.parameters.tools.read_block hash in - let handle_branch_refused = - Chain_validator_worker_state.( - match event with - | Head_increment | Ignored_head -> false - | Branch_switch -> true) - in - Lwt_mutex.with_lock pv.lock - @@ fun () : (r, error trace) result Lwt.t -> - Requests.on_flush - ~handle_branch_refused - pv - block - live_blocks - live_operations - | Request.Notify (peer, mempool) -> - let*! () = Requests.on_notify pv.shell peer mempool in - return_unit - | Request.Leftover -> - (* unprocessed ops are handled just below *) - return_unit - | Request.Inject {op; force} -> Requests.on_inject pv ~force op - | Request.Arrived (oph, op) -> Requests.on_arrived pv oph op - | Request.Advertise -> - Requests.on_advertise pv.shell ; - return_unit - | Request.Ban oph -> Requests.on_ban pv oph - - let on_close w = - let pv = Worker.state w in - Operation_hash.Set.iter - pv.shell.parameters.tools.chain_tools.clear_or_cancel - pv.shell.fetching ; - Lwt.return_unit - - let mk_tools (chain_db : Distributed_db.chain_db) : - prevalidation_t Tools.tools = - let advertise_current_head ~mempool bh = - Distributed_db.Advertise.current_head chain_db ~mempool bh - in - let chain_tools = mk_chain_tools chain_db in - let create ~predecessor ~live_operations ~timestamp = - let chain_store = Distributed_db.chain_store chain_db in - Prevalidation_t.create - chain_store - ~predecessor - ~live_operations - ~timestamp - in - let fetch ?peer ?timeout oph = - Distributed_db.Operation.fetch chain_db ?timeout ?peer oph () - in - let read_block bh = - let chain_store = Distributed_db.chain_store chain_db in - Store.Block.read_block chain_store bh - in - let send_get_current_head ?peer () = - Distributed_db.Request.current_head chain_db ?peer () - in - let set_mempool ~head mempool = - let chain_store = Distributed_db.chain_store chain_db in - Store.Chain.set_mempool chain_store ~head mempool - in - { - advertise_current_head; - chain_tools; - create; - fetch; - read_block; - send_get_current_head; - set_mempool; - } - - let mk_worker_tools w : Tools.worker_tools = - let push_request r = Worker.Queue.push_request w r in - let push_request_now r = Worker.Queue.push_request_now w r in - {push_request; push_request_now} - - type launch_error = error trace - - let on_launch w _ (limits, chain_db) : (state, launch_error) result Lwt.t = - let open Lwt_result_syntax in - let chain_store = Distributed_db.chain_store chain_db in - let*! predecessor = Store.Chain.current_head chain_store in - let predecessor_header = Store.Block.header predecessor in - let*! mempool = Store.Chain.mempool chain_store in - let*! live_blocks, live_operations = - Store.Chain.live_blocks chain_store - in - let timestamp_system = Tezos_base.Time.System.now () in - let timestamp = Time.System.to_protocol timestamp_system in - let*! validation_state = - Prevalidation_t.create - chain_store - ~predecessor - ~timestamp - ~live_operations - () - in - let fetching = - List.fold_left - (fun s h -> Operation_hash.Set.add h s) - Operation_hash.Set.empty - mempool.known_valid - in - let classification_parameters = - Classification. - { - map_size_limit = limits.Shell_limits.max_refused_operations; - on_discarded_operation = - Distributed_db.Operation.clear_or_cancel chain_db; - } - in - let classification = Classification.create classification_parameters in - let parameters = {limits; tools = mk_tools chain_db} in - let shell = - { - classification; - parameters; - predecessor; - timestamp = timestamp_system; - live_blocks; - live_operations; - mempool = Mempool.empty; - fetching; - pending = Pending_ops.empty; - advertisement = `None; - banned_operations = Operation_hash.Set.empty; - worker = mk_worker_tools w; - } - in - Shell_metrics.Mempool.set_applied_collector (fun () -> - List.length shell.classification.applied_rev |> float_of_int) ; - Shell_metrics.Mempool.set_prechecked_collector (fun () -> - Prevalidator_classification.Sized_map.cardinal - shell.classification.prechecked - |> float_of_int) ; - Shell_metrics.Mempool.set_refused_collector (fun () -> - Prevalidator_classification.cardinal shell.classification.refused - |> float_of_int) ; - Shell_metrics.Mempool.set_branch_refused_collector (fun () -> - Prevalidator_classification.cardinal - shell.classification.branch_refused - |> float_of_int) ; - Shell_metrics.Mempool.set_branch_delayed_collector (fun () -> - Prevalidator_classification.cardinal - shell.classification.branch_delayed - |> float_of_int) ; - Shell_metrics.Mempool.set_outdated_collector (fun () -> - Prevalidator_classification.cardinal shell.classification.outdated - |> float_of_int) ; - Shell_metrics.Mempool.set_unprocessed_collector (fun () -> - Prevalidator_pending_operations.cardinal shell.pending |> float_of_int) ; - - let* filter_state = - Filter.Mempool.init - Filter.Mempool.default_config - ?validation_state: - (Option.map - Prevalidation_t.validation_state - (Option.of_result validation_state)) - ~predecessor:predecessor_header - () - in - let pv = - { - shell; - validation_state; - filter_state; - operation_stream = Lwt_watcher.create_input (); - rpc_directory = build_rpc_directory w; - filter_config = - (* TODO: https://gitlab.com/tezos/tezos/-/issues/1725 - initialize from config file *) - Filter.Mempool.default_config; - lock = Lwt_mutex.create (); - } - in - let*! () = - Seq.iter_s - (may_fetch_operation pv.shell None) - (Operation_hash.Set.to_seq fetching) - in - return pv - - let on_error (type a b) _w st (request : (a, b) Request.t) (errs : b) : - unit tzresult Lwt.t = - Prometheus.Counter.inc_one metrics.worker_counters.worker_error_count ; - let open Lwt_syntax in - match request with - | Request.(Inject _) as r -> - let* () = Events.(emit request_failed) (Request.view r, st, errs) in - return_ok_unit - | Request.Notify _ -> ( match errs with _ -> .) - | Request.Leftover -> ( match errs with _ -> .) - | Request.Arrived _ -> ( match errs with _ -> .) - | Request.Advertise -> ( match errs with _ -> .) - | Request.Flush _ -> - let request_view = Request.view request in - let* () = Events.(emit request_failed) (request_view, st, errs) in - Lwt.return_error errs - | Request.Ban _ -> - let request_view = Request.view request in - let* () = Events.(emit request_failed) (request_view, st, errs) in - Lwt.return_error errs - - let on_completion _w r _ st = - Prometheus.Counter.inc_one metrics.worker_counters.worker_completion_count ; - match Request.view r with - | Request.View (Flush _) | View (Inject _) | View (Ban _) -> - Events.(emit request_completed_notice) (Request.view r, st) - | View (Notify _) | View Leftover | View (Arrived _) | View Advertise -> - Events.(emit request_completed_debug) (Request.view r, st) - - let on_no_request _ = Lwt.return_unit - end - - let table = Worker.create_table Queue - - (* NOTE: we register a single worker for each instantiation of this Make - * functor (and thus a single worker for the single instantiation of Worker). - * Whilst this is somewhat abusing the intended purpose of worker, it is part - * of a transition plan to a one-worker-per-peer architecture. *) - let worker_promise = - Worker.launch table name (Arg.limits, Arg.chain_db) (module Handlers) - - let worker = - lazy - (match Lwt.state worker_promise with - | Lwt.Return (Ok worker) -> worker - | Lwt.Return (Error _) | Lwt.Fail _ | Lwt.Sleep -> assert false) -end module ChainProto_registry = Map.Make (struct type t = Chain_id.t * Protocol_hash.t @@ -1665,25 +46,23 @@ let create limits (module Filter : Shell_plugin.FILTER) chain_db = ChainProto_registry.find (chain_id, Filter.Proto.hash) !chain_proto_registry with | None -> - let module Prevalidation_t = Prevalidation.Make (Filter.Proto) in - let module Prevalidator = - Make - (Filter) - (struct - let limits = limits - - let chain_db = chain_db - - let chain_id = chain_id - end) - (Prevalidation_t) + let prevalidator = + if Filter.Proto.(compare environment_version V7 >= 0) then + Prevalidator_internal.make limits chain_db chain_id (module Filter) + else + Legacy_prevalidator_internal.make + limits + chain_db + chain_id + (module Filter) in + let (module Prevalidator : T) = prevalidator in chain_proto_registry := ChainProto_registry.add Prevalidator.name - (module Prevalidator : T) + prevalidator !chain_proto_registry ; - return (module Prevalidator : T) + return prevalidator | Some p -> return p let shutdown (t : t) = @@ -1794,93 +173,5 @@ let rpc_directory : t option RPC_directory.t = let module Prevalidator : T = (val t : T) in let w = Lazy.force Prevalidator.worker in let pv = Prevalidator.Worker.state w in - let pv_rpc_dir = Lazy.force pv.rpc_directory in + let pv_rpc_dir = Lazy.force (Prevalidator.get_rpc_directory pv) in Lwt.return (RPC_directory.map (fun _ -> Lwt.return pv) pv_rpc_dir)) - -module Internal_for_tests = struct - include Tools - - type nonrec ('a, 'b) types_state_shell = ('a, 'b) types_state_shell - - let mk_types_state_shell ~(predecessor : Store.Block.t) ~(tools : 'a tools) - ~(worker : worker_tools) : (_, 'a) types_state_shell = - let parameters = - {limits = Shell_limits.default_prevalidator_limits; tools} - in - let c_parameters : Classification.parameters = - {map_size_limit = 32; on_discarded_operation = Fun.const ()} - in - let advertisement = `None in - let banned_operations = Operation_hash.Set.empty in - let classification = Classification.create c_parameters in - let fetching = Operation_hash.Set.empty in - let mempool = Mempool.empty in - let live_blocks = Block_hash.Set.empty in - let live_operations = Operation_hash.Set.empty in - let pending = Pending_ops.empty in - let timestamp = Tezos_base.Time.System.now () in - { - advertisement; - banned_operations; - classification; - fetching; - live_blocks; - live_operations; - mempool; - parameters; - pending; - predecessor; - timestamp; - worker; - } - - module Make - (Filter : Shell_plugin.FILTER) - (Prevalidation_t : Prevalidation.T - with type validation_state = - Filter.Proto.validation_state - and type protocol_operation = Filter.Proto.operation - and type operation_receipt = - Filter.Proto.operation_receipt) = - struct - module Internal = Make_s (Filter) (Prevalidation_t) - - type nonrec types_state = Internal.types_state - - let mk_types_state - ~(shell : - ( Prevalidation_t.protocol_operation, - Prevalidation_t.t ) - types_state_shell) ~(validation_state : Prevalidation_t.t) : - types_state Lwt.t = - let open Lwt_syntax in - let filter_config = Filter.Mempool.default_config in - let predecessor = Store.Block.header shell.predecessor in - let* r = Filter.Mempool.init filter_config ~predecessor () in - match r with - | Error err -> - let err_string = - Format.asprintf "%a" Error_monad.pp_print_trace err - in - let* () = Lwt_io.eprintf "%s" err_string in - assert false - | Ok filter_state -> - Lwt.return - Internal. - { - shell; - filter_config; - filter_state; - lock = Lwt_mutex.create (); - operation_stream = Lwt_watcher.create_input (); - rpc_directory = Lazy.from_fun (fun () -> assert false); - validation_state = Ok validation_state; - } - - let to_shell (t : types_state) = t.shell - - let handle_unprocessed = Internal.handle_unprocessed - - module Requests = Internal.Requests - end -end diff --git a/src/lib_shell/prevalidator.mld b/src/lib_shell/prevalidator.mld index 97082eb4ef946c384bd6862528fc0d80b77f505b..bf33ad23c70833a3e5b0bf80f0b5b5826f7f6d7c 100644 --- a/src/lib_shell/prevalidator.mld +++ b/src/lib_shell/prevalidator.mld @@ -1,5 +1,17 @@ {0 Overview of the prevalidator implementation } +This documentation was written for what is now considered the legacy +version of the mempool (see +{{: https://gitlab.com/tezos/tezos/-/issues/4113 } issue #4113}). +This mempool supports the Kathmandu protocol and is implemented in +{!Legacy_prevalidator_internal} and its dependencies. The newer +mempool implementation, supporting protocols Lima and up, does not +have a similar documentation yet. Nevertheless, most of the concepts +presented here still apply to the newer mempool. + +FIXME: https://gitlab.com/tezos/tezos/-/issues/4146 +Some links in this file have been broken by file renamings. + This page details the internals of the prevalidator component. It explains the complete lifecycle of an operation in the prevalidator, from its reception to its classification and advertisement to the neighborhood. diff --git a/src/lib_shell/prevalidator.mli b/src/lib_shell/prevalidator.mli index 62a1bde1a49a6caa9d1f9144577d6191ea299da5..5e9bc04ccf75206ea41e6adf5d3cc3027a10c35d 100644 --- a/src/lib_shell/prevalidator.mli +++ b/src/lib_shell/prevalidator.mli @@ -2,7 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2018-2021 Nomadic Labs, *) +(* Copyright (c) 2018-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"),*) @@ -103,103 +103,3 @@ val information : t -> Worker_types.worker_information val pipeline_length : t -> int val rpc_directory : t option RPC_directory.t - -(**/**) - -module Internal_for_tests : sig - (** Documented in {!Prevalidator}, because this is only exported for tests. *) - type 'prevalidation_t tools = { - advertise_current_head : mempool:Mempool.t -> Store.Block.t -> unit; - chain_tools : Store.Block.t Prevalidator_classification.chain_tools; - create : - predecessor:Store.Block.t -> - live_operations:Operation_hash.Set.t -> - timestamp:Time.Protocol.t -> - unit -> - 'prevalidation_t tzresult Lwt.t; - fetch : - ?peer:P2p_peer.Id.t -> - ?timeout:Time.System.Span.t -> - Operation_hash.t -> - Operation.t tzresult Lwt.t; - read_block : Block_hash.t -> Store.Block.t tzresult Lwt.t; - send_get_current_head : ?peer:P2p_peer_id.t -> unit -> unit; - set_mempool : head:Block_hash.t -> Mempool.t -> unit tzresult Lwt.t; - } - - (** Documented in {!Prevalidator}, because this is only exported for tests. *) - type worker_tools = { - push_request : - (unit, Empty.t) Prevalidator_worker_state.Request.t -> bool Lwt.t; - push_request_now : - (unit, Empty.t) Prevalidator_worker_state.Request.t -> unit; - } - - (** The corresponding internal type of the mempool (see {!Prevalidator.S}), - that is independent from the protocol. *) - type ('a, 'b) types_state_shell - - (** Create a pristine value of {!type_state_shell} *) - val mk_types_state_shell : - predecessor:Store.Block.t -> - tools:'prevalidation_t tools -> - worker:worker_tools -> - ('protocol_data, 'prevalidation_t) types_state_shell - - module Make - (Filter : Shell_plugin.FILTER) - (Prevalidation_t : Prevalidation.T - with type validation_state = - Filter.Proto.validation_state - and type protocol_operation = Filter.Proto.operation - and type operation_receipt = - Filter.Proto.operation_receipt) : sig - (** The corresponding internal type of the mempool (see {!Prevalidator.S}), - that depends on the protocol *) - type types_state - - (** Create a pristine value of {!type_state} *) - val mk_types_state : - shell: - ( Prevalidation_t.protocol_operation, - Prevalidation_t.t ) - types_state_shell -> - validation_state:Prevalidation_t.t -> - types_state Lwt.t - - (** [to_shell pv] returns the shell part of [pv] *) - val to_shell : - types_state -> - (Prevalidation_t.protocol_operation, Prevalidation_t.t) types_state_shell - - (** Documented in {!Prevalidator.S} *) - val handle_unprocessed : types_state -> unit Lwt.t - - (** Documented in {!Prevalidator.S} (as are all the functions of this module) *) - module Requests : sig - val on_advertise : _ types_state_shell -> unit - - val on_arrived : - types_state -> - Operation_hash.t -> - Operation.t -> - (unit, Empty.t) result Lwt.t - - val on_ban : types_state -> Operation_hash.t -> unit tzresult Lwt.t - - val on_flush : - handle_branch_refused:bool -> - types_state -> - Store.Block.t -> - Block_hash.Set.t -> - Operation_hash.Set.t -> - unit tzresult Lwt.t - - val on_inject : - types_state -> force:bool -> Operation.t -> unit tzresult Lwt.t - - val on_notify : - _ types_state_shell -> P2p_peer_id.t -> Mempool.t -> unit Lwt.t - end - end -end diff --git a/src/lib_shell/prevalidator_classification.ml b/src/lib_shell/prevalidator_classification.ml index 4a3ec6d03db44bbbb25f4d191dfccc2376de80c8..727fc912ffeed5dd41ab7501dc77c0b705b1091f 100644 --- a/src/lib_shell/prevalidator_classification.ml +++ b/src/lib_shell/prevalidator_classification.ml @@ -1,7 +1,7 @@ (*****************************************************************************) (* *) (* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) +(* Copyright (c) 2021-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"),*) @@ -23,6 +23,16 @@ (* *) (*****************************************************************************) +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the implementation of the new mempool, which + uses features of the protocol that only exist since Lima. + + When you modify this file, consider whether you should also change + the files that implement the legacy mempool for Kathmandu. They all + start with the "legacy" prefix and will be removed when Lima is + activated on Mainnet. *) + module Event = struct let section = ["prevalidator_classification"] diff --git a/src/lib_shell/prevalidator_classification.mli b/src/lib_shell/prevalidator_classification.mli index cfc7682091e2b3fcf44dd1bca687e8b99ef28ebd..24c1ad663be71ab96ac25c41183f5b4bb377d1de 100644 --- a/src/lib_shell/prevalidator_classification.mli +++ b/src/lib_shell/prevalidator_classification.mli @@ -1,7 +1,7 @@ (*****************************************************************************) (* *) (* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs, *) +(* Copyright (c) 2021-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"),*) @@ -23,6 +23,16 @@ (* *) (*****************************************************************************) +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the implementation of the new mempool, which + uses features of the protocol that only exist since Lima. + + When you modify this file, consider whether you should also change + the files that implement the legacy mempool for Kathmandu. They all + start with the "legacy" prefix and will be removed when Lima is + activated on Mainnet. *) + (** Classifications which correspond to errors *) type error_classification = [ `Branch_delayed of tztrace diff --git a/src/lib_shell/prevalidator_internal.ml b/src/lib_shell/prevalidator_internal.ml new file mode 100644 index 0000000000000000000000000000000000000000..0ee2305e239b7f79c7484959cb49403f80c498e0 --- /dev/null +++ b/src/lib_shell/prevalidator_internal.ml @@ -0,0 +1,1730 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2018-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. *) +(* *) +(*****************************************************************************) + +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the implementation of the new mempool, which + uses features of the protocol that only exist since Lima. + + When you modify this file, consider whether you should also change + the files that implement the legacy mempool for Kathmandu. They all + start with the "legacy" prefix and will be removed when Lima is + activated on Mainnet. *) + +open Prevalidator_internal_common +open Prevalidator_worker_state +module Events = Prevalidator_events +module Classification = Prevalidator_classification + +(** This module encapsulates pending operations to maintain them in two + different data structure and avoid coslty repetitive convertions when + handling batches in [classify_pending_operations]. *) +module Pending_ops = Prevalidator_pending_operations + +(** Module encapsulating some types that are used both in production + and in tests. Having them in a module makes it possible to + [include] this module in {!Internal_for_tests} below and avoid + code duplication. + + The raison d'etre of these records of functions is to be able to use + alternative implementations of all functions in tests. + + The purpose of the {!Tools.tools} record is to abstract away from {!Store.chain_store}. + Under the hood [Store.chain_store] requires an Irmin store on disk, + which makes it impractical for fast testing: every test would need + to create a temporary folder on disk which doesn't scale well. + + The purpose of the {!Tools.worker_tools} record is to abstract away + from the {!Worker} implementation. This implementation is overkill + for testing: we don't need asynchronicity and concurrency in our + pretty basic existing tests. Having this abstraction allows to get + away with a much simpler state machine model of execution and + to have simpler test setup. *) +module Tools = struct + (** Functions provided by {!Distributed_db} and {!Store.chain_store} + that are used in various places of the mempool. Gathered here so that we can test + the mempool without requiring a full-fledged [Distributed_db]/[Store.Chain_store]. *) + type 'prevalidation_t tools = { + advertise_current_head : mempool:Mempool.t -> Store.Block.t -> unit; + (** [advertise_current_head mempool head] sends a + [Current_head (chain_id, head_header, mempool)] message to all known + active peers for the chain being considered. *) + chain_tools : Store.Block.t Classification.chain_tools; + (** Lower-level tools provided by {!Prevalidator_classification} *) + create : + predecessor:Store.Block.t -> + live_operations:Operation_hash.Set.t -> + timestamp:Time.Protocol.t -> + unit -> + 'prevalidation_t tzresult Lwt.t; + (** Creates a new prevalidation context w.r.t. the protocol associated to the + predecessor block. *) + fetch : + ?peer:P2p_peer.Id.t -> + ?timeout:Time.System.Span.t -> + Operation_hash.t -> + Operation.t tzresult Lwt.t; + (** [fetch ?peer ?timeout oph] returns the value when it is known. + It can fail with [Requester.Timeout] if [timeout] is provided and the value + isn't known before the timeout expires. It can fail with [Requester.Cancel] if + the request is canceled. *) + read_block : Block_hash.t -> Store.Block.t tzresult Lwt.t; + (** [read_block bh] tries to read the block [bh] from the chain store. *) + send_get_current_head : ?peer:P2p_peer_id.t -> unit -> unit; + (** [send_get_current_head ?peer ()] sends a [Get_Current_head] + to a given peer, or to all known active peers for the chain considered. + Expected answer is a [Get_current_head] message *) + set_mempool : head:Block_hash.t -> Mempool.t -> unit tzresult Lwt.t; + (** [set_mempool ~head mempool] sets the [mempool] of + the [chain_store] of the chain considered. Does nothing if [head] differs + from current_head which might happen when a new head concurrently arrives just + before this operation is being called. *) + } + + (** Abstraction over services implemented in production by {!Worker} + but implemented differently in tests. + + Also see the enclosing module documentation as to why we have this record. *) + type worker_tools = { + push_request : + (unit, Empty.t) Prevalidator_worker_state.Request.t -> bool Lwt.t; + (** Adds a message to the queue. *) + push_request_now : + (unit, Empty.t) Prevalidator_worker_state.Request.t -> unit; + (** Adds a message to the queue immediately. *) + } +end + +type 'a parameters = { + limits : Shell_limits.prevalidator_limits; + tools : 'a Tools.tools; +} + +(** The type needed for the implementation of [Make] below, but + * which is independent from the protocol. *) +type ('protocol_data, 'a) types_state_shell = { + classification : 'protocol_data Classification.t; + parameters : 'a parameters; + mutable predecessor : Store.Block.t; + mutable timestamp : Time.System.t; + mutable live_blocks : Block_hash.Set.t; + mutable live_operations : Operation_hash.Set.t; + mutable fetching : Operation_hash.Set.t; + mutable pending : 'protocol_data Pending_ops.t; + mutable mempool : Mempool.t; + mutable advertisement : [`Pending of Mempool.t | `None]; + mutable banned_operations : Operation_hash.Set.t; + worker : Tools.worker_tools; +} + +let metrics = Shell_metrics.Mempool.init ["mempool"] + +(** The concrete production instance of {!block_tools} *) +let block_tools : Store.Block.t Classification.block_tools = + { + hash = Store.Block.hash; + operations = Store.Block.operations; + all_operation_hashes = Store.Block.all_operation_hashes; + } + +(** How to create an instance of {!chain_tools} from a {!Distributed_db.chain_db}. *) +let mk_chain_tools (chain_db : Distributed_db.chain_db) : + Store.Block.t Classification.chain_tools = + let open Lwt_syntax in + let new_blocks ~from_block ~to_block = + let chain_store = Distributed_db.chain_store chain_db in + Store.Chain_traversal.new_blocks chain_store ~from_block ~to_block + in + let read_predecessor_opt block = + let chain_store = Distributed_db.chain_store chain_db in + Store.Block.read_predecessor_opt chain_store block + in + let inject_operation oph op = + let* _ = Distributed_db.inject_operation chain_db oph op in + Lwt.return_unit + in + { + clear_or_cancel = Distributed_db.Operation.clear_or_cancel chain_db; + inject_operation; + new_blocks; + read_predecessor_opt; + } + +(** Module type used both in production and in tests. *) +module type S = sig + (** Type instantiated by {!Filter.Mempool.state}. *) + type filter_state + + (** Type instantiated by {!Filter.Mempool.config}. *) + type filter_config + + (** Similar to the type [operation] from the protocol, + see {!Tezos_protocol_environment.PROTOCOL} *) + type protocol_operation + + (** Type instantiated by {!Prevalidation.t} *) + type prevalidation_t + + type types_state = { + shell : (protocol_operation, prevalidation_t) types_state_shell; + mutable filter_state : filter_state; + (** Internal state of the filter in the plugin *) + mutable validation_state : prevalidation_t tzresult; + mutable operation_stream : + (Classification.classification + * protocol_operation Prevalidation.operation) + Lwt_watcher.input; + mutable rpc_directory : types_state RPC_directory.t lazy_t; + mutable filter_config : filter_config; + lock : Lwt_mutex.t; + } + + (** This function fetches an operation if it is not already handled + as defined by [already_handled] below. The implementation makes + sure to fetch an operation at most once, modulo operations + lost because of bounded buffers becoming full. + + This function is an intruder to this module type. It just happens + that it is needed both by internals of the implementation of {!S} + and by the internals of the implementation of {!T}; so it needs + to be exposed here. *) + val may_fetch_operation : + (protocol_operation, prevalidation_t) types_state_shell -> + P2p_peer_id.t option -> + Operation_hash.t -> + unit Lwt.t + + (** The function called after every call to a function of {!API}. *) + val handle_unprocessed : types_state -> unit Lwt.t + + (** The inner API of the mempool i.e. functions called by the worker + when an individual request arrives. These functions are the + most high-level ones that we test. All these [on_*] functions + correspond to a single event. Possible + sequences of calls to this API are always of the form: + + on_*; handle_unprocessed; on_*; handle_unprocessed; ... *) + module Requests : sig + val on_advertise : _ types_state_shell -> unit + + val on_arrived : + types_state -> + Operation_hash.t -> + Operation.t -> + (unit, Empty.t) result Lwt.t + + val on_ban : types_state -> Operation_hash.t -> unit tzresult Lwt.t + + val on_flush : + handle_branch_refused:bool -> + types_state -> + Store.Block.t -> + Block_hash.Set.t -> + Operation_hash.Set.t -> + unit tzresult Lwt.t + + val on_inject : + types_state -> force:bool -> Operation.t -> unit tzresult Lwt.t + + val on_notify : + _ types_state_shell -> P2p_peer_id.t -> Mempool.t -> unit Lwt.t + end +end + +(** A functor for obtaining the testable part of this file (see + the instantiation of this functor in {!Internal_for_tests} at the + end of this file). Contrary to the production-only functor {!Make} below, + this functor doesn't assume a specific chain store implementation, + which is the crux for having it easily unit-testable. *) +module Make_s + (Filter : Shell_plugin.FILTER) + (Prevalidation_t : Prevalidation.T + with type validation_state = + Filter.Proto.validation_state + and type protocol_operation = Filter.Proto.operation + and type operation_receipt = + Filter.Proto.operation_receipt) : + S + with type filter_state = Filter.Mempool.state + and type filter_config = Filter.Mempool.config + and type protocol_operation = Filter.Proto.operation + and type prevalidation_t = Prevalidation_t.t = struct + type filter_state = Filter.Mempool.state + + type filter_config = Filter.Mempool.config + + type protocol_operation = Filter.Proto.operation + + type prevalidation_t = Prevalidation_t.t + + type 'operation_data operation = 'operation_data Prevalidation.operation + + type types_state = { + shell : (protocol_operation, prevalidation_t) types_state_shell; + mutable filter_state : filter_state; + mutable validation_state : prevalidation_t tzresult; + mutable operation_stream : + (Classification.classification + * protocol_operation Prevalidation.operation) + Lwt_watcher.input; + mutable rpc_directory : types_state RPC_directory.t lazy_t; + mutable filter_config : filter_config; + lock : Lwt_mutex.t; + } + + (* This function is in [Lwt] only for logging. *) + let already_handled ~origin shell oph = + let open Lwt_syntax in + if Operation_hash.Set.mem oph shell.banned_operations then + let+ () = Events.(emit ban_operation_encountered) (origin, oph) in + true + else + Lwt.return + (Pending_ops.mem oph shell.pending + || Operation_hash.Set.mem oph shell.fetching + || Operation_hash.Set.mem oph shell.live_operations + || Classification.is_in_mempool oph shell.classification <> None + || Classification.is_known_unparsable oph shell.classification) + + let advertise (shell : ('operation_data, _) types_state_shell) mempool = + let open Lwt_syntax in + match shell.advertisement with + | `Pending {Mempool.known_valid; pending} -> + shell.advertisement <- + `Pending + { + known_valid = known_valid @ mempool.Mempool.known_valid; + pending = Operation_hash.Set.union pending mempool.pending; + } + | `None -> + shell.advertisement <- `Pending mempool ; + Lwt.dont_wait + (fun () -> + let* () = Lwt_unix.sleep advertisement_delay in + shell.worker.push_request_now Advertise ; + Lwt.return_unit) + (fun exc -> + Format.eprintf "Uncaught exception: %s\n%!" (Printexc.to_string exc)) + + (* Each classified operation should be notified exactly ONCE for a + given stream. Operations which cannot be parsed are not notified. *) + let handle_classification + ~(notifier : + Classification.classification -> + protocol_operation Prevalidation.operation -> + unit) shell (op, kind) = + Classification.add kind op shell.classification ; + notifier kind op + + let mk_notifier operation_stream classification op = + (* This callback is safe encapsulation-wise, because it depends + on an "harmless" field of [types_state_shell]: [operation_stream] *) + Lwt_watcher.notify operation_stream (classification, op) + + let pre_filter shell ~filter_config ~filter_state ~validation_state ~notifier + (parsed_op : protocol_operation operation) : + [Pending_ops.priority | `Drop] Lwt.t = + let open Lwt_syntax in + let validation_state_before = + Option.map + Prevalidation_t.validation_state + (Option.of_result validation_state) + in + let+ v = + Filter.Mempool.pre_filter + ~filter_state + ?validation_state_before + filter_config + parsed_op.protocol + in + match v with + | (`Branch_delayed _ | `Branch_refused _ | `Refused _ | `Outdated _) as errs + -> + handle_classification ~notifier shell (parsed_op, errs) ; + `Drop + | `Passed_prefilter priority -> (priority :> [Pending_ops.priority | `Drop]) + + let post_filter ~filter_config ~filter_state ~validation_state_before + ~validation_state_after op receipt = + Filter.Mempool.post_filter + filter_config + ~filter_state + ~validation_state_before + ~validation_state_after + (op, receipt) + + let set_mempool shell mempool = + shell.mempool <- mempool ; + shell.parameters.tools.set_mempool + ~head:(Store.Block.hash shell.predecessor) + shell.mempool + + let remove_from_advertisement oph = function + | `Pending mempool -> `Pending (Mempool.remove oph mempool) + | `None -> `None + + (* This function retrieves an old/replaced operation and reclassifies it as + [replacement_classification]. Note that we don't need to re-flush the + mempool, as this function is only called in precheck mode. + + The operation is expected to be (a) parsable and (b) in the "prechecked" + class. So, we softly handle the situations where the operation is + unparsable or not found in any class in case this invariant is broken + for some reason. + *) + let reclassify_replaced_manager_op old_hash shell + (replacement_classification : [< Classification.error_classification]) = + shell.advertisement <- + remove_from_advertisement old_hash shell.advertisement ; + match Classification.remove old_hash shell.classification with + | Some (op, _class) -> + [(op, (replacement_classification :> Classification.classification))] + | None -> + (* This case should not happen. *) + shell.parameters.tools.chain_tools.clear_or_cancel old_hash ; + [] + + let precheck ~disable_precheck ~filter_config ~filter_state + ~validation_state:prevalidation_t (op : protocol_operation operation) = + let open Lwt_syntax in + let validation_state = Prevalidation_t.validation_state prevalidation_t in + if disable_precheck then Lwt.return `Undecided + else + let+ v = + Filter.Mempool.precheck + filter_config + ~filter_state + ~validation_state + ~nb_successful_prechecks:op.count_successful_prechecks + op.hash + op.protocol + in + match v with + | `Passed_precheck (filter_state, validation_state, replacement) -> + (* The [precheck] optimization triggers: no need to call the + protocol [apply_operation]. *) + let prevalidation_t = + Prevalidation_t.set_validation_state + prevalidation_t + validation_state + in + let new_op = Prevalidation_t.increment_successful_precheck op in + `Passed_precheck (filter_state, prevalidation_t, new_op, replacement) + | (`Branch_delayed _ | `Branch_refused _ | `Refused _ | `Outdated _) as + errs -> + (* Note that we don't need to distinguish some failure cases + of [Filter.Mempool.precheck], hence grouping them under `Fail. *) + `Fail errs + | `Undecided -> + (* The caller will need to call the protocol's [apply_operation] + function. *) + `Undecided + + (* [classify_operation shell filter_config filter_state validation_state + mempool op oph] allows to determine the class of a given operation. + + Once it's parsed, the operation is prechecked and/or applied in the current + filter/validation state to determine if it could be included in a block on + top of the current head or not. If yes, the operation is accumulated in + the given [mempool]. + + The function returns a tuple + [(filter_state, validation_state, mempool, to_handle)], where: + - [filter_state] is the (possibly) updated filter_state, + - [validation_state] is the (possibly) updated validation_state, + - [mempool] is the (possibly) updated mempool, + - [to_handle] contains the given operation and its classification, and all + operations whose classes are changed/impacted by this classification + (eg. in case of operation replacement). + *) + let classify_operation shell ~filter_config ~filter_state ~validation_state + mempool op : + (filter_state + * prevalidation_t + * Mempool.t + * (protocol_operation operation * Classification.classification) trace) + Lwt.t = + let open Lwt_syntax in + let* v = + let* v = + precheck + ~disable_precheck:shell.parameters.limits.disable_precheck + ~filter_config + ~filter_state + ~validation_state + op + in + match v with + | `Fail errs -> + (* Precheck rejected the operation *) + Lwt.return_error errs + | `Passed_precheck (filter_state, validation_state, new_op, replacement) + -> + (* Precheck succeeded *) + let to_handle = + match replacement with + | `No_replace -> [(new_op, `Prechecked)] + | `Replace (old_oph, replacement_classification) -> + (* Precheck succeeded, but an old operation is replaced *) + let to_replace = + reclassify_replaced_manager_op + old_oph + shell + replacement_classification + in + (new_op, `Prechecked) :: to_replace + in + Lwt.return_ok (filter_state, validation_state, to_handle) + | `Undecided -> ( + (* Precheck was not able to classify *) + let* v = Prevalidation_t.apply_operation validation_state op in + match v with + | Applied (new_validation_state, receipt) -> ( + (* Apply succeeded, call post_filter *) + let* v = + post_filter + ~filter_config + ~filter_state + ~validation_state_before: + (Prevalidation_t.validation_state validation_state) + ~validation_state_after: + (Prevalidation_t.validation_state new_validation_state) + op.protocol + receipt + in + match v with + | `Passed_postfilter new_filter_state -> + (* Post_filter ok, accept operation *) + Lwt.return_ok + (new_filter_state, new_validation_state, [(op, `Applied)]) + | `Refused _ as op_class -> + (* Post_filter refused the operation *) + Lwt.return_error op_class) + (* Apply rejected the operation *) + | Branch_delayed e -> Lwt.return_error (`Branch_delayed e) + | Branch_refused e -> Lwt.return_error (`Branch_refused e) + | Refused e -> Lwt.return_error (`Refused e) + | Outdated e -> Lwt.return_error (`Outdated e)) + in + match v with + | Error err_class -> + Lwt.return (filter_state, validation_state, mempool, [(op, err_class)]) + | Ok (f_state, v_state, to_handle) -> + let mempool = Mempool.cons_valid op.hash mempool in + Lwt.return (f_state, v_state, mempool, to_handle) + + (* Classify pending operations into either: [Refused | + Branch_delayed | Branch_refused | Applied | Outdated]. + To ensure fairness with other worker requests, classification of + operations is done by batch of [operation_batch_size] operations. + + This function ensures the following invariants: + + - If an operation is classified, it is not part of the [pending] + map + + - A classified operation is part of the [in_mempool] set + + - A classified operation is part only of one of the following + classes: [Branch_refused, Branch_delayed, Refused, Applied] + + Moreover, this function ensures that only each newly classified + operations are advertised to the remote peers. However, if a peer + requests our mempool, we advertise all our classified operations and + all our pending operations. *) + let classify_pending_operations ~notifier shell filter_config filter_state + state = + let open Lwt_syntax in + let* r = + Pending_ops.fold_es + (fun _prio + oph + op + (acc_filter_state, acc_validation_state, acc_mempool, limit) -> + if limit <= 0 then + (* Using Error as an early-return mechanism *) + Lwt.return_error + (acc_filter_state, acc_validation_state, acc_mempool) + else ( + shell.pending <- Pending_ops.remove oph shell.pending ; + let+ new_filter_state, new_validation_state, new_mempool, to_handle + = + classify_operation + shell + ~filter_config + ~filter_state:acc_filter_state + ~validation_state:acc_validation_state + acc_mempool + op + in + List.iter (handle_classification ~notifier shell) to_handle ; + Ok (new_filter_state, new_validation_state, new_mempool, limit - 1))) + shell.pending + ( filter_state, + state, + Mempool.empty, + shell.parameters.limits.operations_batch_size ) + in + match r with + | Error (filter_state, state, advertised_mempool) -> + (* Early return after iteration limit was reached *) + let* (_was_pushed : bool) = + shell.worker.push_request Request.Leftover + in + Lwt.return (filter_state, state, advertised_mempool) + | Ok (filter_state, state, advertised_mempool, _) -> + Lwt.return (filter_state, state, advertised_mempool) + + let update_advertised_mempool_fields pv_shell delta_mempool = + let open Lwt_syntax in + if Mempool.is_empty delta_mempool then Lwt.return_unit + else + (* We only advertise newly classified operations. *) + let mempool_to_advertise = + Mempool. + {delta_mempool with known_valid = List.rev delta_mempool.known_valid} + in + advertise pv_shell mempool_to_advertise ; + let our_mempool = + let prechecked_hashes = + (* Outputs hashes in "decreasing" order which should not matter *) + Classification.Sized_map.fold + (fun x _ acc -> x :: acc) + pv_shell.classification.prechecked + [] + in + { + (* FIXME: https://gitlab.com/tezos/tezos/-/issues/2065 + This field does not only contain valid operation *) + Mempool.known_valid = + List.fold_left + (fun acc op -> op.Prevalidation.hash :: acc) + prechecked_hashes + pv_shell.classification.applied_rev; + pending = Pending_ops.hashes pv_shell.pending; + } + in + let* _res = set_mempool pv_shell our_mempool in + Lwt.pause () + + let handle_unprocessed pv = + let open Lwt_syntax in + let notifier = mk_notifier pv.operation_stream in + match pv.validation_state with + | Error err -> + (* At the time this comment was written (26/05/21), this is dead + code since [Proto.begin_construction] cannot fail. *) + Pending_ops.iter + (fun _prio _oph op -> + handle_classification ~notifier pv.shell (op, `Branch_delayed err)) + pv.shell.pending ; + pv.shell.pending <- Pending_ops.empty ; + Lwt.return_unit + | Ok state -> + if Pending_ops.is_empty pv.shell.pending then Lwt.return_unit + else + let* () = Events.(emit processing_operations) () in + let* filter_state, validation_state, delta_mempool = + classify_pending_operations + ~notifier + pv.shell + pv.filter_config + pv.filter_state + state + in + pv.filter_state <- filter_state ; + pv.validation_state <- Ok validation_state ; + update_advertised_mempool_fields pv.shell delta_mempool + + (* This function fetches one operation through the + [distributed_db]. On errors, we emit an event and proceed as + usual. *) + let fetch_operation (shell : ('operation_data, _) types_state_shell) ?peer oph + = + let open Lwt_syntax in + let+ () = Events.(emit fetching_operation) oph in + let* r = + shell.parameters.tools.fetch + ~timeout:shell.parameters.limits.operation_timeout + ?peer + oph + in + match r with + | Ok op -> + shell.worker.push_request_now (Arrived (oph, op)) ; + Lwt.return_unit + | Error (Distributed_db.Operation.Canceled _ :: _) -> + Events.(emit operation_included) oph + | Error _ -> + (* This may happen if the peer timed out for example. *) + Events.(emit operation_not_fetched) oph + + (* This function fetches an operation if it is not already handled + by the mempool. To ensure we fetch at most a given operation, + we record it in the [pv.fetching] field. + + Invariant: This function should be the only one to modify this + field. + + Invariant: To ensure, there is no leak, we ensure that when the + promise [p] is terminated, we remove the operation from the + fetching operations. This is to ensure that if an error + happened, we can still fetch this operation in the future. *) + let may_fetch_operation (shell : ('operation_data, _) types_state_shell) peer + oph = + let open Lwt_syntax in + let origin = + match peer with Some peer -> Events.Peer peer | None -> Leftover + in + let* already_handled = already_handled ~origin shell oph in + if not already_handled then + ignore + (Lwt.finalize + (fun () -> + shell.fetching <- Operation_hash.Set.add oph shell.fetching ; + fetch_operation shell ?peer oph) + (fun () -> + shell.fetching <- Operation_hash.Set.remove oph shell.fetching ; + Lwt.return_unit)) ; + Lwt.return_unit + + (** Module containing functions that are the internal transitions + of the mempool. These functions are called by the {!Worker} when + an event arrives. *) + module Requests = struct + let on_arrived (pv : types_state) oph op : (unit, Empty.t) result Lwt.t = + let open Lwt_syntax in + let* already_handled = + already_handled ~origin:Events.Arrived pv.shell oph + in + if already_handled then return_ok_unit + else + match Prevalidation_t.parse oph op with + | Error _ -> + let* () = Events.(emit unparsable_operation) oph in + Prevalidator_classification.add_unparsable + oph + pv.shell.classification ; + return_ok_unit + | Ok parsed_op -> ( + let* v = + pre_filter + pv.shell + ~filter_config:pv.filter_config + ~filter_state:pv.filter_state + ~validation_state:pv.validation_state + ~notifier:(mk_notifier pv.operation_stream) + parsed_op + in + match v with + | `Drop -> return_ok_unit + | (`High | `Medium | `Low _) as prio -> + if + not + (Block_hash.Set.mem + op.Operation.shell.branch + pv.shell.live_blocks) + then ( + pv.shell.parameters.tools.chain_tools.clear_or_cancel oph ; + return_ok_unit) + else ( + (* TODO: https://gitlab.com/tezos/tezos/-/issues/1723 + Should this have an influence on the peer's score ? *) + pv.shell.pending <- + Pending_ops.add parsed_op prio pv.shell.pending ; + return_ok_unit)) + + let on_inject (pv : types_state) ~force op = + let open Lwt_result_syntax in + let oph = Operation.hash op in + (* Currently, an injection is always done with the highest priority, because: + - We want to process and propagate the injected operations fast, + - We don't want to call prefilter to get the priority. + But, this may change in the future + *) + let prio = `High in + let*! already_handled = + already_handled ~origin:Events.Injected pv.shell oph + in + if already_handled then + (* FIXME: https://gitlab.com/tezos/tezos/-/issues/1722 + Is this an error? *) + return_unit + else + match Prevalidation_t.parse oph op with + | Error err -> + failwith + "Invalid operation %a: %a." + Operation_hash.pp + oph + Error_monad.pp_print_trace + err + | Ok parsed_op -> ( + if force then ( + let*! () = + pv.shell.parameters.tools.chain_tools.inject_operation oph op + in + pv.shell.pending <- + Pending_ops.add parsed_op prio pv.shell.pending ; + return_unit) + else if + not + (Block_hash.Set.mem + op.Operation.shell.branch + pv.shell.live_blocks) + then + failwith + "Operation %a is branched on a block %a which is too old" + Operation_hash.pp + oph + Block_hash.pp + op.Operation.shell.branch + else + let*? validation_state = + Result.bind_error pv.validation_state (fun err -> + error_with + "%s, in function [on_inject], the [validation_state] \ + contains the following error:@\n\ + %a" + __LOC__ + Error_monad.pp_print_top_error_of_trace + err) + in + let notifier = mk_notifier pv.operation_stream in + let*! filter_state, validation_state, delta_mempool, to_handle = + classify_operation + pv.shell + ~filter_config:pv.filter_config + ~filter_state:pv.filter_state + ~validation_state + Mempool.empty + parsed_op + in + let op_status = + (* to_handle contains the given operation and its classification, and + all operations whose classes are changed/impacted by this + classification (eg. in case of operation replacement). Here, we + retrieve the classification of our operation. *) + List.find_opt + (function + | ({hash; _} : protocol_operation operation), _ -> + Operation_hash.equal hash oph) + to_handle + in + match op_status with + | Some (_h, (`Applied | `Prechecked)) -> + (* TODO: https://gitlab.com/tezos/tezos/-/issues/2294 + In case of `Passed_precheck_with_replace, we may want to only do + the injection/replacement if a flag `replace` is set to true + in the injection query. *) + let*! () = + pv.shell.parameters.tools.chain_tools.inject_operation + oph + op + in + (* Call handle & update_advertised_mempool only if op is accepted *) + List.iter (handle_classification ~notifier pv.shell) to_handle ; + pv.filter_state <- filter_state ; + pv.validation_state <- Ok validation_state ; + (* Note that in this case, we may advertise an operation and bypass + the prioritirization strategy. *) + let*! v = + update_advertised_mempool_fields pv.shell delta_mempool + in + return v + | Some + ( _h, + ( `Branch_delayed e + | `Branch_refused e + | `Refused e + | `Outdated e ) ) -> + Lwt.return + @@ error_with + "Error while applying operation %a:@ %a" + Operation_hash.pp + oph + pp_print_trace + e + | None -> + (* This case should not happen *) + failwith + "Unexpected error while injecting operation %a. Operation \ + not found after classifying it." + Operation_hash.pp + oph) + + let on_notify (shell : ('operation_data, _) types_state_shell) peer mempool + = + let open Lwt_syntax in + let may_fetch_operation = may_fetch_operation shell (Some peer) in + let* () = List.iter_s may_fetch_operation mempool.Mempool.known_valid in + Seq.iter_s + may_fetch_operation + (Operation_hash.Set.to_seq mempool.Mempool.pending) + + let on_flush ~handle_branch_refused pv new_predecessor new_live_blocks + new_live_operations = + let open Lwt_result_syntax in + let old_predecessor = pv.shell.predecessor in + pv.shell.predecessor <- new_predecessor ; + pv.shell.live_blocks <- new_live_blocks ; + pv.shell.live_operations <- new_live_operations ; + Lwt_watcher.shutdown_input pv.operation_stream ; + pv.operation_stream <- Lwt_watcher.create_input () ; + let timestamp_system = Tezos_base.Time.System.now () in + pv.shell.timestamp <- timestamp_system ; + let timestamp = Time.System.to_protocol timestamp_system in + let*! validation_state = + pv.shell.parameters.tools.create + ~predecessor:new_predecessor + ~live_operations:new_live_operations + ~timestamp + () + in + pv.validation_state <- validation_state ; + let* filter_state = + Filter.Mempool.on_flush + pv.filter_config + pv.filter_state + ?validation_state: + (Option.map + Prevalidation_t.validation_state + (Option.of_result validation_state)) + ~predecessor:(Store.Block.header new_predecessor) + () + in + pv.filter_state <- filter_state ; + let*! new_pending_operations = + Classification.recycle_operations + ~from_branch:old_predecessor + ~to_branch:new_predecessor + ~live_blocks:new_live_blocks + ~parse:(fun oph op -> Result.to_option (Prevalidation_t.parse oph op)) + ~classes:pv.shell.classification + ~pending:(Pending_ops.operations pv.shell.pending) + ~block_store:block_tools + ~chain:pv.shell.parameters.tools.chain_tools + ~handle_branch_refused + in + (* Could be implemented as Operation_hash.Map.filter_s which + does not exist for the moment. *) + let*! new_pending_operations, nb_pending = + Operation_hash.Map.fold_s + (fun _oph op (pending, nb_pending) -> + let*! v = + pre_filter + pv.shell + ~filter_config:pv.filter_config + ~filter_state:pv.filter_state + ~validation_state:pv.validation_state + ~notifier:(mk_notifier pv.operation_stream) + op + in + match v with + | `Drop -> Lwt.return (pending, nb_pending) + | (`High | `Medium | `Low _) as prio -> + (* Here, an operation injected in this node with `High priority will + now get its approriate priority. *) + Lwt.return (Pending_ops.add op prio pending, nb_pending + 1)) + new_pending_operations + (Pending_ops.empty, 0) + in + let*! () = Events.(emit operations_to_reclassify) nb_pending in + pv.shell.pending <- new_pending_operations ; + set_mempool pv.shell Mempool.empty + + let on_advertise (shell : ('protocol_data, _) types_state_shell) = + match shell.advertisement with + | `None -> + () (* May happen if nothing to advertise since last advertisement. *) + | `Pending mempool -> + shell.advertisement <- `None ; + (* In this case, mempool is not empty, but let's avoid advertising + empty mempools in case this invariant is broken. *) + if not (Mempool.is_empty mempool) then + shell.parameters.tools.advertise_current_head + ~mempool + shell.predecessor + + (* If [flush_if_prechecked] is [true], removing a prechecked + operation triggers a flush of the mempool. Because flushing may + be costly this should be done only when the action is triggered + locally by the user. This allows a better UX if the user bans a + prechecked operation so that a branch delayed operation becomes + [applied] again. *) + let remove ~flush_if_prechecked pv oph = + let open Lwt_result_syntax in + pv.shell.parameters.tools.chain_tools.clear_or_cancel oph ; + pv.shell.advertisement <- + remove_from_advertisement oph pv.shell.advertisement ; + pv.shell.banned_operations <- + Operation_hash.Set.add oph pv.shell.banned_operations ; + match Classification.remove oph pv.shell.classification with + | None -> + pv.shell.pending <- Pending_ops.remove oph pv.shell.pending ; + pv.shell.fetching <- Operation_hash.Set.remove oph pv.shell.fetching ; + return_unit + | Some (_op, classification) -> ( + match (classification, flush_if_prechecked) with + | `Prechecked, true | `Applied, _ -> + (* Modifying the list of operations classified as [Applied] + might change the classification of all the operations in + the mempool. Hence if the removed operation has been + applied we flush the mempool to force the + reclassification of all the operations except the one + removed. *) + let+ () = + on_flush + ~handle_branch_refused:false + pv + pv.shell.predecessor + pv.shell.live_blocks + pv.shell.live_operations + in + pv.shell.pending <- Pending_ops.remove oph pv.shell.pending + | `Branch_delayed _, _ + | `Branch_refused _, _ + | `Refused _, _ + | `Outdated _, _ + | `Prechecked, false -> + pv.filter_state <- + Filter.Mempool.remove ~filter_state:pv.filter_state oph ; + return_unit) + + let on_ban pv oph_to_ban = + pv.shell.banned_operations <- + Operation_hash.Set.add oph_to_ban pv.shell.banned_operations ; + remove ~flush_if_prechecked:true pv oph_to_ban + end +end + +module type ARG = sig + val limits : Shell_limits.prevalidator_limits + + val chain_db : Distributed_db.chain_db + + val chain_id : Chain_id.t +end + +module WorkerGroup = Worker.MakeGroup (Name) (Prevalidator_worker_state.Request) + +(** The functor that is not tested, in other words used only in production. + This functor's code is not tested (contrary to functor {!Make_s} above), + because it hardcodes a dependency to [Store.chain_store] in its instantiation + of type [chain_store]. This is what makes the code of this functor + not testable for the moment, because [Store.chain_store] has poor + testing capabilities. + + Note that, because this functor [include]s {!Make_s}, it is a + strict extension of [Make_s]. *) +module Make + (Filter : Shell_plugin.FILTER) + (Arg : ARG) + (Prevalidation_t : Prevalidation.T + with type validation_state = + Filter.Proto.validation_state + and type protocol_operation = Filter.Proto.operation + and type operation_receipt = + Filter.Proto.operation_receipt + and type chain_store = Store.chain_store) : T = struct + module S = Make_s (Filter) (Prevalidation_t) + open S + + type types_state = S.types_state + + let get_rpc_directory pv = pv.rpc_directory + + let name = (Arg.chain_id, Filter.Proto.hash) + + module Types = struct + type state = types_state + + type parameters = Shell_limits.prevalidator_limits * Distributed_db.chain_db + end + + module Worker : + Worker.T + with type Name.t = Name.t + and type ('a, 'b) Request.t = ('a, 'b) Request.t + and type Request.view = Request.view + and type Types.state = Types.state + and type Types.parameters = Types.parameters = + WorkerGroup.MakeWorker (Types) + + open Types + + type worker = Worker.infinite Worker.queue Worker.t + + (** Returns a json describing the prevalidator's [filter_config]. + The boolean [include_default] ([true] by default) indicates + whether the json should include the fields which have a value + equal to their default value. *) + let get_filter_config_json ?(include_default = true) pv = + let include_default_fields = if include_default then `Always else `Never in + Data_encoding.Json.construct + ~include_default_fields + Filter.Mempool.config_encoding + pv.filter_config + + let build_rpc_directory w = + lazy + (let open Lwt_result_syntax in + let dir : state RPC_directory.t ref = ref RPC_directory.empty in + let module Proto_services = + Block_services.Make (Filter.Proto) (Filter.Proto) + in + dir := + RPC_directory.register + !dir + (Proto_services.S.Mempool.get_filter RPC_path.open_root) + (fun pv params () -> + return + (get_filter_config_json + ~include_default:params#include_default + pv)) ; + dir := + RPC_directory.register + !dir + (Proto_services.S.Mempool.set_filter RPC_path.open_root) + (fun pv () obj -> + let open Lwt_syntax in + let* () = + try + let config = + Data_encoding.Json.destruct Filter.Mempool.config_encoding obj + in + pv.filter_config <- config ; + Lwt.return_unit + with _ -> Events.(emit invalid_mempool_filter_configuration) () + in + return_ok (get_filter_config_json pv)) ; + (* Ban an operation (from its given hash): remove it from the + mempool if present. Add it to the set pv.banned_operations + to prevent it from being fetched/processed/injected in the + future. + Note: If the baker has already received the operation, then + it's necessary to restart it manually to flush the operation + from it. *) + dir := + RPC_directory.register + !dir + (Proto_services.S.Mempool.ban_operation RPC_path.open_root) + (fun _pv () oph -> + let open Lwt_result_syntax in + let*! r = Worker.Queue.push_request_and_wait w (Request.Ban oph) in + match r with + | Error (Closed None) -> fail [Worker_types.Terminated] + | Error (Closed (Some errs)) -> fail errs + | Error (Request_error err) -> fail err + | Error (Any exn) -> fail [Exn exn] + | Ok () -> return_unit) ; + (* Unban an operation (from its given hash): remove it from the + set pv.banned_operations (nothing happens if it was not banned). *) + dir := + RPC_directory.register + !dir + (Proto_services.S.Mempool.unban_operation RPC_path.open_root) + (fun pv () oph -> + pv.shell.banned_operations <- + Operation_hash.Set.remove oph pv.shell.banned_operations ; + return_unit) ; + (* Unban all operations: clear the set pv.banned_operations. *) + dir := + RPC_directory.register + !dir + (Proto_services.S.Mempool.unban_all_operations RPC_path.open_root) + (fun pv () () -> + pv.shell.banned_operations <- Operation_hash.Set.empty ; + return_unit) ; + dir := + RPC_directory.gen_register + !dir + (Proto_services.S.Mempool.pending_operations RPC_path.open_root) + (fun pv params () -> + let map_op_error oph (op, error) acc = + op.Prevalidation.protocol |> fun res -> + Operation_hash.Map.add oph (res, error) acc + in + let applied = + if params#applied then + List.rev_map + (fun op -> (op.Prevalidation.hash, op.Prevalidation.protocol)) + pv.shell.classification.applied_rev + else [] + in + let filter f map = + Operation_hash.Map.fold f map Operation_hash.Map.empty + in + let refused = + if params#refused then + filter + map_op_error + (Classification.map pv.shell.classification.refused) + else Operation_hash.Map.empty + in + let outdated = + if params#outdated then + filter + map_op_error + (Classification.map pv.shell.classification.outdated) + else Operation_hash.Map.empty + in + let branch_refused = + if params#branch_refused then + filter + map_op_error + (Classification.map pv.shell.classification.branch_refused) + else Operation_hash.Map.empty + in + let branch_delayed = + if params#branch_delayed then + filter + map_op_error + (Classification.map pv.shell.classification.branch_delayed) + else Operation_hash.Map.empty + in + let unprocessed = + Pending_ops.fold + (fun _prio oph op acc -> + Operation_hash.Map.add oph op.protocol acc) + pv.shell.pending + Operation_hash.Map.empty + in + (* FIXME https://gitlab.com/tezos/tezos/-/issues/2250 + + We merge prechecked operation with applied operation + so that the encoding of the RPC does not need to be + changed. Once prechecking will be done by the protocol + and not the plugin, we will change the encoding to + reflect that. *) + let prechecked_with_applied = + if params#applied then + Classification.Sized_map.fold + (fun oph op acc -> (oph, op.Prevalidation.protocol) :: acc) + pv.shell.classification.prechecked + applied + else applied + in + let pending_operations = + { + Proto_services.Mempool.applied = prechecked_with_applied; + refused; + outdated; + branch_refused; + branch_delayed; + unprocessed; + } + in + Proto_services.Mempool.pending_operations_version_dispatcher + ~version:params#version + pending_operations) ; + dir := + RPC_directory.register + !dir + (Proto_services.S.Mempool.request_operations RPC_path.open_root) + (fun pv t () -> + pv.shell.parameters.tools.send_get_current_head ?peer:t#peer_id () ; + return_unit) ; + dir := + RPC_directory.gen_register + !dir + (Proto_services.S.Mempool.monitor_operations RPC_path.open_root) + (fun pv params () -> + Lwt_mutex.with_lock pv.lock @@ fun () -> + let op_stream, stopper = + Lwt_watcher.create_stream pv.operation_stream + in + (* Convert ops *) + let fold_op hash (Prevalidation.{protocol; _}, error) acc = + (hash, protocol, error) :: acc + in + (* First call : retrieve the current set of op from the mempool *) + let applied = + if params#applied then + List.map + (fun op -> (op.Prevalidation.hash, op.protocol, [])) + pv.shell.classification.applied_rev + else [] + in + (* FIXME https://gitlab.com/tezos/tezos/-/issues/2250 + + For the moment, applied and prechecked operations are + handled the same way for the user point of view. *) + let prechecked = + if params#applied then + Classification.Sized_map.fold + (fun hash op acc -> + (hash, op.Prevalidation.protocol, []) :: acc) + pv.shell.classification.prechecked + [] + else [] + in + let refused = + if params#refused then + Operation_hash.Map.fold + fold_op + (Classification.map pv.shell.classification.refused) + [] + else [] + in + let branch_refused = + if params#branch_refused then + Operation_hash.Map.fold + fold_op + (Classification.map pv.shell.classification.branch_refused) + [] + else [] + in + let branch_delayed = + if params#branch_delayed then + Operation_hash.Map.fold + fold_op + (Classification.map pv.shell.classification.branch_delayed) + [] + else [] + in + let outdated = + if params#outdated then + Operation_hash.Map.fold + fold_op + (Classification.map pv.shell.classification.outdated) + [] + else [] + in + let current_mempool = + List.concat_map + (List.map (function + | hash, op, [] -> ((hash, op), None) + | hash, op, errors -> ((hash, op), Some errors))) + [ + applied; + prechecked; + refused; + branch_refused; + branch_delayed; + outdated; + ] + in + let current_mempool = ref (Some current_mempool) in + let filter_result = function + | `Prechecked | `Applied -> params#applied + | `Refused _ -> params#refused + | `Outdated _ -> params#outdated + | `Branch_refused _ -> params#branch_refused + | `Branch_delayed _ -> params#branch_delayed + in + let rec next () = + let open Lwt_syntax in + match !current_mempool with + | Some mempool -> + current_mempool := None ; + Lwt.return_some mempool + | None -> ( + let* o = Lwt_stream.get op_stream in + match o with + | Some (kind, op) when filter_result kind -> + let errors = + match kind with + | `Prechecked | `Applied -> None + | `Branch_delayed errors + | `Branch_refused errors + | `Refused errors + | `Outdated errors -> + Some errors + in + Lwt.return_some + [(Prevalidation.(op.hash, op.protocol), errors)] + | Some _ -> next () + | None -> Lwt.return_none) + in + let shutdown () = Lwt_watcher.shutdown stopper in + RPC_answer.return_stream {next; shutdown}) ; + !dir) + + (** Module implementing the events at the {!Worker} level. Contrary + to {!Requests}, these functions depend on [Worker]. *) + module Handlers = struct + type self = worker + + let on_request : + type r request_error. + worker -> + (r, request_error) Request.t -> + (r, request_error) result Lwt.t = + fun w request -> + let open Lwt_result_syntax in + Prometheus.Counter.inc_one metrics.worker_counters.worker_request_count ; + let pv = Worker.state w in + let post_processing : + (r, request_error) result Lwt.t -> (r, request_error) result Lwt.t = + fun r -> + let open Lwt_syntax in + let* () = handle_unprocessed pv in + r + in + post_processing + @@ + match request with + | Request.Flush (hash, event, live_blocks, live_operations) -> + Requests.on_advertise pv.shell ; + (* TODO: https://gitlab.com/tezos/tezos/-/issues/1727 + Rebase the advertisement instead. *) + let* block = pv.shell.parameters.tools.read_block hash in + let handle_branch_refused = + Chain_validator_worker_state.( + match event with + | Head_increment | Ignored_head -> false + | Branch_switch -> true) + in + Lwt_mutex.with_lock pv.lock + @@ fun () : (r, error trace) result Lwt.t -> + Requests.on_flush + ~handle_branch_refused + pv + block + live_blocks + live_operations + | Request.Notify (peer, mempool) -> + let*! () = Requests.on_notify pv.shell peer mempool in + return_unit + | Request.Leftover -> + (* unprocessed ops are handled just below *) + return_unit + | Request.Inject {op; force} -> Requests.on_inject pv ~force op + | Request.Arrived (oph, op) -> Requests.on_arrived pv oph op + | Request.Advertise -> + Requests.on_advertise pv.shell ; + return_unit + | Request.Ban oph -> Requests.on_ban pv oph + + let on_close w = + let pv = Worker.state w in + Operation_hash.Set.iter + pv.shell.parameters.tools.chain_tools.clear_or_cancel + pv.shell.fetching ; + Lwt.return_unit + + let mk_tools (chain_db : Distributed_db.chain_db) : + prevalidation_t Tools.tools = + let advertise_current_head ~mempool bh = + Distributed_db.Advertise.current_head chain_db ~mempool bh + in + let chain_tools = mk_chain_tools chain_db in + let create ~predecessor ~live_operations ~timestamp = + let chain_store = Distributed_db.chain_store chain_db in + Prevalidation_t.create + chain_store + ~predecessor + ~live_operations + ~timestamp + in + let fetch ?peer ?timeout oph = + Distributed_db.Operation.fetch chain_db ?timeout ?peer oph () + in + let read_block bh = + let chain_store = Distributed_db.chain_store chain_db in + Store.Block.read_block chain_store bh + in + let send_get_current_head ?peer () = + Distributed_db.Request.current_head chain_db ?peer () + in + let set_mempool ~head mempool = + let chain_store = Distributed_db.chain_store chain_db in + Store.Chain.set_mempool chain_store ~head mempool + in + { + advertise_current_head; + chain_tools; + create; + fetch; + read_block; + send_get_current_head; + set_mempool; + } + + let mk_worker_tools w : Tools.worker_tools = + let push_request r = Worker.Queue.push_request w r in + let push_request_now r = Worker.Queue.push_request_now w r in + {push_request; push_request_now} + + type launch_error = error trace + + let on_launch w _ (limits, chain_db) : (state, launch_error) result Lwt.t = + let open Lwt_result_syntax in + let chain_store = Distributed_db.chain_store chain_db in + let*! predecessor = Store.Chain.current_head chain_store in + let predecessor_header = Store.Block.header predecessor in + let*! mempool = Store.Chain.mempool chain_store in + let*! live_blocks, live_operations = + Store.Chain.live_blocks chain_store + in + let timestamp_system = Tezos_base.Time.System.now () in + let timestamp = Time.System.to_protocol timestamp_system in + let*! validation_state = + Prevalidation_t.create + chain_store + ~predecessor + ~timestamp + ~live_operations + () + in + let fetching = + List.fold_left + (fun s h -> Operation_hash.Set.add h s) + Operation_hash.Set.empty + mempool.known_valid + in + let classification_parameters = + Classification. + { + map_size_limit = limits.Shell_limits.max_refused_operations; + on_discarded_operation = + Distributed_db.Operation.clear_or_cancel chain_db; + } + in + let classification = Classification.create classification_parameters in + let parameters = {limits; tools = mk_tools chain_db} in + let shell = + { + classification; + parameters; + predecessor; + timestamp = timestamp_system; + live_blocks; + live_operations; + mempool = Mempool.empty; + fetching; + pending = Pending_ops.empty; + advertisement = `None; + banned_operations = Operation_hash.Set.empty; + worker = mk_worker_tools w; + } + in + Shell_metrics.Mempool.set_applied_collector (fun () -> + List.length shell.classification.applied_rev |> float_of_int) ; + Shell_metrics.Mempool.set_prechecked_collector (fun () -> + Prevalidator_classification.Sized_map.cardinal + shell.classification.prechecked + |> float_of_int) ; + Shell_metrics.Mempool.set_refused_collector (fun () -> + Prevalidator_classification.cardinal shell.classification.refused + |> float_of_int) ; + Shell_metrics.Mempool.set_branch_refused_collector (fun () -> + Prevalidator_classification.cardinal + shell.classification.branch_refused + |> float_of_int) ; + Shell_metrics.Mempool.set_branch_delayed_collector (fun () -> + Prevalidator_classification.cardinal + shell.classification.branch_delayed + |> float_of_int) ; + Shell_metrics.Mempool.set_outdated_collector (fun () -> + Prevalidator_classification.cardinal shell.classification.outdated + |> float_of_int) ; + Shell_metrics.Mempool.set_unprocessed_collector (fun () -> + Prevalidator_pending_operations.cardinal shell.pending |> float_of_int) ; + + let* filter_state = + Filter.Mempool.init + Filter.Mempool.default_config + ?validation_state: + (Option.map + Prevalidation_t.validation_state + (Option.of_result validation_state)) + ~predecessor:predecessor_header + () + in + let pv = + { + shell; + validation_state; + filter_state; + operation_stream = Lwt_watcher.create_input (); + rpc_directory = build_rpc_directory w; + filter_config = + (* TODO: https://gitlab.com/tezos/tezos/-/issues/1725 + initialize from config file *) + Filter.Mempool.default_config; + lock = Lwt_mutex.create (); + } + in + let*! () = + Seq.iter_s + (may_fetch_operation pv.shell None) + (Operation_hash.Set.to_seq fetching) + in + return pv + + let on_error (type a b) _w st (request : (a, b) Request.t) (errs : b) : + unit tzresult Lwt.t = + Prometheus.Counter.inc_one metrics.worker_counters.worker_error_count ; + let open Lwt_syntax in + match request with + | Request.(Inject _) as r -> + let* () = Events.(emit request_failed) (Request.view r, st, errs) in + return_ok_unit + | Request.Notify _ -> ( match errs with _ -> .) + | Request.Leftover -> ( match errs with _ -> .) + | Request.Arrived _ -> ( match errs with _ -> .) + | Request.Advertise -> ( match errs with _ -> .) + | Request.Flush _ -> + let request_view = Request.view request in + let* () = Events.(emit request_failed) (request_view, st, errs) in + Lwt.return_error errs + | Request.Ban _ -> + let request_view = Request.view request in + let* () = Events.(emit request_failed) (request_view, st, errs) in + Lwt.return_error errs + + let on_completion _w r _ st = + Prometheus.Counter.inc_one metrics.worker_counters.worker_completion_count ; + match Request.view r with + | Request.View (Flush _) | View (Inject _) | View (Ban _) -> + Events.(emit request_completed_notice) (Request.view r, st) + | View (Notify _) | View Leftover | View (Arrived _) | View Advertise -> + Events.(emit request_completed_debug) (Request.view r, st) + + let on_no_request _ = Lwt.return_unit + end + + let table = Worker.create_table Queue + + (* NOTE: we register a single worker for each instantiation of this Make + * functor (and thus a single worker for the single instantiation of Worker). + * Whilst this is somewhat abusing the intended purpose of worker, it is part + * of a transition plan to a one-worker-per-peer architecture. *) + let worker_promise = + Worker.launch table name (Arg.limits, Arg.chain_db) (module Handlers) + + let worker = + lazy + (match Lwt.state worker_promise with + | Lwt.Return (Ok worker) -> worker + | Lwt.Return (Error _) | Lwt.Fail _ | Lwt.Sleep -> assert false) +end + +let make limits chain_db chain_id (module Filter : Shell_plugin.FILTER) : t = + let module Prevalidation_t = Prevalidation.Make (Filter.Proto) in + let module Prevalidator = + Make + (Filter) + (struct + let limits = limits + + let chain_db = chain_db + + let chain_id = chain_id + end) + (Prevalidation_t) + in + (module Prevalidator : T) + +module Internal_for_tests = struct + include Tools + + type nonrec ('a, 'b) types_state_shell = ('a, 'b) types_state_shell + + let mk_types_state_shell ~(predecessor : Store.Block.t) ~(tools : 'a tools) + ~(worker : worker_tools) : (_, 'a) types_state_shell = + let parameters = + {limits = Shell_limits.default_prevalidator_limits; tools} + in + let c_parameters : Classification.parameters = + {map_size_limit = 32; on_discarded_operation = Fun.const ()} + in + let advertisement = `None in + let banned_operations = Operation_hash.Set.empty in + let classification = Classification.create c_parameters in + let fetching = Operation_hash.Set.empty in + let mempool = Mempool.empty in + let live_blocks = Block_hash.Set.empty in + let live_operations = Operation_hash.Set.empty in + let pending = Pending_ops.empty in + let timestamp = Tezos_base.Time.System.now () in + { + advertisement; + banned_operations; + classification; + fetching; + live_blocks; + live_operations; + mempool; + parameters; + pending; + predecessor; + timestamp; + worker; + } + + module Make + (Filter : Shell_plugin.FILTER) + (Prevalidation_t : Prevalidation.T + with type validation_state = + Filter.Proto.validation_state + and type protocol_operation = Filter.Proto.operation + and type operation_receipt = + Filter.Proto.operation_receipt) = + struct + module Internal = Make_s (Filter) (Prevalidation_t) + + type nonrec types_state = Internal.types_state + + let mk_types_state + ~(shell : + ( Prevalidation_t.protocol_operation, + Prevalidation_t.t ) + types_state_shell) ~(validation_state : Prevalidation_t.t) : + types_state Lwt.t = + let open Lwt_syntax in + let filter_config = Filter.Mempool.default_config in + let predecessor = Store.Block.header shell.predecessor in + let* r = Filter.Mempool.init filter_config ~predecessor () in + match r with + | Error err -> + let err_string = + Format.asprintf "%a" Error_monad.pp_print_trace err + in + let* () = Lwt_io.eprintf "%s" err_string in + assert false + | Ok filter_state -> + Lwt.return + Internal. + { + shell; + filter_config; + filter_state; + lock = Lwt_mutex.create (); + operation_stream = Lwt_watcher.create_input (); + rpc_directory = Lazy.from_fun (fun () -> assert false); + validation_state = Ok validation_state; + } + + let to_shell (t : types_state) = t.shell + + let handle_unprocessed = Internal.handle_unprocessed + + module Requests = Internal.Requests + end +end diff --git a/src/lib_shell/prevalidator_internal.mli b/src/lib_shell/prevalidator_internal.mli new file mode 100644 index 0000000000000000000000000000000000000000..f9153f2374736d83e95bd73c14af226503e546fe --- /dev/null +++ b/src/lib_shell/prevalidator_internal.mli @@ -0,0 +1,150 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2018-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. *) +(* *) +(*****************************************************************************) + +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the implementation of the new mempool, which + uses features of the protocol that only exist since Lima. + + When you modify this file, consider whether you should also change + the files that implement the legacy mempool for Kathmandu. They all + start with the "legacy" prefix and will be removed when Lima is + activated on Mainnet. *) + +(** Create a prevalidator instance for a specific protocol + ([Filter.Proto] where [module Filter : Shell_plugin.FILTER]). + + The protocol must be Lima (environment V7) or a more recent + version. For Kathmandu and older protocols, use + {!Legacy_prevalidator_internal.make} instead. + + This function is wrapped in {!Prevalidator.create}. *) +val make : + Shell_limits.prevalidator_limits -> + Distributed_db.chain_db -> + Chain_id.t -> + (module Shell_plugin.FILTER) -> + Prevalidator_internal_common.t + +(**/**) + +module Internal_for_tests : sig + (** Documented in the ml file, because this is only exported for tests. *) + type 'prevalidation_t tools = { + advertise_current_head : mempool:Mempool.t -> Store.Block.t -> unit; + chain_tools : Store.Block.t Prevalidator_classification.chain_tools; + create : + predecessor:Store.Block.t -> + live_operations:Operation_hash.Set.t -> + timestamp:Time.Protocol.t -> + unit -> + 'prevalidation_t tzresult Lwt.t; + fetch : + ?peer:P2p_peer.Id.t -> + ?timeout:Time.System.Span.t -> + Operation_hash.t -> + Operation.t tzresult Lwt.t; + read_block : Block_hash.t -> Store.Block.t tzresult Lwt.t; + send_get_current_head : ?peer:P2p_peer_id.t -> unit -> unit; + set_mempool : head:Block_hash.t -> Mempool.t -> unit tzresult Lwt.t; + } + + (** Documented in the ml file, because this is only exported for tests. *) + type worker_tools = { + push_request : + (unit, Empty.t) Prevalidator_worker_state.Request.t -> bool Lwt.t; + push_request_now : + (unit, Empty.t) Prevalidator_worker_state.Request.t -> unit; + } + + (** The corresponding internal type of the mempool (see {!Prevalidator.S}), + that is independent from the protocol. *) + type ('a, 'b) types_state_shell + + (** Create a pristine value of {!type_state_shell} *) + val mk_types_state_shell : + predecessor:Store.Block.t -> + tools:'prevalidation_t tools -> + worker:worker_tools -> + ('protocol_data, 'prevalidation_t) types_state_shell + + module Make + (Filter : Shell_plugin.FILTER) + (Prevalidation_t : Prevalidation.T + with type validation_state = + Filter.Proto.validation_state + and type protocol_operation = Filter.Proto.operation + and type operation_receipt = + Filter.Proto.operation_receipt) : sig + (** The corresponding internal type of the mempool (see {!Prevalidator.S}), + that depends on the protocol *) + type types_state + + (** Create a pristine value of {!type_state} *) + val mk_types_state : + shell: + ( Prevalidation_t.protocol_operation, + Prevalidation_t.t ) + types_state_shell -> + validation_state:Prevalidation_t.t -> + types_state Lwt.t + + (** [to_shell pv] returns the shell part of [pv] *) + val to_shell : + types_state -> + (Prevalidation_t.protocol_operation, Prevalidation_t.t) types_state_shell + + (** Documented in the ml file. *) + val handle_unprocessed : types_state -> unit Lwt.t + + (** Documented in the ml file (as are all the functions of this module) *) + module Requests : sig + val on_advertise : _ types_state_shell -> unit + + val on_arrived : + types_state -> + Operation_hash.t -> + Operation.t -> + (unit, Empty.t) result Lwt.t + + val on_ban : types_state -> Operation_hash.t -> unit tzresult Lwt.t + + val on_flush : + handle_branch_refused:bool -> + types_state -> + Store.Block.t -> + Block_hash.Set.t -> + Operation_hash.Set.t -> + unit tzresult Lwt.t + + val on_inject : + types_state -> force:bool -> Operation.t -> unit tzresult Lwt.t + + val on_notify : + _ types_state_shell -> P2p_peer_id.t -> Mempool.t -> unit Lwt.t + end + end +end diff --git a/src/lib_shell/prevalidator_internal_common.ml b/src/lib_shell/prevalidator_internal_common.ml new file mode 100644 index 0000000000000000000000000000000000000000..9a94db3fe99d2a35a369f55e9a55b9052f20ce08 --- /dev/null +++ b/src/lib_shell/prevalidator_internal_common.ml @@ -0,0 +1,71 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2018-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. *) +(* *) +(*****************************************************************************) + +let advertisement_delay = 0.1 + +module Name = struct + type t = Chain_id.t * Protocol_hash.t + + let encoding = Data_encoding.tup2 Chain_id.encoding Protocol_hash.encoding + + let base = ["prevalidator"] + + let pp fmt (chain_id, proto_hash) = + Format.fprintf + fmt + "%a:%a" + Chain_id.pp_short + chain_id + Protocol_hash.pp_short + proto_hash + + let equal (c1, p1) (c2, p2) = + Chain_id.equal c1 c2 && Protocol_hash.equal p1 p2 +end + +open Prevalidator_worker_state + +module type T = sig + type types_state + + val get_rpc_directory : types_state -> types_state RPC_directory.t lazy_t + + val name : Name.t + + module Types : Worker_intf.TYPES with type state = types_state + + module Worker : + Worker.T + with type ('a, 'b) Request.t = ('a, 'b) Request.t + and type Request.view = Request.view + and type Types.state = types_state + + type worker = Worker.infinite Worker.queue Worker.t + + val worker : worker Lazy.t +end + +type t = (module T) diff --git a/src/lib_shell/prevalidator_internal_common.mli b/src/lib_shell/prevalidator_internal_common.mli new file mode 100644 index 0000000000000000000000000000000000000000..e3eae2e19c16665e6e7db01ba7707c44a2a855ed --- /dev/null +++ b/src/lib_shell/prevalidator_internal_common.mli @@ -0,0 +1,67 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* Copyright (c) 2018-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. *) +(* *) +(*****************************************************************************) + +(** Common elements used by both {!Prevalidator_internal} and + {!Legacy_prevalidator_internal}. This module is also included in + {!Prevalidator}. *) + +(** Minimal delay between two mempool advertisements *) +val advertisement_delay : float + +(** Argument that will be provided to {!Worker.MakeGroup} to create + the prevalidator worker. *) +module Name : + Tezos_base.Worker_intf.NAME with type t = Chain_id.t * Protocol_hash.t + +open Prevalidator_worker_state + +(** A prevalidator instance, tailored to a specific protocol (even if + it is not visible in this module type. + + The creation of such prevalidator instances is implemented in + {!Prevalidator_internal} and wrapped in {!Prevalidator.create}. *) +module type T = sig + type types_state + + val get_rpc_directory : types_state -> types_state RPC_directory.t lazy_t + + val name : Name.t + + module Types : Worker_intf.TYPES with type state = types_state + + module Worker : + Worker.T + with type ('a, 'b) Request.t = ('a, 'b) Request.t + and type Request.view = Request.view + and type Types.state = types_state + + type worker = Worker.infinite Worker.queue Worker.t + + val worker : worker Lazy.t +end + +(** Documented in {!Prevalidator}. *) +type t = (module T) diff --git a/src/lib_shell/prevalidator_pending_operations.ml b/src/lib_shell/prevalidator_pending_operations.ml index bf3dc5827f907bed38f980068b3e6c2039407531..1ef2b9deba69e86e8080ca97d072f3700198b3d0 100644 --- a/src/lib_shell/prevalidator_pending_operations.ml +++ b/src/lib_shell/prevalidator_pending_operations.ml @@ -2,7 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2018-2021 Nomadic Labs, *) +(* Copyright (c) 2018-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"),*) @@ -24,6 +24,16 @@ (* *) (*****************************************************************************) +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the implementation of the new mempool, which + uses features of the protocol that only exist since Lima. + + When you modify this file, consider whether you should also change + the files that implement the legacy mempool for Kathmandu. They all + start with the "legacy" prefix and will be removed when Lima is + activated on Mainnet. *) + (* Ordering is important, as it is used below in map keys comparison *) type priority = [`High | `Medium | `Low of Q.t list] diff --git a/src/lib_shell/prevalidator_pending_operations.mli b/src/lib_shell/prevalidator_pending_operations.mli index 774bf377141f93ff885d696179c4d03355647036..a020ed35feb33c6a77cd4b4ddd892945e7a700f0 100644 --- a/src/lib_shell/prevalidator_pending_operations.mli +++ b/src/lib_shell/prevalidator_pending_operations.mli @@ -2,7 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* Copyright (c) 2018-2021 Nomadic Labs, *) +(* Copyright (c) 2018-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"),*) @@ -24,6 +24,16 @@ (* *) (*****************************************************************************) +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the implementation of the new mempool, which + uses features of the protocol that only exist since Lima. + + When you modify this file, consider whether you should also change + the files that implement the legacy mempool for Kathmandu. They all + start with the "legacy" prefix and will be removed when Lima is + activated on Mainnet. *) + (** The priority of a pending operation. A priority is attached to each pending operation. *) diff --git a/src/lib_shell/test/dune b/src/lib_shell/test/dune index 0aafab7b23ba8718942342f2856c1381a47a0510..140ed6254f846542af90c5f73fbfdfae2a27a313 100644 --- a/src/lib_shell/test/dune +++ b/src/lib_shell/test/dune @@ -10,6 +10,11 @@ test_prevalidator_classification test_prevalidator_classification_operations test_prevalidator_pending_operations + legacy_test_prevalidation + legacy_test_prevalidation_t + legacy_test_prevalidator_classification + legacy_test_prevalidator_classification_operations + legacy_test_prevalidator_pending_operations test_peer_validator) (libraries tezos-base @@ -84,6 +89,32 @@ (package tezos-shell) (action (run %{dep:./test_prevalidator_pending_operations.exe}))) +(rule + (alias runtest) + (package tezos-shell) + (action (run %{dep:./legacy_test_prevalidation.exe}))) + +(rule + (alias runtest) + (package tezos-shell) + (action (run %{dep:./legacy_test_prevalidation_t.exe}))) + +(rule + (alias runtest) + (package tezos-shell) + (action (run %{dep:./legacy_test_prevalidator_classification.exe}))) + +(rule + (alias runtest) + (package tezos-shell) + (action + (run %{dep:./legacy_test_prevalidator_classification_operations.exe}))) + +(rule + (alias runtest) + (package tezos-shell) + (action (run %{dep:./legacy_test_prevalidator_pending_operations.exe}))) + (rule (alias runtest) (package tezos-shell) diff --git a/src/lib_shell/test/generators.ml b/src/lib_shell/test/generators.ml index defea0e7286c45d5df98baa1a5c80bd4062f2095..6548f1dddab866261011ac898f582f9031116cb3 100644 --- a/src/lib_shell/test/generators.ml +++ b/src/lib_shell/test/generators.ml @@ -1,7 +1,7 @@ (*****************************************************************************) (* *) (* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs. *) +(* Copyright (c) 2021-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"),*) @@ -23,6 +23,16 @@ (* *) (*****************************************************************************) +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the test suite for the new mempool, which + uses features of the protocol that only exist since Lima. + + When you modify this file, consider whether you should also change + the ones that test the legacy mempool for Kathmandu. They all + start with the "legacy" prefix and will be removed when Lima is + activated on Mainnet. *) + open Prevalidator_classification let add_if_not_present classification op t = diff --git a/src/lib_shell/test/generators_tree.ml b/src/lib_shell/test/generators_tree.ml index 6f7aeab2c34e6594ec302b30f2bdc78864552e56..6476d731bbf9359a7573e867fa1a2bc00caf3c08 100644 --- a/src/lib_shell/test/generators_tree.ml +++ b/src/lib_shell/test/generators_tree.ml @@ -23,6 +23,16 @@ (* *) (*****************************************************************************) +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the test suite for the new mempool, which + uses features of the protocol that only exist since Lima. + + When you modify this file, consider whether you should also change + the ones that test the legacy mempool for Kathmandu. They all + start with the "legacy" prefix and will be removed when Lima is + activated on Mainnet. *) + (** Generators building on top of {!Generators}, that are capable of producing trees of blocks. *) diff --git a/src/lib_shell/test/legacy_generators.ml b/src/lib_shell/test/legacy_generators.ml new file mode 100644 index 0000000000000000000000000000000000000000..c9ef6fe56698b4bb411971fd84945da226fd6af3 --- /dev/null +++ b/src/lib_shell/test/legacy_generators.ml @@ -0,0 +1,300 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021-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. *) +(* *) +(*****************************************************************************) + +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the test suite for the legacy mempool, which + is compatible with Kathmandu and therefore usable on Mainnet. + + This file should be removed once Lima has been activated on Mainnet. + + When you modify this file, consider whether you should also change + the ones that test the more recent mempool for Lima and newer + protocols. *) + +module Prevalidation = Legacy_prevalidation +module Classification = Legacy_prevalidator_classification +module Pending_operations = Legacy_prevalidator_pending_operations +open Classification + +let add_if_not_present classification op t = + if is_in_mempool op.Prevalidation.hash t = None then add classification op t + +(** A generator for the protocol bytes of an operation. *) +let operation_proto_gen = QCheck2.Gen.small_string ?gen:None + +(** A generator for the protocol bytes of an operation, when the protocol + being used has [type operation_data = unit]. *) +let operation_mock_proto_gen = + let open QCheck2.Gen in + (* 9/10 generates the right size (empty), 1/10 generates too long. *) + let* len_gen = frequencya [|(9, return 0); (1, 0 -- 31)|] in + string_size ?gen:None len_gen + +let block_hash_gen : Block_hash.t QCheck2.Gen.t = + let open QCheck2.Gen in + let string_gen = QCheck2.Gen.small_string ?gen:None in + let+ key = opt (string_size (0 -- 64)) + and+ path = list_size (0 -- 10) string_gen in + Block_hash.hash_string ?key path + +(** A generator of operations. + - [proto_gen] is the generator for protocol bytes. By default, it is + {!proto_gen} above. This default is fine for cases where having + valid proto bytes doesn't matter (for example for + {!Legacy_prevalidator_classification}). + - [block_hash_t] is an optional generator for the branch. + If omitted {!block_hash_gen} is used. + + This function should be renamed to [raw_operation_gen] at some point, + because it returns {!Operation.t} (the [op] prefix is for functions + returning {!Prevalidation.operation} values). *) +let operation_gen ?(proto_gen = operation_proto_gen) ?block_hash_t () : + Operation.t QCheck2.Gen.t = + let open QCheck2.Gen in + let prod_block_hash_gen = Option.value ~default:block_hash_gen block_hash_t in + let* branch = prod_block_hash_gen in + let+ proto = proto_gen in + let proto = Bytes.of_string proto in + Operation.{shell = {branch}; proto} + +(** Like {!operation_gen} with a hash. *) +let raw_operation_with_hash_gen ?proto_gen ?block_hash_t () : + (Operation_hash.t * Operation.t) QCheck2.Gen.t = + let open QCheck2.Gen in + let+ op = operation_gen ?proto_gen ?block_hash_t () in + let hash = Operation.hash op in + (hash, op) + +let q_in_0_1 () = + let open QCheck2.Gen in + let* q = Lib_test.Qcheck2_helpers.int64_range_gen 1L Int64.max_int in + let+ p = Lib_test.Qcheck2_helpers.int64_range_gen 0L q in + Q.make (Z.of_int64 p) (Z.of_int64 q) + +let priority_gen () : Pending_operations.priority QCheck2.Gen.t = + let open QCheck2.Gen in + let* top_prio_value = oneofl [`High; `Medium; `Low] in + match top_prio_value with + | `High -> pure `High + | `Medium -> pure `Medium + | `Low -> + let+ weights = small_list (q_in_0_1 ()) in + `Low weights + +(** [operation_with_hash_gen ?proto_gen ?block_hash_t ()] is a generator + for parsable operations, i.e. values of type {!Prevalidation.operation}. + + In production, this type guarantees that the underlying operation + has been successfully parsed. This is NOT the case with this generator. + This is a weakness of this function that can only be solved by + clearly making the difference between proto-dependent tests and + proto-independent tests. + + By default, [?proto_gen] is [operation_proto_gen] which + generates random bytes, making generated operations unparsable generally + speaking. One can make sure that this generator generates + parsable operations by assuming a protocol and using a custom [proto_gen]. + As an example this is the case when using + {!Tezos_protocol_environment.Internal_for_tests.Environment_protocol_T_test.Mock_all_unit} + as the protocol and specifying [proto_gen] to be [string_size (return 0)] + i.e. to have both [operation_data = unit] and strings generated for + [operation_data] always empty. *) +let operation_with_hash_gen ?proto_gen ?block_hash_t () : + unit Prevalidation.operation QCheck2.Gen.t = + let open QCheck2.Gen in + let+ oph, op = raw_operation_with_hash_gen ?proto_gen ?block_hash_t () in + Prevalidation.Internal_for_tests.make_operation op oph () + +let operation_with_hash_and_priority_gen ?proto_gen ?block_hash_t () : + (unit Prevalidation.operation * Pending_operations.priority) QCheck2.Gen.t = + let open QCheck2.Gen in + let* op = operation_with_hash_gen ?proto_gen ?block_hash_t () in + let* priority = priority_gen () in + return (op, priority) + +let raw_op_map_gen ?proto_gen ?block_hash_t () : + Operation.t Operation_hash.Map.t QCheck2.Gen.t = + let open QCheck2.Gen in + let+ ops = + small_list (raw_operation_with_hash_gen ?proto_gen ?block_hash_t ()) + in + List.to_seq ops |> Operation_hash.Map.of_seq + +(** A generator of maps of operations and their hashes. Parameters are: + - [?proto_gen] is an optional generator for the protocol bytes. + - [?block_hash_t] is an optional generator for the branch of operations. + + Because it returns a map, + this generator guarantees that all returned operations are distinct + (because their hashes differ). *) +let op_map_gen ?proto_gen ?block_hash_t () : + unit Prevalidation.operation Operation_hash.Map.t QCheck2.Gen.t = + let open QCheck2.Gen in + let+ ops = small_list (operation_with_hash_gen ?proto_gen ?block_hash_t ()) in + List.to_seq ops + |> Seq.map (fun op -> (op.Prevalidation.hash, op)) + |> Operation_hash.Map.of_seq + +(** A generator like {!raw_op_map_gen} but which guarantees the size + of the returned maps: they are exactly of size [n]. We need + a custom function (as opposed to using a QCheck2 function for lists + of fixed lengths) because we *need* to return maps, because we need + the properties that all operations hashes are different. *) +let raw_op_map_gen_n ?proto_gen ?block_hash_t (n : int) : + Operation.t Operation_hash.Map.t QCheck2.Gen.t = + let open QCheck2.Gen in + let map_take_n n m = + Operation_hash.Map.bindings m + |> List.take_n n |> List.to_seq |> Operation_hash.Map.of_seq + in + let merge _oph old _new = Some old in + let rec go (ops : Operation.t Operation_hash.Map.t) = + if Operation_hash.Map.cardinal ops >= n then + (* Done *) + return (map_take_n n ops) + else + (* Not enough operations yet, generate more *) + let* new_ops = raw_op_map_gen ?proto_gen ?block_hash_t () in + go (Operation_hash.Map.union merge ops new_ops) + in + go Operation_hash.Map.empty + +(** A generator like {!op_map_gen} but which guarantees the size + of the returned maps: they are exactly of size [n]. We need + a custom function (as opposed to using a QCheck2 function for lists + of fixed lengths) because we *need* to return maps, because we need + the properties that all operations hashes are different. *) +let op_map_gen_n ?proto_gen ?block_hash_t (n : int) : + unit Prevalidation.operation Operation_hash.Map.t QCheck2.Gen.t = + let open QCheck2.Gen in + let map_take_n n m = + Operation_hash.Map.bindings m + |> List.take_n n |> List.to_seq |> Operation_hash.Map.of_seq + in + let merge _oph old _new = Some old in + let rec go (ops : unit Prevalidation.operation Operation_hash.Map.t) = + if Operation_hash.Map.cardinal ops >= n then + (* Done *) + return (map_take_n n ops) + else + (* Not enough operations yet, generate more *) + let* new_ops = op_map_gen ?proto_gen ?block_hash_t () in + go (Operation_hash.Map.union merge ops new_ops) + in + go Operation_hash.Map.empty + +(** Do we need richer errors? If so, how to generate those? *) +let classification_gen : classification QCheck2.Gen.t = + QCheck2.Gen.oneofa + [| + `Applied; + `Prechecked; + `Branch_delayed []; + `Branch_refused []; + `Refused []; + `Outdated []; + |] + +let unrefused_classification_gen : classification QCheck2.Gen.t = + QCheck2.Gen.oneofa + [|`Applied; `Prechecked; `Branch_delayed []; `Branch_refused []|] + +let parameters_gen : parameters QCheck2.Gen.t = + let open QCheck2.Gen in + let+ map_size_limit = 1 -- 30 in + let on_discarded_operation _ = () in + {map_size_limit; on_discarded_operation} + +let t_gen_ ~can_be_full : unit t QCheck2.Gen.t = + let open QCheck2.Gen in + let* parameters = parameters_gen in + let limit = parameters.map_size_limit - if can_be_full then 0 else 1 in + let* size = 0 -- limit in + let+ inputs = + list_repeat size (pair classification_gen (operation_with_hash_gen ())) + in + let t = Classification.create parameters in + List.iter + (fun (classification, op) -> add_if_not_present classification op t) + inputs ; + t + +let t_gen = t_gen_ ~can_be_full:true + +(* With probability 1/2, we take an operation hash already present in the + classification. This operation is taken uniformly among the + different classes. *) +let with_t_operation_gen : unit t -> unit Prevalidation.operation QCheck2.Gen.t + = + let open QCheck2 in + fun t -> + let to_ops map = + Operation_hash.Map.bindings map |> List.map (fun (_oph, (op, _)) -> op) + in + (* If map is empty, it cannot be used as a generator *) + let freq_of_map map = if Operation_hash.Map.is_empty map then 0 else 1 in + (* If list is empty, it cannot be used as a generator *) + let freq_of_list = function [] -> 0 | _ -> 1 in + (* If map is not empty, take one of its elements *) + let freq_and_gen_of_map map = + let b = freq_of_map map in + if b = 1 then [(1, Gen.oneofl (to_ops map))] else [] + in + (* If list is not empty, take one of its elements *) + let freq_and_gen_of_list list = + let b = freq_of_list list in + if b = 1 then [(1, Gen.oneofl list)] else [] + in + (* We use max to ensure the ponderation is strictly greater than 0. *) + let freq_fresh t = + max + 1 + (freq_of_list t.applied_rev + + freq_of_map (Sized_map.to_map t.prechecked) + + freq_of_map (Classification.map t.branch_refused) + + freq_of_map (Classification.map t.branch_delayed) + + freq_of_map (Classification.map t.refused) + + freq_of_map (Classification.map t.outdated)) + in + freq_and_gen_of_list t.applied_rev + @ freq_and_gen_of_list (List.map snd (Sized_map.bindings t.prechecked)) + @ freq_and_gen_of_map (Classification.map t.branch_refused) + @ freq_and_gen_of_map (Classification.map t.branch_delayed) + @ freq_and_gen_of_map (Classification.map t.refused) + @ freq_and_gen_of_map (Classification.map t.outdated) + @ [(freq_fresh t, operation_with_hash_gen ())] + |> Gen.frequency + +let t_with_operation_gen_ ~can_be_full : + (unit t * unit Prevalidation.operation) QCheck2.Gen.t = + let open QCheck2.Gen in + let* t = t_gen_ ~can_be_full in + pair (return t) (with_t_operation_gen t) + +let t_with_operation_gen = t_with_operation_gen_ ~can_be_full:true + +let t_with_operation_gen__cant_be_full = + t_with_operation_gen_ ~can_be_full:false diff --git a/src/lib_shell/test/legacy_generators_tree.ml b/src/lib_shell/test/legacy_generators_tree.ml new file mode 100644 index 0000000000000000000000000000000000000000..b2e9993d21be2b80eea23f327bc73496f2e67cec --- /dev/null +++ b/src/lib_shell/test/legacy_generators_tree.ml @@ -0,0 +1,538 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the test suite for the legacy mempool, which + is compatible with Kathmandu and therefore usable on Mainnet. + + This file should be removed once Lima has been activated on Mainnet. + + When you modify this file, consider whether you should also change + the ones that test the more recent mempool for Lima and newer + protocols. *) + +(** Generators building on top of {!Generators}, that are capable of + producing trees of blocks. *) + +module Prevalidation = Legacy_prevalidation +module Classification = Legacy_prevalidator_classification + +(** Various functions about {!list} *) +module List_extra = struct + (** [common_elem l1 l2] returns the first element of [l1] that + occurs in [l2]. If [l1] and [l2] do not have a common element, + [Nothing] is returned. Examples: + + [common_elem [0; 2; 3] [3; 2]] returns [Some 2] + [common_elem [0; 2; 3] [2; 3]] returns [Some 3] + [common_elem [0; 2; 3] [4]] returns [Nothing] *) + let rec common_elem ~(equal : 'a -> 'a -> bool) (l1 : 'a list) (l2 : 'a list) + = + match (l1, l2) with + | [], _ -> None + | e1 :: rest1, _ -> + if List.exists (equal e1) l2 then Some e1 + else common_elem ~equal rest1 l2 + + (** [take_until_if_found ((=) 2) [0; 3; 2; 4; 2]] returns [Some [0; 3]] + [take_until_if_found ((=) -1) [0; 3; 2; 4; 2]] returns [None] + [take_until_if_found ((=) 0) [0]] returns [Some []] *) + let rec take_until_if_found ~(pred : 'a -> bool) (l : 'a list) = + match l with + | [] -> None + | fst :: _ when pred fst -> Some [] + | fst :: rest_l -> ( + match take_until_if_found ~pred rest_l with + | None -> None + | Some tail -> Some (fst :: tail)) +end + +module Tree = struct + (** Trees representing the shape of the chain. The root is the common + ancestor of all blocks, like this: + + head3 + / + head1 head2 . + \ \ / + . . + \ / + ancestor + *) + type 'a tree = + | Leaf of 'a + | Node1 of ('a * 'a tree) + | Node2 of ('a * 'a tree * 'a tree) + + (* Note that I intentionally do not use {!Format} as automatic + line cutting makes reading the output (when debugging) harder. *) + let rec to_string_aux elem_to_string t indent = + match t with + | Leaf e -> indent ^ elem_to_string e + | Node1 (e, subt) -> + let indentpp = indent ^ " " in + Printf.sprintf + "%s%s\n%s" + indent + (elem_to_string e) + (to_string_aux elem_to_string subt indentpp) + | Node2 (e, t1, t2) -> + let indentpp = indent ^ " " in + Printf.sprintf + "%s%s\n%s\n%s" + indent + (elem_to_string e) + (to_string_aux elem_to_string t1 indentpp) + (to_string_aux elem_to_string t2 indentpp) + + (* [to_string] is unused but useful when debugging, renaming it to [_to_string] to keep it around *) + let _to_string elem_to_string t = to_string_aux elem_to_string t "" + + let rec depth = function + | Leaf _ -> 1 + | Node1 (_, t1) -> 1 + depth t1 + | Node2 (_, t1, t2) -> 1 + max (depth t1) (depth t2) + + (** The root value of a tree *) + let value : 'a tree -> 'a = function + | Leaf a -> a + | Node1 (a, _) -> a + | Node2 (a, _, _) -> a + + (** [values t] returns all values within [t] *) + let rec values : 'a tree -> 'a list = function + | Leaf a -> [a] + | Node1 (a, t1) -> a :: values t1 + | Node2 (a, t1, t2) -> (a :: values t1) @ values t2 + + (** Predicate to check that all values are different. We want + this property for trees of blocks. If generation of block + were to repeat a block, this property could get broken. *) + let well_formed (type a) (compare : a -> a -> int) (t : a tree) = + let module Ord = struct + type t = a + + let compare = compare + end in + let module Set = Set.Make (Ord) in + let values_list = values t in + let values_set = Set.of_list values_list in + Compare.List_length_with.(values_list = Set.cardinal values_set) + + (** Given a tree of values, returns an association list from a value to + its parent (i.e. predecessor) in the tree. I.e. given : + + c1 c2 c3 + \ \ / + b0 b1 + \ / + a0 + + return: [(b0, a0); (c1, b0); (b1, a0); (c2, b1); (c3; b1)] + *) + let rec predecessor_pairs (tree : 'a tree) : ('a * 'a) list = + match tree with + | Leaf _ -> [] + | Node1 (e, subtree) -> + let child = value subtree in + (child, e) :: predecessor_pairs subtree + | Node2 (e, subtree1, subtree2) -> + let child1 = value subtree1 in + let child2 = value subtree2 in + ((child1, e) :: (child2, e) :: predecessor_pairs subtree1) + @ predecessor_pairs subtree2 + + (** Returns the predecessors of a tree node. I.e., given + such a tree: + + c1 c2 c3 + \ \ / + b0 b1 + \ / + a0 + + [predecessors [c1]] is [b0; a0] + [predecessors [a0]] is [] + [predecessors [b1]] is [a0] + *) + let predecessors ~(equal : 'a -> 'a -> bool) (tree : 'a tree) (e : 'a) = + let predecessor_pairs = predecessor_pairs tree in + let rec main (x : 'a) = + match List.assoc ~equal x predecessor_pairs with + | None -> [] + | Some parent -> parent :: main parent + in + main e + + let predecessors ~(equal : 'a -> 'a -> bool) (tree : 'a tree) (e : 'a) = + let res = predecessors ~equal tree e in + (* If this assertion breaks, the tree is illformed *) + assert (not (List.mem ~equal e res)) ; + res + + (** [find_ancestor tree e1 e2] returns the common ancestor of [e1] and [e2] + in [tree], if any *) + let find_ancestor ~(equal : 'a -> 'a -> bool) (tree : 'a tree) (e1 : 'a) + (e2 : 'a) : 'a option = + let parents1 = predecessors ~equal tree e1 in + let parents2 = predecessors ~equal tree e2 in + if List.mem ~equal e1 parents2 then Some e1 + else if List.mem ~equal e2 parents1 then Some e2 + else List_extra.common_elem ~equal parents1 parents2 +end + +(** Module concerning the type with which [Prevalidator.Internal_for_tests.block_tools] + and [Prevalidator.Internal_for_tests.chain_tools] are instantiated *) +module Block = struct + (** The block-like interface that suffices to test + [Prevalidator.Internal_for_tests.handle_live_operations] *) + type t = { + hash : Block_hash.t; + operations : unit Prevalidation.operation list list; + } + + (* Because we use hashes to implement equality, we must make sure + that for any pair of generated blocks [(b1, b2)], [b1.hash <> b2.hash] + implies [b1 <> b2] where [<>] is polymorphic inequality. Said + differently, hashes should not be faked. *) + let equal : t -> t -> bool = fun t1 t2 -> Block_hash.equal t1.hash t2.hash + + let compare (t1 : t) (t2 : t) = Block_hash.compare t1.hash t2.hash + + (** [hash_of_blocks ops] is used to compute the hash of a block whose + [operations] field contains [ops]. + + We want the hash to be sound, because it is used to implement equality + (see {!equal} above), like in the production implementation. Given + that {!t} above contains a single field besides the [hash], we hash + the content of this field to obtain the hash of a block. That + is why we hash the hashes of operations. *) + let hash_of_block ops = + let hash = + Operation_list_hash.compute + (List.map (fun op -> op.Prevalidation.hash) @@ List.concat ops) + in + (* We forge a fake [block_header] hash by first hashing the operations + and change the [b58] signature into a signature that looks like + the one of a block header by prefixing it with the letter [B]. *) + let hash_string = Operation_list_hash.to_b58check hash in + let suffix = String.sub hash_string 2 31 in + match Block_hash.of_string @@ "B" ^ suffix with + | Error err -> + Format.printf "Unexpected error: %a" Error_monad.pp_print_trace err ; + assert false + | Ok hash -> hash + + (** Returns the [hash] field of a {!t} *) + let to_hash (blk : t) = blk.hash + + let tools : t Classification.block_tools = + let operations block = + List.map (List.map (fun op -> op.Prevalidation.raw)) block.operations + in + let all_operation_hashes block = + List.map (List.map (fun op -> op.Prevalidation.hash)) block.operations + in + {hash = to_hash; operations; all_operation_hashes} + + let to_string t = + let ops_list_to_string ops = + String.concat + "|" + (List.map + Operation_hash.to_short_b58check + (List.map (fun op -> op.Prevalidation.hash) ops)) + in + let ops_string = + List.fold_left + (fun acc ops -> Format.sprintf "%s[%s]" acc (ops_list_to_string ops)) + "" + t.operations + in + Format.asprintf "%a:[%s]" Block_hash.pp t.hash ops_string + + (* [pp_list] is unused but useful when debugging, renaming it to [_pp_list] to keep it around *) + + (** Pretty prints a list of {!t}, using [sep] as the separator *) + let _pp_list ~(sep : string) (ts : t list) = + String.concat sep @@ List.map to_string ts + + module Ord = struct + type nonrec t = t + + let compare = compare + end + + module Set = Set.Make (Ord) + + let set_to_list s = Set.to_seq s |> List.of_seq +end + +module External_generators = Legacy_generators + +(** [block_gen ?proto_gen ()] generates a block. [proto_gen] is used + to generate protocol bytes of operations. *) +let block_gen ?proto_gen () : Block.t QCheck2.Gen.t = + let open QCheck2.Gen in + let ops_list_gen = + (* Having super long list of operations isn't necessary. + In addition it slows everything down. *) + list_size + (int_range 0 10) + (External_generators.operation_with_hash_gen ?proto_gen ()) + in + let* ops = + (* In production these lists are exactly of size 4, being more general *) + list_size (int_range 0 8) ops_list_gen + in + let hash = Block.hash_of_block ops in + return Block.{hash; operations = ops} + +(* A generator of sets of {!Block.t} where all elements are guaranteed + to be different. [list_gen] is an optional list generator. If omitted + it is defaulted to {!QCheck2.Gen.small_list}. [?proto_gen] is an + optional generator for protocol bytes of operations. *) +let unique_block_gen ?(list_gen = QCheck2.Gen.small_list) ?proto_gen () : + Block.Set.t QCheck2.Gen.t = + QCheck2.Gen.(map Block.Set.of_list @@ list_gen (block_gen ?proto_gen ())) + +(* A generator of sets of {!Block.t} where all elements are guaranteed + to be different and returned sets are guaranteed to be non empty. *) +let unique_nonempty_block_gen = + let open QCheck2.Gen in + let+ block = block_gen () and+ l = unique_block_gen () in + Block.Set.add block l + +(** [unique_block_gen n] returns sets of {!Block.t} such that: + - all blocks are different + - the cardinal of returned sets is equal or greater than [n]. + + [?proto_gen] is an optional generator for protocol bytes of operations. *) +let unique_block_gen_gt ?proto_gen ~(n : int) () : Block.Set.t QCheck2.Gen.t = + assert (n >= 0) ; + let open QCheck2.Gen in + let list_gen = list_repeat n in + let rec go generated = + if Block.Set.cardinal generated >= n then return generated + else + let* new_blocks = unique_block_gen ?proto_gen ~list_gen () in + go (Block.Set.union generated new_blocks) + in + go Block.Set.empty + +(** A tree generator. Written in a slightly unusual style because it + generates all values beforehand, to make sure they are all different. + This is a property we want for trees of blocks. To do so, + this generator first generates a list of elements [e1; e2; e3; e4; e5; e6] + and then progressively splits this list to build the subtrees. + + For example it takes [e1] for the root value and then splits + the rest into [e2; e3] and [e4; e5; e6]. Then it recurses, sending + [e2; e3] as values to create the left subtree and [e4; e5; e6] to + create the right subtree. + + This generator takes as parameter an optional list of blocks. If + they are given, they are used to build the tree; otherwise fresh + ones are generated. *) +let tree_gen ?blocks () = + let open QCheck2.Gen in + let* (blocks : Block.t list) = + match blocks with + | None -> + (* no blocks received: generate them, use the [nonempty] flavor + of the generator, to guarantee [blocks <> []] below. *) + map Block.set_to_list unique_nonempty_block_gen + | Some [] -> + QCheck2.Test.fail_report + "tree_gen should not be called with an empty list of blocks" + | Some blocks -> + (* take blocks passed as parameters *) + return blocks + in + assert (blocks <> []) ; + let ret x = return (Some x) in + let rec go = function + | [] -> return None + | [x] -> ret (Tree.Leaf x) + | x :: xs -> ( + let* one_child = QCheck2.Gen.bool in + if one_child then + let* sub = go xs in + match sub with + | None -> ret (Tree.Leaf x) + | Some sub -> ret (Tree.Node1 (x, sub)) + else + let* n = QCheck2.Gen.int_bound (List.length xs - 1) in + let left, right = List.split_n n xs in + let* left = go left and* right = go right in + match (left, right) with + | None, None -> ret (Tree.Leaf x) + | None, Some sub | Some sub, None -> ret (Tree.Node1 (x, sub)) + | Some left, Some right -> ret (Tree.Node2 (x, left, right))) + in + (* The assertion cannot break, because we made sure that [blocks] is + not empty. *) + map (WithExceptions.Option.get ~loc:__LOC__) (go blocks) + +(** A generator for passing the last argument of + [Prevalidator.handle_live_operations] *) +let old_mempool_gen (tree : Block.t Tree.tree) : + unit Prevalidation.operation Operation_hash.Map.t QCheck2.Gen.t = + let blocks = Tree.values tree in + let pairs = List.concat_map Block.tools.operations blocks |> List.concat in + let elements = + List.map + (fun (op : Operation.t) -> + let hash = Operation.hash op in + Prevalidation.Internal_for_tests.make_operation op hash ()) + pairs + in + if elements = [] then QCheck2.Gen.return Operation_hash.Map.empty + else + let list_gen = QCheck2.Gen.(oneofl elements |> list) in + QCheck2.Gen.map + (fun l -> + List.to_seq l + |> Seq.map (fun op -> (op.Prevalidation.hash, op)) + |> Operation_hash.Map.of_seq) + list_gen + +(** Function to implement + {!Legacy_prevalidator_classification.chain_tools.new_blocks} *) +let new_blocks (type a) ~(equal : a -> a -> bool) (tree : a Tree.tree) + ~from_block ~to_block = + match Tree.find_ancestor ~equal tree from_block to_block with + | None -> assert false (* Like the production implementation *) + | Some ancestor -> ( + let to_parents = Tree.predecessors ~equal tree to_block in + match + ( to_parents, + List_extra.take_until_if_found ~pred:(( = ) ancestor) to_parents ) + with + | [], _ -> + (* This case is not supported, because the production + implementation of new_blocks doesn't support it either + (since it MUST return an ancestor, acccording to its return + type). If you end up here, this means generated + data is not constrained enough: this pair [(from_block, + to_block)] should NOT be tried. Ideally the return type + of new_blocks should allow this case, hereby allowing + a more general test. *) + assert false + | _, None -> + (* Should not happen, because [ancestor] + is a member of [to_parents] *) + assert false + | _, Some path -> + (* Because [to_block] must be included in new_blocks' + returned value. *) + let path = to_block :: path in + Lwt.return (ancestor, List.rev path)) + +(** Function to implement + {!Legacy_prevalidator_classification.chain_tools.read_predecessor_opt} *) +let read_predecessor_opt (type a) ~(compare : a -> a -> int) + (tree : a Tree.tree) (a : a) : a option Lwt.t = + let module Ord = struct + type t = a + + let compare = compare + end in + let module Map = Map.Make (Ord) in + let predecessors_map = + Tree.predecessor_pairs tree |> List.to_seq |> Map.of_seq + in + Map.find a predecessors_map |> Lwt.return + +(** Function providing the instance of + {!Legacy_prevalidator_classification.chain_tools} for a given {!Tree.tree} *) +let generic_classification_chain_tools (type a) ~(compare : a -> a -> int) + (tree : a Tree.tree) : a Classification.chain_tools = + let equal a b = compare a b = 0 in + Classification. + { + clear_or_cancel = Fun.const (); + inject_operation = (fun _ _ -> Lwt.return_unit); + new_blocks = new_blocks ~equal tree; + read_predecessor_opt = read_predecessor_opt ~compare tree; + } + +(** A specific instance of {!generic_classification_chain_tools}, + for handiness of users. *) +let classification_chain_tools (tree : Block.t Tree.tree) : + Block.t Classification.chain_tools = + generic_classification_chain_tools ~compare:Block.compare tree + +(** Returns: + - An instance of [Tree.tree]: the tree of blocks + - a pair of blocks (that belong to the tree) and is + fine for being passed as [(~from_branch, ~to_branch)]; i.e. + the two blocks have a common ancestor. + - a map of operations that is fine for being passed as the + last argument of [handle_live_operations]. + + If given, the specified [?blocks] are used. Otherwise they are + generated. *) +let tree_gen ?blocks () : + (Block.t Tree.tree + * (Block.t * Block.t) option + * unit Prevalidation.operation Operation_hash.Map.t) + QCheck2.Gen.t = + let open QCheck2.Gen in + let* tree = tree_gen ?blocks () in + assert (Tree.well_formed Block.compare tree) ; + let equal = Block.equal in + let not_equal x y = not @@ equal x y in + let tree_elems : Block.t list = Tree.values tree in + (* Pairs of blocks that are valid for being ~from_block and ~to_block *) + let heads_pairs : (Block.t * Block.t) list = + List.product tree_elems tree_elems + (* don't take from_block=to_block*) + |> List.filter (fun (left, right) -> not_equal left right) + (* keep only pairs of blocks that have a common ancestor *) + |> List.filter (fun (left, right) -> + Tree.find_ancestor ~equal tree left right |> function + | None -> false (* We want an ancestor *) + | Some ancestor -> + (* We don't want from_block to be the parent of to_block (or vice versa), + because it means the chain would rollback. This is not supported + (it hits an assert false in new_blocks, because its return type is + not general enough) *) + not_equal ancestor left && not_equal ancestor right) + in + let* chosen_pair = + if heads_pairs = [] then return None + else map Option.some (oneofl heads_pairs) + in + let+ old_mempool = old_mempool_gen tree in + (tree, chosen_pair, old_mempool) + +(** [split_in_two l] is a generator producing [(l1, l2)] such that [l1 @ l2 = l] *) +let split_in_two (l : 'a list) : ('a list * 'a list) QCheck2.Gen.t = + let open QCheck2.Gen in + let length = List.length l in + let+ i = 0 -- length in + List.split_n i l diff --git a/src/lib_shell/test/legacy_test_prevalidation.ml b/src/lib_shell/test/legacy_test_prevalidation.ml new file mode 100644 index 0000000000000000000000000000000000000000..e21e1315f80e80cd7cf646183928e30c8b92c8a8 --- /dev/null +++ b/src/lib_shell/test/legacy_test_prevalidation.ml @@ -0,0 +1,278 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021-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. *) +(* *) +(*****************************************************************************) + +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the test suite for the legacy mempool, which + is compatible with Kathmandu and therefore usable on Mainnet. + + This file should be removed once Lima has been activated on Mainnet. + + When you modify this file, consider whether you should also change + the ones that test the more recent mempool for Lima and newer + protocols. *) + +(** Testing + ------- + Component: Legacy_prevalidation + Invocation: dune exec src/lib_shell/test/legacy_test_prevalidation.exe + Subject: Unit tests for [Legacy_prevalidation] +*) + +module Prevalidation = Legacy_prevalidation + +let test_safe_decode () = + let exception Custom_exception of string in + let broken_encoding = + Data_encoding.conv + Fun.id + (fun _ -> raise (Custom_exception "Should not leave the function scope")) + Data_encoding.unit + in + let actual = + Prevalidation.Internal_for_tests.safe_binary_of_bytes + broken_encoding + Bytes.empty + in + Alcotest.( + check + bool + "A broken encoding should return None" + (actual = Result_syntax.tzfail Validation_errors.Parse_error) + true) + +open Tezos_requester +module Classification = Legacy_prevalidator_classification + +module Parameters : + Requester_impl.PARAMETERS + with type key = Operation_hash.t + and type value = int = struct + type key = Operation_hash.t + + type value = int +end + +module Hash : Requester.HASH with type t = Operation_hash.t = struct + type t = Parameters.key + + let name = "test_with_key_Operation_hash_dot_t" + + let encoding = Operation_hash.encoding + + let pp = Operation_hash.pp +end + +module Test_request = Requester_impl.Simple_request (Parameters) +module Test_disk_table = Requester_impl.Disk_memory_table (Parameters) +module Test_Requester = + Requester_impl.Make_memory_full_requester (Hash) (Parameters) (Test_request) + +let init_full_requester_disk ?global_input () : + Test_Requester.t * Test_Requester.store = + let (st : Test_Requester.store) = Test_disk_table.create 16 in + let requester = Test_Requester.create ?global_input () st in + (requester, st) + +let init_full_requester ?global_input () : Test_Requester.t = + fst (init_full_requester_disk ?global_input ()) + +let mk_operation n : Operation.t = + let base = "BLuxtLkkNKWgV8xTzBuGcHJRPukgk4nY" in + let base_len = String.length base in + let n_string = Int.to_string n in + let n_string_len = String.length n_string in + assert (0 <= n_string_len && n_string_len <= String.length base) ; + let base_prefix = String.sub base 0 (base_len - n_string_len) in + let hash_string = base_prefix ^ n_string in + assert (String.length hash_string = base_len) ; + let branch = Block_hash.of_string_exn hash_string in + let proto = Bytes.of_string n_string in + {shell = {branch}; proto} + +(** Check that when doing a succession of inject/classify operations, + * the memory table of the requester stays small. In the past, this + * was broken; because of a missing call to function + * [Requester.clear_or_cancel]. This could be exploited to create + * a memory leak in {!Distributed_db}. *) +let test_db_leak f (nb_ops : int) (_ : unit) = + let requester = init_full_requester () in + let max_table_size = 32 in + assert (nb_ops >= max_table_size) ; + let parameters = + Classification. + { + map_size_limit = max_table_size; + on_discarded_operation = Test_Requester.clear_or_cancel requester; + } + in + let classes = Classification.create parameters in + let handle i = + let op = mk_operation i in + let oph = Operation.hash op in + let op = Prevalidation.Internal_for_tests.make_operation op oph () in + let injected = Lwt_main.run @@ Test_Requester.inject requester oph i in + assert injected ; + f [] op classes + in + List.iter handle (1 -- nb_ops) ; + let actual_table_size = Test_Requester.memory_table_length requester in + Alcotest.( + check + bool + (Printf.sprintf + "requester memory (%d) is less or equal than %d" + actual_table_size + max_table_size) + (actual_table_size <= max_table_size) + true) + +(** Check that when doing a succession of inject/classify operations, + * the memory table of the requester stays small. In the past, this + * was broken; because of a missing call to remove elements + * from [Classes.in_mempool]. This could be exploited to create + * a memory leak. *) +let test_in_mempool_leak f (nb_ops : int) (_ : unit) = + let requester = init_full_requester () in + let max_table_size = 32 in + assert (nb_ops >= max_table_size) ; + let parameters = + Classification. + { + map_size_limit = max_table_size; + on_discarded_operation = Test_Requester.clear_or_cancel requester; + } + in + let classes = Classification.create parameters in + let handle i = + let op = mk_operation i in + let oph = Operation.hash op in + let op = Prevalidation.Internal_for_tests.make_operation op oph () in + let injected = Lwt_main.run @@ Test_Requester.inject requester oph i in + assert injected ; + f [] op classes + in + List.iter handle (1 -- nb_ops) ; + let actual_in_mempool_size = Operation_hash.Map.cardinal classes.in_mempool in + Alcotest.( + check + bool + (Printf.sprintf + "in_mempool size (%d) is less or equal than %d" + actual_in_mempool_size + max_table_size) + (actual_in_mempool_size <= max_table_size) + true) + +(** Check that right after doing a classify operations, + * the memory table contains the concerned operation. This got + * broken in the past: it was being cleared right away when the ring was full. + * This could be exploited to create a memory leak in {!Distributed_db}. *) +let test_db_do_not_clear_right_away f (nb_ops : int) (_ : unit) = + let requester = init_full_requester () in + let max_table_size = 32 in + assert (nb_ops >= max_table_size) ; + let parameters = + Classification. + { + map_size_limit = max_table_size; + on_discarded_operation = Test_Requester.clear_or_cancel requester; + } + in + let classes = Classification.create parameters in + let handle i = + let op = mk_operation i in + let oph = Operation.hash op in + let op = Prevalidation.Internal_for_tests.make_operation op oph () in + Format.printf "Injecting op: %a\n" Operation_hash.pp oph ; + let injected = Lwt_main.run @@ Test_Requester.inject requester oph i in + assert injected ; + f [] op classes ; + Alcotest.( + check + bool + (Format.asprintf + "requester memory contains most recent classified operation (%a)" + Operation_hash.pp + oph) + (Option.is_some @@ Lwt_main.run @@ Test_Requester.read_opt requester oph) + true) + in + List.iter handle (1 -- nb_ops) + +let () = + let nb_ops = [64; 128] in + let handle_refused_pair = + [ + ((fun tztrace -> Classification.add (`Refused tztrace)), "handle_refused"); + ( (fun tztrace -> Classification.add (`Outdated tztrace)), + "handle_outdated" ); + ] + in + let handle_branch_pairs = + [ + ( (fun tztrace -> Classification.add (`Branch_refused tztrace)), + "handle_branch_refused" ); + ( (fun tztrace -> Classification.add (`Branch_delayed tztrace)), + "handle_branch_delayed" ); + ] + in + let applier_funs = handle_branch_pairs @ handle_refused_pair in + let mk_test_cases ~test (applier_fun, applier_fun_str) = + List.map + (fun nb_ops -> + Alcotest.test_case + (Format.sprintf "%s:%d calls" applier_fun_str nb_ops) + `Quick + (test applier_fun nb_ops)) + nb_ops + in + let all_ddb_leak_tests = + List.concat_map (mk_test_cases ~test:test_db_leak) applier_funs + in + let in_mempool_leak_test = + List.concat_map + (mk_test_cases ~test:test_in_mempool_leak) + handle_refused_pair + in + let ddb_clearing_tests = + List.concat_map + (mk_test_cases ~test:test_db_do_not_clear_right_away) + handle_branch_pairs + in + Alcotest.run + "Prevalidation" + [ + ( "Corner cases", + [ + Alcotest.test_case + "Raising an exception in encoding doesn't break" + `Quick + test_safe_decode; + ] ); + ("Ddb leaks", all_ddb_leak_tests); + ("Mempool Leaks", in_mempool_leak_test); + ("Ddb clearing", ddb_clearing_tests); + ] diff --git a/src/lib_shell/test/legacy_test_prevalidation_t.ml b/src/lib_shell/test/legacy_test_prevalidation_t.ml new file mode 100644 index 0000000000000000000000000000000000000000..986dcf9300de47d7ec61d2cc526fcb76715ada74 --- /dev/null +++ b/src/lib_shell/test/legacy_test_prevalidation_t.ml @@ -0,0 +1,385 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021-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. *) +(* *) +(*****************************************************************************) + +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the test suite for the legacy mempool, which + is compatible with Kathmandu and therefore usable on Mainnet. + + This file should be removed once Lima has been activated on Mainnet. + + When you modify this file, consider whether you should also change + the ones that test the more recent mempool for Lima and newer + protocols. *) + +(** Testing + ------- + Component: Legacy_prevalidation + Invocation: dune exec src/lib_shell/test/legacy_test_prevalidation_t.exe + Subject: Unit tests for {!Legacy_prevalidation.T} +*) + +module Prevalidation = Legacy_prevalidation + +module Mock_protocol : + Tezos_protocol_environment.PROTOCOL + with type operation_data = unit + and type operation_receipt = unit + and type validation_state = unit + and type application_state = unit = struct + open Tezos_protocol_environment.Internal_for_tests + include Environment_protocol_T_test.Mock_all_unit + + (* We need to override these functions so that they're not [assert + false], because the tests below use [Legacy_prevalidation.create] which + calls them. *) + + let begin_validation _ctxt _chain_id _mode ~predecessor:_ ~cache:_ = + Lwt_result_syntax.return_unit + + let begin_application _ctxt _chain_id _mode ~predecessor:_ ~cache:_ = + Lwt_result_syntax.return_unit +end + +module Internal_for_tests = Prevalidation.Internal_for_tests + +module Init = struct + let genesis_protocol = + Protocol_hash.of_b58check_exn + "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp" + + let chain_id = Chain_id.zero + + let genesis_time = Time.Protocol.of_seconds 0L + + (** [wrap_tzresult_lwt f ()] provides an instance of {!Context.t} to + a test [f]. For this, it creates a temporary directory on disk, + populates it with the data required for a {!Context.t} and then calls + [f] by passing it an empty [Context.t]. After [f] finishes, the state + is cleaned up. *) + let wrap_tzresult_lwt_disk + (f : Tezos_protocol_environment.Context.t -> unit tzresult Lwt.t) () : + unit tzresult Lwt.t = + Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir -> + let open Lwt_result_syntax in + let root = Filename.concat base_dir "context" in + let*! idx = Context.init root in + let* genesis = + Context.commit_genesis + idx + ~chain_id + ~time:genesis_time + ~protocol:genesis_protocol + in + let*! v = Context.checkout_exn idx genesis in + let v = Tezos_shell_context.Shell_context.wrap_disk_context v in + f v) + + let genesis_block (context_hash : Context_hash.t) : Store.Block.t = + let block_hash : Block_hash.t = Block_hash.hash_string ["genesis"] in + let genesis : Genesis.t = + {time = genesis_time; block = block_hash; protocol = genesis_protocol} + in + let repr : Block_repr.t = + Block_repr.create_genesis_block ~genesis context_hash + in + Store.Unsafe.block_of_repr repr +end + +let create_prevalidation + (module Mock_protocol : Tezos_protocol_environment.PROTOCOL + with type operation_data = unit + and type operation_receipt = unit + and type validation_state = unit) ctxt = + let module Chain_store : + Internal_for_tests.CHAIN_STORE with type chain_store = unit = struct + type chain_store = unit + + let context () _block : Tezos_protocol_environment.Context.t tzresult Lwt.t + = + Lwt_result_syntax.return ctxt + + let chain_id () = Init.chain_id + end in + let module Prevalidation_t = + Internal_for_tests.Make (Chain_store) (Mock_protocol) + in + (module Prevalidation_t : Prevalidation.T + with type operation_receipt = unit + and type validation_state = unit + and type chain_store = Chain_store.chain_store) + +let now () = Time.System.to_protocol (Tezos_base.Time.System.now ()) + +(** The value of [chain_store] used in all tests below. *) +let chain_store = () + +(** Test that [create] returns [Ok] in a pristine context. *) +let test_create ctxt = + let open Lwt_result_syntax in + let live_operations = Operation_hash.Set.empty in + let timestamp : Time.Protocol.t = now () in + let (module Prevalidation) = + create_prevalidation (module Mock_protocol) ctxt + in + let predecessor : Store.Block.t = + Init.genesis_block @@ Context_ops.hash ~time:timestamp ctxt + in + let* _ = + Prevalidation.create chain_store ~predecessor ~live_operations ~timestamp () + in + return_unit + +(** A generator of [Prevalidation.operation] values that make sure + to return distinct operations (hashes are not fake and they are + all different). Returned maps are exactly of size [n]. *) +let prevalidation_operations_gen (type a) + (module P : Prevalidation.T with type protocol_operation = a) ~(n : int) : + a Prevalidation.operation list QCheck2.Gen.t = + let mk_operation (hash, (raw : Operation.t)) : + P.protocol_operation Prevalidation.operation = + match P.parse hash raw with + | Ok x -> x + | Error err -> + Format.printf "%a" Error_monad.pp_print_trace err ; + assert false + in + let open QCheck2.Gen in + (* We need to specify the protocol bytes generator to always generate the + empty string, otherwise the call to [P.parse] will fail with the + bytes being too long (hereby looking like an attack). *) + let proto_gen : string QCheck2.Gen.t = QCheck2.Gen.return "" in + let+ (ops : Operation.t Operation_hash.Map.t) = + Generators.raw_op_map_gen_n ~proto_gen ?block_hash_t:None n + in + List.map mk_operation (Operation_hash.Map.bindings ops) + +(** The number of operations used by tests that follow *) +let nb_ops = 100 + +let mk_ops (type a) + (module P : Prevalidation.T with type protocol_operation = a) : + a Prevalidation.operation list = + let ops = + QCheck2.Gen.generate1 (prevalidation_operations_gen (module P) ~n:nb_ops) + in + assert (Compare.List_length_with.(ops = nb_ops)) ; + ops + +(** Test that [Prevalidation.apply_operations] only returns [Branch_delayed _] + when the protocol's [apply_operation] crashes. *) +let test_apply_operation_crash ctxt = + let open Lwt_result_syntax in + let live_operations = Operation_hash.Set.empty in + let timestamp : Time.Protocol.t = now () in + let (module P) = create_prevalidation (module Mock_protocol) ctxt in + let ops : P.protocol_operation Prevalidation.operation list = + mk_ops (module P) + in + let predecessor : Store.Block.t = + Init.genesis_block @@ Context_ops.hash ~time:timestamp ctxt + in + let* pv = P.create chain_store ~predecessor ~live_operations ~timestamp () in + let apply_op pv op = + let*! application_result = P.apply_operation pv op in + match application_result with + | Applied _ | Branch_refused _ | Refused _ | Outdated _ -> + (* These cases should not happen because + [Mock_protocol.apply_operation] is [assert false]. *) + assert false + | Branch_delayed _ -> + (* This is the only allowed case. *) + Lwt.return pv + in + let*! _ = List.fold_left_s apply_op pv ops in + return_unit + +(** Logical implication *) +let ( ==> ) a b = (not a) || b + +(** Returns a random generator initialized with a seed from [QCheck2] *) +let mk_rand () = + (* We use QCheck2 as the source of randomness, as we hope one day + this will become a traditional QCheck2 test. *) + QCheck2.Gen.generate ~n:8 QCheck2.Gen.int + |> Array.of_list |> Random.State.make + +(** [mk_live_operations rand ops] returns a subset of [ops], which is + appropriate for being passed as the [live_operations] argument + of [Prevalidation.create] *) +let mk_live_operations (type a) rand (ops : a Prevalidation.operation list) = + List.fold_left + (fun acc (op : _ Prevalidation.operation) -> + if Random.State.bool rand then + Operation_hash.Set.add + (Internal_for_tests.to_raw op |> Operation.hash) + acc + else acc) + Operation_hash.Set.empty + ops + +(** Test that [Prevalidation.apply_operations] returns [Outdated] + for operations in [live_operations] *) +let test_apply_operation_live_operations ctxt = + let open Lwt_result_syntax in + let timestamp : Time.Protocol.t = now () in + let rand : Random.State.t = mk_rand () in + let (module Protocol : Tezos_protocol_environment.PROTOCOL + with type operation_data = unit + and type operation_receipt = unit + and type validation_state = unit + and type application_state = unit) = + (module struct + include Mock_protocol + + let apply_operation _ _ _ = + Lwt.return + (if Random.State.bool rand then Ok ((), ()) + else error_with "Operation doesn't apply") + end) + in + let (module P) = create_prevalidation (module Protocol) ctxt in + let ops : P.protocol_operation Prevalidation.operation list = + mk_ops (module P) + in + let live_operations : Operation_hash.Set.t = mk_live_operations rand ops in + let predecessor : Store.Block.t = + Init.genesis_block @@ Context_ops.hash ~time:timestamp ctxt + in + let* pv = P.create chain_store ~predecessor ~live_operations ~timestamp () in + let op_in_live_operations op = + Operation_hash.Set.mem + (Internal_for_tests.to_raw op |> Operation.hash) + live_operations + in + let apply_op pv (op : _ Prevalidation.operation) = + let*! application_result = P.apply_operation pv op in + let next_pv, result_is_outdated = + match application_result with + | Applied (next_pv, _receipt) -> (next_pv, false) + | Outdated _ -> (pv, true) + | Branch_delayed _ | Branch_refused _ | Refused _ -> (pv, false) + in + (* Here is the main check of this test: *) + assert (op_in_live_operations op ==> result_is_outdated) ; + Lwt.return next_pv + in + let*! _ = List.fold_left_s apply_op pv ops in + return_unit + +(** Test that [Prevalidation.apply_operations] makes field [applied] + grow and that it grows only for operations on which the protocol + [apply_operation] returns [Ok]. *) +let test_apply_operation_applied ctxt = + let open Lwt_result_syntax in + let timestamp : Time.Protocol.t = now () in + let rand : Random.State.t = mk_rand () in + let (module Protocol : Tezos_protocol_environment.PROTOCOL + with type operation_data = unit + and type operation_receipt = unit + and type validation_state = unit) = + (module struct + include Mock_protocol + + let apply_operation _ _ _ = + Lwt.return + (if Random.State.bool rand then Ok ((), ()) + else error_with "Operation doesn't apply") + end) + in + let (module P) = create_prevalidation (module Protocol) ctxt in + let ops : P.protocol_operation Prevalidation.operation list = + mk_ops (module P) + in + let live_operations : Operation_hash.Set.t = mk_live_operations rand ops in + let predecessor : Store.Block.t = + Init.genesis_block @@ Context_ops.hash ~time:timestamp ctxt + in + let* pv = P.create chain_store ~predecessor ~live_operations ~timestamp () in + let to_applied = P.Internal_for_tests.to_applied in + let apply_op pv (op : _ Prevalidation.operation) = + let applied_before = to_applied pv in + let*! application_result = P.apply_operation pv op in + let next_pv, result_is_applied = + match application_result with + | Applied (next_pv, _receipt) -> (next_pv, true) + | Branch_delayed _ -> + (* As in [test_apply_operation_crash] *) + (pv, false) + | Outdated _ -> + (* This case can happen, because we specified a non-empty [live_operations] set *) + (pv, false) + | Branch_refused _ | Refused _ -> + (* As in [test_apply_operation_crash], these cases cannot happen. *) + assert false + in + let applied_after = to_applied next_pv in + (* Here is the main check of this test: *) + if result_is_applied then + assert (Stdlib.List.tl applied_after = applied_before) + else + (* Physical equality: intended, the [applied] field should + not be changed in this case. *) + assert (applied_after == applied_before) ; + Lwt.return next_pv + in + let*! _ = List.fold_left_s apply_op pv ops in + return_unit + +let () = + Alcotest_lwt.run + "mempool-prevalidation" + [ + (* Run only those tests with: + dune exec src/lib_shell/test/test_prevalidation_t.exe -- test create '0' *) + ( "create", + [ + Tztest.tztest + "[create] returns Ok" + `Quick + (Init.wrap_tzresult_lwt_disk test_create); + ] ); + (* Run only those tests with: + dune exec src/lib_shell/test/test_prevalidation_t.exe -- test apply_operation '0..2' *) + ( "apply_operation", + [ + Tztest.tztest + "[apply_operation] returns [Branch_delayed] when [apply_operation] \ + from the protocol crashes" + `Quick + (Init.wrap_tzresult_lwt_disk test_apply_operation_crash); + Tztest.tztest + "[apply_operation] returns [Outdated] on operations in \ + [live_operations]" + `Quick + (Init.wrap_tzresult_lwt_disk test_apply_operation_live_operations); + Tztest.tztest + "[apply_operation] makes the [applied] field grow for [Applied] \ + operations (and only for them)" + `Quick + (Init.wrap_tzresult_lwt_disk test_apply_operation_applied); + ] ); + ] + |> Lwt_main.run diff --git a/src/lib_shell/test/legacy_test_prevalidator_classification.ml b/src/lib_shell/test/legacy_test_prevalidator_classification.ml new file mode 100644 index 0000000000000000000000000000000000000000..711abb39a530e58813cf61526983e5aa62669670 --- /dev/null +++ b/src/lib_shell/test/legacy_test_prevalidator_classification.ml @@ -0,0 +1,871 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021-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. *) +(* *) +(*****************************************************************************) + +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the test suite for the legacy mempool, which + is compatible with Kathmandu and therefore usable on Mainnet. + + This file should be removed once Lima has been activated on Mainnet. + + When you modify this file, consider whether you should also change + the ones that test the more recent mempool for Lima and newer + protocols. *) + +(** Testing + ------- + Component: Shell (Legacy prevalidator classification) + Invocation: dune exec src/lib_shell/test/legacy_test_prevalidator_classification.exe + Subject: Unit tests the Prevalidator classification APIs +*) + +open Lib_test.Qcheck2_helpers +module Prevalidation = Legacy_prevalidation +module Classification = Legacy_prevalidator_classification +module Generators = Legacy_generators + +let is_in_mempool oph t = Classification.is_in_mempool oph t <> None + +module Operation_map = struct + let pp_with_trace ppf map = + Format.fprintf + ppf + "[%a]" + (Format.pp_print_list (fun ppf (oph, (op, _tztrace)) -> + Format.fprintf + ppf + "(%a: (%a, ))" + Operation_hash.pp + oph + Operation.pp + op.Prevalidation.raw)) + (Operation_hash.Map.bindings map) + + let pp ppf map = + Format.fprintf + ppf + "[%a]" + (Format.pp_print_list (fun ppf (oph, op) -> + Format.fprintf + ppf + "(%a: %a)" + Operation_hash.pp + oph + Operation.pp + op.Prevalidation.raw)) + (Operation_hash.Map.bindings map) + + (* Uses polymorphic equality on tztraces! *) + let eq = + Operation_hash.Map.equal (fun (o1, t1) (o2, t2) -> + Operation_hash.equal o1.Prevalidation.hash o2.hash && t1 = t2) +end + +type classification_event = + | Add_if_not_present of + Classification.classification * unit Prevalidation.operation + | Remove of Operation_hash.t + | Flush of bool + +let drop oph t = + let open Classification in + let (_ : (unit Prevalidation.operation * classification) option) = + remove oph t + in + () + +let play_event event t = + let open Classification in + match event with + | Add_if_not_present (classification, op) -> + Generators.add_if_not_present classification op t + | Remove oph -> drop oph t + | Flush handle_branch_refused -> + Internal_for_tests.flush ~handle_branch_refused t + +module Extra_generators = struct + open Classification + + (** Generates an [event]. + The operation hash for [Remove] events is generated using + [with_t_operation_gen] with the given [t]. + The classification, hash and operation for [Add_if_not_present] + events are generated independently from [t]. *) + let event_gen t = + let open QCheck2.Gen in + let add_gen = + let+ classification, op = + pair + Generators.classification_gen + (Generators.operation_with_hash_gen ()) + in + Add_if_not_present (classification, op) + in + let remove_gen = + let+ op = Generators.with_t_operation_gen t in + Remove op.Prevalidation.hash + in + let flush_gen = + let+ b = bool in + Flush b + in + (* the weights are chosen so that the total number of classified + operations may grow before the next flush *) + frequency [(20, add_gen); (10, remove_gen); (1, flush_gen)] + + (** Generates a record [t_initial] and a sequence of [events]. + The [t] given to each [event_gen] (used to generate the + operation hash in the case of a [Remove] event) is the [t] + obtained by having applied all previous events to [t_initial]. *) + let t_with_event_sequence_gen = + let open QCheck2.Gen in + let* t = Generators.t_gen in + let t_initial = Internal_for_tests.copy t in + let rec loop acc_gen n = + if n <= 0 then acc_gen + else + let acc = + let+ event = + let+ event = event_gen t in + play_event event t ; + event + and+ tl = acc_gen in + event :: tl + in + loop acc (n - 1) + in + pair (return t_initial) (loop (return []) 100) +end + +let qcheck_eq_true ~actual = + let _ = qcheck_eq' ~pp:Format.pp_print_bool ~expected:true ~actual () in + () + +let qcheck_eq_false ~actual = + let _ = qcheck_eq' ~pp:Format.pp_print_bool ~expected:false ~actual () in + () + +let qcheck_bounded_map_is_empty bounded_map = + let actual = + bounded_map |> Classification.map |> Operation_hash.Map.is_empty + in + qcheck_eq_true ~actual + +(** Computes the set of operation hashes present in fields [refused; outdated; + branch_refused; branch_delayed; prechecked; applied_rev] of [t]. Also checks + that these fields are disjoint. *) +let disjoint_union_classified_fields ?fail_msg (t : unit Classification.t) = + let ( +> ) acc next_set = + if not (Operation_hash.Set.disjoint acc next_set) then + QCheck2.Test.fail_reportf + "Invariant 'The fields: [refused; outdated; branch_refused; \ + branch_delayed; applied] are disjoint' broken by t =@.%a@.%s" + Classification.Internal_for_tests.pp + t + (match fail_msg with None -> "" | Some msg -> "\n" ^ msg ^ "@.") ; + Operation_hash.Set.union acc next_set + in + let to_set = Classification.Internal_for_tests.set_of_bounded_map in + to_set t.refused +> to_set t.outdated +> to_set t.branch_refused + +> to_set t.branch_delayed + +> (Classification.Sized_map.to_seq t.prechecked + |> Seq.map fst |> Operation_hash.Set.of_seq) + +> (Operation_hash.Set.of_list + @@ List.rev_map (fun op -> op.Prevalidation.hash) t.applied_rev) + +(** Checks both invariants of type [Legacy_prevalidator_classification.t]: + - The field [in_mempool] is the set of all operation hashes present + in fields: [refused; outdated; branch_refused; branch_delayed; applied]. + - The fields: [refused; outdated; branch_refused; branch_delayed; applied] + are disjoint. + These invariants are enforced by [Legacy_prevalidator_classification] + **as long as the caller does not [add] an operation which is already + present in [t]**. We use [check_invariants] in tests where we know + this does not happen. + Ensuring that the caller behaves correctly would require unit testing + the [prevalidator] module, which we cannot do at the moment (September + 2021). Instead, we run scenarios which might carry particular risks + of breaking this using [Tezt]. *) +let check_invariants ?fail_msg (t : unit Classification.t) = + let to_set map = + Operation_hash.Map.to_seq map |> Seq.map fst |> Operation_hash.Set.of_seq + in + let expected_in_mempool = disjoint_union_classified_fields ?fail_msg t in + let mempool_as_set = to_set t.in_mempool in + if not (Operation_hash.Set.equal expected_in_mempool mempool_as_set) then + let set_pp ppf set = + set |> Operation_hash.Set.elements + |> Format.fprintf ppf "%a" (Format.pp_print_list Operation_hash.pp) + in + let set1 = Operation_hash.Set.diff expected_in_mempool mempool_as_set in + let set2 = Operation_hash.Set.diff mempool_as_set expected_in_mempool in + let sets_report = + Format.asprintf + "In individual fields but not in [in_mempool]:\n\ + %a@.In [in_mempool] but not individual fields:\n\ + %a@." + set_pp + set1 + set_pp + set2 + in + QCheck2.Test.fail_reportf + "Invariant 'The field [in_mempool] is the set of all operation hashes \ + present in fields: [refused; outdated; branch_refused; branch_delayed; \ + applied]' broken by t =@.%a\n\ + @.%s@.%a@.%s" + Classification.Internal_for_tests.pp + t + sets_report + Classification.Internal_for_tests.pp_t_sizes + t + (match fail_msg with + | None -> "" + | Some msg -> Format.sprintf "\n%s@." msg) + +let classification_pp pp classification = + Format.fprintf + pp + (match classification with + | `Applied -> "Applied" + | `Prechecked -> "Prechecked" + | `Branch_delayed _ -> "Branch_delayed" + | `Branch_refused _ -> "Branch_refused" + | `Refused _ -> "Refused" + | `Outdated _ -> "Outdated") + +let event_pp pp = function + | Add_if_not_present (classification, op) -> + Format.fprintf + pp + "Add_if_not_present %a %a" + classification_pp + classification + Operation_hash.pp + op.Prevalidation.hash + | Remove oph -> Format.fprintf pp "Remove %a" Operation_hash.pp oph + | Flush handle_branch_refused -> + Format.fprintf pp "Flush ~handle_branch_refused:%b" handle_branch_refused + +let test_flush_empties_all_except_refused_and_outdated = + let open QCheck2 in + Test.make + ~name: + "[flush ~handle_branch_refused:true] empties everything except [refused] \ + and [outdated]" + Generators.t_gen + @@ fun t -> + let refused_before = t.refused |> Classification.map in + let outdated_before = t.outdated |> Classification.map in + Classification.Internal_for_tests.flush ~handle_branch_refused:true t ; + let refused_after = t.refused |> Classification.map in + let outdated_after = t.outdated |> Classification.map in + qcheck_bounded_map_is_empty t.branch_refused ; + qcheck_bounded_map_is_empty t.branch_delayed ; + qcheck_eq_true ~actual:(t.applied_rev = []) ; + qcheck_eq' + ~pp:Operation_map.pp_with_trace + ~eq:Operation_map.eq + ~expected:refused_before + ~actual:refused_after + () + && qcheck_eq' + ~pp:Operation_map.pp_with_trace + ~eq:Operation_map.eq + ~expected:outdated_before + ~actual:outdated_after + () + +let test_flush_empties_all_except_refused_and_branch_refused = + let open QCheck2 in + Test.make + ~name: + "[flush ~handle_branch_refused:false] empties everything except \ + [refused], [outdated] and [branch_refused]" + Generators.t_gen + @@ fun t -> + let refused_before = t.refused |> Classification.map in + let outdated_before = t.outdated |> Classification.map in + let branch_refused_before = t.branch_refused |> Classification.map in + Classification.Internal_for_tests.flush ~handle_branch_refused:false t ; + let refused_after = t.refused |> Classification.map in + let outdated_after = t.outdated |> Classification.map in + let branch_refused_after = t.branch_refused |> Classification.map in + let _ = + qcheck_eq' + ~pp:Operation_map.pp_with_trace + ~eq:Operation_map.eq + ~expected:branch_refused_before + ~actual:branch_refused_after + () + in + qcheck_bounded_map_is_empty t.branch_delayed ; + qcheck_eq_true ~actual:(t.applied_rev = []) ; + qcheck_eq' + ~pp:Operation_map.pp_with_trace + ~eq:Operation_map.eq + ~expected:refused_before + ~actual:refused_after + () + && qcheck_eq' + ~pp:Operation_map.pp_with_trace + ~eq:Operation_map.eq + ~expected:outdated_before + ~actual:outdated_after + () + +let test_is_in_mempool_remove = + let open QCheck2 in + Test.make + ~name:"[is_in_mempool] and [remove_*] are well-behaved" + Generators.(Gen.pair t_with_operation_gen unrefused_classification_gen) + @@ fun ((t, op), unrefused_classification) -> + Classification.add unrefused_classification op t ; + let oph = op.Prevalidation.hash in + qcheck_eq_true ~actual:(is_in_mempool oph t) ; + drop oph t ; + qcheck_eq_false ~actual:(is_in_mempool oph t) ; + true + +let test_is_applied = + let open QCheck2 in + Test.make + ~name:"[is_applied] is well-behaved" + Generators.(Gen.pair t_gen (operation_with_hash_gen ())) + @@ fun (t, op) -> + Classification.add `Applied op t ; + let oph = op.Prevalidation.hash in + qcheck_eq_true ~actual:(is_in_mempool oph t) ; + match Classification.remove oph t with + | None -> false + | Some (_op, classification) -> + qcheck_eq_true ~actual:(classification = `Applied) ; + qcheck_eq_false ~actual:(is_in_mempool oph t) ; + true + +let test_invariants = + let open QCheck2 in + Test.make + ~name: + "invariants are preserved through any sequence of events (provided we do \ + not [add] already present operations)" + Extra_generators.t_with_event_sequence_gen + @@ fun (t, events) -> + let _ = + List.fold_left + (fun (fail_msg, cnt) event -> + play_event event t ; + let fail_msg = + Format.asprintf "%s\n%3d - %a" fail_msg cnt event_pp event + in + check_invariants ~fail_msg t ; + (fail_msg, cnt + 1)) + ("Sequence of events played:", 0) + events + in + true + +module Unparsable = struct + (** Tests the relationship between [Classification.add_unparsable] + and [Classification.is_known_unparsable] *) + let test_add_is_known = + let open QCheck2 in + Test.make + ~name:"[is_known_unparsable oph (add_unparsable oph t)] holds" + Generators.(t_with_operation_gen) + @@ fun (t, op) -> + let oph = op.Prevalidation.hash in + Classification.add_unparsable oph t ; + qcheck_eq_true ~actual:(Classification.is_known_unparsable oph t) ; + true + + (** Tests the relationship between [flush] and + [Classification.is_known_unparsable]. This test shows that + flushing does not put any previously classified operations into + the [unparsable] field. *) + let test_flush_is_known = + let open QCheck2 in + Test.make + ~name:"[is_known_unparsable _ (flush t)] does not hold" + (Gen.pair Generators.t_with_operation_gen Gen.bool) + @@ fun ((t, op), handle_branch_refused) -> + let oph = op.Prevalidation.hash in + Classification.Internal_for_tests.flush ~handle_branch_refused t ; + qcheck_eq_false ~actual:(Classification.is_known_unparsable oph t) ; + true +end + +module Bounded = struct + type binding = unit Prevalidation.operation + + type custom = + unit Classification.t + * [ `Branch_delayed of tztrace + | `Branch_refused of tztrace + | `Refused of tztrace + | `Outdated of tztrace ] + * binding list + * binding list + + let custom_print : custom QCheck2.Print.t = + fun (t, classification, first_bindings, other_bindings) -> + let classification_string = + match classification with + | `Branch_delayed _ -> "Branch_delayed " + | `Branch_refused _ -> "Branch_refused " + | `Refused _ -> "Refused " + | `Outdated _ -> "Outdated " + in + let binding_pp ppf bindings = + bindings + |> List.map (fun value -> value.Prevalidation.hash) + |> Format.pp_print_list Operation_hash.pp ppf + in + Format.asprintf + "Legacy_prevalidator_classification.t:@.%a@.Classification:@.%s@.First \ + bindings:@.%a@.Other bindings:@.%a" + Classification.Internal_for_tests.pp + t + classification_string + binding_pp + first_bindings + binding_pp + other_bindings + + let custom_gen (discarded_operations_rev : Operation_hash.t list ref) : + custom QCheck2.Gen.t = + let open QCheck2.Gen in + let* map_size_limit = 1 -- 20 in + let on_discarded_operation oph = + discarded_operations_rev := oph :: !discarded_operations_rev + in + let parameters = Classification.{map_size_limit; on_discarded_operation} in + let* size = 0 -- map_size_limit in + let* inputs = + list_repeat + size + Generators.(pair classification_gen (operation_with_hash_gen ())) + in + let t = Classification.create parameters in + List.iter + (fun (classification, operation) -> + Classification.add classification operation t) + inputs ; + let+ error_classification = + oneofl [`Branch_delayed []; `Branch_refused []; `Refused []; `Outdated []] + and+ first_bindings = + list_size (1 -- 10) Generators.(operation_with_hash_gen ()) + and+ other_bindings = + list_repeat map_size_limit Generators.(operation_with_hash_gen ()) + in + (t, error_classification, first_bindings, other_bindings) + + let add_ops ops classification t = + List.iter (fun op -> Classification.add classification op t) ops + + let check_discarded_contains_ops ~discarded_hashes ~ops = + let excess_hashes = List.map (fun op -> op.Prevalidation.hash) ops in + if + not + (List.for_all + (fun excess_hash -> + List.mem ~equal:Operation_hash.equal excess_hash discarded_hashes) + excess_hashes) + then + let hashes_pp = Format.pp_print_list Operation_hash.pp in + QCheck2.Test.fail_reportf + "Expected all excess hashes to have been discarded but it was \ + not.@.Excess hashes:@.%a@.Discarded hashes:@.%a" + hashes_pp + excess_hashes + hashes_pp + discarded_hashes + + let check_map_is_full ~expected_size ~bounded_map = + if + Compare.List_length_with.( + Operation_hash.Map.bindings (Classification.map bounded_map) + <> expected_size) + then + QCheck2.Test.fail_reportf + "Expected bounded_map to be full (size = %i) but its actual size is \ + %i.@.Bounded_map content:@.%a" + expected_size + (List.length + (Operation_hash.Map.bindings (Classification.map bounded_map))) + Classification.Internal_for_tests.bounded_map_pp + bounded_map + + let test_bounded = + let open QCheck2 in + let discarded_operations_rev = ref [] in + Test.make + ~name: + "When more error operations than the size limit are added, then the \ + first operations are discarded" + ~print:custom_print + (custom_gen discarded_operations_rev) + @@ fun (t, error_classification, first_ops, other_ops) -> + (* We must not have duplicate operation hashes otherwise we may not go over the bound *) + let hashes = + first_ops @ other_ops |> List.map (fun op -> op.Prevalidation.hash) + in + let unique_hashes = Operation_hash.Set.of_list hashes in + QCheck2.assume + Compare.List_length_with.( + hashes = Operation_hash.Set.cardinal unique_hashes) ; + (* Remove all operations for the tested classification *) + let bounded_map = + match error_classification with + | `Branch_delayed _ -> t.branch_delayed + | `Branch_refused _ -> t.branch_refused + | `Refused _ -> t.refused + | `Outdated _ -> t.outdated + in + let () = + Operation_hash.Map.iter + (fun oph _op -> drop oph t) + (Classification.map bounded_map) + in + discarded_operations_rev := [] ; + (* Add the first bindings (the ones that will get discarded once the other bindings are added) *) + add_ops first_ops (error_classification :> Classification.classification) t ; + (* Now add the other bindings that should cause the first ones to get discarded *) + add_ops other_ops (error_classification :> Classification.classification) t ; + (* [add] calls [on_discarded_operation] when adding any [Refused] or + [Outdated] operation, so the recorded discarded operations is a superset + of the [first_bindings] ones. *) + check_discarded_contains_ops + ~discarded_hashes:(!discarded_operations_rev |> List.rev) + ~ops:first_ops ; + check_map_is_full ~expected_size:t.parameters.map_size_limit ~bounded_map ; + true +end + +(** Tests of [Legacy_prevalidator_classification.to_map] *) +module To_map = struct + let map_pp fmt x = + let map_to_list m = + Operation_hash.Map.to_seq m |> Seq.map (fun (_, op) -> op) |> List.of_seq + in + let pp_pair fmt op = + Format.fprintf + fmt + "%a:%a" + Operation_hash.pp + op.Prevalidation.hash + Operation.pp + op.raw + in + Format.fprintf fmt "%a" (Format.pp_print_list pp_pair) (map_to_list x) + + let map_eq = + Operation_hash.Map.equal (fun op1 op2 -> + Operation.equal op1.Prevalidation.raw op2.raw) + + (** [remove_all m1 m2] returns the subset of [m1] thas is not within [m2]. + Said differently, [remove_all m1 m2] removes from [m1] all keys + that are in [m2]. *) + let remove_all m1 m2 = + let keys2 = + Operation_hash.Map.bindings m2 + |> List.map fst |> Operation_hash.Set.of_list + in + Operation_hash.Map.filter + (fun key _val -> not (Operation_hash.Set.mem key keys2)) + m1 + + (** [eq_mod_binding m1 (k, v_opt) m2] holds iff: + + - [m1] equals [m2], or + - [v_opt] is [Some v] and the union of [m1] and [(k,v)] equals [m2], or + - [v_opt] is [None] and the union of [m1] and [(k,v)] equals [m2], + for some unknown value [v]. *) + let eq_mod_op m1 (k, v_opt) m2 = + let diff = remove_all m2 m1 in + match (Operation_hash.Map.bindings diff, v_opt) with + | [], _ -> true + | [(kdiff, vdiff)], Some v + when Operation_hash.equal kdiff k + && Operation.equal v.Prevalidation.raw vdiff.Prevalidation.raw -> + true + | [(kdiff, _)], None when Operation_hash.equal kdiff k -> true + | _ -> false + + (** [to_map_all] calls [Classification.to_map] with all named + arguments set to [true] *) + let to_map_all = + Classification.Internal_for_tests.to_map + ~applied:true + ~prechecked:true + ~branch_delayed:true + ~branch_refused:true + ~refused:true + ~outdated:true + + (** Tests the relationship between [Classification.create] + and [Classification.to_map] *) + let test_create = + let open QCheck2 in + Test.make + ~name:"[to_map_all (create params)] is empty" + Generators.parameters_gen + @@ fun parameters -> + let t = Classification.create parameters in + qcheck_eq' + ~pp:map_pp + ~eq:map_eq + ~expected:Operation_hash.Map.empty + ~actual:(to_map_all t) + () + + (** Tests the relationship between [Classification.add] + and [Classification.to_map] *) + let test_add = + let open QCheck2 in + Test.make + ~name:"[add] extends the size of [to_map] by 0 or 1" + (Gen.pair Generators.t_with_operation_gen Generators.classification_gen) + @@ fun ((t, op), classification) -> + let initial = to_map_all t in + Classification.add classification op t ; + (* We need to use [eq_mod_binding] because it covers the two possible cases: + if [oph] is not in [initial], we have [initial @@ [(oph, op)] = to_map_all t] + if [oph] is in [initial] already, we have [initial = to_map_all t] *) + qcheck_eq' + ~expected:true + ~actual: + (eq_mod_op initial (op.Prevalidation.hash, Some op) (to_map_all t)) + () + + (** Tests the relationship between [Classification.remove] + and [Classification.to_map] *) + let test_remove = + let open QCheck2 in + Test.make + ~name:"[remove] reduces the size of [to_map] by 0 or 1" + Generators.t_with_operation_gen + @@ fun (t, op) -> + let initial = to_map_all t in + drop op.Prevalidation.hash t ; + (* We need to use [eq_mod_binding] because it covers the two possible cases: + if [oph] is not in [initial], we have [initial = to_map_all t] + if [oph] is in [initial], we have [initial = to_map_all t @@ [(oph, op)] ] *) + qcheck_eq' + ~expected:true + ~actual:(eq_mod_op (to_map_all t) (op.Prevalidation.hash, None) initial) + () + + let to_string ((t, op), _classification) = + Format.asprintf + "Starting with:@. %a@.and operation hash %a@. " + Operation_map.pp + (to_map_all t) + Operation_hash.pp + op.Prevalidation.hash + + let test_map_remove_add = + (* Property checked: + + - \forall t oph class, C.to_map (C.remove t oph) + oph = + C.to_map (C.add t oph class) + + where (+)/(-) are add/remove over maps. + + This property is true only if [t] is not full with regard to + the classification of the operation. *) + let open QCheck2 in + Test.make + ~name:"Check property between map, remove and add (1)" + ~count:1000 + ~print:to_string + (Gen.pair + Generators.t_with_operation_gen__cant_be_full + Generators.classification_gen) + @@ fun ((t, op), classification) -> + let t' = Classification.Internal_for_tests.copy t in + drop op.Prevalidation.hash t ; + let initial = to_map_all t in + let left = Operation_hash.Map.add op.Prevalidation.hash op initial in + Classification.add classification op t' ; + let right = to_map_all t' in + qcheck_eq' + ~expected:left + ~actual:right + ~eq: + (Operation_hash.Map.equal (fun op1 op2 -> + Operation_hash.equal op1.Prevalidation.hash op2.hash)) + ~pp:map_pp + () + + let test_map_add_remove = + (* Property checked: + + - \forall t oph class, C.to_map (C.add t oph class) - oph = + C.to_map (C.remove t oph) + + where (+)/(-) are add/remove over maps. + + This property is true only if [t] is not full with regard to + the classification of the operation. *) + let open QCheck2 in + Test.make + ~name:"Check property between map, remove and add (2)" + ~print:to_string + (Gen.pair + Generators.t_with_operation_gen__cant_be_full + Generators.classification_gen) + @@ fun ((t, op), classification) -> + let t' = Classification.Internal_for_tests.copy t in + Classification.add classification op t ; + let initial = to_map_all t in + let oph = op.Prevalidation.hash in + let left = Operation_hash.Map.remove oph initial in + drop oph t' ; + let right = to_map_all t' in + qcheck_eq' + ~expected:left + ~actual:right + ~eq: + (Operation_hash.Map.equal (fun op1 op2 -> + Operation_hash.equal op1.Prevalidation.hash op2.Prevalidation.hash)) + ~pp:map_pp + () + + (** Tests the relationship between [Classification.flush] + and [Classification.to_map] *) + let test_flush = + let open QCheck2 in + Test.make + ~name:"[flush] can be emulated by [to_map ~refused:true ..]" + (Gen.pair Generators.t_gen Gen.bool) + @@ fun (t, handle_branch_refused) -> + let initial = + Classification.Internal_for_tests.to_map + ~applied:false + ~prechecked:false + ~branch_delayed:false + ~branch_refused:(not handle_branch_refused) + ~refused:true + ~outdated:true + t + in + Classification.Internal_for_tests.flush ~handle_branch_refused t ; + let flushed = to_map_all t in + qcheck_eq' ~pp:map_pp ~eq:map_eq ~expected:initial ~actual:flushed () + + (** Tests the relationship between [is_in_mempool] + and [Classification.to_map] *) + let test_is_in_mempool = + let open QCheck2 in + Test.make + ~name:"[is_in_mempool] can be emulated by [to_map]" + Generators.t_with_operation_gen + @@ fun (t, op) -> + let oph = op.Prevalidation.hash in + let is_in_mempool = is_in_mempool oph t in + let map = + to_map_all t |> Operation_hash.Map.filter (fun oph' _ -> oph' = oph) + in + qcheck_eq' + ~expected:is_in_mempool + ~actual:(Operation_hash.Map.cardinal map = 1) + () + + (** Tests that [Classification.to_map] returns an empty map if all parameters + are set to [false] *) + let test_none = + let open QCheck2 in + Test.make + ~name:"[to_map] returns an empty map if all parameters are set to [false]" + Generators.t_gen + @@ fun t -> + qcheck_eq' + ~pp:map_pp + ~eq:map_eq + ~expected:Operation_hash.Map.empty + ~actual: + (Classification.Internal_for_tests.to_map + ~applied:false + ~prechecked:false + ~branch_delayed:false + ~branch_refused:false + ~refused:false + ~outdated:false + t) + () +end + +(** Tests the relationship between [Classification.create] + and [Classification.is_empty] *) +let test_create_is_empty = + let open QCheck2 in + Test.make ~name:"[is_empty (create params)] holds" Generators.parameters_gen + @@ fun parameters -> + let t = Classification.create parameters in + qcheck_eq' ~expected:true ~actual:(Classification.is_empty t) () + +(** Tests that after adding something to a classification, it is not empty. *) +let test_create_add_not_empty = + let open QCheck2 in + Test.make + ~name:"[not (is_empty (add _ _ _ t))] holds" + (Gen.pair Generators.t_with_operation_gen Generators.classification_gen) + @@ fun ((t, op), classification) -> + Classification.add classification op t ; + qcheck_eq' ~expected:false ~actual:(Classification.is_empty t) () + +let () = + let mk_tests label tests = (label, qcheck_wrap tests) in + Alcotest.run + "Legacy_prevalidator_classification" + [ + mk_tests + "flush" + [ + test_flush_empties_all_except_refused_and_outdated; + test_flush_empties_all_except_refused_and_branch_refused; + ]; + mk_tests "is_in_mempool" [test_is_in_mempool_remove]; + mk_tests "is_applied" [test_is_applied]; + mk_tests "unparsable" Unparsable.[test_add_is_known; test_flush_is_known]; + mk_tests "invariants" [test_invariants]; + mk_tests "bounded" [Bounded.test_bounded]; + mk_tests + "to_map" + To_map. + [ + test_create; + test_add; + test_remove; + test_map_remove_add; + test_map_add_remove; + test_flush; + test_is_applied; + test_is_in_mempool; + test_none; + ]; + mk_tests "is_empty" [test_create_is_empty; test_create_add_not_empty]; + ] diff --git a/src/lib_shell/test/legacy_test_prevalidator_classification_operations.ml b/src/lib_shell/test/legacy_test_prevalidator_classification_operations.ml new file mode 100644 index 0000000000000000000000000000000000000000..02f909690eb00244168729ed9271a6421c0273e8 --- /dev/null +++ b/src/lib_shell/test/legacy_test_prevalidator_classification_operations.ml @@ -0,0 +1,610 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021-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. *) +(* *) +(*****************************************************************************) + +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the test suite for the legacy mempool, which + is compatible with Kathmandu and therefore usable on Mainnet. + + This file should be removed once Lima has been activated on Mainnet. + + When you modify this file, consider whether you should also change + the ones that test the more recent mempool for Lima and newer + protocols. *) + +(** Testing + ------- + Component: Shell (Prevalidator) + Invocation: dune exec src/lib_shell/test/test_prevalidator_classification_operations.exe + Subject: Unit tests [Prevalidator_classification.Internal_for_tests.handle_live_operations] + and [Prevalidator_classification.recyle_operations] +*) + +open Lib_test.Qcheck2_helpers +module Op_map = Operation_hash.Map +module Prevalidation = Legacy_prevalidation +module Classification = Legacy_prevalidator_classification +module Generators = Legacy_generators +module Generators_tree = Legacy_generators_tree +module Tree = Generators_tree.Tree +module List_extra = Generators_tree.List_extra +module Block = Generators_tree.Block + +(** Function to unwrap an [option] when it MUST be a [Some] *) +let force_opt ~loc = function + | Some x -> x + | None -> QCheck2.Test.fail_reportf "Unexpected None at %s" loc + +(* Values from [start] (included) to [ancestor] (excluded) *) +let values_from_to ~(equal : 'a -> 'a -> bool) (tree : 'a Tree.tree) + (start : 'a) (ancestor : 'a) : 'a list = + Tree.predecessors ~equal tree start + |> List_extra.take_until_if_found ~pred:(( = ) ancestor) + |> force_opt ~loc:__LOC__ + |> fun preds -> start :: preds + +(** Pretty print values of type [Operation_hash.Set.t] *) +let op_set_pp fmt x = + let set_to_list m = Operation_hash.Set.to_seq m |> List.of_seq in + Format.fprintf + fmt + "%a" + (Format.pp_print_list Operation_hash.pp) + (set_to_list x) + +(** Pretty print values of type [Operation.t Operation_hash.Map] *) +let op_map_pp fmt x = + let pp_pair fmt (hash, op) = + Format.fprintf + fmt + "%a:%a" + Operation_hash.pp + hash + Operation.pp + op.Prevalidation.raw + in + Format.fprintf + fmt + "%a" + (Format.pp_print_list pp_pair) + (Operation_hash.Map.bindings x) + +let qcheck_cond ?pp ~cond e1 e2 () = + if cond e1 e2 then true + else + match pp with + | None -> + QCheck2.Test.fail_reportf + "@[The condition check failed, but no pretty printer was \ + provided.@]" + | Some pp -> + QCheck2.Test.fail_reportf + "@[The condition check failed!@,\ + first element:@,\ + %a@,\ + second element:@,\ + %a@]" + pp + e1 + pp + e2 + +let blocks_to_oph_set (blocks : Operation_hash.t list list list) : + Operation_hash.Set.t = + List.concat blocks |> List.concat |> Operation_hash.Set.of_list + +(** [is_subset m1 m2] returns whether all bindings of [m1] are in [m2]. + In other words, it returns whether [m2] is a superset of [m1]. *) +let is_subset (m1 : unit Prevalidation.operation Op_map.t) + (m2 : unit Prevalidation.operation Op_map.t) = + let rec go (m1_seq : (Operation_hash.t * unit Prevalidation.operation) Seq.t) + = + match m1_seq () with + | Seq.Nil -> true + | Seq.Cons ((m1_key, m1_value), m1_rest) -> ( + match Op_map.find m1_key m2 with + | None -> (* A key in [m1] that is not in [m2] *) false + | Some m2_value -> + Operation_hash.equal + m1_value.Prevalidation.hash + m2_value.Prevalidation.hash + && go m1_rest) + in + go (Op_map.to_seq m1) + +module Handle_operations = struct + (* This is used only if operations are not parsable*) + let dummy_classes = + Classification.( + create {map_size_limit = 1; on_discarded_operation = (fun _oph -> ())}) + + let parse raw hash = + Some (Prevalidation.Internal_for_tests.make_operation hash raw ()) + + (** Test that operations returned by [handle_live_operations] + are all in the alive branch. *) + let test_handle_live_operations_is_branch_alive = + (* Like [Generators.chain_tools_gen], but also picks a random subset of + blocks from the tree to pass an interesting value to [is_branch_alive]. + Could be in [chain_tools_gen] itself, but only used in this test. So + it would be overkill. *) + let gen = + let open QCheck2.Gen in + let* tree, pair_blocks_opt, old_mempool = + Generators_tree.tree_gen ?blocks:None () + in + let* live_blocks = sublist (Tree.values tree) in + let live_blocks = + List.map (fun (blk : Block.t) -> blk.hash) live_blocks + in + return + (tree, pair_blocks_opt, old_mempool, Block_hash.Set.of_list live_blocks) + in + QCheck2.Test.make + ~name:"[handle_live_operations] is a subset of alive blocks" + gen + @@ fun (tree, pair_blocks_opt, old_mempool, live_blocks) -> + QCheck2.assume @@ Option.is_some pair_blocks_opt ; + let from_branch, to_branch = force_opt ~loc:__LOC__ pair_blocks_opt in + let chain = Generators_tree.classification_chain_tools tree in + let expected_superset : unit Prevalidation.operation Op_map.t = + (* Take all blocks *) + Tree.values tree + (* Keep only the ones in live_blocks *) + |> List.to_seq + |> Seq.filter (fun (blk : Block.t) -> + Block_hash.Set.mem blk.hash live_blocks) + (* Then extract (oph, op) pairs from them *) + |> Seq.flat_map (fun (blk : Block.t) -> List.to_seq blk.operations) + |> Seq.flat_map List.to_seq + |> Seq.map (fun op -> (op.Prevalidation.hash, op)) + |> Op_map.of_seq + in + let actual : unit Prevalidation.operation Op_map.t = + Classification.Internal_for_tests.handle_live_operations + ~classes:dummy_classes + ~block_store:Block.tools + ~chain + ~from_branch + ~to_branch + ~is_branch_alive:(fun blk_hash -> + Block_hash.Set.mem blk_hash live_blocks) + ~parse + old_mempool + |> Lwt_main.run + in + qcheck_cond ~pp:op_map_pp ~cond:is_subset actual expected_superset () + + (** Test that operations returned by [handle_live_operations] is + the union of 1/ operations from its last argument (a map) and 2/ + operations on the "path" between [from_branch] and [to_branch] (when + all blocks are considered live). *) + let test_handle_live_operations_path_spec = + QCheck2.Test.make + ~name:"[handle_live_operations] path specification" + (Generators_tree.tree_gen ()) + @@ fun (tree, pair_blocks_opt, _) -> + QCheck2.assume @@ Option.is_some pair_blocks_opt ; + let from_branch, to_branch = force_opt ~loc:__LOC__ pair_blocks_opt in + let chain = Generators_tree.classification_chain_tools tree in + let equal = Block.equal in + let ancestor : Block.t = + Tree.find_ancestor ~equal tree from_branch to_branch + |> force_opt ~loc:__LOC__ + in + (* Operations from [start] (included) to [ancestor] (excluded). + [ancestor] should be the ancestor of [start]. *) + let operations_on_path start ancestor = + List.map + Block.tools.all_operation_hashes + (values_from_to ~equal tree start ancestor) + |> blocks_to_oph_set + in + let expected_superset = operations_on_path from_branch ancestor in + let from_ancestor_to_to_branch = operations_on_path to_branch ancestor in + (* Expected operations are the ones from [ancestor] to [from_branch], + minus the ones from ancestor to [to_branch]. *) + let expected = + Operation_hash.Set.diff expected_superset from_ancestor_to_to_branch + in + let actual = + Classification.Internal_for_tests.handle_live_operations + ~classes:dummy_classes + ~block_store:Block.tools + ~chain + ~from_branch + ~to_branch + ~is_branch_alive:(Fun.const true) + ~parse + Operation_hash.Map.empty + |> Lwt_main.run |> Op_map.bindings |> List.map fst + |> Operation_hash.Set.of_list + in + qcheck_eq' ~pp:op_set_pp ~eq:Operation_hash.Set.equal ~expected ~actual () + + (** Test that operations cleared by [handle_live_operations] + are operations on the path from [ancestor] to [to_branch] (when all + operations are deemed up-to-date). *) + let test_handle_live_operations_clear = + QCheck2.Test.make + ~name:"[handle_live_operations] clear approximation" + Generators_tree.(tree_gen ()) + @@ fun (tree, pair_blocks_opt, old_mempool) -> + QCheck2.assume @@ Option.is_some pair_blocks_opt ; + let from_branch, to_branch = force_opt ~loc:__LOC__ pair_blocks_opt in + let chain = Generators_tree.classification_chain_tools tree in + let cleared = ref Operation_hash.Set.empty in + let clearer oph = cleared := Operation_hash.Set.add oph !cleared in + let chain = {chain with clear_or_cancel = clearer} in + let equal = Block.equal in + let ancestor : Block.t = + Tree.find_ancestor ~equal tree from_branch to_branch + |> force_opt ~loc:__LOC__ + in + let expected_superset = + List.map + Block.tools.all_operation_hashes + (values_from_to ~equal tree to_branch ancestor) + |> blocks_to_oph_set + in + Classification.Internal_for_tests.handle_live_operations + ~classes:dummy_classes + ~block_store:Block.tools + ~chain + ~from_branch + ~to_branch + ~is_branch_alive:(Fun.const true) + ~parse + old_mempool + |> Lwt_main.run |> ignore ; + qcheck_cond + ~pp:op_set_pp + ~cond:Operation_hash.Set.subset + !cleared + expected_superset + () + + (** Test that operations injected by [handle_live_operations] + are operations on the path from [ancestor] to [from_branch]. *) + let test_handle_live_operations_inject = + QCheck2.Test.make + ~name:"[handle_live_operations] inject approximation" + (Generators_tree.tree_gen ()) + @@ fun (tree, pair_blocks_opt, old_mempool) -> + QCheck2.assume @@ Option.is_some pair_blocks_opt ; + let from_branch, to_branch = force_opt ~loc:__LOC__ pair_blocks_opt in + let chain = Generators_tree.classification_chain_tools tree in + let injected = ref Operation_hash.Set.empty in + let inject_operation oph _op = + injected := Operation_hash.Set.add oph !injected ; + Lwt.return_unit + in + let chain = {chain with inject_operation} in + let equal = Block.equal in + let ancestor : Block.t = + Tree.find_ancestor ~equal tree from_branch to_branch + |> force_opt ~loc:__LOC__ + in + let expected_superset = + List.map + Block.tools.all_operation_hashes + (values_from_to ~equal tree from_branch ancestor) + |> blocks_to_oph_set + in + Classification.Internal_for_tests.handle_live_operations + ~classes:dummy_classes + ~block_store:Block.tools + ~chain + ~from_branch + ~to_branch + ~is_branch_alive:(Fun.const true) + ~parse + old_mempool + |> Lwt_main.run |> ignore ; + qcheck_cond + ~pp:op_set_pp + ~cond:Operation_hash.Set.subset + !injected + expected_superset + () +end + +module Recyle_operations = struct + (** A generator of {!Classification.t} that uses + the given operations and hashes. It is used in place + of {!Prevalidator_generators.t_gen} because we need to + control the operations and hashes used (because we want them + to be distinct from the one in the tree of blocks). This + generator generates classifications that contains all the + given operations and hashes, spreading them among the different + classes of {!Legacy_prevalidator_classification.t}. This generator is NOT + a fully random generator like {!Prevalidator_generators.t_gen}. *) + let classification_of_ops_gen (ops : unit Prevalidation.operation Op_map.t) : + unit Classification.t QCheck2.Gen.t = + let open QCheck2.Gen in + let ops = Operation_hash.Map.bindings ops |> List.map snd in + let length = List.length ops in + let* empty_space = 0 -- 100 in + (* To avoid throwing part of [ops], we want the capacity of the classification + to be equal or larger than [length], hence: *) + let map_size_limit = length + empty_space in + (* Because capacity must be > 0 in Ring.create: *) + let map_size_limit = max 1 map_size_limit in + let parameters : Classification.parameters = + {map_size_limit; on_discarded_operation = Fun.const ()} + in + let* classes = list_repeat length Generators.classification_gen in + assert (List.compare_length_with classes length = 0) ; + let t = Classification.create parameters in + List.iter + (fun (classification, op) -> + Generators.add_if_not_present classification op t) + (List.combine_drop classes ops) ; + return t + + (** Returns data to test {!Classification.recyle_operations}: + - an instance of [block chain_tools] + - the tree of blocks + - a pair of blocks (that belong to the tree) and is + fine for being passed as [(~from_branch, ~to_branch)]; i.e. + the two blocks have a common ancestor. + - a classification + - a list of pending operations + + As in production, the following lists of operations are disjoint: + operations in the blocks, classification, and pending list. Note + that this is not a precondition of [recycle_operations], it's + to test the typical use case. *) + let gen = + let open QCheck2.Gen in + let* blocks = Generators_tree.unique_nonempty_block_gen in + let blocks = Block.set_to_list blocks in + assert (blocks <> []) ; + let to_ops (blk : Block.t) = List.concat blk.operations in + let oph_op_list_to_map l = List.to_seq l |> Op_map.of_seq in + let blocks_ops = + List.concat_map to_ops blocks + |> List.map (fun op -> (op.Prevalidation.hash, op)) + |> oph_op_list_to_map + in + let blocks_hashes = List.map Block.to_hash blocks in + let block_hash_t = + (* For classification and pending, put 50% of them in live_blocks. + For the remaining 50%, generate branch randomly, so likely outside + live_blocks. *) + frequency [(1, Generators.block_hash_gen); (1, oneofl blocks_hashes)] + in + let* classification_pendings_ops = + (* For classification and pending, we want operations that are NOT in + the blocks already. Hence: *) + Generators.op_map_gen ~block_hash_t () + in + let classification_pendings_ops = + Op_map.filter + (fun oph _ -> not (Op_map.mem oph blocks_ops)) + classification_pendings_ops + in + let* classification_ops, pending_ops = + Op_map.bindings classification_pendings_ops + |> Generators_tree.split_in_two + in + let classification_ops = oph_op_list_to_map classification_ops in + let pending_ops = oph_op_list_to_map pending_ops in + let* tree, from_to, _ = Generators_tree.tree_gen ~blocks () in + let+ classification = classification_of_ops_gen classification_ops in + (tree, from_to, classification, pending_ops) + + (** Test that {!Classification.recycle_operations} returns an empty map when + live blocks are empty. + + We do not lift the test + {!Handle_operations.test_handle_live_operations_is_branch_alive} + to [recycle_operations] (checking that operations returned by + [recycle_operations] are all in [live_blocks]), because we have + to account for operations in [classification] and [pending], and + we don't have the assumption that their branch are disjoint from + each other and from branches in [tree] (because generation + is partly random for them). This makes lifting + the [handle_operations] test quite heavy. We don't do that. *) + let test_recycle_operations_empty_live_blocks = + let open QCheck2 in + Test.make + ~name:"[recycle_operations ~live_blocks:empty] is empty" + Gen.(pair gen bool) + @@ fun ((tree, pair_blocks_opt, classes, pending), handle_branch_refused) -> + assume @@ Option.is_some pair_blocks_opt ; + let from_branch, to_branch = force_opt ~loc:__LOC__ pair_blocks_opt in + let chain = Generators_tree.classification_chain_tools tree in + let parse raw hash = + Some (Prevalidation.Internal_for_tests.make_operation hash raw ()) + in + let actual : unit Prevalidation.operation Op_map.t = + Classification.recycle_operations + ~block_store:Block.tools + ~chain + ~from_branch + ~to_branch + ~live_blocks:Block_hash.Set.empty + ~classes + ~pending + ~handle_branch_refused + ~parse + |> Lwt_main.run + in + qcheck_eq' ~pp:op_map_pp ~actual ~expected:Op_map.empty () + + (** Test that the value returned by {!Classification.recycle_operations} + can be approximated by unioning the sets of values: + - returned by {!Classification.Internal_for_tests.handle_live_operations} + - classified in the classification data structure + - sent as [pending]. *) + let test_recycle_operations_returned_value_spec = + QCheck2.Test.make + ~name:"[recycle_operations] returned value can be approximated" + QCheck2.Gen.(pair gen bool) + @@ fun ((tree, pair_blocks_opt, classes, pending), handle_branch_refused) -> + QCheck2.assume @@ Option.is_some pair_blocks_opt ; + let from_branch, to_branch = force_opt ~loc:__LOC__ pair_blocks_opt in + let chain = Generators_tree.classification_chain_tools tree in + let equal = Block.equal in + let ancestor : Block.t = + Tree.find_ancestor ~equal tree from_branch to_branch + |> force_opt ~loc:__LOC__ + in + let live_blocks : Block_hash.Set.t = + Tree.values tree |> List.map Block.to_hash |> Block_hash.Set.of_list + in + (* This is inherited from the behavior of [handle_live_operations] *) + let expected_from_tree : Operation_hash.Set.t = + List.map + Block.tools.all_operation_hashes + (values_from_to ~equal tree from_branch ancestor) + |> blocks_to_oph_set + in + (* This is coming from [recycle_operations] itself *) + let op_map_to_hash_list (m : 'a Operation_hash.Map.t) = + Op_map.bindings m |> List.map fst |> Operation_hash.Set.of_list + in + let expected_from_classification = + Classification.Internal_for_tests.to_map + ~applied:true + ~prechecked:true + ~branch_delayed:true + ~branch_refused:handle_branch_refused + ~refused:false + ~outdated:false + classes + |> op_map_to_hash_list + in + let expected_from_pending = op_map_to_hash_list pending in + let expected_superset : Operation_hash.Set.t = + Operation_hash.Set.union + (Operation_hash.Set.union + expected_from_tree + expected_from_classification) + expected_from_pending + in + let parse raw hash = + Some (Prevalidation.Internal_for_tests.make_operation hash raw ()) + in + let actual : Operation_hash.Set.t = + Classification.recycle_operations + ~block_store:Block.tools + ~chain + ~from_branch + ~to_branch + ~live_blocks + ~classes + ~pending + ~handle_branch_refused + ~parse + |> Lwt_main.run |> Op_map.bindings |> List.map fst + |> Operation_hash.Set.of_list + in + qcheck_cond + ~pp:op_set_pp + ~cond:Operation_hash.Set.subset + actual + expected_superset + () + + (** Test that the classification is appropriately trimmed + by {!Classification.recycle_operations} *) + let test_recycle_operations_classification = + QCheck2.Test.make + ~name:"[recycle_operations] correctly trims its input classification" + QCheck2.Gen.(pair gen bool) + @@ fun ((tree, pair_blocks_opt, classes, pending), handle_branch_refused) -> + QCheck2.assume @@ Option.is_some pair_blocks_opt ; + let live_blocks : Block_hash.Set.t = + Tree.values tree |> List.map Block.to_hash |> Block_hash.Set.of_list + in + let expected : unit Prevalidation.operation Op_map.t = + Classification.Internal_for_tests.to_map + ~applied:false + ~prechecked:false + ~branch_delayed:false + ~branch_refused:(not handle_branch_refused) + ~refused:true + ~outdated:true + classes + in + let from_branch, to_branch = force_opt ~loc:__LOC__ pair_blocks_opt in + let chain = Generators_tree.classification_chain_tools tree in + let parse raw hash = + Some (Prevalidation.Internal_for_tests.make_operation hash raw ()) + in + let () = + Classification.recycle_operations + ~block_store:Block.tools + ~chain + ~from_branch + ~to_branch + ~live_blocks + ~classes + ~pending + ~handle_branch_refused + ~parse + |> Lwt_main.run |> ignore + in + let actual = + Classification.Internal_for_tests.to_map + ~applied:true + ~prechecked:true + ~branch_delayed:true + ~branch_refused:true + ~refused:true + ~outdated:true + classes + in + qcheck_eq' ~pp:op_map_pp ~expected ~actual () +end + +let () = + Alcotest.run + "Legacy_prevalidator" + [ + (* Run only those tests with: + dune exec src/lib_shell/test/test_prevalidator_classification_operations.exe -- test 'handle_operations' *) + ( "handle_operations", + qcheck_wrap + Handle_operations. + [ + test_handle_live_operations_is_branch_alive; + test_handle_live_operations_path_spec; + test_handle_live_operations_clear; + test_handle_live_operations_inject; + ] ); + (* Run only first two tests (for example) with: + dune exec src/lib_shell/test/test_prevalidator_classification_operations.exe -- test 'recycle_operations' '0..2'*) + ( "recycle_operations", + qcheck_wrap + Recyle_operations. + [ + test_recycle_operations_empty_live_blocks; + test_recycle_operations_returned_value_spec; + test_recycle_operations_classification; + ] ); + ] diff --git a/src/lib_shell/test/legacy_test_prevalidator_pending_operations.ml b/src/lib_shell/test/legacy_test_prevalidator_pending_operations.ml new file mode 100644 index 0000000000000000000000000000000000000000..66642ac83a5c6c19e379358adbc4397051dc03b3 --- /dev/null +++ b/src/lib_shell/test/legacy_test_prevalidator_pending_operations.ml @@ -0,0 +1,167 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the test suite for the legacy mempool, which + is compatible with Kathmandu and therefore usable on Mainnet. + + This file should be removed once Lima has been activated on Mainnet. + + When you modify this file, consider whether you should also change + the ones that test the more recent mempool for Lima and newer + protocols. *) + +(** Testing + ------- + Component: Shell (Legacy prevalidator pending operations) + Invocation: dune exec src/lib_shell/test/legacy_test_prevalidator_pending_operations.exe + Subject: Unit tests the Prevalidator pending operations APIs +*) + +open Lib_test.Qcheck2_helpers +module Prevalidation = Legacy_prevalidation +module Pending_ops = Legacy_prevalidator_pending_operations +module Generators = Legacy_generators +module CompareListQ = Compare.List (Q) + +let pending_of_list = + List.fold_left + (fun pendings (op, priority) -> + if + Operation_hash.Set.mem + (Prevalidation.Internal_for_tests.hash_of op) + (Pending_ops.hashes pendings) + then (* no duplicate hashes *) + pendings + else Pending_ops.add op priority pendings) + Pending_ops.empty + +(* 1. Test iterators ordering *) + +let test_iterators_ordering ~name ~iterator return_value = + let open QCheck2 in + Test.make + ~name: + (Format.sprintf + "Ensure that %s returns operations in their priority ordering" + name) + (Gen.small_list (Generators.operation_with_hash_and_priority_gen ())) + @@ fun ops -> + let previous_priority = ref `High in + let previous_prio_ok ~priority ~previous_priority = + match (previous_priority, priority) with + | `High, `High -> true + | (`High | `Medium), `Medium -> true + | (`High | `Medium), `Low _ -> true + | `Low q_prev, `Low q_new -> CompareListQ.(q_new <= q_prev) + | _, _ -> false + in + iterator + (fun priority _hash _op () -> + (* Here, we check the priority ordering in the iterators of + prevalidator_pending_operations module : if the current considered + priority is `High, it should be true that the previously seen is also + `High. *) + if not @@ previous_prio_ok ~priority ~previous_priority:!previous_priority + then + QCheck.Test.fail_reportf + "Pending operations are not ordered by priority" ; + previous_priority := priority ; + return_value) + (pending_of_list ops) + () + |> fun _ -> true + +let test_iter_ordering = + test_iterators_ordering + ~name:"iter" + ~iterator:(fun f ops _acc -> Pending_ops.iter (fun p h o -> f p h o ()) ops) + () + +let test_fold_ordering = + test_iterators_ordering ~name:"fold" ~iterator:Pending_ops.fold () + +let test_fold_es_ordering = + test_iterators_ordering + ~name:"fold_es" + ~iterator:Pending_ops.fold_es + Lwt_result_syntax.return_unit + +(* 2. Test partial iteration with fold_es *) + +let test_partial_fold_es = + let open QCheck2 in + Test.make + ~name:"Test cardinal after partial iteration with fold_es" + (Gen.pair + (Gen.small_list (Generators.operation_with_hash_and_priority_gen ())) + Gen.small_nat) + @@ fun (ops, to_process) -> + let pending = pending_of_list ops in + let card0 = Pending_ops.cardinal pending in + Lwt_main.run + @@ Pending_ops.fold_es + (fun _priority hash _op (remaining_to_process, acc) -> + assert (remaining_to_process >= 0) ; + if remaining_to_process = 0 then Lwt.return_error acc + else + Lwt.return_ok (remaining_to_process - 1, Pending_ops.remove hash acc)) + pending + (to_process, pending) + |> function + | Ok (remaining_to_process, pending) -> + (* [Ok] means we have reached the end of the collection before exhausting + the limit of iterations: the remaining collection is empty && we spent + as many iterations as there were elements in the original collection. *) + let card1 = Pending_ops.cardinal pending in + qcheck_eq' ~pp:Format.pp_print_int ~expected:0 ~actual:card1 () + && qcheck_eq' + ~pp:Format.pp_print_int + ~expected:card0 + ~actual:(to_process - remaining_to_process) + () + | Error pending -> + (* [Error] means we have reached the limit of the number of iterations: + the number of removed elements is exactly the number of iterations && + there are still elements in the resulting collection. *) + let card1 = Pending_ops.cardinal pending in + qcheck_eq' + ~pp:Format.pp_print_int + ~expected:to_process + ~actual:(card0 - card1) + () + && qcheck_neq ~pp:Format.pp_print_int card1 0 + +let () = + let mk_tests label tests = (label, qcheck_wrap tests) in + Alcotest.run + "Prevalidator_pending_operations" + [ + mk_tests "iter ordering" [test_iter_ordering]; + mk_tests "fold ordering" [test_fold_ordering]; + mk_tests "fold_es ordering" [test_fold_es_ordering]; + mk_tests "partial fold_es" [test_partial_fold_es]; + ] diff --git a/src/lib_shell/test/test_prevalidation.ml b/src/lib_shell/test/test_prevalidation.ml index 28250bf022c9e061758b99241958dfd7f29a8ae2..42335c27f07c1dc6d366f6cd138e5c0e29b2f3dd 100644 --- a/src/lib_shell/test/test_prevalidation.ml +++ b/src/lib_shell/test/test_prevalidation.ml @@ -1,7 +1,7 @@ (*****************************************************************************) (* *) (* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs. *) +(* Copyright (c) 2021-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"),*) @@ -23,6 +23,16 @@ (* *) (*****************************************************************************) +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the test suite for the new mempool, which + uses features of the protocol that only exist since Lima. + + When you modify this file, consider whether you should also change + the ones that test the legacy mempool for Kathmandu. They all + start with the "legacy" prefix and will be removed when Lima is + activated on Mainnet. *) + (** Testing ------- Component: Prevalidation diff --git a/src/lib_shell/test/test_prevalidation_t.ml b/src/lib_shell/test/test_prevalidation_t.ml index 19edf742676dbe79d911fe3985dc3d632a989546..137d06b8dae9da875f0dd9be0f7f569ffaeee448 100644 --- a/src/lib_shell/test/test_prevalidation_t.ml +++ b/src/lib_shell/test/test_prevalidation_t.ml @@ -1,7 +1,7 @@ (*****************************************************************************) (* *) (* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs. *) +(* Copyright (c) 2021-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"),*) @@ -23,6 +23,16 @@ (* *) (*****************************************************************************) +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the test suite for the new mempool, which + uses features of the protocol that only exist since Lima. + + When you modify this file, consider whether you should also change + the ones that test the legacy mempool for Kathmandu. They all + start with the "legacy" prefix and will be removed when Lima is + activated on Mainnet. *) + (** Testing ------- Component: Prevalidation @@ -50,7 +60,7 @@ module Mock_protocol : Lwt_result_syntax.return_unit end -module Internal_for_tests = Tezos_shell.Prevalidation.Internal_for_tests +module Internal_for_tests = Prevalidation.Internal_for_tests module Init = struct let genesis_protocol = @@ -110,10 +120,10 @@ let create_prevalidation let chain_id () = Init.chain_id end in - let module Prevalidation = + let module Prevalidation_t = Internal_for_tests.Make (Chain_store) (Mock_protocol) in - (module Prevalidation : Tezos_shell.Prevalidation.T + (module Prevalidation_t : Prevalidation.T with type operation_receipt = unit and type validation_state = unit and type chain_store = Chain_store.chain_store) diff --git a/src/lib_shell/test/test_prevalidator_classification.ml b/src/lib_shell/test/test_prevalidator_classification.ml index 5e02aec118402022e808a0016b8a2914a3a7741d..344c28039b7664d03cafb7586df87b492121e6f7 100644 --- a/src/lib_shell/test/test_prevalidator_classification.ml +++ b/src/lib_shell/test/test_prevalidator_classification.ml @@ -1,7 +1,7 @@ (*****************************************************************************) (* *) (* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs. *) +(* Copyright (c) 2021-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"),*) @@ -23,6 +23,16 @@ (* *) (*****************************************************************************) +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the test suite for the new mempool, which + uses features of the protocol that only exist since Lima. + + When you modify this file, consider whether you should also change + the ones that test the legacy mempool for Kathmandu. They all + start with the "legacy" prefix and will be removed when Lima is + activated on Mainnet. *) + (** Testing ------- Component: Shell (Prevalidator classification) diff --git a/src/lib_shell/test/test_prevalidator_classification_operations.ml b/src/lib_shell/test/test_prevalidator_classification_operations.ml index 6fede967e2e03496e600267855fb190f4a8f4a7c..b34033d39b0e56a8489906015f9706bfd33b870c 100644 --- a/src/lib_shell/test/test_prevalidator_classification_operations.ml +++ b/src/lib_shell/test/test_prevalidator_classification_operations.ml @@ -1,7 +1,7 @@ (*****************************************************************************) (* *) (* Open Source License *) -(* Copyright (c) 2021 Nomadic Labs. *) +(* Copyright (c) 2021-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"),*) @@ -23,6 +23,16 @@ (* *) (*****************************************************************************) +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the test suite for the new mempool, which + uses features of the protocol that only exist since Lima. + + When you modify this file, consider whether you should also change + the ones that test the legacy mempool for Kathmandu. They all + start with the "legacy" prefix and will be removed when Lima is + activated on Mainnet. *) + (** Testing ------- Component: Shell (Prevalidator) diff --git a/src/lib_shell/test/test_prevalidator_pending_operations.ml b/src/lib_shell/test/test_prevalidator_pending_operations.ml index 875421d68e5ed2d6990c5eed6dca1cf94dd06069..43adc3e6be195e54cbf4bf55794313dc4db1b9df 100644 --- a/src/lib_shell/test/test_prevalidator_pending_operations.ml +++ b/src/lib_shell/test/test_prevalidator_pending_operations.ml @@ -23,6 +23,16 @@ (* *) (*****************************************************************************) +(* FIXME: https://gitlab.com/tezos/tezos/-/issues/4113 + + This file is part of the test suite for the new mempool, which + uses features of the protocol that only exist since Lima. + + When you modify this file, consider whether you should also change + the ones that test the legacy mempool for Kathmandu. They all + start with the "legacy" prefix and will be removed when Lima is + activated on Mainnet. *) + (** Testing ------- Component: Shell (Prevalidator pending operations) diff --git a/tezt/tests/dal.ml b/tezt/tests/dal.ml index 69517a863bb780159d80f8591d59a702851ee986..5071884c80e50d261708e7fc1efbcc6b1156f8d9 100644 --- a/tezt/tests/dal.ml +++ b/tezt/tests/dal.ml @@ -378,11 +378,7 @@ let check_dal_raw_context node = unit let test_slot_management_logic = - Protocol.register_test - ~__FILE__ - ~title:"dal basic logic" - ~tags:["dal"] - ~supports:Protocol.(From_protocol (Protocol.number Alpha)) + Protocol.register_test ~__FILE__ ~title:"dal basic logic" ~tags:["dal"] @@ fun protocol -> setup ~dal_enable:true ~protocol @@ fun parameters cryptobox node client _bootstrap -> @@ -505,7 +501,6 @@ let test_dal_node_slot_management = ~__FILE__ ~title:"dal node slot management" ~tags:["dal"; "dal_node"] - ~supports:Protocol.(From_protocol (Protocol.number Alpha)) @@ fun protocol -> let* _node, _client, dal_node = init_dal_node protocol in let slot_content = "test with invalid UTF-8 byte sequence \xFA" in @@ -535,7 +530,6 @@ let test_dal_node_slots_headers_tracking = ~__FILE__ ~title:"dal node slot headers tracking" ~tags:["dal"; "dal_node"] - ~supports:Protocol.(From_protocol (Protocol.number Alpha)) @@ fun protocol -> let* node, client, dal_node = init_dal_node protocol in let publish = publish_and_store_slot node client dal_node in @@ -569,7 +563,6 @@ let test_dal_node_rebuild_from_shards = ~__FILE__ ~title:"dal node shard fetching and slot reconstruction" ~tags:["dal"; "dal_node"] - ~supports:Protocol.(From_protocol (Protocol.number Alpha)) @@ fun protocol -> let open Tezos_crypto_dal in let* node, client, dal_node = init_dal_node protocol in @@ -621,7 +614,6 @@ let test_dal_node_test_slots_propagation = ~__FILE__ ~title:"dal node slots propagation" ~tags:["dal"; "dal_node"] - ~supports:Protocol.(From_protocol (Protocol.number Alpha)) @@ fun protocol -> let* node, _client, dal_node1 = init_dal_node protocol in let dal_node2 = Dal_node.create ~node () in @@ -650,7 +642,6 @@ let test_dal_node_startup = ~__FILE__ ~title:"dal node startup" ~tags:["dal"; "dal_node"] - ~supports:Protocol.(From_protocol (Protocol.number Alpha)) @@ fun protocol -> let run_dal = Dal_node.run ~wait_ready:false in let nodes_args = Node.[Synchronisation_threshold 0] in @@ -675,7 +666,7 @@ let test_dal_node_startup = Node.Config_file.update node (Node.Config_file.set_sandbox_network_with_user_activated_overrides - [(Protocol.hash previous_protocol, Protocol.hash Alpha)]) ; + [(Protocol.hash previous_protocol, Protocol.hash protocol)]) ; let* () = Node.run node nodes_args in let* () = Node.wait_for_ready node in let* () = run_dal dal_node in diff --git a/tezt/tests/prevalidator.ml b/tezt/tests/prevalidator.ml index 70a49c7beac3fbc54944c97e3179e90d5bb49018..c26e7a8b0d4667a93870cd96c0e40da536d0af3f 100644 --- a/tezt/tests/prevalidator.ml +++ b/tezt/tests/prevalidator.ml @@ -30,6 +30,30 @@ Subject: . *) +(** Section containing the prevalidator worker events. + + These events are defined in [lib_workers/worker_events.ml], and + the section name comes from the [Name] module given as argument to + [Worker.MakeGroup] in either [lib_shell/prevalidator_internal.ml] + (for Lima and Alpha) or [lib_shell/legacy_prevalidator_internal.ml] + (for Kathmandu). They should not be confused with the + prevalidator-specific events from + [lib_shell/prevalidator_events.ml], which are always in the + "prevalidator" section regardless of the protocol version. *) +let prevalidator_worker_event_section = function + | Protocol.Kathmandu -> "legacy_prevalidator" + | Lima | Alpha -> "prevalidator" + +(** The [event_sections_levels] argument that should be provided to + {!Node.init} in order to observe all debug-level prevalidator + events, depending on the protocol version. See + {!prevalidator_worker_event_section} regarding the section + names. *) +let prevalidator_debug = function + | Protocol.Kathmandu -> + [("prevalidator", `Debug); ("legacy_prevalidator", `Debug)] + | Lima | Alpha -> [("prevalidator", `Debug)] + (* FIXME: https://gitlab.com/tezos/tezos/-/issues/1657 Some refactorisation is needed. All new tests should be in the Revamped @@ -258,7 +282,7 @@ module Revamped = struct log_step 1 "Connect and initialise two nodes." ; let* node1 = Node.init - ~event_sections_levels:[("prevalidator", `Debug)] + ~event_sections_levels:(prevalidator_debug protocol) [Synchronisation_threshold 0; Private_mode] and* node2 = Node.init [Synchronisation_threshold 0; Private_mode] in let* client1 = Client.init ~endpoint:(Node node1) () @@ -577,7 +601,7 @@ module Revamped = struct in let* node3, client3 = Client.init_with_protocol - ~event_sections_levels:[("prevalidator", `Debug)] + ~event_sections_levels:(prevalidator_debug protocol) ~nodes_args:[Synchronisation_threshold 0] ~protocol `Client @@ -1036,7 +1060,7 @@ module Revamped = struct log_step 1 "Initialize a node and a client." ; let* node, client = Client.init_with_protocol - ~event_sections_levels:[("prevalidator", `Debug)] + ~event_sections_levels:(prevalidator_debug protocol) ~nodes_args:[Synchronisation_threshold 0] ~protocol `Client @@ -1375,7 +1399,7 @@ module Revamped = struct in let* node2, client2 = Client.init_with_node - ~event_sections_levels:[("prevalidator", `Debug)] + ~event_sections_levels:(prevalidator_debug protocol) ~nodes_args:[Synchronisation_threshold 0; Connections 2] `Client () @@ -1420,7 +1444,7 @@ module Revamped = struct log_step 5 "Add node3 connected only to node2." ; let* node3, client3 = Client.init_with_node - ~event_sections_levels:[("prevalidator", `Debug)] + ~event_sections_levels:(prevalidator_debug protocol) ~nodes_args:[Synchronisation_threshold 0; Connections 1] `Client () @@ -1578,14 +1602,14 @@ module Revamped = struct log_step 1 "Start two nodes, connect them, activate the protocol." ; let* node1, client1 = Client.init_with_node - ~event_sections_levels:[("prevalidator", `Debug)] + ~event_sections_levels:(prevalidator_debug protocol) ~nodes_args:[Synchronisation_threshold 0; Connections 1] `Client () in let* node2, client2 = Client.init_with_node - ~event_sections_levels:[("prevalidator", `Debug)] + ~event_sections_levels:(prevalidator_debug protocol) ~nodes_args:[Synchronisation_threshold 0; Connections 1] `Client () @@ -1663,7 +1687,7 @@ module Revamped = struct let gas_limit = 1500 in let* node1 = Node.init - ~event_sections_levels:[("prevalidator", `Debug)] + ~event_sections_levels:(prevalidator_debug protocol) [Synchronisation_threshold 0; Private_mode] and* node2 = Node.init [Synchronisation_threshold 0; Private_mode] in let* client1 = Client.init ~endpoint:(Node node1) () @@ -1845,7 +1869,7 @@ module Revamped = struct let gas_limit = 1500 in let* node1 = Node.init - ~event_sections_levels:[("prevalidator", `Debug)] + ~event_sections_levels:(prevalidator_debug protocol) [Synchronisation_threshold 0; Private_mode] and* node2 = Node.init [Synchronisation_threshold 0; Private_mode] in let* client1 = Client.init ~endpoint:(Node node1) () @@ -2446,11 +2470,11 @@ let propagation_future_endorsement = let* node_1 = Node.init [Synchronisation_threshold 0; Private_mode] and* node_2 = Node.init - ~event_sections_levels:[("prevalidator", `Debug)] + ~event_sections_levels:(prevalidator_debug protocol) [Synchronisation_threshold 0; Private_mode] and* node_3 = Node.init - ~event_sections_levels:[("prevalidator", `Debug)] + ~event_sections_levels:(prevalidator_debug protocol) [Synchronisation_threshold 0; Private_mode] in let* client_1 = Client.init ~endpoint:(Node node_1) () @@ -2667,7 +2691,7 @@ let refetch_failed_operation = Node.init (* Run the node with the new config. event_level is set to debug to catch fetching event at this level *) - ~event_sections_levels:[("prevalidator", `Debug)] + ~event_sections_levels:(prevalidator_debug protocol) (* Set a low operations_request_timeout to force timeout at fetching *) ~patch_config:(set_config_operations_timeout 0.00001) [Synchronisation_threshold 0; Private_mode] @@ -2858,7 +2882,7 @@ let ban_operation_and_check_applied = Log.info "Step 1: Start two nodes, connect them, activate the protocol." ; let* node_1 = Node.init - ~event_sections_levels:[("prevalidator", `Debug)] + ~event_sections_levels:(prevalidator_debug protocol) (* to witness operation arrival events *) [Synchronisation_threshold 0; Connections 1] and* node_2 = Node.init [Synchronisation_threshold 0; Connections 1] in @@ -3013,11 +3037,13 @@ let check_mempool_ops ?(log = false) client ~applied ~refused = in (* various checks about applied and refused operations *) Check.( - (List.compare_length_with applied_ophs applied = 0) + (* Not using [List.compare_length_with] allows for a more informative + error message. The lists are expected to be short anyway. *) + (List.length applied_ophs = applied) int ~error_msg:(name ^ ": found %L applied operation(s), expected %R.")) ; Check.( - (List.compare_length_with refused_ophs refused = 0) + (List.length refused_ophs = refused) int ~error_msg:(name ^ ": found %L refused operation(s), expected %R.")) ; List.iter @@ -3041,8 +3067,13 @@ let check_mempool_ops ?(log = false) client ~applied ~refused = (** Waits for [node] to receive a notification from a peer of a mempool containing exactly [n_ops] valid operations. *) -let wait_for_notify_n_valid_ops node n_ops = - Node.wait_for node "request_no_errors_prevalidator.v0" (fun event -> +let wait_for_notify_n_valid_ops proto node n_ops = + let name = + Format.sprintf + "request_no_errors_%s.v0" + (prevalidator_worker_event_section proto) + in + Node.wait_for node name (fun event -> let open JSON in let view = event |-> "view" in match view |-> "request" |> as_string_opt with @@ -3114,7 +3145,7 @@ let test_do_not_reclassify = "Step 1: Start two nodes, connect them, and activate the protocol." ; let* node1 = Node.init - ~event_sections_levels:[("prevalidator", `Debug)] + ~event_sections_levels:(prevalidator_debug protocol) [Synchronisation_threshold 0; Connections 1] and* node2 = Node.init [Synchronisation_threshold 0; Connections 1] in let* client1 = Client.init ~endpoint:Client.(Node node1) () @@ -3177,7 +3208,9 @@ let test_do_not_reclassify = so it must not be revalidated." ; let* _ = set_filter_no_fee_requirement client1 in let* () = inject_transfer Constant.bootstrap3 ~fee:5 in - let waiter_notify_3_valid_ops = wait_for_notify_n_valid_ops node1 3 in + let waiter_notify_3_valid_ops = + wait_for_notify_n_valid_ops protocol node1 3 + in let* () = bake_empty_block_and_wait_for_flush ~protocol ~log:true client1 node1 in @@ -3233,7 +3266,7 @@ let test_pending_operation_version = (* Initialise one node *) let* node_1 = Node.init - ~event_sections_levels:[("prevalidator", `Debug)] + ~event_sections_levels:(prevalidator_debug protocol) [Synchronisation_threshold 0; Private_mode] in let* client_1 = Client.init ~endpoint:(Node node_1) () in @@ -3723,7 +3756,7 @@ let test_get_post_mempool_filter = (* We need event level [debug] for event [invalid_mempool_filter_configuration]. *) init_single_node_and_activate_protocol - ~event_sections_levels:[("prevalidator", `Debug)] + ~event_sections_levels:(prevalidator_debug protocol) protocol in log_step 2 step2_msg ; @@ -3975,7 +4008,7 @@ let test_mempool_filter_operation_arrival = let* node1, client1, node2, client2 = init_two_connected_nodes_and_activate_protocol (* Need event level [debug] to receive operation arrival events in [node1]. *) - ~event_sections_levels1:[("prevalidator", `Debug)] + ~event_sections_levels1:(prevalidator_debug protocol) protocol in log_step 2 step2 ; @@ -4056,7 +4089,7 @@ let test_request_operations_peer = Log.info "%s" step1_msg ; let init_node () = Node.init - ~event_sections_levels:[("prevalidator", `Debug)] + ~event_sections_levels:(prevalidator_debug protocol) [Synchronisation_threshold 0; Private_mode] in let* node_1 = init_node () and* node_2 = init_node () in