Prevalidator/Prevalidation: move existential

Note that now, the chain_validator is responsible for swapping the
prevalidator when a new protocol arrives.

Co-authored-by: Raphaël Proust <code@bnwr.net>
Co-authored-by: Pietro Abate <pietro.abate@tezcore.com>
Co-authored-by: Grégoire Henry <gregoire.henry@tezos.com>

src/lib_shell/block_validator.ml

@@ -333,6 +333,7 @@ let on_request
             (* TODO catch other temporary error (e.g. system errors)
                and do not 'commit' them on disk... *)
             | Error [Canceled | Unavailable_protocol _] as err ->
+                (* FIXME: Canceled can escape. Canceled is not registered. BOOM! *)
                 return err
             | Error errors ->
                 Worker.protect w begin fun () ->

src/lib_shell/chain_validator.ml

@@ -25,6 +25,8 @@
 
 open Chain_validator_worker_state
 
+module Log = Tezos_stdlib.Logging.Make(struct let name = "node.chain_validator" end)
+
 module Name = struct
   type t = Chain_id.t
   let encoding = Chain_id.encoding
@@ -72,7 +74,7 @@ module Types = struct
 
     mutable child:
       (state * (unit -> unit Lwt.t (* shutdown *))) option ;
-    prevalidator: Prevalidator.t option ;
+    mutable prevalidator: Prevalidator.t option ;
     active_peers: Peer_validator.t Lwt.t P2p_peer.Table.t ;
     bootstrapped_peers: unit P2p_peer.Table.t ;
   }
@@ -249,6 +251,16 @@ let broadcast_head w ~previous block =
     end
   end
 
+let safe_get_protocol hash =
+  match Registered_protocol.get hash with
+  | None ->
+      (* FIXME. *)
+      (* This should not happen: it should be handled in the validator. *)
+      failwith "chain_validator: missing protocol '%a' for the current block."
+        Protocol_hash.pp_short hash
+  | Some protocol ->
+      return protocol
+
 let on_request (type a) w spawn_child (req : a Request.t) : a tzresult Lwt.t =
   let Request.Validated block = req in
   let nv = Worker.state w in
@@ -266,8 +278,28 @@ let on_request (type a) w spawn_child (req : a Request.t) : a tzresult Lwt.t =
     may_update_checkpoint nv.parameters.chain_state block >>= fun () ->
     broadcast_head w ~previous block >>= fun () ->
     begin match nv.prevalidator with
-      | Some prevalidator ->
+      | Some old_prevalidator ->
-          Prevalidator.flush prevalidator block_hash
+          State.Block.protocol_hash block >>= fun new_protocol ->
+          let old_protocol = Prevalidator.protocol_hash old_prevalidator in
+          begin
+            if not (Protocol_hash.equal old_protocol new_protocol) then begin
+              safe_get_protocol new_protocol >>=? fun (module Proto) ->
+              let (limits, chain_db) = Prevalidator.parameters old_prevalidator in
+              (* TODO inject in the new prevalidator the operation
+                 from the previous one. *)
+              Prevalidator.create
+                limits
+                (module Proto)
+                chain_db >>= fun prevalidator ->
+              nv.prevalidator <- Some prevalidator ;
+              Prevalidator.shutdown old_prevalidator >>= fun () ->
+              return_unit
+            end else begin
+              Prevalidator.flush old_prevalidator block_hash >>=? fun () ->
+              return_unit
+            end
+          end >>=? fun () ->
+          return_unit
       | None -> return_unit
     end >>=? fun () ->
     may_switch_test_chain w spawn_child block >>= fun () ->
@@ -302,9 +334,20 @@ let on_close w =
 let on_launch start_prevalidator w _ parameters =
   Chain.init_head parameters.chain_state >>= fun () ->
   (if start_prevalidator then
-     Prevalidator.create
+     State.read_chain_data parameters.chain_state
-       parameters.prevalidator_limits parameters.chain_db >>= fun prevalidator ->
+       (fun _ {State.current_head} -> Lwt.return current_head) >>= fun head ->
-     Lwt.return_some prevalidator
+     State.Block.protocol_hash head >>= fun head_hash ->
+     safe_get_protocol head_hash >>= function
+     | Ok (module Proto) ->
+         Prevalidator.create
+           parameters.prevalidator_limits
+           (module Proto)
+           parameters.chain_db >>= fun prevalor ->
+         Lwt.return_some prevalor
+     | Error err ->
+         Log.lwt_log_error "@[Failed to instantiate prevalidator:@ %a@]"
+           pp_print_error err >>= fun () ->
+         Lwt.return_none
    else Lwt.return_none) >>= fun prevalidator ->
   let valid_block_input = Lwt_watcher.create_input () in
   let new_head_input = Lwt_watcher.create_input () in
@@ -336,12 +379,9 @@ let on_launch start_prevalidator w _ parameters =
         may_activate_peer_validator w peer_id >>= fun pv ->
         Peer_validator.notify_head pv block ;
         (* TODO notify prevalidator only if head is known ??? *)
-        begin match nv.prevalidator with
+        match nv.prevalidator with
-          | Some prevalidator ->
+        | Some prevalidator -> Prevalidator.notify_operations prevalidator peer_id ops
-              Prevalidator.notify_operations prevalidator peer_id ops
+        | None -> Lwt.return_unit
-          | None -> ()
-        end ;
-        Lwt.return_unit
       end;
     end ;
     disconnection = begin fun peer_id ->

src/lib_shell/prevalidation.ml

@@ -23,10 +23,10 @@
 (*                                                                           *)
 (*****************************************************************************)
 
-open Preapply_result
 open Validation_errors
 
 let rec apply_operations apply_operation state r max_ops ~sort ops =
+  let open Preapply_result in
   Lwt_list.fold_left_s
     (fun (state, max_ops, r) (hash, op, parsed_op) ->
        apply_operation state max_ops op parsed_op >>= function
@@ -63,30 +63,245 @@ let rec apply_operations apply_operation state r max_ops ~sort ops =
   | _ ->
       Lwt.return (state, max_ops, r)
 
-type prevalidation_state =
-    State : { proto : ('state, 'operation_data) proto ; state : 'state ;
-              max_number_of_operations : int ;
-              new_operation_input : ([ `Applied | `Refused | `Branch_refused | `Branch_delayed ] *
-                                     Operation.shell_header * 'operation_data) Lwt_watcher.input ;
-            }
-    -> prevalidation_state
 
-and ('state, 'operation_data) proto =
+module type T = sig
-  (module Registered_protocol.T
-    with type P.validation_state = 'state
-     and type P.operation_data = 'operation_data )
 
-let start_prevalidation
+  type state
-    ?protocol_data
+
-    ~predecessor ~timestamp () =
+  (** Creates a new prevalidation context w.r.t. the protocol associate to the
-  let { Block_header.shell =
+      predecessor block . When ?protocol_data is passed to this function, it will
-          { fitness = predecessor_fitness ;
+      be used to create the new block *)
-            timestamp = predecessor_timestamp ;
+  val start_prevalidation :
-            level = predecessor_level } } =
+    ?protocol_data: MBytes.t ->
-    State.Block.header predecessor in
+    predecessor: State.Block.t ->
+    timestamp: Time.t ->
+    unit -> state tzresult Lwt.t
+
+  (** Given a prevalidation context applies a list of operations,
+      returns a new prevalidation context plus the preapply result containing the
+      list of operations that cannot be applied to this context *)
+  val prevalidate :
+    state -> sort:bool ->
+    (Operation_hash.t * Operation.t) list ->
+    (state * error Preapply_result.t) Lwt.t
+
+  val end_prevalidation :
+    state ->
+    Tezos_protocol_environment_shell.validation_result tzresult Lwt.t
+
+  val notify_operation :
+    state ->
+    error Preapply_result.t ->
+    unit
+
+  val shutdown_operation_input :
+    state ->
+    unit
+
+  val rpc_directory : (state * error Preapply_result.t) RPC_directory.t tzresult Lwt.t
+
+end
+
+module Make(Proto : Registered_protocol.T) : T = struct
+
+  type state =
+    { state : Proto.validation_state ;
+      max_number_of_operations : int ;
+      new_operation_input : ([ `Applied | `Refused | `Branch_refused | `Branch_delayed ] *
+                             Operation.shell_header * Proto.operation_data) Lwt_watcher.input ;
+    }
+
+  let start_prevalidation
+      ?protocol_data
+      ~predecessor ~timestamp () =
+    let { Block_header.shell =
+            { fitness = predecessor_fitness ;
+              timestamp = predecessor_timestamp ;
+              level = predecessor_level } } =
+      State.Block.header predecessor in
+    State.Block.context predecessor >>= fun predecessor_context ->
+    let predecessor_hash = State.Block.hash predecessor in
+    Context.reset_test_chain
+      predecessor_context predecessor_hash
+      timestamp >>= fun predecessor_context ->
+    begin
+      match protocol_data with
+      | None -> return_none
+      | Some protocol_data ->
+          match
+            Data_encoding.Binary.of_bytes
+              Proto.block_header_data_encoding
+              protocol_data
+          with
+          | None -> failwith "Invalid block header"
+          | Some protocol_data -> return_some protocol_data
+    end >>=? fun protocol_data ->
+    Proto.begin_construction
+      ~chain_id: (State.Block.chain_id predecessor)
+      ~predecessor_context
+      ~predecessor_timestamp
+      ~predecessor_fitness
+      ~predecessor_level
+      ~predecessor: predecessor_hash
+      ~timestamp
+      ?protocol_data
+      ()
+    >>=? fun state ->
+    (* FIXME arbitrary value, to be customisable *)
+    let max_number_of_operations = 1000 in
+    let new_operation_input = Lwt_watcher.create_input () in
+    return { state ; max_number_of_operations ; new_operation_input ; }
+
+  let prevalidate
+      { state ; max_number_of_operations ; new_operation_input ; }
+      ~sort (ops : (Operation_hash.t * Operation.t) list) =
+    let ops =
+      List.map
+        (fun (h, op) ->
+           let parsed_op =
+             match Data_encoding.Binary.of_bytes
+                     Proto.operation_data_encoding
+                     op.Operation.proto with
+             | None -> error Parse_error
+             | Some protocol_data ->
+                 Ok ({ shell = op.shell ; protocol_data } : Proto.operation) in
+           (h, op, parsed_op))
+        ops in
+    let invalid_ops =
+      List.filter_map
+        (fun (h, op, parsed_op) -> match parsed_op with
+           | Ok _ -> None
+           | Error err -> Some (h, op, err)) ops
+    and parsed_ops =
+      List.filter_map
+        (fun (h, op, parsed_op) -> match parsed_op with
+           | Ok parsed_op -> Some (h, op, parsed_op)
+           | Error _ -> None) ops in
+    ignore invalid_ops; (* FIXME *)
+    let sorted_ops =
+      if sort then
+        let compare (_, _, op1) (_, _, op2) = Proto.compare_operations op1 op2 in
+        List.sort compare parsed_ops
+      else parsed_ops in
+    let apply_operation state max_ops op (parse_op) =
+      let size = Data_encoding.Binary.length Operation.encoding op in
+      if max_ops <= 0 then
+        fail Too_many_operations
+      else if size > Proto.max_operation_data_length then
+        fail (Oversized_operation { size ; max = Proto.max_operation_data_length })
+      else
+        Proto.apply_operation state parse_op >>=? fun (state, receipt) ->
+        return (state, receipt) in
+    apply_operations
+      apply_operation
+      state Preapply_result.empty max_number_of_operations
+      ~sort sorted_ops >>= fun (state, max_number_of_operations, r) ->
+    let r =
+      { r with
+        applied = List.rev r.applied ;
+        branch_refused =
+          List.fold_left
+            (fun map (h, op, err) -> Operation_hash.Map.add h (op, err) map)
+            r.branch_refused invalid_ops } in
+    Lwt.return ({ state ; max_number_of_operations ; new_operation_input ; }, r)
+
+  let end_prevalidation { state } =
+    Proto.finalize_block state >>=? fun (result, _metadata) ->
+    return result
+
+  let notify_operation { new_operation_input } result =
+    let open Preapply_result in
+    let { applied ; refused ; branch_refused ; branch_delayed } = result in
+    (* Notify new opperations *)
+    let map_op kind { Operation.shell ; proto } =
+      let protocol_data =
+        Data_encoding.Binary.of_bytes_exn
+          Proto.operation_data_encoding
+          proto in
+      kind, shell, protocol_data in
+    let fold_op kind _k (op, _error) acc = map_op kind op :: acc in
+    let applied = List.map (map_op `Applied) (List.map snd applied) in
+    let refused = Operation_hash.Map.fold (fold_op `Refused) refused [] in
+    let branch_refused = Operation_hash.Map.fold (fold_op `Branch_refused) branch_refused [] in
+    let branch_delayed = Operation_hash.Map.fold (fold_op `Branch_delayed) branch_delayed [] in
+    let ops = List.concat [ applied ; refused ; branch_refused ; branch_delayed ] in
+    List.iter (Lwt_watcher.notify new_operation_input) ops
+
+  let shutdown_operation_input { new_operation_input } =
+    Lwt_watcher.shutdown_input new_operation_input
+
+  let rpc_directory =
+    let module Proto_services = Block_services.Make(Proto)(Proto) in
+
+    let dir : (state * Error_monad.error Preapply_result.t) RPC_directory.t ref =
+      ref RPC_directory.empty in
+
+    let gen_register s f =
+      dir := RPC_directory.gen_register !dir s f in
+
+    gen_register
+      (Proto_services.S.Mempool.monitor_operations RPC_path.open_root)
+      begin fun ({ new_operation_input }, current_mempool) params () ->
+        let open Preapply_result in
+        let operation_stream, stopper =
+          Lwt_watcher.create_stream new_operation_input in
+        (* Convert ops *)
+        let map_op op =
+          let protocol_data =
+            Data_encoding.Binary.of_bytes_exn
+              Proto.operation_data_encoding
+              op.Operation.proto in
+          Proto.{ shell = op.shell ; protocol_data } in
+        let fold_op _k (op, _error) acc = map_op op :: acc in
+        (* First call : retrieve the current set of op from the mempool *)
+        let { applied ; refused ; branch_refused ; branch_delayed } = current_mempool in
+        let applied = if params#applied then List.map map_op (List.map snd applied) else [] in
+        let refused = if params#refused then
+            Operation_hash.Map.fold fold_op refused [] else [] in
+        let branch_refused = if params#branch_refused then
+            Operation_hash.Map.fold fold_op branch_refused [] else [] in
+        let branch_delayed = if params#branch_delayed then
+            Operation_hash.Map.fold fold_op branch_delayed [] else [] in
+        let current_mempool = List.concat [ applied ; refused ; branch_refused ; branch_delayed ] in
+        let current_mempool = ref (Some current_mempool) in
+        let filter_result = function
+          | `Applied -> params#applied
+          | `Refused -> params#branch_refused
+          | `Branch_refused -> params#refused
+          | `Branch_delayed -> params#branch_delayed
+        in
+        let next () =
+          match !current_mempool with
+          | Some mempool -> begin
+              current_mempool := None ;
+              Lwt.return_some mempool
+            end
+          | None -> begin
+              Lwt_stream.get operation_stream >>= function
+              | Some (kind, shell, protocol_data) when filter_result kind ->
+                  (* NOTE: Should the protocol change, a new Prevalidation
+                   * context would be created. Thus, we use the same Proto. *)
+                  let bytes = Data_encoding.Binary.to_bytes_exn
+                      Proto.operation_data_encoding
+                      protocol_data in
+                  let protocol_data = Data_encoding.Binary.of_bytes_exn
+                      Proto.operation_data_encoding
+                      bytes in
+                  Lwt.return_some [ { Proto.shell ; protocol_data } ]
+              | _ -> Lwt.return_none
+            end
+        in
+        let shutdown () = Lwt_watcher.shutdown stopper in
+        RPC_answer.return_stream { next ; shutdown }
+      end ;
+
+    return !dir
+
+end
+
+let preapply ~predecessor ~timestamp ~protocol_data ~sort_operations:sort ops =
   State.Block.context predecessor >>= fun predecessor_context ->
   Context.get_protocol predecessor_context >>= fun protocol ->
-  let predecessor_hash = State.Block.hash predecessor in
   begin
     match Registered_protocol.get protocol with
     | None ->
@@ -97,106 +312,13 @@ let start_prevalidation
     | Some protocol ->
         return protocol
   end >>=? fun (module Proto) ->
-  Context.reset_test_chain
+  let module Prevalidation = Make(Proto) in
-    predecessor_context predecessor_hash
+  Prevalidation.start_prevalidation
-    timestamp >>= fun predecessor_context ->
-  begin
-    match protocol_data with
-    | None -> return_none
-    | Some protocol_data ->
-        match
-          Data_encoding.Binary.of_bytes
-            Proto.block_header_data_encoding
-            protocol_data
-        with
-        | None -> failwith "Invalid block header"
-        | Some protocol_data -> return_some protocol_data
-  end >>=? fun protocol_data ->
-  Proto.begin_construction
-    ~chain_id: (State.Block.chain_id predecessor)
-    ~predecessor_context
-    ~predecessor_timestamp
-    ~predecessor_fitness
-    ~predecessor_level
-    ~predecessor: predecessor_hash
-    ~timestamp
-    ?protocol_data
-    ()
-  >>=? fun state ->
-  (* FIXME arbitrary value, to be customisable *)
-  let max_number_of_operations = 1000 in
-  let new_operation_input = Lwt_watcher.create_input () in
-  return (State { proto = (module Proto) ; state ;
-                  max_number_of_operations ;
-                  new_operation_input ;
-                })
-
-let prevalidate
-    (State { proto = (module Proto) ; state ;
-             max_number_of_operations ; new_operation_input })
-    ~sort (ops : (Operation_hash.t * Operation.t) list) =
-  let ops =
-    List.map
-      (fun (h, op) ->
-         let parsed_op =
-           match Data_encoding.Binary.of_bytes
-                   Proto.operation_data_encoding
-                   op.Operation.proto with
-           | None -> error Parse_error
-           | Some protocol_data ->
-               Ok ({ shell = op.shell ; protocol_data } : Proto.operation) in
-         (h, op, parsed_op))
-      ops in
-  let invalid_ops =
-    List.filter_map
-      (fun (h, op, parsed_op) -> match parsed_op with
-         | Ok _ -> None
-         | Error err -> Some (h, op, err)) ops
-  and parsed_ops =
-    List.filter_map
-      (fun (h, op, parsed_op) -> match parsed_op with
-         | Ok parsed_op -> Some (h, op, parsed_op)
-         | Error _ -> None) ops in
-  let sorted_ops =
-    if sort then
-      let compare (_, _, op1) (_, _, op2) = Proto.compare_operations op1 op2 in
-      List.sort compare parsed_ops
-    else parsed_ops in
-  let apply_operation state max_ops op (parse_op) =
-    let size = Data_encoding.Binary.length Operation.encoding op in
-    if max_ops <= 0 then
-      fail Too_many_operations
-    else if size > Proto.max_operation_data_length then
-      fail (Oversized_operation { size ; max = Proto.max_operation_data_length })
-    else
-      Proto.apply_operation state parse_op >>=? fun (state, receipt) ->
-      return (state, receipt) in
-  apply_operations
-    apply_operation
-    state Preapply_result.empty max_number_of_operations
-    ~sort sorted_ops >>= fun (state, max_number_of_operations, r) ->
-  let r =
-    { r with
-      applied = List.rev r.applied ;
-      branch_refused =
-        List.fold_left
-          (fun map (h, op, err) -> Operation_hash.Map.add h (op, err) map)
-          r.branch_refused invalid_ops } in
-  Lwt.return (State { proto = (module Proto) ; state ;
-                      max_number_of_operations ; new_operation_input },
-              r)
-
-let end_prevalidation (State { proto = (module Proto) ; state }) =
-  Proto.finalize_block state >>=? fun (result, _metadata) ->
-  return result
-
-let preapply ~predecessor ~timestamp ~protocol_data ~sort_operations:sort ops =
-  start_prevalidation
     ~protocol_data ~predecessor ~timestamp () >>=? fun validation_state ->
   let ops = List.map (List.map (fun x -> Operation.hash x, x)) ops in
   Lwt_list.fold_left_s
     (fun (validation_state, rs) ops ->
-       prevalidate
+       Prevalidation.prevalidate
          validation_state ~sort ops >>= fun (validation_state, r) ->
        Lwt.return (validation_state, rs @ [r]))
     (validation_state, []) ops >>= fun (validation_state, rs) ->
@@ -207,7 +329,7 @@ let preapply ~predecessor ~timestamp ~protocol_data ~sort_operations:sort ops =
             Operation_list_hash.compute
               (List.map fst r.Preapply_result.applied))
          rs) in
-  end_prevalidation validation_state >>=? fun validation_result ->
+  Prevalidation.end_prevalidation validation_state >>=? fun validation_result ->
   let pred_shell_header = State.Block.shell_header predecessor in
   let level = Int32.succ pred_shell_header.level in
   Block_validator.may_patch_protocol
@@ -243,97 +365,3 @@ let preapply ~predecessor ~timestamp ~protocol_data ~sort_operations:sort ops =
   end >>=? fun (context, message) ->
   Context.hash ?message ~time:timestamp context >>= fun context ->
   return ({ shell_header with context }, rs)
-
-let notify_operation (State { proto = (module Proto) ; new_operation_input ; }) result =
-  let { applied ; refused ; branch_refused ; branch_delayed } = result in
-  (* Notify new opperations *)
-  let map_op kind { Operation.shell ; proto } =
-    let protocol_data =
-      Data_encoding.Binary.of_bytes_exn
-        Proto.operation_data_encoding
-        proto in
-    kind, shell, protocol_data in
-  let fold_op kind _k (op, _error) acc = map_op kind op :: acc in
-  let applied = List.map (map_op `Applied) (List.map snd applied) in
-  let refused = Operation_hash.Map.fold (fold_op `Refused) refused [] in
-  let branch_refused = Operation_hash.Map.fold (fold_op `Branch_refused) branch_refused [] in
-  let branch_delayed = Operation_hash.Map.fold (fold_op `Branch_delayed) branch_delayed [] in
-  let ops = List.concat [ applied ; refused ; branch_refused ; branch_delayed ] in
-  List.iter (Lwt_watcher.notify new_operation_input) ops
-
-let shutdown_operation_input (State { new_operation_input }) =
-  Lwt_watcher.shutdown_input new_operation_input
-
-let build_rpc_directory protocol =
-  begin
-    match Registered_protocol.get protocol with
-    | None ->
-        (* FIXME. *)
-        (* This should not happen: it should be handled in the validator. *)
-        failwith "Prevalidation: missing protocol '%a' for the current block."
-          Protocol_hash.pp_short protocol
-    | Some protocol ->
-        return protocol
-  end >>=? fun (module Proto) ->
-  let module Proto_services = Block_services.Make(Proto)(Proto) in
-
-  let dir : (prevalidation_state * Error_monad.error Preapply_result.t) RPC_directory.t ref =
-    ref RPC_directory.empty in
-
-  let gen_register s f =
-    dir := RPC_directory.gen_register !dir s f in
-
-  gen_register
-    (Proto_services.S.Mempool.monitor_operations RPC_path.open_root)
-    begin fun ((State { new_operation_input ; proto = (module Next_proto) }), current_mempool) params () ->
-      let operation_stream, stopper =
-        Lwt_watcher.create_stream new_operation_input in
-      (* Convert ops *)
-      let map_op op =
-        let protocol_data =
-          Data_encoding.Binary.of_bytes_exn
-            Proto.operation_data_encoding
-            op.Operation.proto in
-        Proto.{ shell = op.shell ; protocol_data } in
-      let fold_op _k (op, _error) acc = map_op op :: acc in
-      (* First call : retrieve the current set of op from the mempool *)
-      let { applied ; refused ; branch_refused ; branch_delayed } = current_mempool in
-      let applied = if params#applied then List.map map_op (List.map snd applied) else [] in
-      let refused = if params#refused then
-          Operation_hash.Map.fold fold_op refused [] else [] in
-      let branch_refused = if params#branch_refused then
-          Operation_hash.Map.fold fold_op branch_refused [] else [] in
-      let branch_delayed = if params#branch_delayed then
-          Operation_hash.Map.fold fold_op branch_delayed [] else [] in
-      let current_mempool = List.concat [ applied ; refused ; branch_refused ; branch_delayed ] in
-      let current_mempool = ref (Some current_mempool) in
-      let filter_result = function
-        | `Applied -> params#applied
-        | `Refused -> params#branch_refused
-        | `Branch_refused -> params#refused
-        | `Branch_delayed -> params#branch_delayed
-      in
-      let next () =
-        match !current_mempool with
-        | Some mempool -> begin
-            current_mempool := None ;
-            Lwt.return_some mempool
-          end
-        | None -> begin
-            Lwt_stream.get operation_stream >>= function
-            | Some (kind, shell, protocol_data) when filter_result kind ->
-                let bytes = Data_encoding.Binary.to_bytes_exn
-                    Next_proto.operation_data_encoding
-                    protocol_data in
-                let protocol_data = Data_encoding.Binary.of_bytes_exn
-                    Proto.operation_data_encoding
-                    bytes in
-                Lwt.return_some [ { Proto.shell ; protocol_data } ]
-            | _ -> Lwt.return_none
-          end
-      in
-      let shutdown () = Lwt_watcher.shutdown stopper in
-      RPC_answer.return_stream { next ; shutdown }
-    end ;
-
-  return !dir

src/lib_shell/prevalidation.mli

@@ -28,31 +28,47 @@
     consistency. This module is stateless and creates and manupulates the
     prevalidation_state. *)
 
-type prevalidation_state
+module type T = sig
 
-(** Creates a new prevalidation context w.r.t. the protocol associate to the
+  type state
-    predecessor block . When ?protocol_data is passed to this function, it will
-    be used to create the new block *)
-val start_prevalidation :
-  ?protocol_data: MBytes.t ->
-  predecessor: State.Block.t ->
-  timestamp: Time.t ->
-  unit -> prevalidation_state tzresult Lwt.t
 
-(** Given a prevalidation context applies a list of operations,
+  (** Creates a new prevalidation context w.r.t. the protocol associate to the
-    returns a new prevalidation context plus the preapply result containing the
+      predecessor block . When ?protocol_data is passed to this function, it will
-    list of operations that cannot be applied to this context *)
+      be used to create the new block *)
-val prevalidate :
+  val start_prevalidation :
-  prevalidation_state -> sort:bool ->
+    ?protocol_data: MBytes.t ->
-  (Operation_hash.t * Operation.t) list ->
+    predecessor: State.Block.t ->
-  (prevalidation_state * error Preapply_result.t) Lwt.t
+    timestamp: Time.t ->
+    unit -> state tzresult Lwt.t
 
-val end_prevalidation :
+  (** Given a prevalidation context applies a list of operations,
-  prevalidation_state ->
+      returns a new prevalidation context plus the preapply result containing the
-  Tezos_protocol_environment_shell.validation_result tzresult Lwt.t
+      list of operations that cannot be applied to this context *)
+  val prevalidate :
+    state -> sort:bool ->
+    (Operation_hash.t * Operation.t) list ->
+    (state * error Preapply_result.t) Lwt.t
 
-(** Pre-apply creates a new block ( running start_prevalidation, prevalidate and
+  val end_prevalidation :
-    end_prevalidation), and returns a new block. *)
+    state ->
+    Tezos_protocol_environment_shell.validation_result tzresult Lwt.t
+
+  val notify_operation :
+    state ->
+    error Preapply_result.t ->
+    unit
+
+  val shutdown_operation_input :
+    state ->
+    unit
+
+  val rpc_directory : (state * error Preapply_result.t) RPC_directory.t tzresult Lwt.t
+
+end
+
+module Make(Proto : Registered_protocol.T) : T
+
+(** Pre-apply creates a new block and returns it. *)
 val preapply :
   predecessor:State.Block.t ->
   timestamp:Time.t ->
@@ -60,16 +76,3 @@ val preapply :
   sort_operations:bool ->
   Operation.t list list ->
   (Block_header.shell_header * error Preapply_result.t list) tzresult Lwt.t
-
-val notify_operation :
-  prevalidation_state ->
-  error Preapply_result.t ->
-  unit
-
-val shutdown_operation_input :
-  prevalidation_state ->
-  unit
-
-val build_rpc_directory :
-  Protocol_hash.t ->
-  (prevalidation_state * error Preapply_result.t) RPC_directory.t tzresult Lwt.t

src/lib_shell/prevalidator.mli

@@ -25,25 +25,29 @@
 
 (** Tezos Shell - Prevalidation of pending operations (a.k.a Mempool) *)
 
-(** The prevalidation worker is in charge of the "mempool" (a.k.a. the
+(** The prevalidator is in charge of the "mempool" (a.k.a. the
     set of known not-invalid-for-sure operations that are not yet
     included in the blockchain).
 
-    The worker also maintains a sorted subset of the mempool that
+    The prevalidator also maintains a sorted subset of the mempool that
     might correspond to a valid block on top of the current head. The
     "in-progress" context produced by the application of those
     operations is called the (pre)validation context.
 
-    Before to include an operation into the mempool, the prevalidation
+    Before including an operation into the mempool, the prevalidation
     worker tries to append the operation the prevalidation context. If
     the operation is (strongly) refused, it will not be added into the
     mempool and then it will be ignored by the node and never
-    broadcasted. If the operation is only "branch_refused" or
+    broadcast. If the operation is only "branch_refused" or
     "branch_delayed", the operation won't be appended in the
-    prevalidation context, but still broadcasted.
+    prevalidation context, but still broadcast.
 
 *)
 
+
+
+(** An (abstract) prevalidator context. Separate prevalidator contexts should be
+ * used for separate chains (e.g., mainchain vs testchain). *)
 type t
 
 type limits = {
@@ -52,29 +56,27 @@ type limits = {
   worker_limits : Worker_types.limits ;
 }
 
-type error += Closed of Chain_id.t
+(** Creates/tear-down a new prevalidator context. *)
-
+val create:
-(** Creates a new worker. Each chain is associated with a prevalidator. Typically,
+  limits ->
-    this is the case for the main chain and a test chain *)
+  (module Registered_protocol.T) ->
-val create: limits -> Distributed_db.chain_db -> t Lwt.t
+  Distributed_db.chain_db ->
-
+  t Lwt.t
 val shutdown: t -> unit Lwt.t
 
-(** Notify the prevalidator worker of a set of operations (in the form of a mempool)
+(** Notify the prevalidator that the identified peer has sent a bunch of
-    received from a peer. *)
+ * operations relevant to the specified context. *)
-val notify_operations: t -> P2p_peer.Id.t -> Mempool.t -> unit
+val notify_operations: t -> P2p_peer.Id.t -> Mempool.t -> unit Lwt.t
 
-(** Notify the prevalidator worker of a new injected operation. This will be added
+(** Notify the prevalidator worker of a new injected operation. *)
-    to the mempool of the worker *)
 val inject_operation: t -> Operation.t -> unit tzresult Lwt.t
 
-(** Notify the prevalidator worker that a new head was received. The new head will
+(** Notify the prevalidator that a new head has been selected. *)
-    cause the reset of the prevalidation context *)
 val flush: t -> Block_hash.t -> unit tzresult Lwt.t
 
 (** Returns the timestamp of the prevalidator worker, that is the timestamp of the last
     reset of the prevalidation context *)
-val timestamp: t -> Time.t
+val timestamp: t -> Time.t Lwt.t
 
 (** Returns the list of valid operations known to this prevalidation worker *)
 val operations: t -> error Preapply_result.t * Operation.t Operation_hash.Map.t
@@ -82,12 +84,22 @@ val operations: t -> error Preapply_result.t * Operation.t Operation_hash.Map.t
 (** Returns the list of pending operations known to this prevalidation worker *)
 val pending: ?block:State.Block.t -> t -> Operation.t Operation_hash.Map.t Lwt.t
 
-(** Returns the list of prevalidation workers running and their associated chain *)
+(** Returns the list of prevalidation contexts running and their associated chain *)
-val running_workers: unit -> (Chain_id.t * t) list
+val running_workers: unit -> (Chain_id.t * Protocol_hash.t * t) list
+
+(** Two functions that are useful for managing the prevalidator's transition
+ * from one protocol to the next. *)
+
+(** Returns the hash of the protocol the prevalidator was instantiated with *)
+val protocol_hash: t -> Protocol_hash.t
+
+(** Returns the parameters the prevalidator was created with. *)
+val parameters: t -> limits * Distributed_db.chain_db
 
 (** Worker status and events *)
 
-val status: t -> Worker_types.worker_status
+(* None indicates the there are no workers for the current protocol. *)
+val status: t -> Worker_types.worker_status Lwt.t
 val pending_requests : t -> (Time.t * Prevalidator_worker_state.Request.view) list
 val current_request : t -> (Time.t * Time.t * Prevalidator_worker_state.Request.view) option
 val last_events : t -> (Lwt_log_core.level * Prevalidator_worker_state.Event.t list) list

src/lib_shell/worker_directory.ml

@@ -36,20 +36,29 @@ let build_rpc_directory state =
   (* Workers : Prevalidators *)
 
   register0  Worker_services.Prevalidators.S.list begin fun () () ->
-    return
+    let workers = Prevalidator.running_workers () in
-      (List.map
+    Lwt_list.map_p
-         (fun (id, w) -> (id, Prevalidator.status w))
+      (fun (chain_id, _, t) ->
-         (Prevalidator.running_workers ()))
+         Prevalidator.status t >>= fun status ->
+         Lwt.return (chain_id, status))
+      workers >>= fun info ->
+    return info
   end ;
 
   register1 Worker_services.Prevalidators.S.state begin fun chain () () ->
     Chain_directory.get_chain_id state chain >>= fun chain_id ->
-    let w = List.assoc chain_id (Prevalidator.running_workers ()) in
+    let workers = Prevalidator.running_workers () in
+    let (_, _, t) =
+      (* NOTE: it is technically possible to use the Prevalidator interface to
+       * register multiple Prevalidator for a single chain (using distinct
+       * protocols). However, this is never done. *)
+      List.find (fun (c, _, _) -> Chain_id.equal c chain_id) workers in
+    Prevalidator.status t >>= fun status ->
     return
-      { Worker_types.status = Prevalidator.status w ;
+      { Worker_types.status = status ;
-        pending_requests = Prevalidator.pending_requests w ;
+        pending_requests = Prevalidator.pending_requests t ;
-        backlog = Prevalidator.last_events w ;
+        backlog = Prevalidator.last_events t ;
-        current_request = Prevalidator.current_request w }
+        current_request = Prevalidator.current_request t }
   end ;
 
   (* Workers : Block_validator *)

src/lib_shell_services/worker_services.ml

@@ -42,7 +42,7 @@ module Prevalidators = struct
 
     let state =
       RPC_service.get_service
-        ~description:"Introspect the state of a prevalidator worker."
+        ~description:"Introspect the state of prevalidator workers."
         ~query: RPC_query.empty
         ~output:
           (Worker_types.full_status_encoding