diff --git a/src/lib_shell/prevalidation.ml b/src/lib_shell/prevalidation.ml index 5cc4c5b31c5d967364a6f5148bcce4990e308e53..3dd8940456e0c2081e51e8dcd5597a4109b1e7ba 100644 --- a/src/lib_shell/prevalidation.ml +++ b/src/lib_shell/prevalidation.ml @@ -87,13 +87,13 @@ module type T = sig val remove_operation : t -> Operation_hash.t -> t module Internal_for_tests : sig - val get_valid_operations : t -> protocol_operation Operation_hash.Map.t + val get_mempool_operations : t -> protocol_operation Operation_hash.Map.t val get_filter_state : t -> filter_state - type validation_info + type mempool - val set_validation_info : t -> validation_info -> t + val set_mempool : t -> mempool -> t end end @@ -104,8 +104,7 @@ module MakeAbstract (Chain_store : CHAIN_STORE) (Filter : Shell_plugin.FILTER) : and type filter_state = Filter.Mempool.state and type filter_config = Filter.Mempool.config and type chain_store = Chain_store.chain_store - and type Internal_for_tests.validation_info = - Filter.Proto.Mempool.validation_info = struct + and type Internal_for_tests.mempool = Filter.Proto.Mempool.t = struct module Proto = Filter.Proto type protocol_operation = Proto.operation @@ -311,13 +310,13 @@ module MakeAbstract (Chain_store : CHAIN_STORE) (Filter : Shell_plugin.FILTER) : {state with mempool; filter_state} module Internal_for_tests = struct - let get_valid_operations {mempool; _} = Proto.Mempool.operations mempool + let get_mempool_operations {mempool; _} = Proto.Mempool.operations mempool let get_filter_state {filter_state; _} = filter_state - type validation_info = Proto.Mempool.validation_info + type mempool = Proto.Mempool.t - let set_validation_info state validation_info = {state with validation_info} + let set_mempool state mempool = {state with mempool} end end diff --git a/src/lib_shell/prevalidation.mli b/src/lib_shell/prevalidation.mli index d90d52e91ac75d4ee843fb9368a273611e377e84..b891da3864c0b08f6b0690e77e933075d24cf98d 100644 --- a/src/lib_shell/prevalidation.mli +++ b/src/lib_shell/prevalidation.mli @@ -133,16 +133,16 @@ module type T = sig module Internal_for_tests : sig (** Return the map of operations currently present in the protocol representation of the mempool. *) - val get_valid_operations : t -> protocol_operation Operation_hash.Map.t + val get_mempool_operations : t -> protocol_operation Operation_hash.Map.t (** Return the filter_state component of the state. *) val get_filter_state : t -> filter_state - (** Type {!Tezos_protocol_environment.PROTOCOL.Mempool.validation_info}. *) - type validation_info + (** Type {!Tezos_protocol_environment.PROTOCOL.Mempool.t}. *) + type mempool - (** Modify the [validation_info] field of the internal state [t]. *) - val set_validation_info : t -> validation_info -> t + (** Modify the [mempool] field of the internal state [t]. *) + val set_mempool : t -> mempool -> t end end @@ -187,6 +187,5 @@ module Internal_for_tests : sig and type filter_state = Filter.Mempool.state and type filter_config = Filter.Mempool.config and type chain_store = Chain_store.chain_store - and type Internal_for_tests.validation_info = - Filter.Proto.Mempool.validation_info + and type Internal_for_tests.mempool = Filter.Proto.Mempool.t end diff --git a/src/lib_shell/test/generators.ml b/src/lib_shell/test/generators.ml index 699f26e93b3373646873b8e2f3cbf8ca166b3f0e..8075ee937626baa45a0f23c33f728006557cec34 100644 --- a/src/lib_shell/test/generators.ml +++ b/src/lib_shell/test/generators.ml @@ -40,11 +40,13 @@ let operation_mock_proto_gen = let* len_gen = frequencya [|(9, return 0); (1, 0 -- 31)|] in string_size ?gen:None len_gen +let key_gen = QCheck2.Gen.(opt (string_size (0 -- 64))) + +let path_gen = QCheck2.Gen.(list_size (0 -- 10) (small_string ?gen:None)) + 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 + let+ key = key_gen and+ path = path_gen in Block_hash.hash_string ?key path (** A generator of operations. @@ -284,3 +286,14 @@ 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 + +let operation_hash_gen = + let open QCheck2.Gen in + let+ key = key_gen and+ path = path_gen in + Operation_hash.hash_string ?key path + +(** Generate an operation hash that is not present as a key in the given map. *) +let rec fresh_oph_gen ophmap = + let open QCheck2.Gen in + let* oph = operation_hash_gen in + if Operation_hash.Map.mem oph ophmap then fresh_oph_gen ophmap else return oph diff --git a/src/lib_shell/test/test_prevalidation.ml b/src/lib_shell/test/test_prevalidation.ml index e7fb6355d4db868da4885216d07972431ae132b5..4cbbf7477bef2a132cebfda6e818557050cfb401 100644 --- a/src/lib_shell/test/test_prevalidation.ml +++ b/src/lib_shell/test/test_prevalidation.ml @@ -26,10 +26,16 @@ (** Testing ------- Component: Prevalidation - Invocation: dune exec src/lib_shell/test/main.exe + Invocation: dune exec src/lib_shell/test/main.exe -- -f test_prevalidation.ml Subject: Unit tests for {!Prevalidation.T} *) +let register_test ~title ~additional_tags = + Test.register + ~__FILE__ + ~title:("Shell: Mempool prevalidation: " ^ title) + ~tags:(["mempool"; "prevalidation"] @ additional_tags) + module Init = struct let chain_id = Shell_test_helpers.chain_id @@ -64,6 +70,17 @@ module Init = struct context_hash in Store.Unsafe.block_of_repr repr + + (** Register a Tezt test from a function that takes a context as + argument and returns a tzresult promise. *) + let register_test_that_needs_ctxt f = + register_test (fun () -> + let open Lwt_syntax in + let* res = wrap_tzresult_lwt_disk f () in + match res with + | Ok () -> unit + | Error err -> + Test.fail "Test failed with tztrace:@.%a" pp_print_trace err) end let make_chain_store ctxt = @@ -106,8 +123,7 @@ module MakeFilter (Proto : Tezos_protocol_environment.PROTOCOL) : with type Proto.operation_data = Proto.operation_data and type Proto.operation = Proto.operation and type Mempool.state = unit - and type Proto.Mempool.validation_info = Proto.Mempool.validation_info = -Shell_plugin.No_filter (struct + and type Proto.Mempool.t = Proto.Mempool.t = Shell_plugin.No_filter (struct let hash = Protocol_hash.zero include Proto @@ -123,7 +139,9 @@ let now () = Time.System.to_protocol (Tezos_base.Time.System.now ()) let chain_store = () (** Test that [create] returns [Ok] in a pristine context. *) -let test_create ctxt = +let () = + Init.register_test_that_needs_ctxt ~title:"create" ~additional_tags:["create"] + @@ fun ctxt -> let open Lwt_result_syntax in let (module Chain_store) = make_chain_store ctxt in let module Filter = MakeFilter (Mock_protocol) in @@ -173,39 +191,30 @@ let pp_classification fmt classification = | `Refused trace -> print_error_classification "Refused" trace | `Outdated trace -> print_error_classification "Outdated" trace -let check_classification_is_exn loc - (classification : Prevalidator_classification.classification) = - match classification with +let unexpected_classification ~__LOC__ expected classification = + Test.fail + "%s:@.Expected classification %s, but got %a" + __LOC__ + expected + pp_classification + classification + +let assert_success ~__LOC__ = function + | `Prechecked -> () + | classification -> + unexpected_classification ~__LOC__ "Prechecked" classification + +let assert_operation_conflict ~__LOC__ = function + | `Branch_delayed [Validation_errors.Operation_conflict _] -> () + | cl -> + unexpected_classification + ~__LOC__ + "Branch_delayed: [Operation_conflict]" + cl + +let assert_exn ~__LOC__ = function | `Branch_delayed [Exn _] -> () - | _ -> - QCheck2.Test.fail_reportf - "%s:@.Expected classification (Branch_delayed: [Exn]), but got %a" - loc - pp_classification - classification - -let pp_expected fmt = function - | `Prechecked -> Format.fprintf fmt "Prechecked" - | `Branch_delayed -> Format.fprintf fmt "Branch_delayed" - | `Branch_refused -> Format.fprintf fmt "Branch_refused" - | `Refused -> Format.fprintf fmt "Refused" - -let check_classification loc ~expected - (classification : Prevalidator_classification.classification) = - match (expected, classification) with - | `Prechecked, `Prechecked - | `Branch_delayed, `Branch_delayed _ - | `Branch_refused, `Branch_refused _ - | `Refused, `Refused _ -> - () - | _ -> - QCheck2.Test.fail_reportf - "%s:@.Expected classification %a, but got %a" - loc - pp_expected - expected - pp_classification - classification + | cl -> unexpected_classification ~__LOC__ "Branch_delayed: [Exn]" cl type error += Branch_delayed_error | Branch_refused_error | Refused_error @@ -236,25 +245,61 @@ let () = (function Refused_error -> Some () | _ -> None) (fun () -> Refused_error) +let assert_replacement ~__LOC__ = function + (* Replaced by the protocol *) + | `Outdated [Validation_errors.Operation_replacement _] -> () + (* Replaced by the filter *) + | `Branch_delayed [Branch_delayed_error] -> () + | classification -> + unexpected_classification + ~__LOC__ + "Outdated: [Operation_replacement] or Branch_delayed: \ + [Branch_delayed_error]" + classification + +let assert_branch_delayed_error ~__LOC__ = function + | `Branch_delayed [Branch_delayed_error] -> () + | cl -> + unexpected_classification + ~__LOC__ + "Branch_delayed: [Branch_delayed_error]" + cl + +let assert_branch_refused_error ~__LOC__ = function + | `Branch_refused [Branch_refused_error] -> () + | cl -> + unexpected_classification + ~__LOC__ + "Branch_refused: [Branch_refused_error]" + cl + +let assert_refused_error ~__LOC__ = function + | `Refused [Refused_error] -> () + | cl -> unexpected_classification ~__LOC__ "Refused: [Refused_error]" cl + +type proto_replacement = Replacement | No_replacement + (** Possible outcomes of protocol's [Mempool.add_operation] that we want to test. *) -type proto_add_outcome = - | Proto_added (** Return [Proto.Mempool.Added]. *) - | Proto_replaced (** Return [Proto.Mempool.Replaced]. *) +type proto_outcome = + | Proto_success of proto_replacement + (** Return either [Proto.Mempool.Added] (when [proto_replacement] is + [No_replacement]) or [Proto.Mempool.Replaced] (when it is + [Replacement]. *) | Proto_unchanged (** Return [Proto.Mempool.Unchanged]. *) | Proto_branch_delayed (** Fail with a [`Temporary] error. *) | Proto_branch_refused (** Fail with a [`Branch] error. *) | Proto_refused (** Fail with a [`Permanent] error. *) | Proto_crash (** Raise an exception. *) -let proto_add_outcome_gen = +let proto_outcome_gen = (* We try to give higher weights to more usual outcomes, and in - particular to [Proto_added] so that the number of operations in - the mempool can grow. *) + particular to [Proto_success No_replacement] so that the number + of operations in the mempool can grow. *) QCheck2.Gen.frequencyl [ - (4, Proto_added); - (2, Proto_replaced); + (8, Proto_success No_replacement); + (2, Proto_success Replacement); (2, Proto_unchanged); (1, Proto_branch_delayed); (1, Proto_branch_refused); @@ -262,64 +307,78 @@ let proto_add_outcome_gen = (1, Proto_crash); ] -(** Mock protocol with a toy mempool that has an adjustable - [add_operation] function: it behaves as instructed by the provided - [proto_add_outcome]. +(** Get a random operation hash from an [Operation_hash.Map.t]. + Fail with [Invalid_argument] when the map is empty. *) +let random_oph_from_map ophmap = + fst QCheck2.Gen.(generate1 (oneofl (Operation_hash.Map.bindings ophmap))) - Unlike in [Mock_protocol], here [Mempool.t] is an actual state - that keeps track of validated operations and can be retrieved with - [Mempool.operations]. This allows the test below to check that - operations were correctly added or removed. *) +(** Mock protocol with a toy mempool that has an adjustable + [add_operation] function. + + At the center of the toy mempool is the [Mempool.t] type, which is + no longer [unit] as in [Mock_protocol]. Instead, this type has two + components: + + - A map that keeps track of validated operations and can be + retrieved with [Mempool.operations]. This allows the tests to check + that operations were correctly added or removed. + + - A [proto_outcome] that allows the caller of + [Mempool.add_operation] to specify the desired outcome of this + function. It is then returned unchanged by the function. It is + first initialized to [Proto_success No_replacement], so that the + mempool can easily be filled with valid operations by simply + leaving it unmodified. *) module Toy_proto : Tezos_protocol_environment.PROTOCOL with type operation_data = unit and type operation = Mock_protocol.operation - and type Mempool.validation_info = proto_add_outcome = struct + and type Mempool.t = + Mock_protocol.operation Operation_hash.Map.t * proto_outcome = struct include Mock_protocol module Mempool = struct include Mempool - type t = operation Operation_hash.Map.t + type t = operation Operation_hash.Map.t * proto_outcome - (* We use this type as a hack to tell [add_operation] which - outcome we want. *) - type validation_info = proto_add_outcome + type validation_info = unit let init _ctxt _chain_id ~head_hash:_ ~head:_ ~cache:_ = - Lwt_result.return (Proto_crash, Operation_hash.Map.empty) - - let operation_encoding = + (* The default outcome is [Proto_success No_replacement]: this + is useful when we just want to set up a mempool that contains + operations, as in [test_remove_operation]. *) + Lwt_result.return + ((), (Operation_hash.Map.empty, Proto_success No_replacement)) + + (* Fake encoding that will not be used anyway. *) + let encoding = Data_encoding.conv - (fun {shell; protocol_data = ()} -> shell) - (fun shell -> {shell; protocol_data = ()}) - Operation.shell_header_encoding + (fun _ -> ()) + (fun () -> (Operation_hash.Map.empty, Proto_success No_replacement)) + Data_encoding.unit - let encoding = Operation_hash.Map.encoding operation_encoding - - let add_operation ?check_signature:_ ?conflict_handler info state (oph, op) - = + let add_operation ?check_signature:_ ?conflict_handler _info + (state, desired_outcome) (oph, op) = if Option.is_none conflict_handler then - QCheck2.Test.fail_reportf + Test.fail "Prevalidation should always call [Proto.Mempool.add_operation] with \ an explicit [conflict_handler]." ; - match (info : proto_add_outcome) with - | Proto_added -> - let state = Operation_hash.Map.add oph op state in - Lwt_result.return (state, Added) - | Proto_replaced -> - let removed = - match Operation_hash.Map.choose state with - | Some (hash, _) -> hash - | None -> - (* This outcome should not be used when the mempool is - empty. See [consistent_outcomes]. *) - assert false - in + match desired_outcome with + (* To be able to replace an operation, we need the mempool to be + non-empty. If it is empty, then [Proto_success Replacement] falls back + to the behavior of [Proto_success No_replacement]. *) + | Proto_success Replacement when not (Operation_hash.Map.is_empty state) + -> + let removed = random_oph_from_map state in let state = Operation_hash.Map.remove removed state in let state = Operation_hash.Map.add oph op state in - Lwt_result.return (state, Replaced {removed}) - | Proto_unchanged -> Lwt_result.return (state, Unchanged) + Lwt_result.return ((state, desired_outcome), Replaced {removed}) + | Proto_success (No_replacement | Replacement) -> + let state = Operation_hash.Map.add oph op state in + Lwt_result.return ((state, desired_outcome), Added) + | Proto_unchanged -> + Lwt_result.return ((state, desired_outcome), Unchanged) | Proto_branch_delayed -> Lwt_result.fail (Validation_error [Branch_delayed_error]) | Proto_branch_refused -> @@ -327,11 +386,12 @@ module Toy_proto : | Proto_refused -> Lwt_result.fail (Validation_error [Refused_error]) | Proto_crash -> assert false - let remove_operation state oph = Operation_hash.Map.remove oph state + let remove_operation (state, desired_outcome) oph = + (Operation_hash.Map.remove oph state, desired_outcome) let merge ?conflict_handler:_ _ _ = assert false - let operations = Fun.id + let operations = fst end end @@ -358,7 +418,7 @@ let filter_add_outcome_encoding = let filter_add_outcome_gen = (* We try to give higher weights to more usual outcomes, and in - particular to [Proto_added] so that the number of operations in + particular to [F_no_replace] so that the number of operations in the mempool can grow. *) QCheck2.Gen.frequencyl [ @@ -401,25 +461,31 @@ module Toy_filter = struct | None -> filter_state | Some replace_oph -> Operation_hash.Set.remove replace_oph filter_state in - let filter_state = Operation_hash.Set.add oph filter_state in match config with - | F_no_replace -> Lwt_result.return (filter_state, `No_replace) - | F_replace -> + (* To be able to replace an operation, we need the state to be + non-empty and [replace] to be [None]. Indeed, if we have + already removed an operation because of [replace], then the + state is not full and the filter shouldn't also remove an + operation. If these conditions are not fulfilled, then + [F_replace] falls back to the behavior of [F_no_replace]. *) + | F_replace + when (not (Operation_hash.Set.is_empty filter_state)) + && Option.is_none replace -> let replace_oph = - match Operation_hash.Set.choose filter_state with - | Some hash -> hash - | None -> - (* This outcome should not be used when the mempool is - empty. See [consistent_outcomes]. *) - assert false + QCheck2.Gen.( + generate1 (oneofl (Operation_hash.Set.elements filter_state))) in let filter_state = Operation_hash.Set.remove replace_oph filter_state in + let filter_state = Operation_hash.Set.add oph filter_state in let replacement = (replace_oph, `Branch_delayed [Branch_delayed_error]) in Lwt_result.return (filter_state, `Replace replacement) + | F_no_replace | F_replace -> + let filter_state = Operation_hash.Set.add oph filter_state in + Lwt_result.return (filter_state, `No_replace) | F_branch_delayed -> Lwt_result.fail (`Branch_delayed [Branch_delayed_error]) | F_branch_refused -> @@ -431,58 +497,30 @@ module Toy_filter = struct end end -(** Adjust the outcomes of [Proto.Mempool.add_operation] and - [Filter.Mempool.add_operation_and_enforce_mempool_bound] we wish to - test, to avoid asking these functions to return a result that - wouldn't make sense. *) -let consistent_outcomes ~mempool_is_empty proto_outcome filter_outcome = - if mempool_is_empty then - (* If the mempool contains no valid operations, then there is no - operation to replace, so outcomes can be neither - [Proto_replaced] nor [F_replace]. *) - let proto_outcome = - match proto_outcome with - | Proto_replaced -> Proto_added - | _ -> proto_outcome - in - let filter_outcome = - match filter_outcome with - | F_replace -> F_no_replace - | _ -> filter_outcome - in - (proto_outcome, filter_outcome) - else - (* If the protocol already causes the removal of an old operation, - then the mempool is not full and the filter won't also remove - an operation. In other words, the outcomes [Proto_replaced] and - [F_replace] are incompatible. *) - match (proto_outcome, filter_outcome) with - | Proto_replaced, F_replace -> (Proto_replaced, F_no_replace) - | _ -> (proto_outcome, filter_outcome) - (** Test [Prevalidation.add_operation]. For various outcomes of the protocol's [Mempool.add_operation] and the filter's [Mempool.add_operation_and_enforce_mempool_bound], check the returned classification and the updates of the protocol and filter internal states. *) -let test_add_operation ctxt = +let () = + Init.register_test_that_needs_ctxt + ~title:"add_operation" + ~additional_tags:["add"] + @@ fun ctxt -> (* Number of operations that will be added. *) let nb_ops = 100 in let open Lwt_result_syntax in let (module Chain_store) = make_chain_store ctxt in let module P = MakePrevalidation (Chain_store) (Toy_filter) in + let open P.Internal_for_tests in let add_op state (op, (proto_outcome, filter_outcome)) = - let valid_ops_before = P.Internal_for_tests.get_valid_operations state in - let filter_state_before = P.Internal_for_tests.get_filter_state state in + let proto_ophmap_before = get_mempool_operations state in + let filter_state_before = get_filter_state state in assert ( - not (Operation_hash.Map.mem op.Shell_operation.hash valid_ops_before)) ; + not (Operation_hash.Map.mem op.Shell_operation.hash proto_ophmap_before)) ; assert (not (Operation_hash.Set.mem op.hash filter_state_before)) ; - let proto_outcome, filter_outcome = - let mempool_is_empty = Operation_hash.Map.is_empty valid_ops_before in - consistent_outcomes ~mempool_is_empty proto_outcome filter_outcome - in - let state = P.Internal_for_tests.set_validation_info state proto_outcome in + let state = set_mempool state (proto_ophmap_before, proto_outcome) in let*! ( state, (_op : Mock_protocol.operation Shell_operation.operation), classification, @@ -491,41 +529,39 @@ let test_add_operation ctxt = in (* Check the classification. *) (match (proto_outcome, filter_outcome) with - | (Proto_added | Proto_replaced), (F_no_replace | F_replace) -> - check_classification __LOC__ ~expected:`Prechecked classification - | (Proto_unchanged | Proto_branch_delayed), _ - | (Proto_added | Proto_replaced), F_branch_delayed -> - check_classification __LOC__ ~expected:`Branch_delayed classification - | Proto_branch_refused, _ | (Proto_added | Proto_replaced), F_branch_refused - -> - check_classification __LOC__ ~expected:`Branch_refused classification - | Proto_refused, _ | (Proto_added | Proto_replaced), F_refused -> - check_classification __LOC__ ~expected:`Refused classification - | Proto_crash, _ | (Proto_added | Proto_replaced), F_crash -> - check_classification_is_exn __LOC__ classification) ; + | Proto_success _, (F_no_replace | F_replace) -> + assert_success ~__LOC__ classification + | Proto_unchanged, _ -> assert_operation_conflict ~__LOC__ classification + | Proto_branch_delayed, _ | Proto_success _, F_branch_delayed -> + assert_branch_delayed_error ~__LOC__ classification + | Proto_branch_refused, _ | Proto_success _, F_branch_refused -> + assert_branch_refused_error ~__LOC__ classification + | Proto_refused, _ | Proto_success _, F_refused -> + assert_refused_error ~__LOC__ classification + | Proto_crash, _ | Proto_success _, F_crash -> + assert_exn ~__LOC__ classification) ; (* Check whether the new operation has been added, whether there is a replacement, and when there is one, whether it has been removed. *) - let valid_ops = P.Internal_for_tests.get_valid_operations state in - let filter_state = P.Internal_for_tests.get_filter_state state in + let proto_ophmap = get_mempool_operations state in + let filter_state = get_filter_state state in (match (proto_outcome, filter_outcome) with - | Proto_added, F_no_replace -> - assert (Operation_hash.Map.mem op.hash valid_ops) ; + | Proto_success proto_replacement, (F_no_replace | F_replace) -> ( + assert (Operation_hash.Map.mem op.hash proto_ophmap) ; assert (Operation_hash.Set.mem op.hash filter_state) ; - assert (List.is_empty replacements) - | Proto_added, F_replace | Proto_replaced, F_no_replace -> ( - assert (Operation_hash.Map.mem op.hash valid_ops) ; - assert (Operation_hash.Set.mem op.hash filter_state) ; - match replacements with - | [] | _ :: _ :: _ -> assert false - | [(removed, _)] -> - assert (Operation_hash.Map.mem removed valid_ops_before) ; - assert (Operation_hash.Set.mem removed filter_state_before) ; - assert (not (Operation_hash.Map.mem removed valid_ops)) ; - assert (not (Operation_hash.Set.mem removed filter_state))) - | Proto_replaced, F_replace -> - (* [consistent_outcomes] makes this case impossible. *) assert false + match (proto_replacement, filter_outcome) with + | (Replacement, _ | _, F_replace) + when not (Operation_hash.Map.is_empty proto_ophmap_before) -> ( + match replacements with + | [] | _ :: _ :: _ -> assert false + | [(removed, replacement_classification)] -> + assert (Operation_hash.Map.mem removed proto_ophmap_before) ; + assert (Operation_hash.Set.mem removed filter_state_before) ; + assert (not (Operation_hash.Map.mem removed proto_ophmap)) ; + assert (not (Operation_hash.Set.mem removed filter_state)) ; + assert_replacement ~__LOC__ replacement_classification) + | _ -> assert (List.is_empty replacements)) | _ -> - assert (not (Operation_hash.Map.mem op.hash valid_ops)) ; + assert (not (Operation_hash.Map.mem op.hash proto_ophmap)) ; assert (not (Operation_hash.Set.mem op.hash filter_state)) ; assert (List.is_empty replacements)) ; Lwt.return state @@ -536,143 +572,101 @@ let test_add_operation ctxt = let ops = mk_ops nb_ops in let outcomes = QCheck2.Gen.( - generate ~n:nb_ops (pair proto_add_outcome_gen filter_add_outcome_gen)) + generate ~n:nb_ops (pair proto_outcome_gen filter_add_outcome_gen)) in let ops_and_outcomes, leftovers = List.combine_with_leftovers ops outcomes in assert (Option.is_none leftovers) ; let*! final_prevalidation_state = List.fold_left_s add_op prevalidation_state ops_and_outcomes in - let final_valid_ops = - P.Internal_for_tests.get_valid_operations final_prevalidation_state - in - let final_filter_state = - P.Internal_for_tests.get_filter_state final_prevalidation_state - in + let final_proto_ophmap = get_mempool_operations final_prevalidation_state in + let final_filter_state = get_filter_state final_prevalidation_state in assert ( - Operation_hash.Map.cardinal final_valid_ops + Operation_hash.Map.cardinal final_proto_ophmap = Operation_hash.Set.cardinal final_filter_state) ; Operation_hash.Map.iter (fun oph _ -> assert (Operation_hash.Set.mem oph final_filter_state)) - final_valid_ops ; + final_proto_ophmap ; return_unit (** Test [Prevalidation.remove_operation]. *) -let test_remove_operation ctxt = +let () = + Init.register_test_that_needs_ctxt + ~title:"remove_operation" + ~additional_tags:["remove"] + @@ fun ctxt -> (* Number of operations initially added to the validation state. *) - let nb_initial_ops = 20 in + let nb_initial_ops = 50 in (* Number of operations on which we will call [remove_operation] after we have added [nb_initial_ops] operations to the state. We must have [nb_ops_to_remove <= nb_initial_ops]; removal from an empty state will be tested separately. *) - let nb_ops_to_remove = 10 in + let nb_ops_to_remove = 30 in let open Lwt_result_syntax in let (module Chain_store) = make_chain_store ctxt in let module P = MakePrevalidation (Chain_store) (Toy_filter) in + let open P.Internal_for_tests in let timestamp : Time.Protocol.t = now () in let head = Init.genesis_block ~timestamp ctxt in - let* state = P.create chain_store ~head ~timestamp in (* Test removal from empty state. *) - let state = P.remove_operation state Operation_hash.zero in - assert ( - Operation_hash.Map.is_empty - (P.Internal_for_tests.get_valid_operations state)) ; - assert ( - Operation_hash.Set.is_empty (P.Internal_for_tests.get_filter_state state)) ; - (* For each operation that will be removed, we generate a boolean - that indicates whether the operation should be present in the - prevalidation state. *) - let removed_op_was_present = - QCheck2.Gen.(generate ~n:nb_ops_to_remove bool) - in - (* We will need as many original operations to remove as there are - occurrences of [false] in [removed_op_was_present]. *) - let nb_original_ops_to_remove = - List.fold_left (fun n b -> if b then n else n + 1) 0 removed_op_was_present + let* state = P.create chain_store ~head ~timestamp in + let oph = QCheck2.Gen.generate1 Generators.operation_hash_gen in + let state = P.remove_operation state oph in + assert (Operation_hash.Map.is_empty (get_mempool_operations state)) ; + assert (Operation_hash.Set.is_empty (get_filter_state state)) ; + (* Prepare the initial state. *) + let*! initial_state = + List.fold_left_s + (fun state op -> + let*! state, _op, _classification, _replacement = + P.add_operation state F_no_replace op + in + Lwt.return state) + state + (mk_ops nb_initial_ops) in - (* We generate all needed operations at the same time to have - [operations_gen]'s guarantee that their hashes are distinct. *) - let ops = mk_ops (nb_initial_ops + nb_original_ops_to_remove) in - (* Add [nb_initial_ops] operations to the prevalidation state. *) - let state = P.Internal_for_tests.set_validation_info state Proto_added in - let rec add_ops n state ops = - if n <= 0 then return (state, ops) + let initial_proto_ophmap = get_mempool_operations initial_state in + let initial_cardinal = Operation_hash.Map.cardinal initial_proto_ophmap in + assert (initial_cardinal = nb_initial_ops) ; + (* Test the removal of present or fresh operations. *) + let test_remove (state, proto_ophmap_before, cardinal_before) = + if QCheck2.Gen.(generate1 bool) then ( + (* Remove a present operation. *) + let oph = random_oph_from_map proto_ophmap_before in + let state = P.remove_operation state oph in + let proto_ophmap = get_mempool_operations state in + let filter_state = get_filter_state state in + assert (not (Operation_hash.Map.mem oph proto_ophmap)) ; + assert (not (Operation_hash.Set.mem oph filter_state)) ; + let cardinal = Operation_hash.Map.cardinal proto_ophmap in + assert (cardinal = cardinal_before - 1) ; + assert (Operation_hash.Set.cardinal filter_state = cardinal) ; + (state, proto_ophmap, cardinal)) else - match ops with - | [] -> - (* We generated more than [nb_initial_ops] operations. *) assert false - | op :: remaining_ops -> - let*! state, _op, _classification, _replacement = - P.add_operation state F_no_replace op - in - add_ops (n - 1) state remaining_ops + (* Remove a fresh operation. *) + let filter_state_before = get_filter_state state in + let oph = + QCheck2.Gen.generate1 (Generators.fresh_oph_gen proto_ophmap_before) + in + let state = P.remove_operation state oph in + let proto_ophmap = get_mempool_operations state in + let filter_state = get_filter_state state in + (* Internal states are physically unchanged. *) + assert (proto_ophmap == proto_ophmap_before) ; + assert (filter_state == filter_state_before) ; + (state, proto_ophmap, cardinal_before) in - let* state, ops = add_ops nb_initial_ops state ops in - assert ( - Operation_hash.Map.cardinal - (P.Internal_for_tests.get_valid_operations state) - = nb_initial_ops) ; - (* Call [Prevalidation.remove_operation] on [nb_ops_to_remove] - operations, which are already present in the state or not as - specified by [removed_op_was_present]. *) - let rec remove_ops state old_cardinal removed_op_was_present ops = - match removed_op_was_present with - | [] -> () - | was_present :: rest_was_present -> - let oph, remaining_ops = - if was_present then - match - Operation_hash.Map.choose - (P.Internal_for_tests.get_valid_operations state) - with - | Some (oph, _) -> (oph, ops) - | None -> - (* More operations have been added to the state than removed. *) - assert false - else - match ops with - | op :: remaining_ops -> (op.Shell_operation.hash, remaining_ops) - | [] -> - (* We generated enough operations for each occurrence of - [false] in [removed_op_was_present]. *) - assert false - in - let state = P.remove_operation state oph in - let valid_ops = P.Internal_for_tests.get_valid_operations state in - let filter_state = P.Internal_for_tests.get_filter_state state in - assert (not (Operation_hash.Map.mem oph valid_ops)) ; - assert (not (Operation_hash.Set.mem oph filter_state)) ; - let new_cardinal = Operation_hash.Map.cardinal valid_ops in - assert ( - if was_present then new_cardinal = old_cardinal - 1 - else new_cardinal = old_cardinal) ; - remove_ops state new_cardinal rest_was_present remaining_ops + let rec fun_power f x n = if n <= 0 then x else fun_power f (f x) (n - 1) in + let final_state, final_proto_ophmap, final_cardinal = + fun_power + test_remove + (initial_state, initial_proto_ophmap, initial_cardinal) + nb_ops_to_remove in - remove_ops state nb_initial_ops removed_op_was_present ops ; + let final_filter_state = get_filter_state final_state in + assert (Operation_hash.Set.cardinal final_filter_state = final_cardinal) ; + assert ( + Operation_hash.Map.for_all + (fun oph _op -> Operation_hash.Set.mem oph final_filter_state) + final_proto_ophmap) ; return_unit - -let () = - let register_test name f = - Tztest.tztest name `Quick (Init.wrap_tzresult_lwt_disk f) - in - Alcotest_lwt.run - ~__FILE__ - "mempool-prevalidation" - [ - (* Run only those tests with: - dune exec src/lib_shell/test/test_prevalidation.exe -- test create '0' *) - ("create", [register_test "[create] succeeds" test_create]); - (* Run only those tests with: - dune exec src/lib_shell/test/test_prevalidation.exe -- test add_operation '0' *) - ( "add_operation", - [ - register_test - "Check classification and state updates" - test_add_operation; - ] ); - (* Run only those tests with: - dune exec src/lib_shell/test/test_prevalidation.exe -- test remove_operation '0' *) - ( "remove_operation", - [register_test "Test remove_operation" test_remove_operation] ); - ] - |> Lwt_main.run