Shell: Extract the block-application function into a separate module

src/lib_shell/block_validator.ml

@@ -43,9 +43,10 @@ module Types = struct
   include Worker_state
   type state = {
     protocol_validator: Protocol_validator.t ;
+    validation_process: Validator_process.t ;
     limits : limits ;
   }
-  type parameters = limits * Distributed_db.t
+  type parameters = limits * Distributed_db.t * Validator_process.t
   let view _state _parameters = ()
 end
 
@@ -140,11 +141,10 @@ let may_patch_protocol
 
 let apply_block
     chain_state
+    validation_process
     pred (module Proto : Registered_protocol.T)
     hash (header: Block_header.t)
     operations =
-  let pred_header = State.Block.header pred
-  and pred_hash = State.Block.hash pred in
   check_header pred (List.length Proto.validation_passes) hash header >>=? fun () ->
   iteri2_p
     (fun i ops quota ->
@@ -176,92 +176,17 @@ let apply_block
         fail (invalid_block hash Cannot_parse_block_header)
     | Some protocol_data ->
         return ({ shell = header.shell ; protocol_data } : Proto.block_header)
-  end >>=? fun header ->
+  end >>=? fun _header ->
-  mapi2_s (fun pass -> map2_s begin fun op_hash op ->
+  Validator_process.apply_block
-      match
+    validation_process header operations chain_state
-        Data_encoding.Binary.of_bytes
+  >>=? fun { validation_result ; block_data ; ops_metadata ; context_hash } ->
-          Proto.operation_data_encoding
+  let validation_store =
-          op.Operation.proto with
+    ({ context_hash ;
-      | None ->
+       message = validation_result.message ;
-          fail (invalid_block hash (Cannot_parse_operation op_hash))
+       max_operations_ttl =  validation_result.max_operations_ttl ;
-      | Some protocol_data ->
+       last_allowed_fork_level = validation_result.last_allowed_fork_level} :
-          let op = { Proto.shell = op.shell ; protocol_data } in
+       State.Block.validation_store) in
-          let allowed_pass = Proto.acceptable_passes op in
+  return (validation_store, block_data, ops_metadata)
-          fail_unless (List.mem pass allowed_pass)
-            (invalid_block hash
-               (Unallowed_pass { operation = op_hash ;
-                                 pass ; allowed_pass } )) >>=? fun () ->
-          return op
-    end)
-    operation_hashes
-    operations >>=? fun parsed_operations ->
-  State.Block.context pred >>= fun pred_context ->
-  Context.reset_test_chain
-    pred_context pred_hash header.shell.timestamp >>= fun context ->
-  (* TODO wrap 'proto_error' into 'block_error' *)
-  Proto.begin_application
-    ~chain_id: (State.Chain.id chain_state)
-    ~predecessor_context:context
-    ~predecessor_timestamp:pred_header.shell.timestamp
-    ~predecessor_fitness:pred_header.shell.fitness
-    header >>=? fun state ->
-  fold_left_s
-    (fun (state, acc) ops ->
-       fold_left_s
-         (fun (state, acc) op ->
-            Proto.apply_operation state op >>=? fun (state, op_metadata) ->
-            return (state, op_metadata :: acc))
-         (state, []) ops >>=? fun (state, ops_metadata) ->
-       return (state, List.rev ops_metadata :: acc))
-    (state, []) parsed_operations >>=? fun (state, ops_metadata) ->
-  let ops_metadata = List.rev ops_metadata in
-  Proto.finalize_block state >>=? fun (validation_result, block_data) ->
-  may_patch_protocol
-    ~level:header.shell.level validation_result >>=? fun validation_result ->
-  Context.get_protocol validation_result.context >>= fun new_protocol ->
-  let expected_proto_level =
-    if Protocol_hash.equal new_protocol Proto.hash then
-      pred_header.shell.proto_level
-    else
-      (pred_header.shell.proto_level + 1) mod 256 in
-  fail_when (header.shell.proto_level <> expected_proto_level)
-    (invalid_block hash @@  Invalid_proto_level {
-        found = header.shell.proto_level ;
-        expected = expected_proto_level ;
-      }) >>=? fun () ->
-  fail_when
-    Fitness.(validation_result.fitness <> header.shell.fitness)
-    (invalid_block hash @@ Invalid_fitness {
-        expected = header.shell.fitness ;
-        found = validation_result.fitness ;
-      }) >>=? fun () ->
-  begin
-    if Protocol_hash.equal new_protocol Proto.hash then
-      return validation_result
-    else
-      match Registered_protocol.get new_protocol with
-      | None ->
-          fail (Unavailable_protocol { block = hash ;
-                                       protocol = new_protocol })
-      | Some (module NewProto) ->
-          NewProto.init validation_result.context header.shell
-  end >>=? fun validation_result ->
-  let max_operations_ttl =
-    max 0
-      (min
-         ((State.Block.max_operations_ttl pred)+1)
-         validation_result.max_operations_ttl) in
-  let validation_result =
-    { validation_result with max_operations_ttl } in
-  let block_data =
-    Data_encoding.Binary.to_bytes_exn Proto.block_header_metadata_encoding block_data in
-  let ops_metadata =
-    List.map
-      (List.map
-         (Data_encoding.Binary.to_bytes_exn
-            Proto.operation_receipt_encoding))
-      ops_metadata in
-  return (validation_result, block_data, ops_metadata)
 
 let check_chain_liveness chain_db hash (header: Block_header.t) =
   let chain_state = Distributed_db.chain_state chain_db in
@@ -282,6 +207,7 @@ let get_proto pred hash =
                                    protocol = pred_protocol_hash })
   | Some p -> return p
 
+
 let on_request
   : type r. t -> r Request.t -> r tzresult Lwt.t
   = fun w
@@ -313,6 +239,7 @@ let on_request
               protect ?canceler begin fun () ->
                 apply_block
                   (Distributed_db.chain_state chain_db)
+                  bv.validation_process
                   pred proto hash
                   header operations >>=? fun (result, header_data, operations_data) ->
                 Distributed_db.commit_block
@@ -343,9 +270,9 @@ let on_request
                 assert commited ;
                 return (Error errors)
 
-let on_launch _ _ (limits, db) =
+let on_launch _ _ (limits, db, validation_process) =
   let protocol_validator = Protocol_validator.create db in
-  Lwt.return { Types.protocol_validator ; limits }
+  Lwt.return { Types.protocol_validator ; validation_process ; limits }
 
 let on_error w r st errs =
   Worker.record_event w (Validation_failure (r, st, errs)) ;
@@ -366,14 +293,18 @@ let on_completion
           (Event.Validation_failure (Request.view r, st, errs)) ;
         Lwt.return_unit
 
+let on_close w =
+  let bv = Worker.state w in
+  Validator_process.close bv.validation_process
+
 let table = Worker.create_table Queue
 
-let create limits db =
+let create limits db validation_process_kind =
   let module Handlers = struct
     type self = t
     let on_launch = on_launch
     let on_request = on_request
-    let on_close _ = Lwt.return_unit
+    let on_close = on_close
     let on_error = on_error
     let on_completion = on_completion
     let on_no_request _ = return_unit
@@ -382,7 +313,7 @@ let create limits db =
     table
     limits.worker_limits
     ()
-    (limits, db)
+    (limits, db, validation_process_kind)
     (module Handlers)
 
 let shutdown = Worker.shutdown

src/lib_shell/block_validator.mli

@@ -33,7 +33,9 @@ type limits = {
 type error += Closed of unit
 
 val create:
-  limits -> Distributed_db.t -> t Lwt.t
+  limits ->  Distributed_db.t ->
+  Validator_process.t ->
+  t Lwt.t
 
 val validate:
   t ->

src/lib_shell/distributed_db.mli

@@ -146,7 +146,7 @@ val commit_block:
   Block_hash.t ->
   Block_header.t -> MBytes.t ->
   Operation.t list list -> MBytes.t list list ->
-  Tezos_protocol_environment_shell.validation_result ->
+  State.Block.validation_store ->
   State.Block.t option tzresult Lwt.t
 
 (** Store on disk all the data associated to an invalid block. *)

src/lib_shell/node.ml

@@ -177,7 +177,8 @@ let create
     ?(sandboxed = false)
     { genesis ; store_root ; context_root ;
       patch_context ; p2p = p2p_params ;
-      test_chain_max_tll = max_child_ttl ; checkpoint }
+      test_chain_max_tll = max_child_ttl ;
+      checkpoint }
     peer_validator_limits
     block_validator_limits
     prevalidator_limits
@@ -187,15 +188,18 @@ let create
     | Some (config, _limits) -> not config.P2p.disable_mempool
     | None -> true in
   init_p2p ~sandboxed p2p_params >>=? fun p2p ->
-  State.read
+  State.init
     ~store_root ~context_root ?patch_context genesis >>=? fun (state, mainchain_state) ->
   may_update_checkpoint mainchain_state checkpoint >>= fun () ->
   let distributed_db = Distributed_db.create state p2p in
+  Validator_process.(init ~context_root Internal) >>= fun validation_process ->
   Validator.create state distributed_db
     peer_validator_limits
     block_validator_limits
+    validation_process
     prevalidator_limits
-    chain_validator_limits >>= fun validator ->
+    chain_validator_limits
+  >>= fun validator ->
   Validator.activate validator
     ?max_child_ttl ~start_prevalidator mainchain_state >>= fun mainchain_validator ->
   let shutdown () =

src/lib_shell/state.ml

@@ -625,6 +625,13 @@ module Block = struct
   }
   type block = t
 
+  type validation_store = {
+    context_hash: Context_hash.t;
+    message: string option;
+    max_operations_ttl: int;
+    last_allowed_fork_level: Int32.t;
+  }
+
   module Header = struct
 
     type t = hashed_header = {
@@ -833,8 +840,7 @@ module Block = struct
       ?(dont_enforce_context_hash = false)
       chain_state block_header block_header_metadata
       operations operations_metadata
-      { Tezos_protocol_environment_shell.context ; message ;
+      { context_hash ; message ; max_operations_ttl ; last_allowed_fork_level } =
-        max_operations_ttl ; last_allowed_fork_level } =
     let bytes = Block_header.to_bytes block_header in
     let hash = Block_header.hash_raw bytes in
     fail_unless
@@ -872,8 +878,12 @@ module Block = struct
         fail_unless
           acceptable_block
           (Checkpoint_error (hash, None)) >>=? fun () ->
-        Context.commit
+        let commit = context_hash in
-          ~time:block_header.shell.timestamp ?message context >>= fun commit ->
+        Context.exists chain_state.context_index.data commit
+        >>= fun exists ->
+        fail_unless exists
+          (failure "State.Block.store: context hash not found in context")
+        >>=? fun _ ->
         fail_unless
           (dont_enforce_context_hash
            || Context_hash.equal block_header.shell.context commit)
@@ -1257,6 +1267,25 @@ let may_create_chain state chain genesis =
         state genesis
 
 let read
+    global_store
+    context_index
+    main_chain =
+  let global_data = {
+    chains = Chain_id.Table.create 17 ;
+    global_store ;
+    context_index ;
+  } in
+  let state = {
+    global_data = Shared.create global_data ;
+    protocol_store = Shared.create @@ Store.Protocol.get global_store ;
+    main_chain ;
+    protocol_watcher = Lwt_watcher.create_input () ;
+    block_watcher = Lwt_watcher.create_input () ;
+  } in
+  Chain.read_all state >>=? fun () ->
+  return state
+
+let init
     ?patch_context
     ?(store_mapsize=4_096_000_000_000L)
     ?(context_mapsize=40_960_000_000L)
@@ -1267,20 +1296,8 @@ let read
   Context.init
     ~mapsize:context_mapsize ?patch_context
     context_root >>= fun context_index ->
-  let global_data = {
-    chains = Chain_id.Table.create 17 ;
-    global_store ;
-    context_index ;
-  } in
   let main_chain = Chain_id.of_block_hash genesis.Chain.block in
-  let state = {
+  read global_store context_index main_chain >>=? fun state ->
-    global_data = Shared.create global_data ;
-    protocol_store = Shared.create @@ Store.Protocol.get global_store ;
-    main_chain ;
-    protocol_watcher = Lwt_watcher.create_input () ;
-    block_watcher = Lwt_watcher.create_input () ;
-  } in
-  Chain.read_all state >>=? fun () ->
   may_create_chain state main_chain genesis >>= fun main_chain_state ->
   return (state, main_chain_state)
 

src/lib_shell/state.mli

@@ -119,6 +119,13 @@ module Block : sig
   type t
   type block = t
 
+  type validation_store = {
+    context_hash: Context_hash.t ;
+    message: string option ;
+    max_operations_ttl: int ;
+    last_allowed_fork_level: Int32.t ;
+  }
+
   val known: Chain.t -> Block_hash.t -> bool Lwt.t
   val known_valid: Chain.t -> Block_hash.t -> bool Lwt.t
   val known_invalid: Chain.t -> Block_hash.t -> bool Lwt.t
@@ -135,7 +142,7 @@ module Block : sig
     Chain.t ->
     Block_header.t -> MBytes.t ->
     Operation.t list list -> MBytes.t list list ->
-    Tezos_protocol_environment_shell.validation_result ->
+    validation_store ->
     block option tzresult Lwt.t
 
   val store_invalid:
@@ -311,7 +318,7 @@ end
 
 (** Read the internal state of the node and initialize
     the databases. *)
-val read:
+val init:
   ?patch_context:(Context.t -> Context.t Lwt.t) ->
   ?store_mapsize:int64 ->
   ?context_mapsize:int64 ->

src/lib_shell/test/test_locator.ml

@@ -39,8 +39,8 @@ let genesis_time = Time.of_seconds 0L
 
 let state_genesis_block =
   {
-    State.Chain.time = genesis_time;
+    State.Chain.time = genesis_time ;
-    State.Chain.block= genesis_hash;
+    State.Chain.block= genesis_hash ;
     State.Chain.protocol = genesis_protocol
   }
 
@@ -70,7 +70,7 @@ let incr_fitness fitness =
 let init_chain base_dir : State.Chain.t Lwt.t =
   let store_root = base_dir // "store" in
   let context_root = base_dir // "context" in
-  State.read
+  State.init
     ~store_root ~context_root state_genesis_block >>= function
   | Error _ -> Pervasives.failwith "read err"
   | Ok (_state, chain) ->
@@ -105,12 +105,15 @@ let make_empty_chain (chain:State.Chain.t) n : Block_hash.t Lwt.t =
   State.Block.read_exn chain genesis_hash >>= fun genesis ->
   State.Block.context genesis >>= fun empty_context ->
   let header = State.Block.header genesis in
+  let timestamp = State.Block.timestamp genesis in
+  Context.hash ~time:timestamp empty_context
+  >>= fun empty_context_hash ->
   Context.commit
     ~time:header.shell.timestamp empty_context >>= fun context ->
   let header = { header with shell = { header.shell with context } } in
-  let empty_result : Tezos_protocol_environment_shell.validation_result = {
+  let empty_result = {
-    context = empty_context ;
+    State.Block.
-    fitness = [] ;
+    context_hash = empty_context_hash ;
     message = None ;
     max_operations_ttl = 0 ;
     last_allowed_fork_level = 0l ;

src/lib_shell/test/test_state.ml

@@ -121,8 +121,15 @@ let build_valid_chain state vtbl pred names =
              (* no operations *)
              Proto.finalize_block vstate
            end >>=? fun (ctxt, _metadata) ->
+           Context.commit ~time:block.shell.timestamp ctxt.context
+           >>= fun context_hash ->
            State.Block.store state
-             block zero [[op]] [[zero]] ctxt >>=? fun _vblock ->
+             block zero [[op]] [[zero]]
+             ({context_hash;
+               message = ctxt.message;
+               max_operations_ttl = ctxt.max_operations_ttl;
+               last_allowed_fork_level = ctxt.last_allowed_fork_level} :
+                State.Block.validation_store) >>=? fun _vblock ->
            State.Block.read state hash >>=? fun vblock ->
            Hashtbl.add vtbl name vblock ;
            return vblock
@@ -168,7 +175,7 @@ let wrap_state_init f base_dir =
   begin
     let store_root = base_dir // "store" in
     let context_root = base_dir // "context" in
-    State.read
+    State.init
       ~store_mapsize:4_096_000_000L
       ~context_mapsize:4_096_000_000L
       ~store_root

src/lib_shell/validator.ml

@@ -43,12 +43,15 @@ type t = {
 let create state db
     peer_validator_limits
     block_validator_limits
+    validation_process
     prevalidator_limits
-    chain_validator_limits =
+    chain_validator_limits
-  Block_validator.create block_validator_limits db >>= fun block_validator ->
+  =
+  Block_validator.create block_validator_limits db validation_process >>= fun block_validator ->
   let valid_block_input = Lwt_watcher.create_input () in
   Lwt.return
-    { state ; db ; block_validator ;
+    { state ; db ;
+      block_validator ;
       block_validator_limits ; prevalidator_limits ;
       peer_validator_limits ; chain_validator_limits ;
       valid_block_input ;
@@ -67,7 +70,8 @@ let activate v ?max_child_ttl ~start_prevalidator chain_state =
         ?max_child_ttl
         ~start_prevalidator
         v.peer_validator_limits v.prevalidator_limits
-        v.block_validator v.valid_block_input v.db chain_state
+        v.block_validator
+        v.valid_block_input v.db chain_state
         v.chain_validator_limits in
     Chain_id.Table.add v.active_chains chain_id nv ;
     nv

src/lib_shell/validator.mli

@@ -32,6 +32,7 @@ val create:
   Distributed_db.t ->
   Peer_validator.limits ->
   Block_validator.limits ->
+  Validator_process.t ->
   Prevalidator.limits ->
   Chain_validator.limits ->
   t Lwt.t

src/lib_shell/validator_process.ml

@@ -0,0 +1,223 @@
+(*****************************************************************************)
+(*                                                                           *)
+(* Open Source License                                                       *)
+(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
+(*                                                                           *)
+(* Permission is hereby granted, free of charge, to any person obtaining a   *)
+(* copy of this software and associated documentation files (the "Software"),*)
+(* to deal in the Software without restriction, including without limitation *)
+(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
+(* and/or sell copies of the Software, and to permit persons to whom the     *)
+(* Software is furnished to do so, subject to the following conditions:      *)
+(*                                                                           *)
+(* The above copyright notice and this permission notice shall be included   *)
+(* in all copies or substantial portions of the Software.                    *)
+(*                                                                           *)
+(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
+(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
+(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
+(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
+(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
+(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
+(* DEALINGS IN THE SOFTWARE.                                                 *)
+(*                                                                           *)
+(*****************************************************************************)
+
+type application_result = {
+  validation_result: Tezos_protocol_environment_shell.validation_result ;
+  block_data: Secp256k1.watermark ;
+  ops_metadata: Secp256k1.watermark list list ;
+  context_hash: Context_hash.t ;
+}
+
+type error +=
+  | Failed_to_checkout_context of Context_hash.t
+
+let () =
+  register_error_kind
+    `Permanent
+    ~id:"Validator_process.failed_to_checkout_context"
+    ~title: "Fail during checkout context"
+    ~description: "The context checkout failed using a given hash"
+    ~pp:(fun ppf (hash:Context_hash.t) ->
+        Format.fprintf ppf
+          "@[Failed to checkout the context with hash %a@]"
+          Context_hash.pp_short hash)
+    Data_encoding.(obj1 (req "hash" Context_hash.encoding))
+    (function
+      | Failed_to_checkout_context h -> Some h
+      | _ -> None)
+    (fun h -> Failed_to_checkout_context h)
+
+
+(** The standard block validation method *)
+module SeqValidator = struct
+
+  include Logging.Make (struct let name = "sequential validator process" end)
+
+  type validation_context = {
+    context_index : Context.index ;
+  }
+
+  type t = validation_context
+
+  let init context_root =
+    lwt_log_notice "Intialized" >>= fun _ ->
+    Context.init context_root >>= fun context_index ->
+    Lwt.return { context_index }
+
+  let close _ =
+    lwt_log_notice "Shutting down ..." >>= fun _ ->
+    Lwt.return ()
+
+  let get_context index hash =
+    Context.checkout index hash >>= function
+    | None -> fail (Failed_to_checkout_context hash)
+    | Some ctx -> return ctx
+
+  open Block_validator_errors
+
+  let invalid_block block error = Invalid_block { block ; error }
+
+  let apply_block
+      validator_process
+      (header : Block_header.t)
+      operations
+      chain_state =
+    State.Block.read
+      chain_state header.shell.predecessor >>=? fun pred ->
+    State.Block.context pred >>= fun pred_context ->
+    Context.get_protocol pred_context >>= fun pred_protocol_hash ->
+    let hash = Block_header.hash header in
+    let chain_id = State.Chain.id chain_state in
+    begin
+      match Registered_protocol.get pred_protocol_hash with
+      | None ->
+          fail (Unavailable_protocol { block = hash ;
+                                       protocol = pred_protocol_hash })
+      | Some p -> return p
+    end >>=? fun (module Proto) ->
+    let pred_header = State.Block.header pred in
+    get_context
+      validator_process.context_index
+      pred_header.shell.context >>=? fun pred_context ->
+    let pred_hash = State.Block.hash pred in
+    Context.reset_test_chain
+      pred_context pred_hash header.shell.timestamp >>= fun context ->
+    let max_operations_ttl = State.Block.max_operations_ttl pred in
+    let operation_hashes = List.map (List.map Operation.hash) operations in
+    begin
+      match
+        Data_encoding.Binary.of_bytes
+          Proto.block_header_data_encoding
+          header.protocol_data with
+      | None ->
+          fail (invalid_block hash Cannot_parse_block_header)
+      | Some protocol_data ->
+          return ({ shell = header.shell ; protocol_data } : Proto.block_header)
+    end >>=? fun header ->
+    mapi2_s (fun pass -> map2_s begin fun op_hash op ->
+        match
+          Data_encoding.Binary.of_bytes
+            Proto.operation_data_encoding
+            op.Operation.proto with
+        | None ->
+            fail (invalid_block hash (Cannot_parse_operation op_hash))
+        | Some protocol_data ->
+            let op = { Proto.shell = op.shell ; protocol_data } in
+            let allowed_pass = Proto.acceptable_passes op in
+            fail_unless (List.mem pass allowed_pass)
+              (invalid_block hash
+                 (Unallowed_pass { operation = op_hash ;
+                                   pass ; allowed_pass } )) >>=? fun () ->
+            return op
+      end)
+      operation_hashes
+      operations >>=? fun parsed_operations ->
+    (* TODO wrap 'proto_error' into 'block_error' *)
+    Proto.begin_application
+      ~chain_id: chain_id
+      ~predecessor_context:context
+      ~predecessor_timestamp:pred_header.shell.timestamp
+      ~predecessor_fitness:pred_header.shell.fitness
+      header >>=? fun state ->
+    fold_left_s
+      (fun (state, acc) ops ->
+         fold_left_s
+           (fun (state, acc) op ->
+              Proto.apply_operation state op >>=? fun (state, op_metadata) ->
+              return (state, op_metadata :: acc))
+           (state, []) ops >>=? fun (state, ops_metadata) ->
+         return (state, List.rev ops_metadata :: acc))
+      (state, []) parsed_operations >>=? fun (state, ops_metadata) ->
+    let ops_metadata = List.rev ops_metadata in
+    Proto.finalize_block state >>=? fun (validation_result, block_data) ->
+    Context.get_protocol validation_result.context >>= fun new_protocol ->
+    let expected_proto_level =
+      if Protocol_hash.equal new_protocol Proto.hash then
+        pred_header.shell.proto_level
+      else
+        (pred_header.shell.proto_level + 1) mod 256 in
+    fail_when (header.shell.proto_level <> expected_proto_level)
+      (invalid_block hash @@  Invalid_proto_level {
+          found = header.shell.proto_level ;
+          expected = expected_proto_level ;
+        }) >>=? fun () ->
+    fail_when
+      Fitness.(validation_result.fitness <> header.shell.fitness)
+      (invalid_block hash @@ Invalid_fitness {
+          expected = header.shell.fitness ;
+          found = validation_result.fitness ;
+        }) >>=? fun () ->
+    begin
+      if Protocol_hash.equal new_protocol Proto.hash then
+        return validation_result
+      else
+        match Registered_protocol.get new_protocol with
+        | None ->
+            fail (Unavailable_protocol { block = hash ;
+                                         protocol = new_protocol })
+        | Some (module NewProto) ->
+            NewProto.init validation_result.context header.shell
+    end >>=? fun validation_result ->
+    let max_operations_ttl =
+      max 0
+        (min
+           ((max_operations_ttl)+1)
+           validation_result.max_operations_ttl) in
+    let validation_result =
+      { validation_result with max_operations_ttl } in
+    let block_data =
+      Data_encoding.Binary.to_bytes_exn
+        Proto.block_header_metadata_encoding block_data in
+    let ops_metadata =
+      List.map
+        (List.map
+           (Data_encoding.Binary.to_bytes_exn
+              Proto.operation_receipt_encoding))
+        ops_metadata in
+    Context.commit
+      ~time:header.shell.timestamp
+      ?message:validation_result.message
+      validation_result.context >>= fun context_hash ->
+    return ({ validation_result ; block_data ;
+              ops_metadata ; context_hash })
+
+end
+
+type kind =
+  | Internal
+
+type t =
+  | Sequential of SeqValidator.t
+
+let init ~context_root = function
+  | Internal ->
+      SeqValidator.init context_root >>= fun v ->
+      Lwt.return (Sequential v)
+
+let close = function
+  | Sequential vp -> SeqValidator.close vp
+
+let apply_block = function
+  | Sequential vp -> SeqValidator.apply_block vp

src/lib_shell/validator_process.mli

@@ -0,0 +1,46 @@
+(*****************************************************************************)
+(*                                                                           *)
+(* Open Source License                                                       *)
+(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
+(*                                                                           *)
+(* Permission is hereby granted, free of charge, to any person obtaining a   *)
+(* copy of this software and associated documentation files (the "Software"),*)
+(* to deal in the Software without restriction, including without limitation *)
+(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
+(* and/or sell copies of the Software, and to permit persons to whom the     *)
+(* Software is furnished to do so, subject to the following conditions:      *)
+(*                                                                           *)
+(* The above copyright notice and this permission notice shall be included   *)
+(* in all copies or substantial portions of the Software.                    *)
+(*                                                                           *)
+(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
+(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
+(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
+(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
+(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
+(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
+(* DEALINGS IN THE SOFTWARE.                                                 *)
+(*                                                                           *)
+(*****************************************************************************)
+
+type kind =
+  | Internal
+
+type t
+
+val init : context_root:string -> kind -> t Lwt.t
+val close : t -> unit Lwt.t
+
+type application_result = {
+  validation_result: Tezos_protocol_environment_shell.validation_result ;
+  block_data: Secp256k1.watermark ;
+  ops_metadata: Secp256k1.watermark list list ;
+  context_hash: Context_hash.t ;
+}
+
+val apply_block :
+  t ->
+  Block_header.t ->
+  Operation.t list list ->
+  State.Chain.t ->
+  application_result tzresult Lwt.t