From 8f347f0896cab938391b8d3ce0298ae773fb6e6c Mon Sep 17 00:00:00 2001
From: Diane Gallois-Wong <diane.gallois-wong@nomadic-labs.com>
Date: Mon, 17 Apr 2023 17:24:22 +0200
Subject: [PATCH 1/7] Shell/test_prevalidation: register directly with Tezt

---
 src/lib_shell/test/test_prevalidation.ml | 61 ++++++++++++------------
 1 file changed, 31 insertions(+), 30 deletions(-)

diff --git a/src/lib_shell/test/test_prevalidation.ml b/src/lib_shell/test/test_prevalidation.ml
index e7fb6355d4db..bebd7f04280e 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 =
@@ -123,7 +140,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
@@ -466,7 +485,11 @@ let consistent_outcomes ~mempool_is_empty proto_outcome filter_outcome =
     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
@@ -558,7 +581,11 @@ let test_add_operation ctxt =
   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
   (* Number of operations on which we will call [remove_operation]
@@ -650,29 +677,3 @@ let test_remove_operation ctxt =
   in
   remove_ops state nb_initial_ops removed_op_was_present ops ;
   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
-- 
GitLab


From 7dd5fe7e8ef442bb8956df07b28ead289cabccf0 Mon Sep 17 00:00:00 2001
From: Diane Gallois-Wong <diane.gallois-wong@nomadic-labs.com>
Date: Tue, 18 Apr 2023 18:13:56 +0200
Subject: [PATCH 2/7] Shell/test_prevalidation: simplify remove_operation test

---
 src/lib_shell/test/generators.ml         |  19 +++-
 src/lib_shell/test/test_prevalidation.ml | 136 ++++++++++-------------
 2 files changed, 77 insertions(+), 78 deletions(-)

diff --git a/src/lib_shell/test/generators.ml b/src/lib_shell/test/generators.ml
index 699f26e93b33..8075ee937626 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 bebd7f04280e..c1241edcfe8e 100644
--- a/src/lib_shell/test/test_prevalidation.ml
+++ b/src/lib_shell/test/test_prevalidation.ml
@@ -587,93 +587,79 @@ let () =
     ~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_valid_operations state)) ;
+  assert (Operation_hash.Set.is_empty (get_filter_state state)) ;
+  (* Prepare the initial state. *)
+  let state = set_validation_info state Proto_added in
+  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_valid_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 present_ops = Operation_hash.Map.bindings proto_ophmap_before in
+      let oph = fst QCheck2.Gen.(generate1 (oneofl present_ops)) in
+      let state = P.remove_operation state oph in
+      let proto_ophmap = get_valid_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_valid_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
-- 
GitLab


From 47ff21a5f505eb17664612cfde043f5a62b0be78 Mon Sep 17 00:00:00 2001
From: Diane Gallois-Wong <diane.gallois-wong@nomadic-labs.com>
Date: Mon, 13 Feb 2023 16:06:22 +0100
Subject: [PATCH 3/7] Shell/test_prevalidation: choose randomly from map/set

instead of using Operation_hash.Map.choose
---
 src/lib_shell/test/test_prevalidation.ml | 35 ++++++++++++------------
 1 file changed, 17 insertions(+), 18 deletions(-)

diff --git a/src/lib_shell/test/test_prevalidation.ml b/src/lib_shell/test/test_prevalidation.ml
index c1241edcfe8e..8d248f7b50fe 100644
--- a/src/lib_shell/test/test_prevalidation.ml
+++ b/src/lib_shell/test/test_prevalidation.ml
@@ -281,6 +281,11 @@ let proto_add_outcome_gen =
       (1, Proto_crash);
     ]
 
+(** 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)))
+
 (** Mock protocol with a toy mempool that has an adjustable
     [add_operation] function: it behaves as instructed by the provided
     [proto_add_outcome].
@@ -327,14 +332,9 @@ module Toy_proto :
           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
+          (* This outcome should not be used when the mempool is
+             empty. See [consistent_outcomes]. *)
+          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})
@@ -420,21 +420,21 @@ 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_no_replace ->
+          let filter_state = Operation_hash.Set.add oph filter_state in
+          Lwt_result.return (filter_state, `No_replace)
       | F_replace ->
+          (* This outcome should not be used when the mempool is
+             empty. See [consistent_outcomes]. *)
           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
@@ -624,8 +624,7 @@ let () =
   let test_remove (state, proto_ophmap_before, cardinal_before) =
     if QCheck2.Gen.(generate1 bool) then (
       (* Remove a present operation. *)
-      let present_ops = Operation_hash.Map.bindings proto_ophmap_before in
-      let oph = fst QCheck2.Gen.(generate1 (oneofl present_ops)) in
+      let oph = random_oph_from_map proto_ophmap_before in
       let state = P.remove_operation state oph in
       let proto_ophmap = get_valid_operations state in
       let filter_state = get_filter_state state in
-- 
GitLab


From be85056f1adc5cb857baceb270e9fb8501c52fc6 Mon Sep 17 00:00:00 2001
From: Diane Gallois-Wong <diane.gallois-wong@nomadic-labs.com>
Date: Fri, 10 Feb 2023 11:48:30 +0100
Subject: [PATCH 4/7] Shell/test_prevalidation: simplify handling of
 incompatible outcomes

Instead of modifying specified outcomes to eliminate incompatible ones
before calling add_operation, now the Toy_proto and Toy_filter directly
adapt their behavior if the specified outcome is not possible.
---
 src/lib_shell/test/test_prevalidation.ml | 90 ++++++++----------------
 1 file changed, 31 insertions(+), 59 deletions(-)

diff --git a/src/lib_shell/test/test_prevalidation.ml b/src/lib_shell/test/test_prevalidation.ml
index 8d248f7b50fe..73f1d5f8e668 100644
--- a/src/lib_shell/test/test_prevalidation.ml
+++ b/src/lib_shell/test/test_prevalidation.ml
@@ -328,16 +328,17 @@ module Toy_proto :
           "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 ->
-          (* This outcome should not be used when the mempool is
-             empty. See [consistent_outcomes]. *)
+      (* To be able to replace an operation, we need the mempool to be
+         non-empty. If it is empty, then [Proto_replaced] falls back
+         to the behavior of [Proto_added]. *)
+      | Proto_replaced 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_added | Proto_replaced ->
+          let state = Operation_hash.Map.add oph op state in
+          Lwt_result.return (state, Added)
       | Proto_unchanged -> Lwt_result.return (state, Unchanged)
       | Proto_branch_delayed ->
           Lwt_result.fail (Validation_error [Branch_delayed_error])
@@ -421,12 +422,15 @@ module Toy_filter = struct
         | Some replace_oph -> Operation_hash.Set.remove replace_oph filter_state
       in
       match config with
-      | F_no_replace ->
-          let filter_state = Operation_hash.Set.add oph filter_state in
-          Lwt_result.return (filter_state, `No_replace)
-      | F_replace ->
-          (* This outcome should not be used when the mempool is
-             empty. See [consistent_outcomes]. *)
+      (* 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 =
             QCheck2.Gen.(
               generate1 (oneofl (Operation_hash.Set.elements filter_state)))
@@ -439,6 +443,9 @@ module Toy_filter = struct
             (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 ->
@@ -450,35 +457,6 @@ 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
@@ -501,10 +479,6 @@ let () =
     assert (
       not (Operation_hash.Map.mem op.Shell_operation.hash valid_ops_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,
             (_op : Mock_protocol.operation Shell_operation.operation),
@@ -531,22 +505,20 @@ let () =
     let valid_ops = P.Internal_for_tests.get_valid_operations state in
     let filter_state = P.Internal_for_tests.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) ;
-        assert (Operation_hash.Set.mem op.hash filter_state) ;
-        assert (List.is_empty replacements)
-    | Proto_added, F_replace | Proto_replaced, F_no_replace -> (
+    | (Proto_added | Proto_replaced), (F_no_replace | F_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_outcome, filter_outcome) with
+        | (Proto_replaced, _ | _, F_replace)
+          when not (Operation_hash.Map.is_empty valid_ops_before) -> (
+            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)))
+        | _ -> assert (List.is_empty replacements))
     | _ ->
         assert (not (Operation_hash.Map.mem op.hash valid_ops)) ;
         assert (not (Operation_hash.Set.mem op.hash filter_state)) ;
-- 
GitLab


From 5b35e594faf6926755277b08d4c35f4d51ed1c73 Mon Sep 17 00:00:00 2001
From: Diane Gallois-Wong <diane.gallois-wong@nomadic-labs.com>
Date: Thu, 26 Jan 2023 11:07:02 +0100
Subject: [PATCH 5/7] Shell/test_prevalidation: merge outcomes Proto_added &
 Proto_replaced

into Proto_success (No_replacement | Replacement) because we often
handle both cases the same way.
---
 src/lib_shell/test/test_prevalidation.ml | 60 +++++++++++++-----------
 1 file changed, 32 insertions(+), 28 deletions(-)

diff --git a/src/lib_shell/test/test_prevalidation.ml b/src/lib_shell/test/test_prevalidation.ml
index 73f1d5f8e668..2cb0d001efd3 100644
--- a/src/lib_shell/test/test_prevalidation.ml
+++ b/src/lib_shell/test/test_prevalidation.ml
@@ -255,25 +255,29 @@ let () =
     (function Refused_error -> Some () | _ -> None)
     (fun () -> Refused_error)
 
+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);
@@ -288,7 +292,7 @@ let random_oph_from_map ophmap =
 
 (** Mock protocol with a toy mempool that has an adjustable
     [add_operation] function: it behaves as instructed by the provided
-    [proto_add_outcome].
+    [proto_outcome].
 
     Unlike in [Mock_protocol], here [Mempool.t] is an actual state
     that keeps track of validated operations and can be retrieved with
@@ -298,7 +302,7 @@ 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.validation_info = proto_outcome = struct
   include Mock_protocol
 
   module Mempool = struct
@@ -308,7 +312,7 @@ module Toy_proto :
 
     (* We use this type as a hack to tell [add_operation] which
        outcome we want. *)
-    type validation_info = proto_add_outcome
+    type validation_info = proto_outcome
 
     let init _ctxt _chain_id ~head_hash:_ ~head:_ ~cache:_ =
       Lwt_result.return (Proto_crash, Operation_hash.Map.empty)
@@ -327,16 +331,17 @@ module Toy_proto :
         QCheck2.Test.fail_reportf
           "Prevalidation should always call [Proto.Mempool.add_operation] with \
            an explicit [conflict_handler]." ;
-      match (info : proto_add_outcome) with
+      match (info : proto_outcome) with
       (* To be able to replace an operation, we need the mempool to be
-         non-empty. If it is empty, then [Proto_replaced] falls back
-         to the behavior of [Proto_added]. *)
-      | Proto_replaced when not (Operation_hash.Map.is_empty state) ->
+         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_added | Proto_replaced ->
+      | Proto_success (No_replacement | Replacement) ->
           let state = Operation_hash.Map.add oph op state in
           Lwt_result.return (state, Added)
       | Proto_unchanged -> Lwt_result.return (state, Unchanged)
@@ -378,7 +383,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
     [
@@ -488,28 +493,27 @@ let () =
     in
     (* Check the classification. *)
     (match (proto_outcome, filter_outcome) with
-    | (Proto_added | Proto_replaced), (F_no_replace | F_replace) ->
+    | Proto_success _, (F_no_replace | F_replace) ->
         check_classification __LOC__ ~expected:`Prechecked classification
     | (Proto_unchanged | Proto_branch_delayed), _
-    | (Proto_added | Proto_replaced), F_branch_delayed ->
+    | Proto_success _, F_branch_delayed ->
         check_classification __LOC__ ~expected:`Branch_delayed classification
-    | Proto_branch_refused, _ | (Proto_added | Proto_replaced), F_branch_refused
-      ->
+    | Proto_branch_refused, _ | Proto_success _, F_branch_refused ->
         check_classification __LOC__ ~expected:`Branch_refused classification
-    | Proto_refused, _ | (Proto_added | Proto_replaced), F_refused ->
+    | Proto_refused, _ | Proto_success _, F_refused ->
         check_classification __LOC__ ~expected:`Refused classification
-    | Proto_crash, _ | (Proto_added | Proto_replaced), F_crash ->
+    | Proto_crash, _ | Proto_success _, F_crash ->
         check_classification_is_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
     (match (proto_outcome, filter_outcome) with
-    | (Proto_added | Proto_replaced), (F_no_replace | F_replace) -> (
+    | Proto_success proto_replacement, (F_no_replace | F_replace) -> (
         assert (Operation_hash.Map.mem op.hash valid_ops) ;
         assert (Operation_hash.Set.mem op.hash filter_state) ;
-        match (proto_outcome, filter_outcome) with
-        | (Proto_replaced, _ | _, F_replace)
+        match (proto_replacement, filter_outcome) with
+        | (Replacement, _ | _, F_replace)
           when not (Operation_hash.Map.is_empty valid_ops_before) -> (
             match replacements with
             | [] | _ :: _ :: _ -> assert false
@@ -531,7 +535,7 @@ let () =
   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) ;
@@ -578,7 +582,7 @@ let () =
   assert (Operation_hash.Map.is_empty (get_valid_operations state)) ;
   assert (Operation_hash.Set.is_empty (get_filter_state state)) ;
   (* Prepare the initial state. *)
-  let state = set_validation_info state Proto_added in
+  let state = set_validation_info state (Proto_success No_replacement) in
   let*! initial_state =
     List.fold_left_s
       (fun state op ->
-- 
GitLab


From 7f98dd93d14894ca958a45defe1314eb6ad6bd37 Mon Sep 17 00:00:00 2001
From: Diane Gallois-Wong <diane.gallois-wong@nomadic-labs.com>
Date: Thu, 26 Jan 2023 11:07:02 +0100
Subject: [PATCH 6/7] Shell/test_prevalidation: provide proto_outcome as part
 of the state

instead of as validation_info. Indeed, it is not more difficult, and
it is more similar to what we will be doing in the future with the
bounding_state.

We also rename get_valid_operations to get_mempool_operations to
stress that they are the operations recorded by the protocol mempool,
not to be confused with the records by other states (filter_state for
now, bounder_state in the future).
---
 src/lib_shell/prevalidation.ml           |  15 ++-
 src/lib_shell/prevalidation.mli          |  13 ++-
 src/lib_shell/test/test_prevalidation.ml | 116 ++++++++++++-----------
 3 files changed, 75 insertions(+), 69 deletions(-)

diff --git a/src/lib_shell/prevalidation.ml b/src/lib_shell/prevalidation.ml
index 5cc4c5b31c5d..3dd8940456e0 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 d90d52e91ac7..b891da3864c0 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/test_prevalidation.ml b/src/lib_shell/test/test_prevalidation.ml
index 2cb0d001efd3..6007e2ae40ee 100644
--- a/src/lib_shell/test/test_prevalidation.ml
+++ b/src/lib_shell/test/test_prevalidation.ml
@@ -123,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
@@ -291,47 +290,58 @@ let random_oph_from_map ophmap =
   fst QCheck2.Gen.(generate1 (oneofl (Operation_hash.Map.bindings ophmap)))
 
 (** Mock protocol with a toy mempool that has an adjustable
-    [add_operation] function: it behaves as instructed by the provided
-    [proto_outcome].
-
-    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. *)
+    [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_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_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
           "Prevalidation should always call [Proto.Mempool.add_operation] with \
            an explicit [conflict_handler]." ;
-      match (info : proto_outcome) with
+      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]. *)
@@ -340,11 +350,12 @@ module Toy_proto :
           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})
+          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, Added)
-      | Proto_unchanged -> Lwt_result.return (state, Unchanged)
+          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 ->
@@ -352,11 +363,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
 
@@ -478,13 +490,14 @@ let () =
   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 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,
@@ -506,25 +519,25 @@ let () =
         check_classification_is_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_success proto_replacement, (F_no_replace | F_replace) -> (
-        assert (Operation_hash.Map.mem op.hash valid_ops) ;
+        assert (Operation_hash.Map.mem op.hash proto_ophmap) ;
         assert (Operation_hash.Set.mem op.hash filter_state) ;
         match (proto_replacement, filter_outcome) with
         | (Replacement, _ | _, F_replace)
-          when not (Operation_hash.Map.is_empty valid_ops_before) -> (
+          when not (Operation_hash.Map.is_empty proto_ophmap_before) -> (
             match replacements with
             | [] | _ :: _ :: _ -> assert false
             | [(removed, _)] ->
-                assert (Operation_hash.Map.mem removed valid_ops_before) ;
+                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 valid_ops)) ;
+                assert (not (Operation_hash.Map.mem removed proto_ophmap)) ;
                 assert (not (Operation_hash.Set.mem removed filter_state)))
         | _ -> 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
@@ -542,18 +555,14 @@ let () =
   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]. *)
@@ -579,10 +588,9 @@ let () =
   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_valid_operations state)) ;
+  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 state = set_validation_info state (Proto_success No_replacement) in
   let*! initial_state =
     List.fold_left_s
       (fun state op ->
@@ -593,7 +601,7 @@ let () =
       state
       (mk_ops nb_initial_ops)
   in
-  let initial_proto_ophmap = get_valid_operations initial_state in
+  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. *)
@@ -602,7 +610,7 @@ let () =
       (* 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_valid_operations state 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)) ;
@@ -617,7 +625,7 @@ let () =
         QCheck2.Gen.generate1 (Generators.fresh_oph_gen proto_ophmap_before)
       in
       let state = P.remove_operation state oph in
-      let proto_ophmap = get_valid_operations state 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) ;
-- 
GitLab


From 8c2e1cb0bfbd492225fa9c25b2d8ffeb95eaf147 Mon Sep 17 00:00:00 2001
From: Diane Gallois-Wong <diane.gallois-wong@nomadic-labs.com>
Date: Thu, 9 Feb 2023 16:48:37 +0100
Subject: [PATCH 7/7] Shell/test_prevalidation: check errors more precisely

---
 src/lib_shell/test/test_prevalidation.ml | 108 ++++++++++++++---------
 1 file changed, 66 insertions(+), 42 deletions(-)

diff --git a/src/lib_shell/test/test_prevalidation.ml b/src/lib_shell/test/test_prevalidation.ml
index 6007e2ae40ee..4cbbf7477bef 100644
--- a/src/lib_shell/test/test_prevalidation.ml
+++ b/src/lib_shell/test/test_prevalidation.ml
@@ -191,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
 
@@ -254,6 +245,38 @@ 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
@@ -338,7 +361,7 @@ module Toy_proto :
     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 desired_outcome with
@@ -507,16 +530,16 @@ let () =
     (* Check the classification. *)
     (match (proto_outcome, filter_outcome) with
     | Proto_success _, (F_no_replace | F_replace) ->
-        check_classification __LOC__ ~expected:`Prechecked classification
-    | (Proto_unchanged | Proto_branch_delayed), _
-    | Proto_success _, F_branch_delayed ->
-        check_classification __LOC__ ~expected:`Branch_delayed classification
+        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 ->
-        check_classification __LOC__ ~expected:`Branch_refused classification
+        assert_branch_refused_error ~__LOC__ classification
     | Proto_refused, _ | Proto_success _, F_refused ->
-        check_classification __LOC__ ~expected:`Refused classification
+        assert_refused_error ~__LOC__ classification
     | Proto_crash, _ | Proto_success _, F_crash ->
-        check_classification_is_exn __LOC__ classification) ;
+        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 proto_ophmap = get_mempool_operations state in
@@ -530,11 +553,12 @@ let () =
           when not (Operation_hash.Map.is_empty proto_ophmap_before) -> (
             match replacements with
             | [] | _ :: _ :: _ -> assert false
-            | [(removed, _)] ->
+            | [(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 (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 proto_ophmap)) ;
-- 
GitLab