Split the signature on Protocol.apply.

This prepares the node for the multi-pass validator by allowing
more fine grained interaction between the shell and the economic
protocol.

See merge request !103

src/Makefile.files

@@ -227,6 +227,7 @@ NODE_LIB_INTFS := \
   node/shell/distributed_db_message.mli \
   node/shell/distributed_db_metadata.mli \
   node/shell/distributed_db.mli \
+  node/shell/prevalidation.mli \
   node/shell/prevalidator.mli \
   node/shell/validator.mli \
   \
@@ -273,6 +274,7 @@ FULL_NODE_LIB_IMPLS := \
   node/shell/distributed_db_message.ml \
   node/shell/distributed_db_metadata.ml \
   node/shell/distributed_db.ml \
+  node/shell/prevalidation.ml \
   node/shell/prevalidator.ml \
   node/shell/validator.ml \
   \

src/client/client_keys.ml

@@ -83,16 +83,17 @@ let get_key cctxt pkh =
 
 let get_keys cctxt =
   Secret_key.load cctxt >>=? fun sks ->
-  map_filter_s
+  Lwt_list.filter_map_s
     (fun (name, sk) ->
-       Lwt.catch begin fun () ->
+       begin
          Public_key.find cctxt name >>=? fun pk ->
          Public_key_hash.find cctxt name >>=? fun pkh ->
-         return (Some (name, pkh, pk, sk))
+         return (name, pkh, pk, sk)
-       end begin fun _ ->
+       end >>= function
-         return None
+       | Ok r -> Lwt.return (Some r)
-       end)
+       | Error _ -> Lwt.return_none)
-    sks
+    sks >>= fun keys ->
+  return keys
 
 let list_keys cctxt =
   Public_key_hash.load cctxt >>=? fun l ->

src/client/client_node_rpcs.ml

@@ -70,7 +70,7 @@ module Blocks = struct
     timestamp: Time.t option ;
   }
   type preapply_result = Services.Blocks.preapply_result = {
-    operations: error Updater.preapply_result ;
+    operations: error Prevalidation.preapply_result ;
     fitness: MBytes.t list ;
     timestamp: Time.t ;
   }

src/client/client_node_rpcs.mli

@@ -98,7 +98,7 @@ module Blocks : sig
   val pending_operations:
     config ->
     block ->
-    (error Updater.preapply_result * Operation_hash.Set.t) tzresult Lwt.t
+    (error Prevalidation.preapply_result * Operation_hash.Set.t) tzresult Lwt.t
 
   type block_info = {
     hash: Block_hash.t ;
@@ -131,7 +131,7 @@ module Blocks : sig
     unit -> block_info list list tzresult Lwt_stream.t tzresult Lwt.t
 
   type preapply_result = {
-    operations: error Updater.preapply_result ;
+    operations: error Prevalidation.preapply_result ;
     fitness: MBytes.t list ;
     timestamp: Time.t ;
   }

src/client/embedded/alpha/baker/client_mining_forge.ml

@@ -93,7 +93,9 @@ let forge_block cctxt block
         Client_node_rpcs.Blocks.pending_operations
           cctxt block >>=? fun (ops, pendings) ->
         return (Operation_hash.Set.elements @@
-                Operation_hash.Set.union (Updater.operations ops) pendings)
+                Operation_hash.Set.union
+                  (Prevalidation.preapply_result_operations ops)
+                  pendings)
     | Some operations -> return operations
   end >>=? fun operations ->
   begin
@@ -417,7 +419,7 @@ let mine cctxt state =
          block >>=? fun (res, ops) ->
        let operations =
          let open Operation_hash.Set in
-         elements (union ops (Updater.operations res)) in
+         elements (union ops (Prevalidation.preapply_result_operations res)) in
        let request = List.length operations in
        Client_node_rpcs.Blocks.preapply cctxt.rpc_config block
          ~timestamp ~sort:true operations >>= function

src/node/shell/node.ml

@@ -276,13 +276,20 @@ module RPC = struct
         let pv = Validator.prevalidator validator in
         let net_state = Validator.net_state validator in
         State.Valid_block.Current.head net_state >>= fun head ->
-        let ctxt = Prevalidator.context pv in
+        Prevalidator.context pv >>= function
-        Context.get_fitness ctxt >|= fun fitness ->
+        | Error _ -> Lwt.fail Not_found
+        | Ok ctxt ->
+            Context.get_fitness ctxt >>= fun fitness ->
+            Context.get_protocol ctxt >>= fun protocol ->
+            let operations =
+              let pv_result, _ = Prevalidator.operations pv in
+              Some [ pv_result.applied ] in
+            let timestamp = Prevalidator.timestamp pv in
+            Lwt.return
               { (convert head) with
                 hash = prevalidation_hash ;
-          fitness ;
+                protocol = Some protocol ;
-          timestamp = Prevalidator.timestamp pv
+                fitness ; operations ; timestamp }
-        }
 
   let get_context node block =
     match block with
@@ -304,7 +311,9 @@ module RPC = struct
     | ( `Prevalidation | `Test_prevalidation ) as block ->
         let validator, _net = get_net node block in
         let pv = Validator.prevalidator validator in
-        Lwt.return (Some (Prevalidator.context pv))
+        Prevalidator.context pv >>= function
+        | Error _ -> Lwt.fail Not_found
+        | Ok ctxt -> Lwt.return (Some ctxt)
 
   let operations node block =
     match block with
@@ -321,7 +330,7 @@ module RPC = struct
     | (`Prevalidation | `Test_prevalidation) as block ->
         let validator, _net = get_net node block in
         let pv = Validator.prevalidator validator in
-        let { Updater.applied }, _ = Prevalidator.operations pv in
+        let { Prevalidation.applied }, _ = Prevalidator.operations pv in
         Lwt.return [applied]
     | `Hash hash ->
         read_valid_block node hash >|= function
@@ -347,24 +356,24 @@ module RPC = struct
         State.Valid_block.Current.head net_state >>= fun head ->
         get_pred net_db n head >>= fun b ->
         Prevalidator.pending ~block:b prevalidator >|= fun ops ->
-        Updater.empty_result, ops
+        Prevalidation.empty_result, ops
     | `Genesis ->
         let net = node.mainnet_net in
         State.Valid_block.Current.genesis net >>= fun b ->
         let validator = get_validator node `Genesis in
         let prevalidator = Validator.prevalidator validator in
         Prevalidator.pending ~block:b prevalidator >|= fun ops ->
-        Updater.empty_result, ops
+        Prevalidation.empty_result, ops
     | `Hash h -> begin
         get_validator_per_hash node h >>= function
         | None ->
-            Lwt.return (Updater.empty_result, Operation_hash.Set.empty)
+            Lwt.return (Prevalidation.empty_result, Operation_hash.Set.empty)
         | Some (validator, net_db) ->
             let net_state = Distributed_db.state net_db in
             let prevalidator = Validator.prevalidator validator in
             State.Valid_block.read_exn net_state h >>= fun block ->
             Prevalidator.pending ~block prevalidator >|= fun ops ->
-            Updater.empty_result, ops
+            Prevalidation.empty_result, ops
       end
 
   let protocols { state } =
@@ -396,17 +405,21 @@ module RPC = struct
           read_valid_block node hash >>= function
           | None -> Lwt.return (error_exn Not_found)
           | Some data -> return data
-    end >>=? fun { hash ; context ; protocol } ->
+    end >>=? fun predecessor ->
-    begin
-      match protocol with
-      | None -> failwith "Unknown protocol version"
-      | Some protocol -> return protocol
-    end >>=? fun ((module Proto) as protocol) ->
     let net_db = Validator.net_db node.mainnet_validator in
-    Prevalidator.preapply
+    map_p
-      net_db context protocol hash timestamp sort ops >>=? fun (ctxt, r) ->
+      (fun h ->
+         Distributed_db.Operation.read net_db h >>= function
+         | None -> failwith "Unknown operation %a" Operation_hash.pp h
+         | Some po -> return (h, po))
+      ops >>=? fun rops ->
+    Prevalidation.start_prevalidation
+      ~predecessor ~timestamp >>=? fun validation_state ->
+    Prevalidation.prevalidate
+      validation_state ~sort rops >>=? fun (validation_state, r) ->
+    Prevalidation.end_prevalidation validation_state >>=? fun ctxt ->
     Context.get_fitness ctxt >>= fun fitness ->
-    return (fitness, r)
+    return (fitness, { r with applied = List.rev r.applied })
 
   let complete node ?block str =
     match block with

src/node/shell/node.mli

@@ -66,7 +66,7 @@ module RPC : sig
     t -> (Operation_hash.t * Store.Operation.t) Lwt_stream.t * Watcher.stopper
 
   val pending_operations:
-    t -> block -> (error Updater.preapply_result * Operation_hash.Set.t) Lwt.t
+    t -> block -> (error Prevalidation.preapply_result * Operation_hash.Set.t) Lwt.t
 
   val protocols:
     t -> Protocol_hash.t list Lwt.t
@@ -82,7 +82,7 @@ module RPC : sig
     t -> block ->
     timestamp:Time.t -> sort:bool ->
     Operation_hash.t list ->
-    (Protocol.fitness * error Updater.preapply_result) tzresult Lwt.t
+    (Protocol.fitness * error Prevalidation.preapply_result) tzresult Lwt.t
 
   val validate: t -> Net_id.t -> Block_hash.t -> unit tzresult Lwt.t
 

src/node/shell/node_rpc_services.ml

@@ -157,7 +157,7 @@ module Blocks = struct
           (opt "timestamp" Time.encoding)))
 
   type preapply_result = {
-    operations: error Updater.preapply_result ;
+    operations: error Prevalidation.preapply_result ;
     fitness: MBytes.t list ;
     timestamp: Time.t ;
   }
@@ -171,7 +171,7 @@ module Blocks = struct
        (obj3
           (req "timestamp" Time.encoding)
           (req "fitness" Fitness.encoding)
-          (req "operations" (Updater.preapply_result_encoding Error.encoding))))
+          (req "operations" (Prevalidation.preapply_result_encoding Error.encoding))))
 
   let block_path : (unit, unit * block) RPC.Path.path =
     RPC.Path.(root / "blocks" /: blocks_arg )
@@ -266,14 +266,14 @@ module Blocks = struct
       ~input: empty
       ~output:
         (conv
-           (fun ({ Updater.applied; branch_delayed ; branch_refused },
+           (fun ({ Prevalidation.applied; branch_delayed ; branch_refused },
                  unprocessed) ->
              (applied,
               Operation_hash.Map.bindings branch_delayed,
               Operation_hash.Map.bindings branch_refused,
               Operation_hash.Set.elements unprocessed))
            (fun (applied, branch_delayed, branch_refused, unprocessed) ->
-              ({ Updater.applied ; refused = Operation_hash.Map.empty ;
+              ({ Prevalidation.applied ; refused = Operation_hash.Map.empty ;
                  branch_refused =
                    List.fold_right
                      (fun (k, o) -> Operation_hash.Map.add k o)

src/node/shell/node_rpc_services.mli

@@ -64,7 +64,7 @@ module Blocks : sig
     (unit, unit * block, unit, (Net_id.t * Time.t) option) RPC.service
   val pending_operations:
     (unit, unit * block, unit,
-     error Updater.preapply_result * Hash.Operation_hash.Set.t) RPC.service
+     error Prevalidation.preapply_result * Hash.Operation_hash.Set.t) RPC.service
 
   type list_param = {
     operations: bool ;
@@ -85,7 +85,7 @@ module Blocks : sig
     timestamp: Time.t option ;
   }
   type preapply_result = {
-    operations: error Updater.preapply_result ;
+    operations: error Prevalidation.preapply_result ;
     fitness: MBytes.t list ;
     timestamp: Time.t ;
   }

src/node/shell/prevalidation.ml

@@ -0,0 +1,176 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+type 'error preapply_result = {
+  applied: Operation_hash.t list;
+  refused: 'error list Operation_hash.Map.t;
+  branch_refused: 'error list Operation_hash.Map.t;
+  branch_delayed: 'error list Operation_hash.Map.t;
+}
+
+let empty_result = {
+  applied = [] ;
+  refused = Operation_hash.Map.empty ;
+  branch_refused = Operation_hash.Map.empty ;
+  branch_delayed = Operation_hash.Map.empty ;
+}
+
+let map_result f r = {
+  applied = r.applied;
+  refused = Operation_hash.Map.map f r.refused ;
+  branch_refused = Operation_hash.Map.map f r.branch_refused ;
+  branch_delayed = Operation_hash.Map.map f r.branch_delayed ;
+}
+
+let preapply_result_encoding error_encoding =
+  let open Data_encoding in
+  let refused_encoding = tup2 Operation_hash.encoding error_encoding in
+  let build_list map = Operation_hash.Map.bindings map in
+  let build_map list =
+    List.fold_right
+      (fun (k, e) m -> Operation_hash.Map.add k e m)
+      list Operation_hash.Map.empty in
+  conv
+    (fun { applied ; refused ; branch_refused ; branch_delayed } ->
+       (applied, build_list refused,
+        build_list branch_refused, build_list branch_delayed))
+    (fun (applied, refused, branch_refused, branch_delayed) ->
+       let refused = build_map refused in
+       let branch_refused = build_map branch_refused in
+       let branch_delayed = build_map branch_delayed in
+       { applied ; refused ; branch_refused ; branch_delayed })
+    (obj4
+       (req "applied" (list Operation_hash.encoding))
+       (req "refused" (list refused_encoding))
+       (req "branch_refused" (list refused_encoding))
+       (req "branch_delayed" (list refused_encoding)))
+
+let preapply_result_operations t =
+  let ops =
+    List.fold_left
+      (fun acc x -> Operation_hash.Set.add x acc)
+      Operation_hash.Set.empty t.applied in
+  let ops =
+    Operation_hash.Map.fold
+      (fun x _ acc -> Operation_hash.Set.add x acc)
+      t.branch_delayed ops in
+  let ops =
+    Operation_hash.Map.fold
+      (fun x _ acc -> Operation_hash.Set.add x acc)
+      t.branch_refused ops in
+  ops
+
+let empty_result =
+  { applied = [] ;
+    refused = Operation_hash.Map.empty ;
+    branch_refused = Operation_hash.Map.empty ;
+    branch_delayed = Operation_hash.Map.empty }
+
+let merge_result r r' =
+  let open Updater in
+  let merge _key a b =
+    match a, b with
+    | None, None -> None
+    | Some x, None -> Some x
+    | _, Some y -> Some y in
+  let merge_map =
+    Operation_hash.Map.merge merge in
+  { applied = r'.applied @ r.applied ;
+    refused = merge_map r.refused r'.refused ;
+    branch_refused = merge_map r.branch_refused r'.branch_refused ;
+    branch_delayed = r'.branch_delayed }
+
+let rec apply_operations apply_operation state ~sort ops =
+  Lwt_list.fold_left_s
+    (fun (state, r) (hash, op) ->
+       apply_operation state op >>= function
+       | Ok state ->
+           let applied = hash :: r.applied in
+           Lwt.return (state, { r with applied} )
+       | Error errors ->
+           match classify_errors errors with
+           | `Branch ->
+               let branch_refused =
+                 Operation_hash.Map.add hash errors r.branch_refused in
+               Lwt.return (state, { r with branch_refused })
+           | `Permanent ->
+               let refused =
+                 Operation_hash.Map.add hash errors r.refused in
+               Lwt.return (state, { r with refused })
+           | `Temporary ->
+               let branch_delayed =
+                 Operation_hash.Map.add hash errors r.branch_delayed in
+               Lwt.return (state, { r with branch_delayed }))
+    (state, empty_result)
+    ops >>= fun (state, r) ->
+  match r.applied with
+  | _ :: _ when sort ->
+      let rechecked_operations =
+        List.filter
+          (fun (hash, _) -> Operation_hash.Map.mem hash r.branch_delayed)
+          ops in
+      apply_operations apply_operation
+        state ~sort rechecked_operations >>=? fun (state, r') ->
+      return (state, merge_result r r')
+  | _ ->
+      return (state, r)
+
+type prevalidation_state =
+    State : { proto : 'a proto ; state : 'a }
+    -> prevalidation_state
+
+and 'a proto =
+  (module Updater.REGISTRED_PROTOCOL
+    with type validation_state = 'a)
+
+let start_prevalidation
+    ~predecessor:
+    { State.Valid_block.protocol ;
+      hash = predecessor ;
+      context = predecessor_context ;
+      timestamp = predecessor_timestamp }
+    ~timestamp =
+  let (module Proto) =
+    match protocol with
+    | None -> assert false (* FIXME, this should not happen! *)
+    | Some protocol -> protocol in
+  Proto.begin_construction
+    ~predecessor_context
+    ~predecessor_timestamp
+    ~predecessor
+    ~timestamp >>=? fun state ->
+  return (State { proto = (module Proto) ; state })
+
+let prevalidate
+    (State { proto = (module Proto) ; state })
+    ~sort ops =
+  (* The operations list length is bounded by the size of the mempool,
+     where eventually an operation should not stay more than one hours. *)
+  Lwt_list.map_p
+    (fun (h, op) ->
+       match Proto.parse_operation h op with
+       | Error _ ->
+           (* the operation will never be validated in the
+              current context, it is silently ignored. It may be
+              reintroduced in the loop by the next `flush`. *)
+           Lwt.return_none
+       | Ok p -> Lwt.return (Some (h, p)))
+    ops >>= fun ops ->
+  let ops = Utils.unopt_list ops in
+  let ops =
+    if sort then
+      let compare (_, op1) (_, op2) = Proto.compare_operations op1 op2 in
+      List.sort compare ops
+    else ops in
+  apply_operations Proto.apply_operation state ~sort ops >>=? fun (state, r) ->
+  return (State { proto = (module Proto) ; state }, r)
+
+let end_prevalidation (State { proto = (module Proto) ; state }) =
+  Proto.finalize_block state

src/node/shell/prevalidation.mli

@@ -0,0 +1,42 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+type 'error preapply_result = {
+  applied: Operation_hash.t list;
+  refused: 'error list Operation_hash.Map.t;
+  (* e.g. invalid signature *)
+  branch_refused: 'error list Operation_hash.Map.t;
+  (* e.g. insufficent balance *)
+  branch_delayed: 'error list Operation_hash.Map.t;
+  (* e.g. timestamp in the future *)
+}
+
+val empty_result : 'error preapply_result
+
+val preapply_result_operations :
+  'error preapply_result -> Operation_hash.Set.t
+
+val preapply_result_encoding :
+  'error list Data_encoding.t ->
+  'error preapply_result Data_encoding.t
+
+type prevalidation_state
+
+val start_prevalidation :
+  predecessor: State.Valid_block.t ->
+  timestamp: Time.t ->
+  prevalidation_state tzresult Lwt.t
+
+val prevalidate :
+  prevalidation_state -> sort:bool ->
+  (Operation_hash.t * Store.Operation.t) list ->
+  (prevalidation_state * error preapply_result) tzresult Lwt.t
+
+val end_prevalidation :
+  prevalidation_state -> Context.t tzresult Lwt.t

src/node/shell/prevalidator.ml

@@ -9,39 +9,6 @@
 
 open Logging.Node.Prevalidator
 
-let preapply
-    net_db ctxt (module Proto : Updater.REGISTRED_PROTOCOL)
-    block timestamp sort ops =
-  lwt_debug "-> prevalidate (%d)" (List.length ops) >>= fun () ->
-  (* The operations list length is bounded by the size of the mempool,
-     where eventually an operation should not stay more than one hours. *)
-  Lwt_list.map_p
-    (fun h ->
-       Distributed_db.Operation.read net_db h >>= function
-       | None -> Lwt.return_none
-       | Some op ->
-           match Proto.parse_operation h op with
-           | Error _ ->
-               (* the operation will never be validated in the
-                  current context, it is silently ignored. It may be
-                  reintroduced in the loop by the next `flush`. *)
-               Lwt.return_none
-           | Ok p -> Lwt.return (Some p))
-    ops >>= fun ops ->
-  Context.set_timestamp ctxt timestamp >>= fun ctxt ->
-  Proto.preapply ctxt block sort (Utils.unopt_list ops) >>= function
-  | Ok (ctxt, r)  ->
-      lwt_debug "<- prevalidate (%d/%d/%d/%d)"
-        (List.length r.Updater.applied)
-        (Operation_hash.Map.cardinal r.Updater.refused)
-        (Operation_hash.Map.cardinal r.Updater.branch_refused)
-        (Operation_hash.Map.cardinal r.Updater.branch_delayed) >>= fun () ->
-      Lwt.return (Ok (ctxt, r))
-  | Error errors ->
-      (* FIXME report internal error *)
-      lwt_debug "<- prevalidate (internal error)" >>= fun () ->
-      Lwt.return (Error errors)
-
 let list_pendings net_db ~from_block ~to_block old_mempool =
   let rec pop_blocks ancestor hash mempool =
     if Block_hash.equal hash ancestor then
@@ -75,22 +42,22 @@ let list_pendings net_db ~from_block ~to_block old_mempool =
 
 exception Invalid_operation of Operation_hash.t
 
+open Prevalidation
+
 type t = {
   net_db: Distributed_db.net ;
   flush: State.Valid_block.t -> unit;
   notify_operations: P2p.Peer_id.t -> Operation_hash.t list -> unit ;
   prevalidate_operations:
     bool -> Store.Operation.t list ->
-    (Operation_hash.t list * error Updater.preapply_result) tzresult Lwt.t ;
+    (Operation_hash.t list * error preapply_result) tzresult Lwt.t ;
-  operations: unit -> error Updater.preapply_result * Operation_hash.Set.t ;
+  operations: unit -> error preapply_result * Operation_hash.Set.t ;
   pending: ?block:State.Valid_block.t -> unit -> Operation_hash.Set.t Lwt.t ;
   timestamp: unit -> Time.t ;
-  context: unit -> Context.t ;
+  context: unit -> Context.t tzresult Lwt.t ;
-  protocol: unit -> (module Updater.REGISTRED_PROTOCOL) ;
   shutdown: unit -> unit Lwt.t ;
 }
 
-
 let merge _key a b =
   match a, b with
   | None, None -> None
@@ -105,27 +72,23 @@ let create net_db =
   let push_to_worker, worker_waiter = Lwt_utils.queue () in
 
   State.Valid_block.Current.head net_state >>= fun head ->
-  State.Valid_block.Current.protocol net_state >>= fun protocol ->
   State.Operation.list_pending net_state >>= fun initial_mempool ->
   let timestamp = ref (Time.now ()) in
-  begin
+  (start_prevalidation head !timestamp >|= ref) >>= fun validation_state ->
-    let (module Proto) = protocol in
-    Context.set_timestamp head.context !timestamp >>= fun ctxt ->
-    Proto.preapply ctxt head.hash false [] >|= function
-    | Error _ -> ref head.context
-    | Ok (ctxt, _) -> ref ctxt
-  end >>= fun context ->
-
   let pending = Operation_hash.Table.create 53 in
-  let protocol = ref protocol in
   let head = ref head in
-  let operations = ref Updater.empty_result in
+  let operations = ref empty_result in
   let running_validation = ref Lwt.return_unit in
   let unprocessed = ref initial_mempool in
   let broadcast_unprocessed = ref false in
 
-  let set_context ctxt =
+  let set_validation_state state =
-    context := ctxt;
+    validation_state := state;
+    Lwt.return_unit in
+
+  let reset_validation_state head timestamp =
+    start_prevalidation head timestamp >>= fun state ->
+    validation_state := state;
     Lwt.return_unit in
 
   let broadcast_operation ops =
@@ -143,23 +106,29 @@ let create net_db =
       broadcast_unprocessed := false ;
       running_validation := begin
         begin
-          preapply
+          Lwt_list.map_p
-            net_db !context !protocol !head.hash !timestamp true
+            (fun h ->
-            (Operation_hash.Set.elements ops) >>= function
+               Distributed_db.Operation.read net_db h >>= function
-          | Ok (ctxt, r) -> Lwt.return (ctxt, r)
+               | None -> Lwt.return_none
+               | Some po -> Lwt.return_some (h, po))
+            (Operation_hash.Set.elements ops) >>= fun rops ->
+          let rops = Utils.unopt_list rops in
+          (Lwt.return !validation_state >>=? fun validation_state ->
+           prevalidate validation_state ~sort:true rops) >>= function
+          | Ok (state, r) -> Lwt.return (Ok state, r)
           | Error err ->
               let r =
-                { Updater.empty_result with
+                { empty_result with
                   branch_delayed =
                     Operation_hash.Set.fold
                       (fun op m -> Operation_hash.Map.add op err m)
                       ops Operation_hash.Map.empty ; } in
-              Lwt.return (!context, r)
+              Lwt.return (!validation_state, r)
-        end >>= fun (ctxt, r) ->
+        end >>= fun (state, r) ->
         let filter_out s m =
           List.fold_right Operation_hash.Map.remove s m in
         operations := {
-          Updater.applied = List.rev_append r.applied !operations.applied ;
+          applied = List.rev_append r.applied !operations.applied ;
              refused = Operation_hash.Map.empty ;
              branch_refused =
                Operation_hash.Map.merge merge
@@ -171,13 +140,13 @@ let create net_db =
                  (filter_out r.applied !operations.branch_delayed)
                  r.branch_delayed ;
         } ;
-        if broadcast then broadcast_operation r.Updater.applied ;
+        if broadcast then broadcast_operation r.applied ;
         Lwt_list.iter_s
           (fun (_op, _exns) ->
              (* FIXME *)
              (* Distributed_db.Operation.mark_invalid net_db op exns >>= fun _ -> *)
              Lwt.return_unit)
-          (Operation_hash.Map.bindings r.Updater.refused) >>= fun () ->
+          (Operation_hash.Map.bindings r.refused) >>= fun () ->
         (* TODO. Keep a bounded set of 'refused' operations. *)
         (* TODO. Log the error in some statistics associated to
                  the peers that informed us of the operations. And
@@ -185,7 +154,7 @@ let create net_db =
         (* TODO. Keep a bounded set of 'branch_refused' operations
                  into the 'state'. It should be associated to the
                  current block, and updated on 'set_current_head'. *)
-        set_context ctxt
+        set_validation_state state
       end;
       Lwt.catch
         (fun () -> !running_validation)
@@ -209,22 +178,10 @@ let create net_db =
           Lwt_list.iter_s
             (function
               | `Prevalidate (ops, w, force) -> begin
-                  let (module Proto) = !protocol in
                   let result =
-                    map_s (fun (h, b) ->
+                    let rops = Operation_hash.Map.bindings ops in
-                        Distributed_db.Operation.known net_db h >>= function
+                    Lwt.return !validation_state >>=? fun validation_state ->
-                        | true ->
+                    prevalidate validation_state ~sort:true rops >>=? fun (state, res) ->
-                            failwith
-                              "Previously injected operation %a"
-                              Operation_hash.pp_short h
-                        | false ->
-                            Lwt.return
-                              (Proto.parse_operation h b
-                               |> record_trace_exn (Invalid_operation h)))
-                      (Operation_hash.Map.bindings ops) >>=? fun parsed_ops ->
-                    Context.set_timestamp !context (Time.now ()) >>= fun ctxt ->
-                    Proto.preapply
-                      ctxt !head.hash true parsed_ops >>=? fun (ctxt, res) ->
                     let register h =
                       let op = Operation_hash.Map.find h ops in
                       Distributed_db.Operation.inject
@@ -237,18 +194,18 @@ let create net_db =
                            { !operations with
                              applied = h :: !operations.applied };
                          Lwt.return_unit )
-                      res.Updater.applied >>= fun () ->
+                      res.applied >>= fun () ->
-                    broadcast_operation res.Updater.applied ;
+                    broadcast_operation res.applied ;
                     begin
                       if force then
                         Lwt_list.iter_p
                           (fun (h, _exns) -> register h)
                           (Operation_hash.Map.bindings
-                             res.Updater.branch_delayed) >>= fun () ->
+                             res.branch_delayed) >>= fun () ->
                         Lwt_list.iter_p
                           (fun (h, _exns) -> register h)
                           (Operation_hash.Map.bindings
-                             res.Updater.branch_refused) >>= fun () ->
+                             res.branch_refused) >>= fun () ->
                         operations :=
                           { !operations with
                             branch_delayed =
@@ -262,7 +219,7 @@ let create net_db =
                       else
                         Lwt.return_unit
                     end >>= fun () ->
-                    set_context ctxt >>= fun () ->
+                    set_validation_state (Ok state) >>= fun () ->
                     return res
                   in
                   result >>= fun result ->
@@ -299,32 +256,20 @@ let create net_db =
                   lwt_debug "register %a" Operation_hash.pp_short op >>= fun () ->
                   Lwt.return_unit
               | `Flush (new_head : State.Valid_block.t) ->
-                  let new_protocol =
-                    match new_head.protocol with
-                    | None ->
-                        assert false (* FIXME, this should not happen! *)
-                    | Some protocol -> protocol in
                   list_pendings
                     net_db ~from_block:!head ~to_block:new_head
-                    (Updater.operations !operations) >>= fun new_mempool ->
+                    (preapply_result_operations !operations) >>= fun new_mempool ->
                   lwt_debug "flush %a (mempool: %d)"
                     Block_hash.pp_short new_head.hash
                     (Operation_hash.Set.cardinal new_mempool) >>= fun () ->
                   (* Reset the pre-validation context *)
                   head := new_head ;
-                  protocol := new_protocol ;
+                  operations := empty_result ;
-                  operations := Updater.empty_result ;
                   broadcast_unprocessed := false ;
                   unprocessed := new_mempool ;
                   timestamp := Time.now () ;
-                  (* Tag the context as a prevalidation context. *)
+                  (* Reset the prevalidation context. *)
-                  let (module Proto) = new_protocol in
+                  reset_validation_state new_head !timestamp)
-                  Context.set_timestamp
-                    new_head.context !timestamp >>= fun ctxt ->
-                  Proto.preapply
-                    ctxt new_head.hash false [] >>= function
-                  | Error _ -> set_context new_head.context
-                  | Ok (ctxt, _) -> set_context ctxt)
             q >>= fun () ->
           worker_loop ()
     in
@@ -357,14 +302,15 @@ let create net_db =
       Lwt.cancel !running_validation;
     cancel () >>= fun () ->
     prevalidation_worker in
-
   let pending ?block () =
-    let ops = Updater.operations !operations in
+    let ops = preapply_result_operations !operations in
     match block with
     | None -> Lwt.return ops
     | Some to_block ->
-        list_pendings net_db ~from_block:!head ~to_block ops
+        list_pendings net_db ~from_block:!head ~to_block ops in
-  in
+  let context () =
+    Lwt.return !validation_state >>=? fun prevalidation_state ->
+    Prevalidation.end_prevalidation prevalidation_state in
   Lwt.return {
     net_db ;
     flush ;
@@ -376,8 +322,7 @@ let create net_db =
          !unprocessed) ;
     pending ;
     timestamp = (fun () -> !timestamp) ;
-    context = (fun () -> !context) ;
+    context ;
-    protocol = (fun () -> !protocol) ;
     shutdown ;
   }
 
@@ -388,7 +333,6 @@ let operations pv = pv.operations ()
 let pending ?block pv = pv.pending ?block ()
 let timestamp pv = pv.timestamp ()
 let context pv = pv.context ()
-let protocol pv = pv.protocol ()
 let shutdown pv = pv.shutdown ()
 
 let inject_operation pv ?(force = false) (op: Store.Operation.t) =
@@ -404,15 +348,15 @@ let inject_operation pv ?(force = false) (op: Store.Operation.t) =
     (Unclassified
        "Prevalidator.inject_operation: invalid network") >>=? fun () ->
   pv.prevalidate_operations force [op] >>=? function
-  | ([h], { Updater.applied = [h'] }) when Operation_hash.equal h h' ->
+  | ([h], { applied = [h'] }) when Operation_hash.equal h h' ->
       return ()
-  | ([h], { Updater.refused })
+  | ([h], { refused })
     when Operation_hash.Map.cardinal refused = 1 ->
       wrap_error h refused
-  | ([h], { Updater.branch_refused })
+  | ([h], { branch_refused })
     when Operation_hash.Map.cardinal branch_refused = 1 && not force  ->
       wrap_error h branch_refused
-  | ([h], { Updater.branch_delayed })
+  | ([h], { branch_delayed })
     when Operation_hash.Map.cardinal branch_delayed = 1 && not force  ->
       wrap_error h branch_delayed
   | _ ->

src/node/shell/prevalidator.mli

@@ -43,13 +43,7 @@ val inject_operation:
 
 val flush: t -> State.Valid_block.t -> unit
 val timestamp: t -> Time.t
-val operations: t -> error Updater.preapply_result * Operation_hash.Set.t
+val operations: t -> error Prevalidation.preapply_result * Operation_hash.Set.t
-val context: t -> Context.t
+val context: t -> Context.t tzresult Lwt.t
-val protocol: t -> (module Updater.REGISTRED_PROTOCOL)
 
 val pending: ?block:State.Valid_block.t -> t -> Operation_hash.Set.t Lwt.t
-
-val preapply:
-  Distributed_db.net -> Context.t -> (module Updater.REGISTRED_PROTOCOL) ->
-  Block_hash.t -> Time.t -> bool -> Operation_hash.t list ->
-  (Context.t * error Updater.preapply_result) tzresult Lwt.t

src/node/shell/validator.ml

@@ -190,7 +190,6 @@ let apply_block net db
     Protocol_hash.pp_short Proto.hash >>= fun () ->
   lwt_debug "validation of %a: parsing header..."
     Block_hash.pp_short hash >>= fun () ->
-  Lwt.return (Proto.parse_block block pred.timestamp) >>=? fun parsed_header ->
   lwt_debug "validation of %a: parsing operations..."
     Block_hash.pp_short hash >>= fun () ->
   map2_s
@@ -201,8 +200,15 @@ let apply_block net db
     operations >>=? fun parsed_operations ->
   lwt_debug "validation of %a: applying block..."
     Block_hash.pp_short hash >>= fun () ->
-  Proto.apply
+  Proto.begin_application
-    patched_context parsed_header parsed_operations >>=? fun new_context ->
+    ~predecessor_context:patched_context
+    ~predecessor_timestamp:pred.timestamp
+    block >>=? fun state ->
+  fold_left_s (fun state op ->
+      Proto.apply_operation state op >>=? fun state ->
+      return state)
+    state parsed_operations >>=? fun state ->
+  Proto.finalize_block state >>=? fun new_context ->
   lwt_log_info "validation of %a: success"
     Block_hash.pp_short hash >>= fun () ->
   return new_context

src/node/updater/protocol.mli

@@ -44,22 +44,6 @@ type raw_block = Store.Block_header.t = {
   proto: MBytes.t ;
 }
 
-(** Result of the {!PROTOCOL.preapply} function of the protocol for
-    discriminating cacheable operations from droppable ones. *)
-type 'error preapply_result =
-  { applied: Operation_hash.t list;
-    (** Operations that where successfully applied. *)
-    refused: 'error list Operation_hash.Map.t;
-    (** Operations which triggered a context independent, unavoidable
-        error (e.g. invalid signature). *)
-    branch_refused: 'error list Operation_hash.Map.t;
-    (** Operations which triggered an error that might not arise in a
-        different context (e.g. past account counter, insufficent
-        balance). *)
-    branch_delayed: 'error list Operation_hash.Map.t;
-    (** Operations which triggered an error that might not arise in a
-        future update of this context (e.g. futur account counter). *) }
-
 (** This is the signature of a Tezos protocol implementation. It has
     access to the standard library and the Environment module. *)
 module type PROTOCOL = sig
@@ -73,47 +57,80 @@ module type PROTOCOL = sig
   (** The maximum size of operations in bytes *)
   val max_operation_data_length : int
 
-  (** The version specific part of blocks. *)
-  type block
-
   (** The maximum size of block headers in bytes *)
   val max_block_length : int
 
   (** The maximum *)
   val max_number_of_operations : int
 
-  (** The parsing / preliminary validation function for blocks. Its
-      role is to check that the raw header is well formed, and to
-      produce a pre-decomposed value of the high level, protocol defined
-      {!block} type. It does not have access to the storage
-      context. It may store the hash and raw bytes for later signature
-      verification by {!apply} or {!preapply}. The timestamp of the
-      predecessor block is also provided for early delay checks. *)
-  val parse_block : raw_block -> Time.t -> block tzresult
-
   (** The parsing / preliminary validation function for
       operations. Similar to {!parse_block}. *)
   val parse_operation :
     Operation_hash.t -> raw_operation -> operation tzresult
 
-  (** The main protocol function that validates blocks. It receives the
+  (** Basic ordering of operations. [compare_operations op1 op2] means
-      block header and the list of associated operations, as
+      that [op1] should appear before [op2] in a block. *)
-      pre-decomposed by {!parse_block} and {!parse_operation}. *)
+  val compare_operations : operation -> operation -> int
-  val apply :
-    Context.t -> block -> operation list ->
-    Context.t tzresult Lwt.t
 
-  (** The auxiliary protocol entry point that validates pending
+  (** A functional state that is transmitted through the steps of a
-      operations out of blocks. This function tries to apply the all
+      block validation sequence. It must retain the current state of
-      operations in the given order, and returns which applications have
+      the store (that can be extracted from the outside using
-      suceeded and which ones have failed. The first two parameters
+      {!current_context}, and whose final value is produced by
-      are a context in which to apply the operations and the hash of the
+      {!finalize_block}). It can also contain the information that
-      preceding block. This function is used by the shell for accepting or
+      must be remembered during the validation, which must be
-      dropping operations, as well as the mining client to check that a
+      immutable (as validator or baker implementations are allowed to
-      sequence of operations forms a valid block. *)
+      pause, replay or backtrack during the validation process). *)
-  val preapply :
+  type validation_state
-    Context.t -> Block_hash.t -> bool -> operation list ->
+
-    (Context.t * error preapply_result) tzresult Lwt.t
+  (** Access the context at a given validation step. *)
+  val current_context : validation_state -> Context.t tzresult Lwt.t
+
+  (** Checks that a block is well formed in a given context. This
+      function should run quickly, as its main use is to reject bad
+      blocks from the network as early as possible. The input context
+      is the one resulting of an ancestor block of same protocol
+      version, not necessarily the one of its predecessor. *)
+  val precheck_block :
+    ancestor_context: Context.t ->
+    ancestor_timestamp: Time.t ->
+    raw_block ->
+    unit tzresult Lwt.t
+
+  (** The first step in a block validation sequence. Initializes a
+      validation context for validating a block. Takes as argument the
+      {!raw_block} to initialize the context for this block, patching
+      the context resulting of the application of the predecessor
+      block passed as parameter. The function {!precheck_block} may
+      not have been called before [begin_application], so all the
+      check performed by the former must be repeated in the latter. *)
+  val begin_application :
+    predecessor_context: Context.t ->
+    predecessor_timestamp: Time.t ->
+    raw_block ->
+    validation_state tzresult Lwt.t
+
+  (** Initializes a validation context for constructing a new block
+      (as opposed to validating an existing block). Since there is no
+      {!raw_block} header available, the parts that it provides are
+      passed as arguments (predecessor block hash, context resulting
+      of the application of the predecessor block, and timestamp). *)
+  val begin_construction :
+    predecessor_context: Context.t ->
+    predecessor_timestamp: Time.t ->
+    predecessor: Block_hash.t ->
+    timestamp: Time.t ->
+    validation_state tzresult Lwt.t
+
+  (** Called after {!begin_application} (or {!begin_construction}) and
+      before {!finalize_block}, with each operation in the block. *)
+  val apply_operation :
+    validation_state -> operation -> validation_state tzresult Lwt.t
+
+  (** The last step in a block validation sequence. It produces the
+      context that will be used as input for the validation of its
+      successor block candidates. *)
+  val finalize_block :
+    validation_state -> Context.t tzresult Lwt.t
 
   (** The list of remote procedures exported by this implementation *)
   val rpc_services : Context.t RPC.directory

src/node/updater/register.ml

@@ -33,12 +33,30 @@ let register (module Proto : Protocol.PACKED_PROTOCOL) =
   let module V = struct
     include Proto
     include Make(Proto)
-    let parse_block d t = parse_block d t |> wrap_error
+    let precheck_block
+        ~ancestor_context ~ancestor_timestamp
+        raw_block =
+      precheck_block
+        ~ancestor_context ~ancestor_timestamp
+        raw_block >|= wrap_error
+    let begin_application
+        ~predecessor_context ~predecessor_timestamp
+        raw_block =
+      begin_application
+        ~predecessor_context ~predecessor_timestamp
+        raw_block >|= wrap_error
+    let begin_construction
+        ~predecessor_context ~predecessor_timestamp
+        ~predecessor ~timestamp =
+      begin_construction
+        ~predecessor_context ~predecessor_timestamp
+        ~predecessor ~timestamp >|= wrap_error
+    let current_context c =
+      current_context c >|= wrap_error
+    let apply_operation c o =
+      apply_operation c o >|= wrap_error
+    let finalize_block c = finalize_block c >|= wrap_error
     let parse_operation h b = parse_operation h b |> wrap_error
-    let apply c h ops = apply c h ops >|= wrap_error
-    let preapply c h b ops =
-      (preapply c h b ops >|= wrap_error) >>=? fun (ctxt, r) ->
-      return (ctxt, Updater.map_result (fun l -> [Ecoproto_error l]) r)
     let configure_sandbox c j =
       configure_sandbox c j >|= wrap_error
   end in

src/node/updater/updater.ml

@@ -53,51 +53,6 @@ type raw_block = Store.Block_header.t = {
 }
 let raw_block_encoding = Store.Block_header.encoding
 
-type 'error preapply_result = 'error Protocol.preapply_result = {
-  applied: Operation_hash.t list;
-  refused: 'error list Operation_hash.Map.t;
-  branch_refused: 'error list Operation_hash.Map.t;
-  branch_delayed: 'error list Operation_hash.Map.t;
-}
-
-let empty_result = {
-  applied = [] ;
-  refused = Operation_hash.Map.empty ;
-  branch_refused = Operation_hash.Map.empty ;
-  branch_delayed = Operation_hash.Map.empty ;
-}
-
-let map_result f r = {
-  applied = r.applied;
-  refused = Operation_hash.Map.map f r.refused ;
-  branch_refused = Operation_hash.Map.map f r.branch_refused ;
-  branch_delayed = Operation_hash.Map.map f r.branch_delayed ;
-}
-
-let preapply_result_encoding error_encoding =
-  let open Data_encoding in
-  let refused_encoding = tup2 Operation_hash.encoding error_encoding in
-  let build_list map = Operation_hash.Map.bindings map in
-  let build_map list =
-    List.fold_right
-      (fun (k, e) m -> Operation_hash.Map.add k e m)
-      list Operation_hash.Map.empty in
-  conv
-    (fun { applied ; refused ; branch_refused ; branch_delayed } ->
-       (applied, build_list refused,
-        build_list branch_refused, build_list branch_delayed))
-    (fun (applied, refused, branch_refused, branch_delayed) ->
-       let refused = build_map refused in
-       let branch_refused = build_map branch_refused in
-       let branch_delayed = build_map branch_delayed in
-       { applied ; refused ; branch_refused ; branch_delayed })
-    (obj4
-       (req "applied" (list Operation_hash.encoding))
-       (req "refused" (list refused_encoding))
-       (req "branch_refused" (list refused_encoding))
-       (req "branch_delayed" (list refused_encoding)))
-
-
 (** Version table *)
 
 module VersionTable = Protocol_hash.Table
@@ -200,18 +155,3 @@ let compile hash units =
       log_error "Internal error while compiling %a" Protocol_hash.pp hash;
     Lwt.return loaded
   end
-
-let operations t =
-  let ops =
-    List.fold_left
-      (fun acc x -> Operation_hash.Set.add x acc)
-      Operation_hash.Set.empty t.applied in
-  let ops =
-    Operation_hash.Map.fold
-      (fun x _ acc -> Operation_hash.Set.add x acc)
-      t.branch_delayed ops in
-  let ops =
-    Operation_hash.Map.fold
-      (fun x _ acc -> Operation_hash.Set.add x acc)
-      t.branch_refused ops in
-  ops

src/node/updater/updater.mli

@@ -41,23 +41,6 @@ type raw_block = Store.Block_header.t = {
 }
 val raw_block_encoding: raw_block Data_encoding.t
 
-type 'error preapply_result = 'error Protocol.preapply_result = {
-  applied: Operation_hash.t list;
-  refused: 'error list Operation_hash.Map.t; (* e.g. invalid signature. *)
-  branch_refused: 'error list Operation_hash.Map.t; (* e.g. past account counter;
-                                                     insufficent balance *)
-  branch_delayed: 'error list Operation_hash.Map.t; (* e.g. futur account counter. *)
-}
-
-val empty_result: 'error preapply_result
-val map_result: ('a list -> 'b list) -> 'a preapply_result -> 'b preapply_result
-
-val operations: 'error preapply_result -> Operation_hash.Set.t
-
-val preapply_result_encoding :
-  'error list Data_encoding.t ->
-  'error preapply_result Data_encoding.t
-
 module type PROTOCOL = Protocol.PROTOCOL
 module type REGISTRED_PROTOCOL = sig
   val hash: Protocol_hash.t

src/proto/alpha/apply.ml

@@ -68,15 +68,11 @@ let apply_delegate_operation_content
         (Wrong_voting_period (level.voting_period, period)) >>=? fun () ->
       Amendment.record_ballot ctxt delegate proposal ballot
 
-let rec is_reject = function
-  | [] -> false
-  | Script_interpreter.Reject _ :: _ -> true
-  | _ :: err -> is_reject err
-
 type error += Non_scripted_contract_with_parameter
 type error += Scripted_contract_without_paramater
 
-let apply_manager_operation_content ctxt origination_nonce accept_failing_script source = function
+let apply_manager_operation_content
+    ctxt origination_nonce source = function
   | Transaction { amount ; parameters ; destination } -> begin
       Contract.spend ctxt source amount >>=? fun ctxt ->
       Contract.credit ctxt destination amount >>=? fun ctxt ->
@@ -84,7 +80,7 @@ let apply_manager_operation_content ctxt origination_nonce accept_failing_script
       | None -> begin
           match parameters with
           | None | Some (Prim (_, "Unit", [])) ->
-              return (ctxt, origination_nonce)
+              return (ctxt, origination_nonce, None)
           | Some _ -> fail Non_scripted_contract_with_parameter
         end
       | Some { code ; storage } ->
@@ -102,12 +98,9 @@ let apply_manager_operation_content ctxt origination_nonce accept_failing_script
                   Contract.update_script_storage_and_fees
                     ctxt destination
                     Script_interpreter.dummy_storage_fee storage_res >>=? fun ctxt ->
-                  return (ctxt, origination_nonce)
+                  return (ctxt, origination_nonce, None)
               | Error err ->
-                  if accept_failing_script && is_reject err then
+                  return (ctxt, origination_nonce, Some err)
-                    return (ctxt, origination_nonce)
-                  else
-                    Lwt.return (Error err)
     end
   | Origination { manager ; delegate ; script ;
                   spendable ; delegatable ; credit } ->
@@ -122,10 +115,10 @@ let apply_manager_operation_content ctxt origination_nonce accept_failing_script
         ~manager ~delegate ~balance:credit
         ?script
         ~spendable ~delegatable >>=? fun (ctxt, _, origination_nonce) ->
-      return (ctxt, origination_nonce)
+      return (ctxt, origination_nonce, None)
   | Delegation delegate ->
       Contract.set_delegate ctxt source delegate >>=? fun ctxt ->
-      return (ctxt, origination_nonce)
+      return (ctxt, origination_nonce, None)
 
 let check_signature_and_update_public_key ctxt id public_key op =
   begin
@@ -138,9 +131,8 @@ let check_signature_and_update_public_key ctxt id public_key op =
   Operation.check_signature public_key op >>=? fun () ->
   return ctxt
 
-(* TODO document parameters *)
 let apply_sourced_operation
-    ctxt accept_failing_script miner_contract pred_block block_prio
+    ctxt miner_contract pred_block block_prio
     operation origination_nonce ops =
   match ops with
   | Manager_operations { source ; public_key ; fee ; counter ; operations = contents } ->
@@ -156,11 +148,14 @@ let apply_sourced_operation
        | None -> return ctxt
        | Some contract ->
            Contract.credit ctxt contract fee) >>=? fun ctxt ->
-      fold_left_s (fun (ctxt, origination_nonce) content ->
+      fold_left_s (fun (ctxt, origination_nonce, err) content ->
+          match err with
+          | Some _ -> return (ctxt, origination_nonce, err)
+          | None ->
               Contract.must_exist ctxt source >>=? fun () ->
-          apply_manager_operation_content ctxt origination_nonce
+              apply_manager_operation_content
-            accept_failing_script source content)
+                ctxt origination_nonce source content)
-        (ctxt, origination_nonce) contents
+        (ctxt, origination_nonce, None) contents
   | Delegate_operations { source ; operations = contents } ->
       let delegate = Ed25519.Public_key.hash source in
       check_signature_and_update_public_key
@@ -171,25 +166,25 @@ let apply_sourced_operation
           apply_delegate_operation_content
             ctxt delegate pred_block block_prio content)
         ctxt contents >>=? fun ctxt ->
-      return (ctxt, origination_nonce)
+      return (ctxt, origination_nonce, None)
   | Dictator_operation (Activate hash) ->
       let dictator_pubkey = Constants.dictator_pubkey ctxt in
       Operation.check_signature dictator_pubkey operation >>=? fun () ->
       activate ctxt hash >>= fun ctxt ->
-      return (ctxt, origination_nonce)
+      return (ctxt, origination_nonce, None)
   | Dictator_operation (Activate_testnet hash) ->
       let dictator_pubkey = Constants.dictator_pubkey ctxt in
       Operation.check_signature dictator_pubkey operation >>=? fun () ->
       set_test_protocol ctxt hash >>= fun ctxt ->
       fork_test_network ctxt >>= fun ctxt ->
-      return (ctxt, origination_nonce)
+      return (ctxt, origination_nonce, None)
 
 let apply_anonymous_operation ctxt miner_contract origination_nonce kind =
   match kind with
   | Seed_nonce_revelation { level ; nonce } ->
       let level = Level.from_raw ctxt level in
-      Nonce.reveal ctxt level nonce >>=? fun (ctxt, delegate_to_reward,
+      Nonce.reveal ctxt level nonce
-                                              reward_amount) ->
+      >>=? fun (ctxt, delegate_to_reward, reward_amount) ->
       Reward.record ctxt
         delegate_to_reward level.cycle reward_amount >>=? fun ctxt ->
       begin
@@ -214,7 +209,7 @@ let apply_anonymous_operation ctxt miner_contract origination_nonce kind =
       return (ctxt, origination_nonce)
 
 let apply_operation
-    ctxt accept_failing_script miner_contract pred_block block_prio operation =
+    ctxt miner_contract pred_block block_prio operation =
   match operation.contents with
   | Anonymous_operations ops ->
       let origination_nonce = Contract.initial_origination_nonce operation.hash in
@@ -222,13 +217,13 @@ let apply_operation
         (fun (ctxt, origination_nonce) ->
            apply_anonymous_operation ctxt miner_contract origination_nonce)
         (ctxt, origination_nonce) ops >>=? fun (ctxt, origination_nonce) ->
-      return (ctxt, Contract.originated_contracts origination_nonce)
+      return (ctxt, Contract.originated_contracts origination_nonce, None)
   | Sourced_operations op ->
       let origination_nonce = Contract.initial_origination_nonce operation.hash in
       apply_sourced_operation
-        ctxt accept_failing_script miner_contract pred_block block_prio
+        ctxt miner_contract pred_block block_prio
-        operation origination_nonce op >>=? fun (ctxt, origination_nonce) ->
+        operation origination_nonce op >>=? fun (ctxt, origination_nonce, err) ->
-      return (ctxt, Contract.originated_contracts origination_nonce)
+      return (ctxt, Contract.originated_contracts origination_nonce, err)
 
 let may_start_new_cycle ctxt =
   Mining.dawn_of_a_new_cycle ctxt >>=? function
@@ -250,58 +245,37 @@ let may_start_new_cycle ctxt =
         ctxt last_cycle reward_date >>=? fun ctxt ->
       return ctxt
 
-let apply_main ctxt accept_failing_script block pred_timestamp operations =
+let begin_construction ctxt =
-  (* read only checks *)
+  Fitness.increase ctxt
+
+let begin_application ctxt block pred_timestamp =
   Mining.check_proof_of_work_stamp ctxt block >>=? fun () ->
   Mining.check_fitness_gap ctxt block >>=? fun () ->
-  Mining.check_mining_rights ctxt block pred_timestamp >>=? fun delegate_pkh ->
+  Mining.check_mining_rights ctxt block pred_timestamp >>=? fun miner ->
-  Mining.check_signature ctxt block delegate_pkh >>=? fun () ->
+  Mining.check_signature ctxt block miner >>=? fun () ->
-  (* automatic bonds payment *)
+  Mining.pay_mining_bond ctxt block miner >>=? fun ctxt ->
-  Mining.pay_mining_bond ctxt block delegate_pkh >>=? fun ctxt ->
-  (* do effectful stuff *)
   Fitness.increase ctxt >>=? fun ctxt ->
-  let priority = block.proto.mining_slot.priority in
+  return (ctxt, miner)
-  fold_left_s (fun ctxt operation ->
+
-      apply_operation
+let finalize_application ctxt block miner op_count =
-        ctxt accept_failing_script
-        (Some (Contract.default_contract delegate_pkh))
-        block.shell.predecessor priority operation
-      >>=? fun (ctxt, _contracts) -> return ctxt)
-    ctxt operations >>=? fun ctxt ->
   (* end of level (from this point nothing should fail) *)
+  let priority = block.Block.proto.mining_slot.priority in
   let reward = Mining.base_mining_reward ctxt ~priority in
   Nonce.record_hash ctxt
-    delegate_pkh reward block.proto.seed_nonce_hash >>=? fun ctxt ->
+    miner reward block.proto.seed_nonce_hash >>=? fun ctxt ->
   Reward.pay_due_rewards ctxt >>=? fun ctxt ->
   Level.increment_current ctxt >>=? fun ctxt ->
   (* end of cycle *)
   may_start_new_cycle ctxt >>=? fun ctxt ->
   Amendment.may_start_new_voting_cycle ctxt >>=? fun ctxt ->
-  return ctxt
-
-type error += Internal_error of string
-
-let apply ctxt accept_failing_script block pred_timestamp operations =
-  (init ctxt >>=? fun ctxt ->
-   get_prevalidation ctxt >>= function
-   | true ->
-       fail (Internal_error "we should not call `apply` after `preapply`!")
-   | false ->
-      apply_main ctxt accept_failing_script block pred_timestamp operations >>=? fun ctxt ->
   Level.current ctxt >>=? fun { level } ->
-      let level = Raw_level.diff level Raw_level.root in
+  let level = Raw_level.to_int32 level in
   Fitness.get ctxt >>=? fun fitness ->
   let commit_message =
-        (* TODO: add more info ? *)
+    Format.asprintf
-        Format.asprintf "lvl %ld, fit %Ld" level fitness in
+      "lvl %ld, fit %Ld, prio %ld, %d ops"
-      finalize ~commit_message ctxt)
+      level fitness priority op_count in
-
+  return (commit_message, ctxt)
-let empty_result =
-  { Updater.applied = [];
-    refused = Operation_hash.Map.empty;
-    branch_refused = Operation_hash.Map.empty;
-    branch_delayed = Operation_hash.Map.empty;
-  }
 
 let compare_operations op1 op2 =
   match op1.contents, op2.contents with
@@ -320,75 +294,3 @@ let compare_operations op1 op2 =
           (* Manager operations with smaller counter are pre-validated first. *)
           Int32.compare op1.counter op2.counter
         end
-
-let merge_result r r' =
-  let open Updater in
-  let merge _key a b =
-    match a, b with
-    | None, None -> None
-    | Some x, None -> Some x
-    | _, Some y -> Some y in
-  { applied = r'.applied @ r.applied ;
-    refused = Operation_hash.Map.merge merge r.refused r'.refused ;
-    branch_refused =
-      Operation_hash.Map.merge merge r.branch_refused r'.branch_refused ;
-    branch_delayed = r'.branch_delayed ;
-  }
-
-let prevalidate ctxt pred_block sort operations =
-  let operations =
-    if sort then List.sort compare_operations operations else operations in
-  let rec loop ctxt operations =
-    (Lwt_list.fold_left_s
-       (fun (ctxt, r) op ->
-          apply_operation ctxt false None pred_block 0l op >>= function
-          | Ok (ctxt, _contracts) ->
-              let applied = op.hash :: r.Updater.applied in
-              Lwt.return (ctxt, { r with Updater.applied} )
-          | Error errors ->
-              match classify_errors errors with
-              | `Branch ->
-                  let branch_refused =
-                    Operation_hash.Map.add op.hash errors r.Updater.branch_refused in
-                  Lwt.return (ctxt, { r with Updater.branch_refused })
-              | `Permanent ->
-                  let refused =
-                    Operation_hash.Map.add op.hash errors r.Updater.refused in
-                  Lwt.return (ctxt, { r with Updater.refused })
-              | `Temporary ->
-                  let branch_delayed =
-                    Operation_hash.Map.add op.hash errors r.Updater.branch_delayed in
-                  Lwt.return (ctxt, { r with Updater.branch_delayed }))
-       (ctxt, empty_result)
-       operations >>= fun (ctxt, r) ->
-     match r.Updater.applied with
-     | _ :: _ when sort ->
-         let rechecked_operations =
-           List.filter
-             (fun op -> Operation_hash.Map.mem op.hash r.Updater.branch_delayed)
-             operations in
-         loop ctxt rechecked_operations >>=? fun (ctxt, r') ->
-         return (ctxt, merge_result r r')
-     | _ ->
-         return (ctxt, r)) in
-  loop ctxt operations
-
-let preapply ctxt pred_block sort operations =
-  let result =
-    init ctxt >>=? fun ctxt ->
-    begin
-      get_prevalidation ctxt >>= function
-      | true -> return ctxt
-      | false ->
-          set_prevalidation ctxt >>= fun ctxt ->
-          Fitness.increase ctxt >>=? fun ctxt ->
-          return ctxt
-    end >>=? fun ctxt ->
-    prevalidate ctxt pred_block sort operations >>=? fun (ctxt, r) ->
-    (* TODO should accept failing script in the last round ?
-            or: what should we export to let the miner decide *)
-    finalize ctxt >>=? fun ctxt ->
-    return (ctxt, r) in
-  (* "Reify" errors into options. *)
-  result >>|? function  (ctxt, r) ->
-    (ctxt, { r with Updater.applied = List.rev r.Updater.applied })

src/proto/alpha/main.ml

@@ -16,14 +16,6 @@ let parse_operation = Tezos_context.Operation.parse
 let max_operation_data_length =
   Tezos_context.Operation.max_operation_data_length
 
-type block =
-  { header : Tezos_context.Block.header ;
-    pred_timestamp : Time.t }
-
-let parse_block raw_header pred_timestamp =
-  Tezos_context.Block.parse_header raw_header >>? fun header ->
-  Ok { header ; pred_timestamp }
-
 let max_number_of_operations =
   Tezos_context.Constants.max_number_of_operations
 
@@ -32,9 +24,72 @@ let max_block_length =
 
 let rpc_services = Services_registration.rpc_services
 
-let apply ctxt block ops =
+type validation_mode =
-  Apply.apply ctxt true block.header block.pred_timestamp ops
+  | Application of Tezos_context.Block.header * Tezos_context.public_key_hash
+  | Construction of { pred_block : Block_hash.t ; timestamp : Time.t }
 
-let preapply = Apply.preapply
+type validation_state =
+  { mode : validation_mode ;
+    ctxt : Tezos_context.t ;
+    op_count : int }
+
+let current_context { ctxt } =
+  Tezos_context.finalize ctxt
+
+let precheck_block
+    ~ancestor_context:_
+    ~ancestor_timestamp:_
+    raw_block =
+  Lwt.return (Tezos_context.Block.parse_header raw_block) >>=? fun _ ->
+  (* TODO: decide what other properties should be checked *)
+  return ()
+
+let begin_application
+    ~predecessor_context:ctxt
+    ~predecessor_timestamp:pred_timestamp
+    raw_block =
+  Lwt.return (Tezos_context.Block.parse_header raw_block) >>=? fun header ->
+  Tezos_context.init ctxt >>=? fun ctxt ->
+  Apply.begin_application ctxt header pred_timestamp >>=? fun (ctxt, miner) ->
+  let mode = Application (header, miner) in
+  return { mode ; ctxt ; op_count = 0 }
+
+let begin_construction
+    ~predecessor_context:ctxt
+    ~predecessor_timestamp:_
+    ~predecessor:pred_block
+    ~timestamp =
+  let mode = Construction { pred_block ; timestamp } in
+  Tezos_context.init ctxt >>=? fun ctxt ->
+  Apply.begin_construction ctxt >>=? fun ctxt ->
+  return { mode ; ctxt ; op_count = 0 }
+
+let apply_operation ({ mode ; ctxt ; op_count } as data) operation =
+  let pred_block, block_prio, miner_contract =
+    match mode with
+    | Construction { pred_block } ->
+        pred_block, 0l, None
+    | Application (block, delegate) ->
+        block.shell.predecessor,
+        block.proto.mining_slot.priority,
+        Some (Tezos_context.Contract.default_contract delegate) in
+  Apply.apply_operation
+    ctxt miner_contract pred_block block_prio operation
+  >>=? fun (ctxt, _contracts, _ignored_script_error) ->
+  let op_count = op_count + 1 in
+  return { data with ctxt ; op_count }
+
+let finalize_block { mode ; ctxt ; op_count } = match mode with
+  | Construction _ ->
+      Tezos_context.finalize ctxt >>=? fun ctxt ->
+      return ctxt
+  | Application (block, miner) ->
+      Apply.finalize_application
+        ctxt block miner op_count >>=? fun (commit_message, ctxt) ->
+      Tezos_context.finalize ~commit_message ctxt >>=? fun ctxt ->
+      return ctxt
+
+let compare_operations op1 op2 =
+  Apply.compare_operations op1 op2
 
 let configure_sandbox = Tezos_context.configure_sandbox

src/proto/alpha/services_registration.ml

@@ -89,10 +89,12 @@ let () =
 
 (*-- Context -----------------------------------------------------------------*)
 
+type error += Unexpected_level_in_context
+
 let level ctxt =
   Level.current ctxt >>=? fun level ->
   match Level.pred ctxt level with
-  | None -> fail (Apply.Internal_error "unexpected level in context")
+  | None -> fail Unexpected_level_in_context
   | Some level -> return level
 
 let () = register0 Services.Context.level level
@@ -192,9 +194,11 @@ let () =
            Mining.mining_priorities ctxt level >>=? fun (Misc.LCons (miner_pkh, _)) ->
            let miner_contract = Contract.default_contract miner_pkh in
            let block_prio = 0l in
-           Apply.apply_operation ctxt false (Some miner_contract) pred_block block_prio operation
+           Apply.apply_operation
-           >>=? fun (_ctxt, contracts) ->
+             ctxt (Some miner_contract) pred_block block_prio operation
-           Error_monad.return contracts) ;
+           >>=? function
+           | (_ctxt, _, Some script_err) -> Lwt.return (Error script_err)
+           | (_ctxt, contracts, None) -> Lwt.return (Ok contracts)) ;
   let run_parameters ctxt (script, storage, input, amount, contract, origination_nonce) =
     let amount =
       match amount with

src/proto/demo/main.ml

@@ -10,14 +10,13 @@
 type operation = Operation_hash.t
 let max_operation_data_length = 42
 
-type block = unit
-
 let max_block_length = 42
 let max_number_of_operations = 42
 
-let parse_block _ _pred_timestamp = Ok ()
 let parse_operation h _ = Ok h
 
+let compare_operations _ _ = 0
+
 module Fitness = struct
 
   let version_number = "\000"
@@ -64,7 +63,34 @@ module Fitness = struct
 
 end
 
-let apply ctxt () _operations =
+type validation_state = Context.t
+
+let current_context ctxt =
+  return ctxt
+
+let precheck_block
+    ~ancestor_context:_
+    ~ancestor_timestamp:_
+    _raw_block =
+  return ()
+
+let begin_application
+    ~predecessor_context:ctxt
+    ~predecessor_timestamp:_
+    _raw_block =
+  return ctxt
+
+let begin_construction
+    ~predecessor_context:ctxt
+    ~predecessor_timestamp:_
+    ~predecessor:_
+    ~timestamp:_ =
+  return ctxt
+
+let apply_operation ctxt _ =
+  return ctxt
+
+let finalize_block ctxt =
   Fitness.increase ctxt >>=? fun ctxt ->
   Fitness.get ctxt >>=? fun fitness ->
   let commit_message =
@@ -72,16 +98,6 @@ let apply ctxt () _operations =
   Context.set_commit_message ctxt commit_message >>= fun ctxt ->
   return ctxt
 
-let preapply context _block_pred _sort operations =
-  Lwt.return
-    (Ok
-       (context,
-        { Updater.applied = List.map (fun h -> h) operations;
-          refused = Operation_hash.Map.empty;
-          branch_delayed = Operation_hash.Map.empty;
-          branch_refused = Operation_hash.Map.empty;
-        }))
-
 let rpc_services = Services.rpc_services
 
 let configure_sandbox ctxt _ = Lwt.return (Ok ctxt)

src/proto/environment/updater.mli

@@ -37,24 +37,8 @@ type raw_block = {
 }
 val raw_block_encoding: raw_block Data_encoding.t
 
-(** Result of the {!PROTOCOL.preapply} function of the protocol for
-    discriminating cacheable operations from droppable ones. *)
-type 'error preapply_result =
-  { applied: Operation_hash.t list;
-    (** Operations that where successfully applied. *)
-    refused: 'error list Operation_hash.Map.t;
-    (** Operations which triggered a context independent, unavoidable
-        error (e.g. invalid signature). *)
-    branch_refused: 'error list Operation_hash.Map.t;
-    (** Operations which triggered an error that might not arise in a
-        different context (e.g. past account counter, insufficent
-        balance). *)
-    branch_delayed: 'error list Operation_hash.Map.t;
-    (** Operations which triggered an error that might not arise in a
-        future update of this context (e.g. futur account counter). *) }
-
 (** This is the signature of a Tezos protocol implementation. It has
-    access to the Environment module. *)
+    access to the standard library and the Environment module. *)
 module type PROTOCOL = sig
 
   type error = ..
@@ -66,46 +50,80 @@ module type PROTOCOL = sig
   (** The maximum size of operations in bytes *)
   val max_operation_data_length : int
 
-  (** The version specific part of blocks. *)
-  type block
-
   (** The maximum size of block headers in bytes *)
   val max_block_length : int
 
   (** The maximum *)
   val max_number_of_operations : int
 
-  (** The parsing / preliminary validation function for blocks. Its
-      role is to check that the raw header is well formed, and to
-      produce a pre-decomposed value of the high level, protocol defined
-      {!block} type. It does not have access to the storage
-      context. It may store the hash and raw bytes for later signature
-      verification by {!apply} or {!preapply}. The timestamp of the
-      predecessor block is also provided for early delay checks. *)
-  val parse_block : raw_block -> Time.t -> block tzresult
-
   (** The parsing / preliminary validation function for
       operations. Similar to {!parse_block}. *)
   val parse_operation :
     Operation_hash.t -> raw_operation -> operation tzresult
 
-  (** The main protocol function that validates blocks. It receives the
+  (** Basic ordering of operations. [compare_operations op1 op2] means
-      block header and the list of associated operations, as
+      that [op1] should appear before [op2] in a block. *)
-      pre-decomposed by {!parse_block} and {!parse_operation}. *)
+  val compare_operations : operation -> operation -> int
-  val apply :
-    Context.t -> block -> operation list -> Context.t tzresult Lwt.t
 
-  (** The auxiliary protocol entry point that validates pending
+  (** A functional state that is transmitted through the steps of a
-      operations out of blocks. This function tries to apply the all
+      block validation sequence. It must retain the current state of
-      operations in the given order, and returns which applications have
+      the store (that can be extracted from the outside using
-      suceeded and which ones have failed. The first two parameters
+      {!current_context}, and whose final value is produced by
-      are a context in which to apply the operations and the hash of the
+      {!finalize_block}). It can also contain the information that
-      preceding block. This function is used by the shell for accepting or
+      must be remembered during the validation, which must be
-      dropping operations, as well as the mining client to check that a
+      immutable (as validator or baker implementations are allowed to
-      sequence of operations forms a valid block. *)
+      pause, replay or backtrack during the validation process). *)
-  val preapply :
+  type validation_state
-    Context.t -> Block_hash.t -> bool -> operation list ->
+
-    (Context.t * error preapply_result) tzresult Lwt.t
+  (** Access the context at a given validation step. *)
+  val current_context : validation_state -> Context.t tzresult Lwt.t
+
+  (** Checks that a block is well formed in a given context. This
+      function should run quickly, as its main use is to reject bad
+      blocks from the network as early as possible. The input context
+      is the one resulting of an ancestor block of same protocol
+      version, not necessarily the one of its predecessor. *)
+  val precheck_block :
+    ancestor_context: Context.t ->
+    ancestor_timestamp: Time.t ->
+    raw_block ->
+    unit tzresult Lwt.t
+
+  (** The first step in a block validation sequence. Initializes a
+      validation context for validating a block. Takes as argument the
+      {!raw_block} to initialize the context for this block, patching
+      the context resulting of the application of the predecessor
+      block passed as parameter. The function {!precheck_block} may
+      not have been called before [begin_application], so all the
+      check performed by the former must be repeated in the latter. *)
+  val begin_application :
+    predecessor_context: Context.t ->
+    predecessor_timestamp: Time.t ->
+    raw_block ->
+    validation_state tzresult Lwt.t
+
+  (** Initializes a validation context for constructing a new block
+      (as opposed to validating an existing block). Since there is no
+      {!raw_block} header available, the parts that it provides are
+      passed as arguments (predecessor block hash, context resulting
+      of the application of the predecessor block, and timestamp). *)
+  val begin_construction :
+    predecessor_context: Context.t ->
+    predecessor_timestamp: Time.t ->
+    predecessor: Block_hash.t ->
+    timestamp: Time.t ->
+    validation_state tzresult Lwt.t
+
+  (** Called after {!begin_application} (or {!begin_construction}) and
+      before {!finalize_block}, with each operation in the block. *)
+  val apply_operation :
+    validation_state -> operation -> validation_state tzresult Lwt.t
+
+  (** The last step in a block validation sequence. It produces the
+      context that will be used as input for the validation of its
+      successor block candidates. *)
+  val finalize_block :
+    validation_state -> Context.t tzresult Lwt.t
 
   (** The list of remote procedures exported by this implementation *)
   val rpc_services : Context.t RPC.directory

src/proto/genesis/main.ml

@@ -32,9 +32,10 @@ let () =
     (function Invalid_signature -> Some () | _ -> None)
     (fun () -> Invalid_signature)
 
-type operation = ()
+type operation = unit
 let max_operation_data_length = 0
 let parse_operation _h _op = Error []
+let compare_operations _ _ = 0
 let max_number_of_operations = 0
 
 type block = {
@@ -48,7 +49,7 @@ let max_block_length =
   | None -> assert false
   | Some len -> len
 
-let parse_block { Updater.shell ; proto } _pred_timestamp : block tzresult =
+let parse_block { Updater.shell ; proto } : block tzresult =
   match Data_encoding.Binary.of_bytes Data.Command.signed_encoding proto with
   | None -> Error [Parsing_error]
   | Some (command, signature) -> Ok { shell ; command ; signature }
@@ -60,7 +61,36 @@ let check_signature ctxt { shell ; command ; signature } =
     (Ed25519.Signature.check public_key signature bytes)
     Invalid_signature
 
-let apply ctxt header _ops =
+type validation_state = block * Context.t
+
+let current_context (_, ctxt) =
+  return ctxt
+
+let precheck_block
+    ~ancestor_context:_
+    ~ancestor_timestamp:_
+    raw_block =
+  Lwt.return (parse_block raw_block) >>=? fun _ ->
+  return ()
+
+let begin_application
+    ~predecessor_context:ctxt
+    ~predecessor_timestamp:_
+    raw_block =
+  Lwt.return (parse_block raw_block) >>=? fun block ->
+  return (block, ctxt)
+
+let begin_construction
+    ~predecessor_context:_
+    ~predecessor_timestamp:_
+    ~predecessor:_
+    ~timestamp:_ =
+  Lwt.return (Error []) (* absurd *)
+
+let apply_operation _vctxt _ =
+  Lwt.return (Error []) (* absurd *)
+
+let finalize_block (header, ctxt) =
   check_signature ctxt header >>=? fun () ->
   Data.Init.may_initialize ctxt >>=? fun ctxt ->
   Context.set_fitness ctxt header.shell.fitness >>= fun ctxt ->
@@ -79,14 +109,6 @@ let apply ctxt header _ops =
       Updater.fork_test_network ctxt >>= fun ctxt ->
       return ctxt
 
-let preapply ctxt _block_pred _sort _ops =
-  return ( ctxt,
-           { Updater.applied = [] ;
-             refused = Operation_hash.Map.empty ;
-             branch_refused = Operation_hash.Map.empty ;
-             branch_delayed = Operation_hash.Map.empty ;
-           } )
-
 let rpc_services = Services.rpc_services
 
 let configure_sandbox = Data.Init.configure_sandbox

test/shell/test_state.ml

@@ -162,8 +162,14 @@ let build_valid_chain state tbl vtbl otbl pred names =
          State.Block_header.read_opt state hash >>= fun block' ->
          equal_block ~msg:__LOC__ (Some block) block' ;
          Hashtbl.add tbl name (hash, block) ;
-         Lwt.return (Proto.parse_block block pred.timestamp) >>=? fun block ->
+         begin
-         Proto.apply pred.context block [] >>=? fun ctxt ->
+           Proto.begin_application
+             ~predecessor_context: pred.context
+             ~predecessor_timestamp: pred.timestamp
+             block >>=? fun vstate ->
+           (* no operations *)
+           Proto.finalize_block vstate
+         end >>=? fun ctxt ->
          State.Valid_block.store state hash ctxt >>=? fun _vblock ->
          State.Valid_block.read state hash >>=? fun vblock ->
          Hashtbl.add vtbl name vblock ;

test/test-basic.sh

@@ -29,7 +29,13 @@ echo "Created node, pid: ${NODE_PID}, log: $DATA_DIR/LOG"
 
 sleep 3
 
-${CLIENT} list versions
+${CLIENT} -block genesis list versions
+
+${CLIENT} -block genesis \
+          activate \
+          protocol ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK \
+          with fitness 1 \
+          and key edskRhxswacLW6jF6ULavDdzwqnKJVS4UcDTNiCyiH6H8ZNnn2pmNviL7pRNz9kRxxaWQFzEQEcZExGHKbwmuaAcoMegj5T99z
 
 ${CLIENT} add identity bootstrap1 tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx
 ${CLIENT} add public key bootstrap1 edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav
@@ -39,11 +45,6 @@ ${CLIENT} add identity bootstrap3 tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU
 ${CLIENT} add identity bootstrap4 tz1b7tUupMgCNw2cCLpKTkSD1NZzB5TkP2sv
 ${CLIENT} add identity bootstrap5 tz1ddb9NMYHZi5UzPdzTZMYQQZoMub195zgv
 
-${CLIENT} activate \
-          protocol ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK \
-          with fitness 1 \
-          and key edskRhxswacLW6jF6ULavDdzwqnKJVS4UcDTNiCyiH6H8ZNnn2pmNviL7pRNz9kRxxaWQFzEQEcZExGHKbwmuaAcoMegj5T99z
-
 sleep 2
 
 KEY1=foo