Shell: remove the on-disk index of operations

Let's get serious. The full index of operations is not sustainable in
the production code. We now only keep the index of operations not yet
in the chain (i.e. the mempool/prevalidation). Operations from the
chain are now only accesible through a block. For instance, see the
RPC:

   /blocks/<hash>/proto/operations

scripts/alphanet_version

@@ -1 +1 @@
-2017-04-17
+2017-04-19

src/Makefile.files

@@ -224,6 +224,8 @@ NODE_LIB_INTFS := \
   node/shell/distributed_db_message.mli \
   node/shell/distributed_db_metadata.mli \
   node/shell/distributed_db.mli \
+  node/shell/chain_traversal.mli \
+  node/shell/chain.mli \
   node/shell/prevalidation.mli \
   node/shell/prevalidator.mli \
   node/shell/validator.mli \
@@ -269,6 +271,8 @@ FULL_NODE_LIB_IMPLS := \
   node/shell/distributed_db_message.ml \
   node/shell/distributed_db_metadata.ml \
   node/shell/distributed_db.ml \
+  node/shell/chain_traversal.ml \
+  node/shell/chain.ml \
   node/shell/prevalidation.ml \
   node/shell/prevalidator.ml \
   node/shell/validator.ml \

src/client/client_node_rpcs.ml

@@ -22,6 +22,12 @@ let forge_block cctxt ?net_id ?level ?proto_level ?predecessor ?timestamp fitnes
 let validate_block cctxt net block =
   call_err_service0 cctxt Services.validate_block (net, block)
 
+type operation = Node_rpc_services.operation =
+  | Blob of Operation.t
+  | Hash of Operation_hash.t
+
+let operation_encoding = Node_rpc_services.operation_encoding
+
 let inject_block cctxt ?(async = false) ?(force = false) raw operations =
   call_err_service0 cctxt Services.inject_block
     { raw ; blocking = not async ; force ; operations }
@@ -66,7 +72,7 @@ module Blocks = struct
     test_network: Context.test_network;
   }
   type preapply_param = Services.Blocks.preapply_param = {
-    operations: Operation_hash.t list ;
+    operations: operation list ;
     sort: bool ;
     timestamp: Time.t option ;
   }
@@ -89,8 +95,9 @@ module Blocks = struct
     call_service1 cctxt Services.Blocks.timestamp h ()
   let fitness cctxt h =
     call_service1 cctxt Services.Blocks.fitness h ()
-  let operations cctxt h =
+  let operations cctxt ?(contents = false) h =
-    call_service1 cctxt Services.Blocks.operations h ()
+    call_service1 cctxt Services.Blocks.operations h
+      { contents ; monitor = false }
   let protocol cctxt h =
     call_service1 cctxt Services.Blocks.protocol h ()
   let test_network cctxt h =
@@ -121,12 +128,10 @@ end
 
 module Operations = struct
 
-  let contents cctxt hashes =
+  let monitor cctxt ?(contents = false) () =
-    call_service1 cctxt Services.Operations.contents hashes ()
+    call_streamed_service1 cctxt Services.Blocks.operations
-
+      `Prevalidation
-  let monitor cctxt ?contents () =
+      { contents ; monitor = true }
-    call_streamed_service0 cctxt Services.Operations.list
-      { monitor = Some true ; contents }
 
 end
 

src/client/client_node_rpcs.mli

@@ -34,10 +34,16 @@ val validate_block:
   Net_id.t -> Block_hash.t ->
   unit tzresult Lwt.t
 
+type operation =
+  | Blob of Operation.t
+  | Hash of Operation_hash.t
+
+val operation_encoding: operation Data_encoding.t
+
 val inject_block:
   config ->
   ?async:bool -> ?force:bool ->
-  MBytes.t -> Operation_hash.t list list ->
+  MBytes.t -> operation list list ->
   Block_hash.t tzresult Lwt.t
 (** [inject_block cctxt ?async ?force raw_block] tries to inject
     [raw_block] inside the node. If [?async] is [true], [raw_block]
@@ -89,7 +95,8 @@ module Blocks : sig
     block -> MBytes.t list tzresult Lwt.t
   val operations:
     config ->
-    block -> Operation_hash.t list list tzresult Lwt.t
+    ?contents:bool ->
+    block -> (Operation_hash.t * Operation.t option) list list tzresult Lwt.t
   val protocol:
     config ->
     block -> Protocol_hash.t tzresult Lwt.t
@@ -144,21 +151,17 @@ module Blocks : sig
     block ->
     ?timestamp:Time.t ->
     ?sort:bool ->
-    Hash.Operation_hash.t list -> preapply_result tzresult Lwt.t
+    operation list -> preapply_result tzresult Lwt.t
 
 end
 
 module Operations : sig
 
-  val contents:
-    config ->
-    Operation_hash.t list -> Operation.t list tzresult Lwt.t
-
   val monitor:
     config ->
-    ?contents:bool -> unit ->
+    ?contents:bool ->
-    (Operation_hash.t * Operation.t option) list list tzresult
+    unit ->
-      Lwt_stream.t tzresult Lwt.t
+    (Operation_hash.t * Operation.t option) list list tzresult Lwt_stream.t tzresult Lwt.t
 
 end
 

src/client/client_rpcs.ml

@@ -277,8 +277,7 @@ let call_service2 cctxt service a1 a2 arg =
   get_json cctxt meth path arg >>=? fun json ->
   parse_answer cctxt service path json
 
-let call_streamed_service0 cctxt service arg =
+let call_streamed cctxt service (meth, path, arg) =
-  let meth, path, arg = RPC.forge_request service () arg in
   get_streamed_json cctxt meth path arg >>=? fun json_st ->
   let parsed_st, push = Lwt_stream.create () in
   let rec loop () =
@@ -296,6 +295,12 @@ let call_streamed_service0 cctxt service arg =
   Lwt.async loop ;
   return parsed_st
 
+let call_streamed_service0 cctxt service arg =
+  call_streamed cctxt service (RPC.forge_request service () arg)
+
+let call_streamed_service1 cctxt service arg1 arg2 =
+  call_streamed cctxt service (RPC.forge_request service ((), arg1) arg2)
+
 let parse_err_answer config service path json =
   match RPC.read_answer service json with
   | Error msg -> (* TODO print_error *)

src/client/client_rpcs.mli

@@ -53,6 +53,11 @@ val call_streamed_service0:
   (unit, unit, 'a, 'b) RPC.service ->
   'a -> ('b, error list) result Lwt_stream.t tzresult Lwt.t
 
+val call_streamed_service1:
+  config ->
+  (unit, unit * 'a, 'b, 'c) RPC.service ->
+  'a -> 'b -> ('c, error list) result Lwt_stream.t tzresult Lwt.t
+
 val call_err_service0:
   config ->
   (unit, unit, 'i, 'o tzresult) RPC.service ->

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

@@ -49,7 +49,7 @@ let inject_block cctxt block
   Client_proto_rpcs.Context.next_level cctxt block >>=? fun level ->
   let operations_hash =
     Operation_list_list_hash.compute
-      (List.map Operation_list_hash.compute operations) in
+      (List.map Operation_list_hash.compute (List.map (List.map (function Client_node_rpcs.Blob op -> Tezos_data.Operation.hash op | Hash oph -> oph)) operations)) in
   let shell =
     { Block_header.net_id = bi.net_id ; level = bi.level ;
       proto_level = bi.proto_level ;
@@ -92,10 +92,12 @@ let forge_block cctxt block
     | None ->
         Client_node_rpcs.Blocks.pending_operations
           cctxt block >>=? fun (ops, pendings) ->
-        return (Operation_hash.Set.elements @@
+        let ops =
+          Operation_hash.Set.elements @@
           Operation_hash.Set.union
             (Prevalidation.preapply_result_operations ops)
-                  pendings)
+            pendings in
+        return (List.map (fun x -> Client_node_rpcs.Hash x) ops)
     | Some operations -> return operations
   end >>=? fun operations ->
   begin
@@ -153,7 +155,7 @@ let forge_block cctxt block
           && Operation_hash.Map.is_empty operations.branch_delayed ) then
     inject_block cctxt ?force ~src_sk
       ~priority ~timestamp ~fitness ~seed_nonce block
-      [operations.applied]
+      [List.map (fun h -> Client_node_rpcs.Hash h) operations.applied]
   else
     failwith "Cannot (fully) validate the given operations."
 
@@ -425,6 +427,7 @@ let mine cctxt state =
          block >>=? fun (res, ops) ->
        let operations =
          let open Operation_hash.Set in
+         List.map (fun x -> Client_node_rpcs.Hash x) @@
          elements (union ops (Prevalidation.preapply_result_operations res)) in
        let request = List.length operations in
        Client_node_rpcs.Blocks.preapply cctxt.rpc_config block
@@ -460,7 +463,7 @@ let mine cctxt state =
       Client_keys.get_key cctxt delegate >>=? fun (_,_,src_sk) ->
       inject_block cctxt.rpc_config
         ~force:true ~src_sk ~priority ~timestamp ~fitness ~seed_nonce
-        (`Hash bi.hash) [operations.applied]
+        (`Hash bi.hash) [List.map (fun h -> Client_node_rpcs.Hash h) operations.applied]
       |> trace_exn (Failure "Error while injecting block") >>=? fun block_hash ->
       State.record_block cctxt level block_hash seed_nonce
       |> trace_exn (Failure "Error while recording block") >>=? fun () ->

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

@@ -22,7 +22,7 @@ val inject_block:
   fitness:Fitness.t ->
   seed_nonce:Nonce.t ->
   src_sk:secret_key ->
-  Operation_hash.t list list ->
+  Client_node_rpcs.operation list list ->
   Block_hash.t tzresult Lwt.t
 (** [inject_block cctxt blk ?force ~priority ~timestamp ~fitness
     ~seed_nonce ~src_sk ops] tries to inject a block in the node. If
@@ -34,7 +34,7 @@ val forge_block:
   Client_rpcs.config ->
   Client_proto_rpcs.block ->
   ?force:bool ->
-  ?operations:Operation_hash.t list ->
+  ?operations:Client_node_rpcs.operation list ->
   ?best_effort:bool ->
   ?sort:bool ->
   ?timestamp:Time.t ->

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

@@ -15,7 +15,7 @@ open Operation
 
 type operation = {
   hash: Operation_hash.t ;
-  content: Tezos_context.Operation.t option
+  content: Operation.t option
 }
 
 let monitor cctxt ?contents ?check () =
@@ -81,7 +81,8 @@ let filter_valid_endorsement cctxt ({ hash ; content } : operation) =
                   pp_print_error error >>= fun () ->
                 Lwt.return_none
             | Ok () ->
-                Client_node_rpcs.Blocks.preapply cctxt (`Hash block) [hash] >>= function
+                Client_node_rpcs.Blocks.preapply
+                  cctxt (`Hash block) [Client_node_rpcs.Hash hash] >>= function
                 | Ok _ ->
                     Lwt.return (Some { hash ; source ; block ; slots })
                 | Error error ->

src/client/embedded/demo/client_proto_main.ml

@@ -16,7 +16,7 @@ let demo cctxt =
   cctxt.Client_commands.message "Calling the 'echo' RPC." >>= fun () ->
   let msg = "test" in
   Client_proto_rpcs.echo cctxt.rpc_config block msg >>=? fun reply ->
-  fail_unless (reply = msg) (Unclassified "...") >>=? fun () ->
+  fail_unless (reply = msg) (failure "...") >>=? fun () ->
   begin
     cctxt.message "Calling the 'failing' RPC." >>= fun () ->
     Client_proto_rpcs.failing cctxt.rpc_config block 3 >>= function

src/minutils/data_encoding.ml

@@ -78,8 +78,15 @@ module Kind = struct
     | `Fixed n1, `Fixed n2 -> `Fixed (n1 + n2)
     | `Dynamic, `Dynamic | `Fixed _, `Dynamic
     | `Dynamic, `Fixed _ -> `Dynamic
-    | `Variable, (`Dynamic | `Fixed _)
+    | `Variable, `Fixed _
     | (`Dynamic | `Fixed _), `Variable -> `Variable
+    | `Variable, `Dynamic ->
+        Printf.ksprintf invalid_arg
+          "Cannot merge two %s when the left element is of variable length \
+           and the right one of dynamic length. \
+           You should use the reverse order, or wrap the second one \
+           with Data_encoding.dynamic_size."
+          name
     | `Variable, `Variable ->
         Printf.ksprintf invalid_arg
           "Cannot merge two %s with variable length. \

src/node/db/store.ml

@@ -66,196 +66,45 @@ module Net = struct
 
 end
 
-
-(**************************************************************************
- * Generic store for "tracked" data: discovery_time, invalidity,
- * incoming peers,... (for operations, block_headers, and protocols).
- **************************************************************************)
-
-module type DATA_STORE = sig
-
-  type store
-  type key
-  type key_set
-  type value
-
-  module Discovery_time : MAP_STORE
-    with type t := store
-     and type key := key
-     and type value := Time.t
-
-  module Contents : SINGLE_STORE
-    with type t = store * key
-     and type value := value
-
-  module RawContents : SINGLE_STORE
-    with type t = store * key
-     and type value := MBytes.t
-
-  module Validation_time : SINGLE_STORE
-    with type t = store * key
-     and type value := Time.t
-
-  module Errors : MAP_STORE
-    with type t := store
-     and type key := key
-     and type value = error list
-
-  module Pending : BUFFERED_SET_STORE
-    with type t = store
-     and type elt := key
-     and type Set.t = key_set
-
-end
-
-module Errors_value =
-  Store_helpers.Make_value(struct
-    type t = error list
-    let encoding = (Data_encoding.list (Error_monad.error_encoding ()))
-  end)
-
-module Raw_value = struct
-  type t = MBytes.t
-  let of_bytes b = ok b
-  let to_bytes b = b
-end
-
-module Make_data_store
-    (S : STORE) (I : INDEX) (V : VALUE)
-    (Set : Set.S with type elt = I.t) = struct
-
-  type key = I.t
-  type value = V.t
-  type key_set = Set.t
-
-  let of_bytes = V.of_bytes
-  let to_bytes = V.to_bytes
-
-  module Indexed_store =
-    Store_helpers.Make_indexed_substore
-      (Store_helpers.Make_substore (S) (struct let name = ["data"] end))
-      (I)
-
-  module Discovery_time =
-    Indexed_store.Make_map
-      (struct let name = ["discovery_time"] end)
-      (Store_helpers.Make_value(Time))
-  module Contents =
-    Store_helpers.Make_single_store
-      (Indexed_store.Store)
-      (struct let name = ["contents"] end)
-      (V)
-  module RawContents =
-    Store_helpers.Make_single_store
-      (Indexed_store.Store)
-      (struct let name = ["contents"] end)
-      (Raw_value)
-  module Errors =
-    Store_helpers.Make_map
-      (Store_helpers.Make_substore (S) (struct let name = ["invalids"] end))
-      (I)
-      (Errors_value)
-  module Pending =
-    Store_helpers.Make_buffered_set
-      (Store_helpers.Make_substore (S) (struct let name = ["pending"] end))
-      (I)
-      (Set)
-  module Validation_time =
-    Store_helpers.Make_single_store
-      (Indexed_store.Store)
-      (struct let name = ["validation_time"] end)
-      (Store_helpers.Make_value(Time))
-
-end
-
-
-(**************************************************************************
- * Operation store under "net/<id>/operations/"
- **************************************************************************)
-
-module Operation = struct
-
-  module Value = Store_helpers.Make_value(Operation)
-
-  let compare o1 o2 =
-    let (>>) x y = if x = 0 then y () else x in
-    Net_id.compare o1.Operation.shell.net_id o2.Operation.shell.net_id >> fun () ->
-    MBytes.compare o1.proto o2.proto
-  let equal b1 b2 = compare b1 b2 = 0
-  let hash op = Operation_hash.hash_bytes [Value.to_bytes op]
-  let hash_raw bytes = Operation_hash.hash_bytes [bytes]
-
-  type store = Net.store
-  let get x = x
-
-  include
-    Make_data_store
-      (Store_helpers.Make_substore
-         (Net.Indexed_store.Store)
-         (struct let name = ["operations"] end))
-      (Operation_hash)
-      (Value)
-      (Operation_hash.Set)
-
-  let register s =
-    Base58.register_resolver Operation_hash.b58check_encoding begin fun str ->
-      let pstr = Operation_hash.prefix_path str in
-      Net.Indexed_store.fold_indexes s ~init:[]
-        ~f:begin fun net acc ->
-          Indexed_store.resolve_index (s, net) pstr >>= fun l ->
-          Lwt.return (List.rev_append l acc)
-        end
-    end
-
-end
-
-
 (**************************************************************************
  * Block_header store under "net/<id>/blocks/"
  **************************************************************************)
 
-module Block_header = struct
+module Block = struct
-
-  module Value = Store_helpers.Make_value(Block_header)
-
-  let compare b1 b2 =
-    let (>>) x y = if x = 0 then y () else x in
-    let rec list compare xs ys =
-      match xs, ys with
-      | [], [] -> 0
-      | _ :: _, [] -> -1
-      | [], _ :: _ -> 1
-      | x :: xs, y :: ys ->
-          compare x y >> fun () -> list compare xs ys in
-    Block_hash.compare b1.Block_header.shell.predecessor b2.Block_header.shell.predecessor >> fun () ->
-    compare b1.proto b2.proto >> fun () ->
-    Operation_list_list_hash.compare
-      b1.shell.operations_hash b2.shell.operations_hash >> fun () ->
-    Time.compare b1.shell.timestamp b2.shell.timestamp >> fun () ->
-    list compare b1.shell.fitness b2.shell.fitness
-
-  let equal b1 b2 = compare b1 b2 = 0
-  let hash block = Block_hash.hash_bytes [Value.to_bytes block]
-  let hash_raw bytes = Block_hash.hash_bytes [bytes]
 
   type store = Net.store
   let get x = x
 
-  include Make_data_store
+  module Indexed_store =
+    Store_helpers.Make_indexed_substore
       (Store_helpers.Make_substore
          (Net.Indexed_store.Store)
          (struct let name = ["blocks"] end))
       (Block_hash)
-      (Value)
-      (Block_hash.Set)
 
-  module Operation_list_count =
+  type contents = {
+    header: Block_header.t ;
+    message: string ;
+    operation_list_count: int ;
+  }
+
+  module Contents =
     Store_helpers.Make_single_store
       (Indexed_store.Store)
-      (struct let name = ["operation_list_count"] end)
+      (struct let name = ["contents"] end)
       (Store_helpers.Make_value(struct
-         type t = int
+         type t = contents
-         let encoding = Data_encoding.int8
+         let encoding =
+           let open Data_encoding in
+           conv
+             (fun { header ; message ; operation_list_count } ->
+               (message, operation_list_count, header))
+             (fun (message, operation_list_count, header) ->
+                { header ; message ; operation_list_count })
+             (obj3
+                (req "message" string)
+                (req "operation_list_count" uint8)
+                (req "header" Block_header.encoding))
        end))
 
   module Operations_index =
@@ -265,15 +114,15 @@ module Block_header = struct
          (struct let name = ["operations"] end))
       (Store_helpers.Integer_index)
 
-  module Operation_list =
+  module Operation_hashes =
     Operations_index.Make_map
-      (struct let name = ["list"] end)
+      (struct let name = ["hashes"] end)
       (Store_helpers.Make_value(struct
          type t = Operation_hash.t list
          let encoding = Data_encoding.list Operation_hash.encoding
        end))
 
-  module Operation_list_path =
+  module Operation_path =
     Operations_index.Make_map
       (struct let name = ["path"] end)
       (Store_helpers.Make_value(struct
@@ -281,6 +130,35 @@ module Block_header = struct
          let encoding = Operation_list_list_hash.path_encoding
        end))
 
+  module Operations =
+    Operations_index.Make_map
+      (struct let name = ["contents"] end)
+      (Store_helpers.Make_value(struct
+         type t = Operation.t list
+         let encoding = Data_encoding.(list (dynamic_size Operation.encoding))
+       end))
+
+  type invalid_block = {
+    level: int32 ;
+    (* errors: Error_monad.error list ; *)
+  }
+
+  module Invalid_block =
+    Store_helpers.Make_map
+      (Store_helpers.Make_substore
+         (Net.Indexed_store.Store)
+         (struct let name = ["invalid_blocks"] end))
+      (Block_hash)
+      (Store_helpers.Make_value(struct
+         type t = invalid_block
+         let encoding =
+           let open Data_encoding in
+           conv
+             (fun { level } -> (level))
+             (fun (level) -> { level  })
+             int32
+       end))
+
   let register s =
     Base58.register_resolver Block_hash.b58check_encoding begin fun str ->
       let pstr = Block_hash.prefix_path str in
@@ -317,17 +195,11 @@ module Chain = struct
       (struct let name = ["current_head"] end)
       (Store_helpers.Make_value(Block_hash))
 
-  module Successor_in_chain =
+  module In_chain =
     Store_helpers.Make_single_store
-      (Block_header.Indexed_store.Store)
+      (Block.Indexed_store.Store)
-      (struct let name = ["successor_in_chain"] end)
+      (struct let name = ["in_chain"] end)
-      (Store_helpers.Make_value(Block_hash))
+      (Store_helpers.Make_value(Block_hash)) (* successor *)
-
-  module In_chain_insertion_time =
-    Store_helpers.Make_single_store
-      (Block_header.Indexed_store.Store)
-      (struct let name = ["in_chain_insertion_time"] end)
-      (Store_helpers.Make_value(Time))
 
 end
 
@@ -338,19 +210,26 @@ end
 
 module Protocol = struct
 
-  include Protocol
-  let hash_raw bytes = Protocol_hash.hash_bytes [bytes]
-
   type store = global_store
   let get x = x
 
-  include Make_data_store
+  module Indexed_store =
+    Store_helpers.Make_indexed_substore
       (Store_helpers.Make_substore
          (Raw_store)
          (struct let name = ["protocols"] end))
       (Protocol_hash)
+
+  module Contents =
+    Indexed_store.Make_map
+      (struct let name = ["contents"] end)
       (Store_helpers.Make_value(Protocol))
-      (Protocol_hash.Set)
+
+  module RawContents =
+    Store_helpers.Make_single_store
+      (Indexed_store.Store)
+      (struct let name = ["contents"] end)
+      (Store_helpers.Raw_value)
 
   let register s =
     Base58.register_resolver Protocol_hash.b58check_encoding begin fun str ->
@@ -358,13 +237,11 @@ module Protocol = struct
       Indexed_store.resolve_index s pstr
     end
 
-
 end
 
 let init dir =
   Raw_store.init dir >>=? fun s ->
-  Block_header.register s ;
+  Block.register s ;
-  Operation.register s ;
   Protocol.register s ;
   return s
 

src/node/db/store.mli

@@ -8,6 +8,7 @@
 (**************************************************************************)
 
 open Store_sigs
+open Tezos_data
 
 type t
 type global_store = t
@@ -70,101 +71,55 @@ module Chain : sig
      and type elt := Block_hash.t
      and module Set := Block_hash.Set
 
-  module Successor_in_chain : SINGLE_STORE
+  module In_chain : SINGLE_STORE
     with type t = store * Block_hash.t
-     and type value := Block_hash.t
+     and type value := Block_hash.t (* successor *)
-
-  module In_chain_insertion_time : SINGLE_STORE
-    with type t = store * Block_hash.t
-     and type value := Time.t
-
-end
-
-
-(** {2 Generic signature} *****************************************************)
-
-(** Generic signature for Operations, Block_header, and Protocol "tracked"
-    contents (i.e. with 'discovery_time', 'validtity', ...) *)
-module type DATA_STORE = sig
-
-  type store
-  type key
-  type key_set
-  type value
-
-  module Discovery_time : MAP_STORE
-    with type t := store
-     and type key := key
-     and type value := Time.t
-
-  module Contents : SINGLE_STORE
-    with type t = store * key
-     and type value := value
-
-  module RawContents : SINGLE_STORE
-    with type t = store * key
-     and type value := MBytes.t
-
-  module Validation_time : SINGLE_STORE
-    with type t = store * key
-     and type value := Time.t
-
-  module Errors : MAP_STORE
-    with type t := store
-     and type key := key
-     and type value = error list
-
-  module Pending : BUFFERED_SET_STORE
-    with type t = store
-     and type elt := key
-     and type Set.t = key_set
-
-end
-
-
-(** {2 Operation store} *****************************************************)
-
-module Operation : sig
-
-  type store
-  val get: Net.store -> store
-
-  include DATA_STORE
-    with type store := store
-     and type key = Operation_hash.t
-     and type value = Operation.t
-     and type key_set = Operation_hash.Set.t
 
 end
 
 
 (** {2 Block header store} **************************************************)
 
-module Block_header : sig
+module Block : sig
 
   type store
   val get: Net.store -> store
 
-  include DATA_STORE
+  type contents = {
-    with type store := store
+    header: Block_header.t ;
-     and type key = Block_hash.t
+    message: string ;
-     and type value = Block_header.t
+    operation_list_count: int ;
-     and type key_set = Block_hash.Set.t
+  }
 
-  module Operation_list_count : SINGLE_STORE
+  module Contents : SINGLE_STORE
     with type t = store * Block_hash.t
-     and type value = int
+     and type value := contents
 
-  module Operation_list : MAP_STORE
+  module Operation_hashes : MAP_STORE
     with type t = store * Block_hash.t
      and type key = int
      and type value = Operation_hash.t list
 
-  module Operation_list_path : MAP_STORE
+  module Operation_path : MAP_STORE
     with type t = store * Block_hash.t
      and type key = int
      and type value = Operation_list_list_hash.path
 
+  module Operations : MAP_STORE
+    with type t = store * Block_hash.t
+     and type key = int
+     and type value = Operation.t list
+
+  type invalid_block = {
+    level: int32 ;
+    (* errors: Error_monad.error list ; *)
+  }
+
+  module Invalid_block : MAP_STORE
+    with type t = store
+     and type key = Block_hash.t
+     and type value = invalid_block
+
 end
 
 
@@ -175,10 +130,13 @@ module Protocol : sig
   type store
   val get: global_store -> store
 
-  include DATA_STORE
+  module Contents : MAP_STORE
-    with type store := store
+    with type t := store
-     and type key = Protocol_hash.t
+     and type key := Protocol_hash.t
-     and type value = Protocol.t
+     and type value := Protocol.t
-     and type key_set = Protocol_hash.Set.t
+
+  module RawContents : SINGLE_STORE
+    with type t = store * Protocol_hash.t
+     and type value := MBytes.t
 
 end

src/node/db/store_helpers.ml

@@ -23,6 +23,12 @@ module Make_value (V : ENCODED_VALUE) = struct
       MBytes.create 0
 end
 
+module Raw_value = struct
+  type t = MBytes.t
+  let of_bytes b = ok b
+  let to_bytes b = b
+end
+
 module Make_single_store (S : STORE) (N : NAME) (V : VALUE) = struct
   type t = S.t
   type value = V.t

src/node/db/store_helpers.mli

@@ -11,6 +11,8 @@ open Store_sigs
 
 module Make_value (V : ENCODED_VALUE) : VALUE with type t = V.t
 
+module Raw_value : VALUE with type t = MBytes.t
+
 module Make_single_store (S : STORE) (N : NAME) (V : VALUE)
   : SINGLE_STORE with type t = S.t
                   and type value = V.t

src/node/net/p2p.ml

@@ -463,7 +463,7 @@ module RPC = struct
 
   let connect net point timeout =
     match net.pool with
-    | None -> fail (Unclassified "fake net")
+    | None -> failwith "fake net"
     | Some pool ->
         P2p_connection_pool.connect ~timeout pool point >>|? ignore
 

src/node/shell/chain.ml

@@ -0,0 +1,95 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+open Logging.Node.State
+open State
+
+let genesis net_state =
+  let genesis = Net.genesis net_state in
+  Block.read_exn net_state genesis.block
+
+let known_heads net_state =
+  read_chain_store net_state begin fun chain_store _data ->
+    Store.Chain.Known_heads.elements chain_store
+  end >>= fun hashes ->
+  Lwt_list.map_p (Block.read_exn net_state) hashes
+
+let head net_state =
+  read_chain_store net_state begin fun _chain_store data ->
+    Lwt.return data.current_head
+  end
+
+let mem net_state hash =
+  read_chain_store net_state begin fun chain_store data ->
+    if Block_hash.equal (Block.hash data.current_head) hash then
+      Lwt.return true
+    else
+      Store.Chain.In_chain.known (chain_store, hash)
+  end
+
+let find_new net_state hist sz =
+  let rec common_ancestor hist =
+    match hist with
+    | [] -> Lwt.return (Net.genesis net_state).block
+    | h :: hist ->
+        mem net_state h >>= function
+        | false -> common_ancestor hist
+        | true -> Lwt.return h in
+  let rec path sz acc h =
+    if sz <= 0 then Lwt.return (List.rev acc)
+    else
+      read_chain_store net_state begin fun chain_store _data ->
+        Store.Chain.In_chain.read_opt (chain_store, h)
+      end >>= function
+      | None -> Lwt.return (List.rev acc)
+      | Some s -> path (sz-1) (s :: acc) s in
+  common_ancestor hist >>= fun ancestor ->
+  path sz [] ancestor
+
+let locked_set_head chain_store data block =
+  let rec pop_blocks ancestor block =
+    let hash = Block.hash block in
+    if Block_hash.equal hash ancestor then
+      Lwt.return_unit
+    else
+      lwt_debug "pop_block %a" Block_hash.pp_short hash >>= fun () ->
+      Store.Chain.In_chain.remove (chain_store, hash) >>= fun () ->
+      Block.predecessor block >>= function
+      | Some predecessor ->
+          pop_blocks ancestor predecessor
+      | None -> assert false (* Cannot pop the genesis... *)
+  in
+  let push_block pred_hash block =
+    let hash = Block.hash block in
+    lwt_debug "push_block %a" Block_hash.pp_short hash >>= fun () ->
+    Store.Chain.In_chain.store (chain_store, pred_hash) hash >>= fun () ->
+    Lwt.return hash
+  in
+  Chain_traversal.new_blocks
+    data.current_head block >>= fun (ancestor, path) ->
+  let ancestor = Block.hash ancestor in
+  pop_blocks ancestor data.current_head >>= fun () ->
+  Lwt_list.fold_left_s push_block ancestor path >>= fun _ ->
+  Store.Chain.Current_head.store chain_store (Block.hash block)
+
+let set_head net_state block =
+  update_chain_store net_state begin fun chain_store data ->
+    locked_set_head chain_store data block >>= fun () ->
+    Lwt.return (Some { current_head = block }, ())
+  end
+
+let test_and_set_head net_state ~old block =
+  update_chain_store net_state begin fun chain_store data ->
+    if not (Block.equal data.current_head old) then
+      Lwt.return (None, false)
+    else
+      locked_set_head chain_store data block >>= fun () ->
+      Lwt.return (Some { current_head = block }, true)
+  end

src/node/shell/chain.mli

@@ -0,0 +1,37 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+open State
+
+val genesis: Net.t -> Block.t Lwt.t
+(** The genesis block of the network's blockchain. On a test network,
+    the test protocol has been promoted as "main" protocol. *)
+
+val head: Net.t -> Block.t Lwt.t
+(** The current head of the network's blockchain. *)
+
+val known_heads: Net.t -> Block.t list Lwt.t
+
+val set_head: Net.t -> Block.t -> unit Lwt.t
+(** Record a block as the current head of the network's blockchain. *)
+
+val mem: Net.t -> Block_hash.t -> bool Lwt.t
+
+val test_and_set_head:
+  Net.t -> old:Block.t -> Block.t -> bool Lwt.t
+(** Atomically change the current head of the network's blockchain.
+    This returns [true] whenever the change succeeded, or [false]
+    when the current head os not equal to the [old] argument. *)
+
+val find_new:
+  Net.t -> Block_hash.t list -> int -> Block_hash.t list Lwt.t
+  (** [find_new net locator max_length], where [locator] is a sparse block
+      locator (/à la/ Bitcoin), returns the missing block when compared
+      with the current branch of [net]. *)

src/node/shell/chain_traversal.ml

@@ -0,0 +1,134 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+open State
+
+let path (b1: Block.t) (b2: Block.t) =
+  if not (Net_id.equal (Block.net_id b1) (Block.net_id b2)) then
+    invalid_arg "Chain_traversal.path" ;
+  let rec loop acc current =
+    if Block.equal b1 current then
+      Lwt.return (Some acc)
+    else
+      Block.predecessor current >>= function
+      | Some pred -> loop (current :: acc) pred
+      | None -> Lwt.return_none in
+  loop [] b2
+
+let common_ancestor (b1: Block.t) (b2: Block.t) =
+  if not ( Net_id.equal (Block.net_id b1) (Block.net_id b2)) then
+    invalid_arg "Chain_traversal.path" ;
+  let rec loop (b1: Block.t) (b2: Block.t) =
+    if Block.equal b1 b2 then
+      Lwt.return b1
+    else if Time.(Block.timestamp b1 <= Block.timestamp b2) then
+      Block.predecessor b2 >>= function
+      | None -> assert false
+      | Some b2 -> loop b1 b2
+    else
+      Block.predecessor b1 >>= function
+      | None -> assert false
+      | Some b1 -> loop b1 b2 in
+  loop b1 b2
+
+let block_locator (b: Block.t) sz =
+  let rec loop acc sz step cpt b =
+    if sz = 0 then
+      Lwt.return (List.rev acc)
+    else
+      Block.predecessor b >>= function
+      | None ->
+          Lwt.return (List.rev (Block.hash b :: acc))
+      | Some predecessor ->
+          if cpt = 0 then
+            loop (Block.hash b :: acc) (sz - 1)
+                 (step * 2) (step * 20 - 1) predecessor
+          else if cpt mod step = 0 then
+            loop (Block.hash b :: acc) (sz - 1)
+                 step (cpt - 1) predecessor
+          else
+            loop acc sz step (cpt - 1) predecessor in
+  loop [] sz 1 9 b
+
+let iter_predecessors ?max ?min_fitness ?min_date heads ~f =
+  let module Local = struct exception Exit end in
+  let compare b1 b2 =
+    match Fitness.compare (Block.fitness b1) (Block.fitness b2) with
+    | 0 -> begin
+        match Time.compare (Block.timestamp b1) (Block.timestamp b2) with
+        | 0 -> Block.compare b1 b2
+        | res -> res
+      end
+    | res -> res in
+  let pop, push =
+    (* Poor-man priority queue *)
+    let queue : Block.t list ref = ref [] in
+    let pop () =
+      match !queue with
+      | [] -> None
+      | b :: bs -> queue := bs ; Some b in
+    let push b =
+      let rec loop = function
+        | [] -> [b]
+        | b' :: bs' as bs ->
+            let cmp = compare b b' in
+            if cmp = 0 then
+              bs
+            else if cmp < 0 then
+              b' :: loop bs'
+            else
+              b :: bs in
+      queue := loop !queue in
+    pop, push in
+  let check_count =
+    match max with
+    | None -> (fun () -> ())
+    | Some max ->
+        let cpt = ref 0 in
+        fun () ->
+          if !cpt >= max then raise Local.Exit ;
+          incr cpt in
+  let check_fitness =
+    match min_fitness with
+    | None -> (fun _ -> true)
+    | Some min_fitness ->
+        (fun b -> Fitness.compare min_fitness (Block.fitness b) <= 0) in
+  let check_date =
+    match min_date with
+    | None -> (fun _ -> true)
+    | Some min_date ->
+        (fun b -> Time.(min_date <= Block.timestamp b)) in
+  let rec loop () =
+    match pop () with
+    | None -> Lwt.return ()
+    | Some b ->
+        check_count () ;
+        f b >>= fun () ->
+        Block.predecessor b >>= function
+        | None -> loop ()
+        | Some p ->
+            if check_fitness p && check_date p then push p ;
+            loop () in
+  List.iter push heads ;
+  try loop () with Local.Exit -> Lwt.return ()
+
+let iter_predecessors ?max ?min_fitness ?min_date heads ~f =
+  match heads with
+  | [] -> Lwt.return_unit
+  | b :: _ ->
+      let net_id = Block.net_id b in
+      if not (List.for_all (fun b -> Net_id.equal net_id (Block.net_id b)) heads) then
+        invalid_arg "State.Helpers.iter_predecessors" ;
+      iter_predecessors ?max ?min_fitness ?min_date heads ~f
+
+let new_blocks ~from_block ~to_block =
+  common_ancestor from_block to_block >>= fun ancestor ->
+  path ancestor to_block >>= function
+  | None -> assert false
+  | Some path -> Lwt.return (ancestor, path)

src/node/shell/chain_traversal.mli

@@ -0,0 +1,48 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+open State
+
+val path: Block.t -> Block.t -> Block.t list option Lwt.t
+(** If [h1] is an ancestor of [h2] in the current [state],
+    then [path state h1 h2] returns the chain of block from
+    [h1] (excluded) to [h2] (included). Returns [None] otherwise. *)
+
+val common_ancestor: Block.t -> Block.t -> Block.t Lwt.t
+(** [common_ancestor state h1 h2] returns the first common ancestors
+    in the history of blocks [h1] and [h2]. *)
+
+val block_locator: Block.t -> int -> Block_hash.t list Lwt.t
+(** [block_locator state max_length h] compute the sparse block locator
+    (/à la/ Bitcoin) for the block [h]. *)
+
+val iter_predecessors:
+  ?max:int ->
+  ?min_fitness:Fitness.t ->
+  ?min_date:Time.t ->
+  Block.t list ->
+  f:(Block.t -> unit Lwt.t) ->
+  unit Lwt.t
+(** [iter_predecessors state blocks f] iter [f] on [blocks] and
+    their recursive predecessors. Blocks are visited with a
+    decreasing fitness (then decreasing timestamp). If the optional
+    argument [max] is provided, the iteration is stopped after [max]
+    visited block. If [min_fitness] id provided, blocks with a
+    fitness lower than [min_fitness] are ignored. If [min_date],
+    blocks with a fitness lower than [min_date] are ignored. *)
+
+val new_blocks:
+  from_block:Block.t -> to_block:Block.t ->
+  (Block.t * Block.t list) Lwt.t
+(** [new_blocks ~from_block ~to_block] returns a pair [(ancestor,
+    path)], where [ancestor] is the common ancestor of [from_block]
+    and [to_block] and where [path] is the chain from [ancestor]
+    (excluded) to [to_block] (included).  The function raises an
+    exception when the two provided blocks do not belong the the same
+    [net].  *)

src/node/shell/distributed_db.ml

@@ -66,40 +66,84 @@ module Make_raw
 
 end
 
-module No_precheck = struct
+module Fake_operation_storage = struct
-  type param = unit
+  type store = State.Net.t
-  let precheck _ _ _ = true
+  type key = Operation_hash.t
+  type value = Operation.t
+  let known _ _ = Lwt.return_false
+  let read _ _ = Lwt.return (Error_monad.error_exn Not_found)
+  let read_opt _ _ = Lwt.return_none
+  let read_exn _ _ = raise Not_found
 end
 
 module Raw_operation =
   Make_raw
     (Operation_hash)
-    (struct
+    (Fake_operation_storage)
-      type value = Operation.t
-      include State.Operation
-    end)
     (Operation_hash.Table)
     (struct
       type param = Net_id.t
       let forge net_id keys = Message.Get_operations (net_id, keys)
     end)
-    (No_precheck)
+    (struct
+      type param = unit
+      type notified_value = Operation.t
+      let precheck _ _ v = Some v
+    end)
+
+module Block_header_storage = struct
+  type store = State.Net.t
+  type key = Block_hash.t
+  type value = Block_header.t
+  let known = State.Block.known_valid
+  let read net_state h =
+    State.Block.read net_state h >>=? fun b ->
+    return (State.Block.header b)
+  let read_opt net_state h =
+    State.Block.read_opt net_state h >>= fun b ->
+    Lwt.return (Utils.map_option State.Block.header b)
+  let read_exn net_state h =
+    State.Block.read_exn net_state h >>= fun b ->
+    Lwt.return (State.Block.header b)
+end
 
 module Raw_block_header =
   Make_raw
     (Block_hash)
-    (struct
+    (Block_header_storage)
-      type value = Block_header.t
-      include State.Block_header
-    end)
     (Block_hash.Table)
     (struct
       type param = Net_id.t
       let forge net_id keys = Message.Get_block_headers (net_id, keys)
     end)
-    (No_precheck)
+    (struct
+      type param = unit
+      type notified_value = Block_header.t
+      let precheck _ _ v = Some v
+    end)
 
-module Operation_list_table =
+module Operation_hashes_storage = struct
+  type store = State.Net.t
+  type key = Block_hash.t * int
+  type value = Operation_hash.t list
+  let known net_state (h, _) = State.Block.known_valid net_state h
+  let read net_state (h, i) =
+    State.Block.read net_state h >>=? fun b ->
+    State.Block.operation_hashes b i >>= fun (ops, _) ->
+    return ops
+  let read_opt net_state (h, i) =
+    State.Block.read_opt net_state h >>= function
+    | None -> Lwt.return_none
+    | Some b ->
+        State.Block.operation_hashes b i >>= fun (ops, _) ->
+        Lwt.return (Some ops)
+  let read_exn net_state (h, i) =
+    State.Block.read_exn net_state h >>= fun b ->
+    State.Block.operation_hashes b i >>= fun (ops, _) ->
+    Lwt.return ops
+end
+
+module Operations_table =
   Hashtbl.Make(struct
     type t = Block_hash.t * int
     let hash = Hashtbl.hash
@@ -107,39 +151,134 @@ module Operation_list_table =
       Block_hash.equal b1 b2 && i1 = i2
   end)
 
-module Raw_operation_list =
+module Raw_operation_hashes = struct
+
+  include
     Make_raw
       (struct type t = Block_hash.t * int end)
-    (State.Operation_list)
+      (Operation_hashes_storage)
-    (Operation_list_table)
+      (Operations_table)
       (struct
         type param = Net_id.t
         let forge net_id keys =
-        Message.Get_operation_list (net_id, keys)
+          Message.Get_operation_hashes_for_blocks (net_id, keys)
       end)
       (struct
         type param = Operation_list_list_hash.t
+        type notified_value =
+          Operation_hash.t list * Operation_list_list_hash.path
         let precheck (_block, expected_ofs) expected_hash (ops, path) =
           let received_hash, received_ofs =
             Operation_list_list_hash.check_path path
               (Operation_list_hash.compute ops) in
+          if
             received_ofs = expected_ofs &&
             Operation_list_list_hash.compare expected_hash received_hash = 0
+          then
+            Some ops
+          else
+            None
       end)
 
+  let inject_all table hash operations =
+    Lwt_list.mapi_p
+      (fun i ops -> Table.inject table (hash, i) ops)
+      operations >>= Lwt_list.for_all_s (fun x -> Lwt.return x)
+
+  let read_all table hash n =
+    map_p (fun i -> Table.read table (hash, i)) (0 -- (n-1))
+
+  let remove_all table hash n =
+    Lwt_list.iter_p (fun i -> Table.remove table (hash, i)) (0 -- (n-1))
+
+end
+
+module Operations_storage = struct
+  type store = State.Net.t
+  type key = Block_hash.t * int
+  type value = Operation.t list
+  let known net_state (h, _) = State.Block.known_valid net_state h
+  let read net_state (h, i) =
+    State.Block.read net_state h >>=? fun b ->
+    State.Block.operations b i >>= fun (ops, _) ->
+    return ops
+  let read_opt net_state (h, i) =
+    State.Block.read_opt net_state h >>= function
+    | None -> Lwt.return_none
+    | Some b ->
+        State.Block.operations b i >>= fun (ops, _) ->
+        Lwt.return (Some ops)
+  let read_exn net_state (h, i) =
+    State.Block.read_exn net_state h >>= fun b ->
+    State.Block.operations b i >>= fun (ops, _) ->
+    Lwt.return ops
+end
+
+module Raw_operations = struct
+  include
+    Make_raw
+      (struct type t = Block_hash.t * int end)
+      (Operations_storage)
+      (Operations_table)
+      (struct
+        type param = Net_id.t
+        let forge net_id keys =
+          Message.Get_operations_for_blocks (net_id, keys)
+      end)
+      (struct
+        type param = Operation_list_list_hash.t
+        type notified_value = Operation.t list * Operation_list_list_hash.path
+        let precheck (_block, expected_ofs) expected_hash (ops, path) =
+          let received_hash, received_ofs =
+            Operation_list_list_hash.check_path path
+              (Operation_list_hash.compute
+                 (List.map Operation.hash ops)) in
+          if
+            received_ofs = expected_ofs &&
+            Operation_list_list_hash.compare expected_hash received_hash = 0
+          then
+            Some ops
+          else
+            None
+      end)
+
+  let inject_all table hash operations =
+    Lwt_list.mapi_p
+      (fun i ops -> Table.inject table (hash, i) ops)
+      operations >>= Lwt_list.for_all_s (fun x -> Lwt.return x)
+
+  let read_all table hash n =
+    map_p (fun i -> Table.read table (hash, i)) (0 -- (n-1))
+
+  let remove_all table hash n =
+    Lwt_list.iter_p (fun i -> Table.remove table (hash, i)) (0 -- (n-1))
+
+end
+
+module Protocol_storage = struct
+  type store = State.t
+  type key = Protocol_hash.t
+  type value = Protocol.t
+  let known = State.Protocol.known
+  let read = State.Protocol.read
+  let read_opt = State.Protocol.read_opt
+  let read_exn = State.Protocol.read_exn
+end
+
 module Raw_protocol =
   Make_raw
     (Protocol_hash)
-    (struct
+    (Protocol_storage)
-      type value = Protocol.t
-      include State.Protocol
-    end)
     (Protocol_hash.Table)
     (struct
       type param = unit
       let forge () keys = Message.Get_protocols keys
     end)
-    (No_precheck)
+    (struct
+      type param = unit
+      type notified_value = Protocol.t
+      let precheck _ _ v = Some v
+    end)
 
 type callback = {
   notify_branch: P2p.Peer_id.t -> Block_hash.t list -> unit ;
@@ -153,18 +292,19 @@ type db = {
   p2p: p2p ;
   p2p_readers: p2p_reader P2p.Peer_id.Table.t ;
   disk: State.t ;
-  active_nets: net Net_id.Table.t ;
+  active_nets: net_db Net_id.Table.t ;
   protocol_db: Raw_protocol.t ;
   block_input: (Block_hash.t * Block_header.t) Watcher.input ;
   operation_input: (Operation_hash.t * Operation.t) Watcher.input ;
 }
 
-and net = {
+and net_db = {
-  net: State.Net.t ;
+  net_state: State.Net.t ;
   global_db: db ;
   operation_db: Raw_operation.t ;
   block_header_db: Raw_block_header.t ;
-  operation_list_db: Raw_operation_list.t ;
+  operation_hashes_db: Raw_operation_hashes.t ;
+  operations_db: Raw_operations.t ;
   callback: callback ;
   active_peers: P2p.Peer_id.Set.t ref ;
   active_connections: p2p_reader P2p.Peer_id.Table.t ;
@@ -173,14 +313,14 @@ and net = {
 and p2p_reader = {
   gid: P2p.Peer_id.t ;
   conn: connection ;
-  peer_active_nets: net Net_id.Table.t ;
+  peer_active_nets: net_db Net_id.Table.t ;
   canceler: Lwt_utils.Canceler.t ;
   mutable worker: unit Lwt.t ;
 }
 
 type t = db
 
-let state { net } = net
+let state { net_state } = net_state
 
 module P2p_reader = struct
 
@@ -248,7 +388,12 @@ module P2p_reader = struct
 
     | Current_branch (net_id, locator) ->
         may_activate global_db state net_id @@ fun net_db ->
+        Lwt_list.exists_p
+          (State.Block.known_invalid net_db.net_state)
+          locator >>= fun known_invalid ->
+        if not known_invalid then
           net_db.callback.notify_branch state.gid locator ;
+        (* TODO Kickban *)
         Lwt.return_unit
 
     | Deactivate net_id ->
@@ -267,22 +412,23 @@ module P2p_reader = struct
 
     | Current_head (net_id, head, mempool) ->
         may_handle state net_id @@ fun net_db ->
+        State.Block.known_invalid net_db.net_state head >>= fun known_invalid ->
+        if not known_invalid then
           net_db.callback.notify_head state.gid head mempool ;
+        (* TODO Kickban *)
         Lwt.return_unit
 
     | Get_block_headers (net_id, hashes) ->
         may_handle state net_id @@ fun net_db ->
-        (* Should we filter out invalid block ? *)
+        (* TODO: Blame request of unadvertised blocks ? *)
-        (* Should we filter out blocks whose validity is unknown ? *)
-        (* Should we blame request of unadvertised blocks ? *)
         Lwt_list.iter_p
           (fun hash ->
-             Raw_block_header.Table.read
+             State.Block.read_opt net_db.net_state hash >|= function
-               net_db.block_header_db.table hash >|= function
              | None -> ()
-             | Some p ->
+             | Some b ->
+                 let header = State.Block.header b in
                  ignore @@
-                 P2p.try_send global_db.p2p state.conn (Block_header p))
+                 P2p.try_send global_db.p2p state.conn (Block_header header))
           hashes
 
     | Block_header block ->
@@ -294,9 +440,10 @@ module P2p_reader = struct
 
     | Get_operations (net_id, hashes) ->
         may_handle state net_id @@ fun net_db ->
+        (* TODO: only answers for prevalidated operations *)
         Lwt_list.iter_p
           (fun hash ->
-             Raw_operation.Table.read
+             Raw_operation.Table.read_opt
                net_db.operation_db.table hash >|= function
              | None -> ()
              | Some p ->
@@ -314,8 +461,7 @@ module P2p_reader = struct
     | Get_protocols hashes ->
         Lwt_list.iter_p
           (fun hash ->
-             Raw_protocol.Table.read
+             State.Protocol.read_opt global_db.disk hash >|= function
-               global_db.protocol_db.table hash >|= function
              | None -> ()
              | Some p ->
                  ignore @@
@@ -328,22 +474,23 @@ module P2p_reader = struct
           global_db.protocol_db.table state.gid hash protocol >>= fun () ->
         Lwt.return_unit
 
-    | Get_operation_list (net_id, hashes) ->
+    | Get_operation_hashes_for_blocks (net_id, blocks) ->
         may_handle state net_id @@ fun net_db ->
+        (* TODO: Blame request of unadvertised blocks ? *)
         Lwt_list.iter_p
-          (fun (block, ofs as key) ->
+          (fun (hash, ofs) ->
-             Raw_operation_list.Table.read
+             State.Block.read_opt net_db.net_state hash >>= function
-               net_db.operation_list_db.table key >>= function
              | None -> Lwt.return_unit
-             | Some (ops, path) ->
+             | Some b ->
+                 State.Block.operation_hashes b ofs >>= fun (hashes, path) ->
                  ignore @@
-                 P2p.try_send
+                 P2p.try_send global_db.p2p state.conn
-                   global_db.p2p state.conn
+                   (Operation_hashes_for_block
-                   (Operation_list (net_id, block, ofs, ops, path)) ;
+                      (net_id, hash, ofs, hashes, path)) ;
                  Lwt.return_unit)
-          hashes
+          blocks
 
-    | Operation_list (net_id, block, ofs, ops, path) ->
+    | Operation_hashes_for_block (net_id, block, ofs, ops, path) -> begin
         may_handle state net_id @@ fun net_db ->
         (* TODO early detection of non-requested list. *)
         let found_hash, found_ofs =
@@ -352,7 +499,7 @@ module P2p_reader = struct
         if found_ofs <> ofs then
           Lwt.return_unit
         else
-          Raw_block_header.Table.read
+          Raw_block_header.Table.read_opt
             net_db.block_header_db.table block >>= function
           | None -> Lwt.return_unit
           | Some bh ->
@@ -360,8 +507,47 @@ module P2p_reader = struct
                   found_hash bh.shell.operations_hash <> 0 then
                 Lwt.return_unit
               else
-                Raw_operation_list.Table.notify
+                Raw_operation_hashes.Table.notify
-                  net_db.operation_list_db.table state.gid
+                  net_db.operation_hashes_db.table state.gid
+                  (block, ofs) (ops, path) >>= fun () ->
+                Lwt.return_unit
+      end
+
+    | Get_operations_for_blocks (net_id, blocks) ->
+        may_handle state net_id @@ fun net_db ->
+        (* TODO: Blame request of unadvertised blocks ? *)
+        Lwt_list.iter_p
+          (fun (hash, ofs) ->
+             State.Block.read_opt net_db.net_state hash >>= function
+             | None -> Lwt.return_unit
+             | Some b ->
+                 State.Block.operations b ofs >>= fun (hashes, path) ->
+                 ignore @@
+                 P2p.try_send global_db.p2p state.conn
+                   (Operations_for_block
+                      (net_id, hash, ofs, hashes, path)) ;
+                 Lwt.return_unit)
+          blocks
+
+    | Operations_for_block (net_id, block, ofs, ops, path) ->
+        may_handle state net_id @@ fun net_db ->
+        (* TODO early detection of non-requested operations. *)
+        let found_hash, found_ofs =
+          Operation_list_list_hash.check_path
+            path (Operation_list_hash.compute (List.map Operation.hash ops)) in
+        if found_ofs <> ofs then
+          Lwt.return_unit
+        else
+          Raw_block_header.Table.read_opt
+            net_db.block_header_db.table block >>= function
+          | None -> Lwt.return_unit
+          | Some bh ->
+              if Operation_list_list_hash.compare
+                   found_hash bh.shell.operations_hash <> 0 then
+                Lwt.return_unit
+              else
+                Raw_operations.Table.notify
+                  net_db.operations_db.table state.gid
                   (block, ofs) (ops, path) >>= fun () ->
         Lwt.return_unit
 
@@ -435,28 +621,30 @@ let create disk p2p =
   P2p.iter_connections p2p (P2p_reader.run db) ;
   db
 
-let activate ~callback ({ p2p ; active_nets } as global_db) net =
+let activate ~callback ({ p2p ; active_nets } as global_db) net_state =
-  let net_id = State.Net.id net in
+  let net_id = State.Net.id net_state in
   match Net_id.Table.find active_nets net_id with
   | exception Not_found ->
       let active_peers = ref P2p.Peer_id.Set.empty in
       let p2p_request =
-        let net_id = State.Net.id net in
         { data = net_id ;
           active = (fun () -> !active_peers) ;
           send = raw_try_send p2p ;
         } in
       let operation_db =
         Raw_operation.create
-          ~global_input:global_db.operation_input p2p_request net in
+          ~global_input:global_db.operation_input p2p_request net_state in
       let block_header_db =
         Raw_block_header.create
-          ~global_input:global_db.block_input p2p_request net in
+          ~global_input:global_db.block_input p2p_request net_state in
-      let operation_list_db =
+      let operation_hashes_db =
-        Raw_operation_list.create p2p_request net in
+        Raw_operation_hashes.create p2p_request net_state in
+      let operations_db =
+        Raw_operations.create p2p_request net_state in
       let net = {
-        global_db ; operation_db ; block_header_db ; operation_list_db ;
+        global_db ; operation_db ; block_header_db ;
-        net ; callback ; active_peers ;
+        operation_hashes_db ; operations_db ;
+        net_state ; callback ; active_peers ;
         active_connections = P2p.Peer_id.Table.create 53 ;
       } in
       P2p.iter_connections p2p (fun _peer_id conn ->
@@ -468,19 +656,19 @@ let activate ~callback ({ p2p ; active_nets } as global_db) net =
   | net ->
       net
 
-let deactivate net =
+let deactivate net_db =
-  let { active_nets ; p2p } = net.global_db in
+  let { active_nets ; p2p } = net_db.global_db in
-  let net_id = State.Net.id net.net in
+  let net_id = State.Net.id net_db.net_state in
   Net_id.Table.remove active_nets net_id ;
   P2p.Peer_id.Table.iter
     (fun _peer_id reader ->
-       P2p_reader.deactivate reader net  ;
+       P2p_reader.deactivate reader net_db  ;
        Lwt.async begin fun () ->
          P2p.send p2p reader.conn (Deactivate net_id)
        end)
-    net.active_connections ;
+    net_db.active_connections ;
-  Raw_operation.shutdown net.operation_db >>= fun () ->
+  Raw_operation.shutdown net_db.operation_db >>= fun () ->
-  Raw_block_header.shutdown net.block_header_db >>= fun () ->
+  Raw_block_header.shutdown net_db.block_header_db >>= fun () ->
     Lwt.return_unit >>= fun () ->
   Lwt.return_unit
 
@@ -504,212 +692,133 @@ let shutdown { p2p ; p2p_readers ; active_nets } =
   P2p.shutdown p2p >>= fun () ->
   Lwt.return_unit
 
-module type PARAMETRIZED_DISTRIBUTED_DB =
+let read_all_operations net_db hash n =
-  Distributed_db_functors.PARAMETRIZED_DISTRIBUTED_DB
+  Lwt_list.map_p
-module type DISTRIBUTED_DB =
+    (fun i ->
-  Distributed_db_functors.DISTRIBUTED_DB
+       Raw_operations.Table.read_opt net_db.operations_db.table (hash, i))
-
+    (0 -- (n-1)) >>= fun operations ->
-module Make
+  mapi_p
-    (Table : PARAMETRIZED_DISTRIBUTED_DB with type param := unit)
-    (Kind : sig
-       type t
-       val proj: t -> Table.t
-     end) = struct
-  type t = Kind.t
-  type key = Table.key
-  type value = Table.value
-  let known t k = Table.known (Kind.proj t) k
-  let read t k = Table.read (Kind.proj t) k
-  let read_exn t k = Table.read_exn (Kind.proj t) k
-  let prefetch t ?peer k = Table.prefetch (Kind.proj t) ?peer k ()
-  let fetch t ?peer k = Table.fetch (Kind.proj t) ?peer k ()
-  let commit t k = Table.commit (Kind.proj t) k
-  let inject t k v = Table.inject (Kind.proj t) k v
-  let watch t = Table.watch (Kind.proj t)
-end
-
-module Operation =
-  Make (Raw_operation.Table) (struct
-    type t = net
-    let proj net = net.operation_db.table
-  end)
-
-module Block_header =
-  Make (Raw_block_header.Table) (struct
-    type t = net
-    let proj net = net.block_header_db.table
-  end)
-
-module Protocol =
-  Make (Raw_protocol.Table) (struct
-    type t = db
-    let proj db = db.protocol_db.table
-  end)
-
-module Operation_list = struct
-
-  type t = net
-  type key = Block_hash.t * int
-  type value = Operation_hash.t list
-  type param = Operation_list_list_hash.t
-
-  let proj net = net.operation_list_db.table
-
-  module Table = Raw_operation_list.Table
-
-  let known t k = Table.known (proj t) k
-  let read t k =
-    Table.read (proj t) k >>= function
-    | None -> Lwt.return_none
-    | Some (op, _) -> Lwt.return (Some op)
-  let read_exn t k = Table.read_exn (proj t) k >|= fst
-  let prefetch t ?peer k p = Table.prefetch (proj t) ?peer k p
-  let fetch t ?peer k p = Table.fetch (proj t) ?peer k p >|= fst
-
-  let rec do_read net block acc i =
-    if i <= 0 then
-      Lwt.return acc
-    else
-      read_exn net (block, i-1) >>= fun ops ->
-      do_read net block (ops :: acc) (i-1)
-
-  let read_all_opt net block =
-    State.Operation_list.read_count_opt
-      net.net block >>= function
-    | None -> Lwt.return_none
-    | Some len -> do_read net block [] len >>= fun ops -> Lwt.return (Some ops)
-
-  let read_all_exn net block =
-    State.Operation_list.read_count_exn
-      net.net block >>= fun len ->
-    do_read net block [] len
-
-  let rec do_commit net block i =
-    if i <= 0 then
-      Lwt.return_unit
-    else
-      Raw_operation_list.Table.commit
-        net.operation_list_db.table (block, i-1) >>= fun () ->
-      do_commit net block (i-1)
-
-  let commit_all net block len =
-    State.Operation_list.store_count net.net block len >>= fun () ->
-    do_commit net block len
-
-  let inject_all net block opss =
-    State.Operation_list.read_count_opt net.net block >>= function
-    | Some _ -> Lwt.return_false
-    | None ->
-        let hashes = List.map Operation_list_hash.compute opss in
-        Lwt_list.mapi_p
     (fun i ops ->
-             let path = Operation_list_list_hash.compute_path hashes i in
+       match ops with
-             Raw_operation_list.Table.inject
+       | Some ops -> return ops
-               net.operation_list_db.table
+       | None ->
-               (block, i) (ops, path))
+           Raw_operation_hashes.Table.read
-          opss >>= fun injected ->
+             net_db.operation_hashes_db.table (hash, i) >>=? fun hashes ->
-        Lwt.return (List.for_all (fun x -> x) injected)
+           map_p (Raw_operation.Table.read net_db.operation_db.table) hashes)
+    operations
 
-end
+let commit_block net_db hash n validation_result =
+  Raw_block_header.Table.read
+    net_db.block_header_db.table hash >>=? fun header ->
+  read_all_operations net_db hash n >>=? fun operations ->
+  State.Block.store
+    net_db.net_state header operations validation_result >>=? fun res ->
+  Raw_block_header.Table.remove
+    net_db.block_header_db.table hash >>= fun () ->
+  Raw_operation_hashes.remove_all
+    net_db.operation_hashes_db.table hash n >>= fun () ->
+  Raw_operations.remove_all
+    net_db.operations_db.table hash n >>= fun () ->
+  (* TODO: proper handling of the operations table by the prevalidator. *)
+  Lwt_list.iter_p
+    (Lwt_list.iter_p
+       (fun op -> Raw_operation.Table.remove
+           net_db.operation_db.table
+           (Operation.hash op)))
+    operations >>= fun () ->
+  return res
 
-let inject_block t bytes operations =
+let commit_invalid_block net_db hash n =
+  Raw_block_header.Table.read
+    net_db.block_header_db.table hash >>=? fun header ->
+  State.Block.store_invalid net_db.net_state header >>=? fun res ->
+  Raw_block_header.Table.remove
+    net_db.block_header_db.table hash >>= fun () ->
+  Raw_operation_hashes.remove_all
+    net_db.operation_hashes_db.table hash n >>= fun () ->
+  Raw_operations.remove_all
+    net_db.operations_db.table hash n >>= fun () ->
+  return res
+
+let inject_operation net_db h op =
+  fail_unless
+    (Net_id.equal op.Operation.shell.net_id (State.Net.id net_db.net_state))
+    (failure "Inconsitent net_id in operation") >>=? fun () ->
+  Raw_operation.Table.inject net_db.operation_db.table h op >>= fun res ->
+  return res
+
+let inject_protocol db h p =
+  Raw_protocol.Table.inject db.protocol_db.table h p
+
+let commit_protocol db h =
+  Raw_protocol.Table.read db.protocol_db.table h >>=? fun p ->
+  State.Protocol.store db.disk p >>= fun res ->
+  Raw_protocol.Table.remove db.protocol_db.table h >>= fun () ->
+  return (res <> None)
+
+type operation =
+  | Blob of Operation.t
+  | Hash of Operation_hash.t
+
+let resolve_operation net_db = function
+  | Blob op ->
+      fail_unless
+        (Net_id.equal op.shell.net_id (State.Net.id net_db.net_state))
+        (failure "Inconsistent net_id in operation.") >>=? fun () ->
+      return (Operation.hash op, op)
+  | Hash oph ->
+      Raw_operation.Table.read net_db.operation_db.table oph >>=? fun op ->
+      return (oph, op)
+
+let inject_block db bytes operations =
   let hash = Block_hash.hash_bytes [bytes] in
-  match
+  match Block_header.of_bytes bytes with
-    Data_encoding.Binary.of_bytes Tezos_data.Block_header.encoding bytes
-  with
   | None ->
       failwith "Cannot parse block header."
   | Some block ->
-      match get_net t block.shell.net_id with
+      match get_net db block.shell.net_id with
       | None ->
           failwith "Unknown network."
       | Some net_db ->
-          Block_header.known net_db hash >>= function
+          map_p
-          | true ->
+            (map_p (resolve_operation net_db))
-              failwith "Previously injected block."
+            operations >>=? fun operations ->
-          | false ->
+          let hashes = List.map (List.map fst) operations in
+          let operations = List.map (List.map snd) operations in
           let computed_hash =
             Operation_list_list_hash.compute
-                  (List.map Operation_list_hash.compute operations) in
+              (List.map Operation_list_hash.compute hashes) in
-              fail_unless
+          fail_when
             (Operation_list_list_hash.compare
-                   computed_hash block.shell.operations_hash = 0)
+               computed_hash block.shell.operations_hash <> 0)
             (Exn (Failure "Incoherent operation list")) >>=? fun () ->
           Raw_block_header.Table.inject
             net_db.block_header_db.table hash block >>= function
           | false ->
               failwith "Previously injected block."
           | true ->
-                  Operation_list.inject_all
+              Raw_operation_hashes.inject_all
-                    net_db hash operations >>= fun _ ->
+                net_db.operation_hashes_db.table hash hashes >>= fun _ ->
+              Raw_operations.inject_all
+                net_db.operations_db.table hash operations >>= fun _ ->
               return (hash, block)
 
-(*
+let remove_block net_db hash n =
-let inject_operation t bytes =
+  Raw_operations.remove_all
-  let hash = Operation_hash.hash_bytes [bytes] in
+    net_db.operations_db.table hash n >>= fun () ->
-  match Data_encoding.Binary.of_bytes Operation.encoding bytes with
+  Raw_operation_hashes.remove_all
-  | None ->
+    net_db.operation_hashes_db.table hash n >>= fun () ->
-      failwith "Cannot parse operations."
+  Raw_block_header.Table.remove net_db.block_header_db.table hash
-  | Some op ->
-      match get_net t op.shell.net_id with
-      | None ->
-          failwith "Unknown network."
-      | Some net_db ->
-          Operation.known net_db hash  >>= function
-          | true ->
-              failwith "Previously injected block."
-          | false ->
-              Raw_operation.Table.inject
-                net_db.operation_db.table hash op >>= function
-              | false ->
-                  failwith "Previously injected block."
-              | true ->
-                  return (hash, op)
-*)
 
-let broadcast_head net head mempool =
+let broadcast_head net_db head mempool =
   let msg : Message.t =
-    Current_head (State.Net.id net.net, head, mempool) in
+    Current_head (State.Net.id net_db.net_state, head, mempool) in
   P2p.Peer_id.Table.iter
     (fun _peer_id state ->
-       ignore (P2p.try_send net.global_db.p2p state.conn msg))
+       ignore (P2p.try_send net_db.global_db.p2p state.conn msg))
-    net.active_connections
+    net_db.active_connections
 
-let read_block { active_nets } hash =
+let watch_block_header { block_input } =
-  Net_id.Table.fold
-    (fun _net_id net acc ->
-       acc >>= function
-       | Some _ -> acc
-       | None ->
-           Block_header.read net hash >>= function
-           | None -> acc
-           | Some block -> Lwt.return (Some (net, block)))
-    active_nets
-    Lwt.return_none
-
-let read_block_exn t hash =
-  read_block t hash >>= function
-  | None -> Lwt.fail Not_found
-  | Some b -> Lwt.return b
-
-let read_operation { active_nets } hash =
-  Net_id.Table.fold
-    (fun _net_id net acc ->
-       acc >>= function
-       | Some _ -> acc
-       | None ->
-           Operation.read net hash >>= function
-           | None -> acc
-           | Some block -> Lwt.return (Some (net, block)))
-    active_nets
-    Lwt.return_none
-
-let read_operation_exn t hash =
-  read_operation t hash >>= function
-  | None -> Lwt.fail Not_found
-  | Some b -> Lwt.return b
-
-let watch_block { block_input } =
   Watcher.create_stream block_input
 let watch_operation { operation_input } =
   Watcher.create_stream operation_input
@@ -725,3 +834,71 @@ module Raw = struct
   let encoding = P2p.Raw.encoding Message.cfg.encoding
   let supported_versions = Message.cfg.versions
 end
+
+module type DISTRIBUTED_DB = sig
+  type t
+  type key
+  type value
+  type param
+  val known: t -> key -> bool Lwt.t
+  type error += Missing_data of key
+  val read: t -> key -> value tzresult Lwt.t
+  val read_opt: t -> key -> value option Lwt.t
+  val read_exn: t -> key -> value Lwt.t
+  val watch: t -> (key * value) Lwt_stream.t * Watcher.stopper
+  val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> unit
+  val fetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> value Lwt.t
+end
+
+module Make
+    (Table : Distributed_db_functors.DISTRIBUTED_DB)
+    (Kind : sig
+       type t
+       val proj: t -> Table.t
+     end) = struct
+  type t = Kind.t
+  type key = Table.key
+  type value = Table.value
+  type param = Table.param
+  let known t k = Table.known (Kind.proj t) k
+  type error += Missing_data of key
+  let read t k = Table.read (Kind.proj t) k
+  let read_opt t k = Table.read_opt (Kind.proj t) k
+  let read_exn t k = Table.read_exn (Kind.proj t) k
+  let prefetch t ?peer k p = Table.prefetch (Kind.proj t) ?peer k p
+  let fetch t ?peer k p = Table.fetch (Kind.proj t) ?peer k p
+  let remove t k = Table.remove (Kind.proj t) k
+  let inject t k v = Table.inject (Kind.proj t) k v
+  let watch t = Table.watch (Kind.proj t)
+end
+
+module Block_header =
+  Make (Raw_block_header.Table) (struct
+    type t = net_db
+    let proj net = net.block_header_db.table
+  end)
+
+module Operation_hashes =
+  Make (Raw_operation_hashes.Table) (struct
+    type t = net_db
+    let proj net = net.operation_hashes_db.table
+  end)
+
+module Operations =
+  Make (Raw_operations.Table) (struct
+    type t = net_db
+    let proj net = net.operations_db.table
+  end)
+
+module Operation =
+  Make (Raw_operation.Table) (struct
+    type t = net_db
+    let proj net = net.operation_db.table
+  end)
+
+module Protocol =
+  Make (Raw_protocol.Table) (struct
+    type t = db
+    let proj db = db.protocol_db.table
+  end)
+

src/node/shell/distributed_db.mli

@@ -18,9 +18,9 @@ type p2p = (Message.t, Metadata.t) P2p.net
 val create: State.t -> p2p -> t
 val shutdown: t -> unit Lwt.t
 
-type net
+type net_db
 
-val state: net -> State.Net.t
+val state: net_db -> State.Net.t
 
 type callback = {
   notify_branch: P2p.Peer_id.t -> Block_hash.t list -> unit ;
@@ -30,90 +30,90 @@ type callback = {
   disconnection: P2p.Peer_id.t -> unit ;
 }
 
-val activate: callback:callback -> t -> State.Net.t -> net
+val activate: callback:callback -> t -> State.Net.t -> net_db
-val deactivate: net -> unit Lwt.t
+val deactivate: net_db -> unit Lwt.t
+
+val broadcast_head:
+  net_db -> Block_hash.t -> Operation_hash.t list -> unit
+
+type operation =
+  | Blob of Operation.t
+  | Hash of Operation_hash.t
+
+val resolve_operation:
+  net_db -> operation -> (Operation_hash.t * Operation.t) tzresult Lwt.t
+
+val commit_block:
+  net_db -> Block_hash.t -> int -> Updater.validation_result ->
+  State.Block.t option tzresult Lwt.t
+val commit_invalid_block:
+  net_db -> Block_hash.t -> int ->
+  bool tzresult Lwt.t
+val inject_block:
+  t -> MBytes.t -> operation list list ->
+  (Block_hash.t * Block_header.t) tzresult Lwt.t
+val remove_block: net_db -> Block_hash.t -> int -> unit Lwt.t
+
+val inject_operation:
+  net_db -> Operation_hash.t -> Operation.t -> bool tzresult Lwt.t
+
+val commit_protocol:
+  db -> Protocol_hash.t -> bool tzresult Lwt.t
+val inject_protocol:
+  db -> Protocol_hash.t -> Protocol.t -> bool Lwt.t
+
+val watch_block_header:
+  t -> (Block_hash.t * Block_header.t) Lwt_stream.t * Watcher.stopper
+val watch_operation:
+  t -> (Operation_hash.t * Operation.t) Lwt_stream.t * Watcher.stopper
+val watch_protocol:
+  t -> (Protocol_hash.t * Protocol.t) Lwt_stream.t * Watcher.stopper
+
 
 module type DISTRIBUTED_DB = sig
   type t
   type key
   type value
+  type param
   val known: t -> key -> bool Lwt.t
-  val read: t -> key -> value option Lwt.t
+  type error += Missing_data of key
+  val read: t -> key -> value tzresult Lwt.t
+  val read_opt: t -> key -> value option Lwt.t
   val read_exn: t -> key -> value Lwt.t
-  val commit: t -> key -> unit Lwt.t
-  val inject: t -> key -> value -> bool Lwt.t
   val watch: t -> (key * value) Lwt_stream.t * Watcher.stopper
-  val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> unit
+  val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> unit
-  val fetch: t -> ?peer:P2p.Peer_id.t -> key -> value Lwt.t
+  val fetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> value Lwt.t
 end
 
-module Operation :
-  DISTRIBUTED_DB with type t = net
-                  and type key := Operation_hash.t
-                  and type value := Operation.t
-
 module Block_header :
-  DISTRIBUTED_DB with type t = net
+  DISTRIBUTED_DB with type t = net_db
                   and type key := Block_hash.t
                   and type value := Block_header.t
+                  and type param := unit
+
+module Operations :
+  DISTRIBUTED_DB with type t = net_db
+                  and type key = Block_hash.t * int
+                  and type value = Operation.t list
+                  and type param := Operation_list_list_hash.t
+
+module Operation_hashes :
+  DISTRIBUTED_DB with type t = net_db
+                  and type key = Block_hash.t * int
+                  and type value = Operation_hash.t list
+                  and type param := Operation_list_list_hash.t
+
+module Operation :
+  DISTRIBUTED_DB with type t = net_db
+                  and type key := Operation_hash.t
+                  and type value := Operation.t
+                  and type param := unit
 
 module Protocol :
   DISTRIBUTED_DB with type t = db
                   and type key := Protocol_hash.t
                   and type value := Protocol.t
-
+                  and type param := unit
-module Operation_list : sig
-
-  type t = net
-  type key = Block_hash.t * int
-  type value = Operation_hash.t list
-  type param = Operation_list_list_hash.t
-
-  val known: t -> key -> bool Lwt.t
-  val read: t -> key -> value option Lwt.t
-  val read_exn: t -> key -> value Lwt.t
-  val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> unit
-  val fetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> value Lwt.t
-
-  val read_all_opt:
-    net -> Block_hash.t -> Operation_hash.t list list option Lwt.t
-  val read_all_exn:
-    net -> Block_hash.t -> Operation_hash.t list list Lwt.t
-
-  val commit_all:
-    net -> Block_hash.t -> int -> unit Lwt.t
-  val inject_all:
-    net -> Block_hash.t -> Operation_hash.t list list -> bool Lwt.t
-
-end
-
-val broadcast_head:
-  net -> Block_hash.t -> Operation_hash.t list -> unit
-
-val inject_block:
-  t -> MBytes.t -> Operation_hash.t list list ->
-  (Block_hash.t * Tezos_data.Block_header.t) tzresult Lwt.t
-
-(* val inject_operation: *)
-  (* t -> MBytes.t -> *)
-  (* (Block_hash.t * Operation.t) tzresult Lwt.t *)
-
-val read_block:
-  t -> Block_hash.t -> (net * Tezos_data.Block_header.t) option Lwt.t
-val read_block_exn:
-  t -> Block_hash.t -> (net * Tezos_data.Block_header.t) Lwt.t
-
-val read_operation:
-  t -> Operation_hash.t -> (net * Tezos_data.Operation.t) option Lwt.t
-val read_operation_exn:
-  t -> Operation_hash.t -> (net * Tezos_data.Operation.t) Lwt.t
-
-val watch_block:
-  t -> (Block_hash.t * Tezos_data.Block_header.t) Lwt_stream.t * Watcher.stopper
-val watch_operation:
-  t -> (Operation_hash.t * Tezos_data.Operation.t) Lwt_stream.t * Watcher.stopper
-val watch_protocol:
-  t -> (Protocol_hash.t * Tezos_data.Protocol.t) Lwt_stream.t * Watcher.stopper
 
 module Raw : sig
   val encoding: Message.t P2p.Raw.t Data_encoding.t

src/node/shell/distributed_db_functors.ml

@@ -7,7 +7,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-module type PARAMETRIZED_RO_DISTRIBUTED_DB = sig
+module type DISTRIBUTED_DB = sig
 
   type t
   type key
@@ -15,34 +15,21 @@ module type PARAMETRIZED_RO_DISTRIBUTED_DB = sig
   type param
 
   val known: t -> key -> bool Lwt.t
-  val read: t -> key -> value option Lwt.t
+
+  type error += Missing_data of key
+  val read: t -> key -> value tzresult Lwt.t
+  val read_opt: t -> key -> value option Lwt.t
   val read_exn: t -> key -> value Lwt.t
 
   val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> unit
   val fetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> value Lwt.t
 
-end
+  val remove: t -> key -> unit Lwt.t
-
-module type PARAMETRIZED_DISTRIBUTED_DB = sig
-
-  include PARAMETRIZED_RO_DISTRIBUTED_DB
-
-  val commit: t -> key -> unit Lwt.t
-  (* val commit_invalid: t -> key -> unit Lwt.t *) (* TODO *)
   val inject: t -> key -> value -> bool Lwt.t
   val watch: t -> (key * value) Lwt_stream.t * Watcher.stopper
 
 end
 
-module type DISTRIBUTED_DB = sig
-
-  include PARAMETRIZED_DISTRIBUTED_DB with type param := unit
-
-  val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> unit
-  val fetch: t -> ?peer:P2p.Peer_id.t -> key -> value Lwt.t
-
-end
-
 module type DISK_TABLE = sig
   type store
   type key
@@ -51,8 +38,6 @@ module type DISK_TABLE = sig
   val read: store -> key -> value tzresult Lwt.t
   val read_opt: store -> key -> value option Lwt.t
   val read_exn: store -> key -> value Lwt.t
-  val store: store -> key -> value -> bool Lwt.t
-  val remove: store -> key -> bool Lwt.t
 end
 
 module type MEMORY_TABLE = sig
@@ -79,8 +64,9 @@ end
 module type PRECHECK = sig
   type key
   type param
+  type notified_value
   type value
-  val precheck: key -> param -> value -> bool
+  val precheck: key -> param -> notified_value -> value option
 end
 
 module Make_table
@@ -91,13 +77,13 @@ module Make_table
     (Precheck : PRECHECK with type key := Hash.t
                           and type value := Disk_table.value) : sig
 
-  include PARAMETRIZED_DISTRIBUTED_DB with type key = Hash.t
+  include DISTRIBUTED_DB with type key = Hash.t
                           and type value = Disk_table.value
                           and type param = Precheck.param
   val create:
     ?global_input:(key * value) Watcher.input ->
     Scheduler.t -> Disk_table.store -> t
-  val notify: t -> P2p.Peer_id.t -> key -> value -> unit Lwt.t
+  val notify: t -> P2p.Peer_id.t -> key -> Precheck.notified_value -> unit Lwt.t
 
 end = struct
 
@@ -123,7 +109,7 @@ end = struct
     | Pending _ -> Lwt.return_false
     | Found _ -> Lwt.return_true
 
-  let read s k =
+  let read_opt s k =
     match Memory_table.find s.memory k with
     | exception Not_found -> Disk_table.read_opt s.disk k
     | Found v -> Lwt.return (Some v)
@@ -135,6 +121,16 @@ end = struct
     | Found v -> Lwt.return v
     | Pending _ -> Lwt.fail Not_found
 
+  type error += Missing_data of key
+
+  let read s k =
+    match Memory_table.find s.memory k with
+    | exception Not_found ->
+        trace (Missing_data k) @@
+        Disk_table.read s.disk k
+    | Found v -> return v
+    | Pending _ -> fail (Missing_data k)
+
   let fetch s ?peer k param =
     match Memory_table.find s.memory k with
     | exception Not_found -> begin
@@ -162,11 +158,12 @@ end = struct
             Scheduler.notify_unrequested s.scheduler p k ;
             Lwt.return_unit
       end
-    | Pending (w, param) ->
+    | Pending (w, param) -> begin
-        if not (Precheck.precheck k param v) then begin
+        match Precheck.precheck k param v with
+        | None ->
             Scheduler.notify_invalid s.scheduler p k ;
             Lwt.return_unit
-        end else begin
+        | Some v ->
             Scheduler.notify s.scheduler p k ;
             Memory_table.replace s.memory k (Found v) ;
             Lwt.wakeup w v ;
@@ -193,12 +190,11 @@ end = struct
     | Found _ ->
         Lwt.return_false
 
-  let commit s k =
+  let remove s k =
     match Memory_table.find s.memory k with
     | exception Not_found -> Lwt.return_unit
     | Pending _ -> assert false
-    | Found v ->
+    | Found _ ->
-        Disk_table.store s.disk k v >>= fun _ ->
         Memory_table.remove s.memory k ;
         Lwt.return_unit
 

src/node/shell/distributed_db_functors.mli

@@ -7,7 +7,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-module type PARAMETRIZED_RO_DISTRIBUTED_DB = sig
+module type DISTRIBUTED_DB = sig
 
   type t
   type key
@@ -15,36 +15,22 @@ module type PARAMETRIZED_RO_DISTRIBUTED_DB = sig
   type param
 
   val known: t -> key -> bool Lwt.t
-  val read: t -> key -> value option Lwt.t
+
+  type error += Missing_data of key
+  val read: t -> key -> value tzresult Lwt.t
+  val read_opt: t -> key -> value option Lwt.t
   val read_exn: t -> key -> value Lwt.t
 
   val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> unit
   val fetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> value Lwt.t
 
-end
+  val remove: t -> key -> unit Lwt.t
-
-module type PARAMETRIZED_DISTRIBUTED_DB = sig
-
-  include PARAMETRIZED_RO_DISTRIBUTED_DB
-
-  val commit: t -> key -> unit Lwt.t
-  (* val commit_invalid: t -> key -> unit Lwt.t *) (* TODO *)
   val inject: t -> key -> value -> bool Lwt.t
   val watch: t -> (key * value) Lwt_stream.t * Watcher.stopper
 
 end
 
-module type DISTRIBUTED_DB = sig
-
-  include PARAMETRIZED_DISTRIBUTED_DB with type param := unit
-
-  val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> unit
-  val fetch: t -> ?peer:P2p.Peer_id.t -> key -> value Lwt.t
-
-end
-
 module type DISK_TABLE = sig
-  (* A subtype of State.DATA_STORE *)
   type store
   type key
   type value
@@ -52,8 +38,6 @@ module type DISK_TABLE = sig
   val read: store -> key -> value tzresult Lwt.t
   val read_opt: store -> key -> value option Lwt.t
   val read_exn: store -> key -> value Lwt.t
-  val store: store -> key -> value -> bool Lwt.t
-  val remove: store -> key -> bool Lwt.t
 end
 
 module type MEMORY_TABLE = sig
@@ -81,8 +65,9 @@ end
 module type PRECHECK = sig
   type key
   type param
+  type notified_value
   type value
-  val precheck: key -> param -> value -> bool
+  val precheck: key -> param -> notified_value -> value option
 end
 
 module Make_table
@@ -93,13 +78,13 @@ module Make_table
     (Precheck : PRECHECK with type key := Hash.t
                           and type value := Disk_table.value) : sig
 
-  include PARAMETRIZED_DISTRIBUTED_DB with type key = Hash.t
+  include DISTRIBUTED_DB with type key = Hash.t
                           and type value = Disk_table.value
-                                       and type param := Precheck.param
+                          and type param = Precheck.param
   val create:
     ?global_input:(key * value) Watcher.input ->
     Scheduler.t -> Disk_table.store -> t
-  val notify: t -> P2p.Peer_id.t -> key -> value -> unit Lwt.t
+  val notify: t -> P2p.Peer_id.t -> key -> Precheck.notified_value -> unit Lwt.t
 
 end
 

src/node/shell/distributed_db_message.ml

@@ -25,10 +25,16 @@ type t =
   | Get_protocols of Protocol_hash.t list
   | Protocol of Protocol.t
 
-  | Get_operation_list of Net_id.t * (Block_hash.t * int) list
+  | Get_operation_hashes_for_blocks of Net_id.t * (Block_hash.t * int) list
-  | Operation_list of Net_id.t * Block_hash.t * int *
+  | Operation_hashes_for_block of
+      Net_id.t * Block_hash.t * int *
       Operation_hash.t list * Operation_list_list_hash.path
 
+  | Get_operations_for_blocks of Net_id.t * (Block_hash.t * int) list
+  | Operations_for_block of
+      Net_id.t * Block_hash.t * int *
+      Operation.t list * Operation_list_list_hash.path
+
 let encoding =
   let open Data_encoding in
   let case ?max_length ~tag encoding unwrap wrap =
@@ -123,22 +129,44 @@ let encoding =
     case ~tag:0x50
       (obj2
          (req "net_id" Net_id.encoding)
-         (req "get_operation_list" (list (tup2 Block_hash.encoding int8))))
+         (req "get_operation_hashes_for_blocks"
+            (list (tup2 Block_hash.encoding int8))))
       (function
-        | Get_operation_list (net_id, keys) -> Some (net_id, keys)
+        | Get_operation_hashes_for_blocks (net_id, keys) -> Some (net_id, keys)
         | _ -> None)
-      (fun (net_id, keys) -> Get_operation_list (net_id, keys));
+      (fun (net_id, keys) -> Get_operation_hashes_for_blocks (net_id, keys));
 
     case ~tag:0x51
       (obj4
          (req "net_id" Net_id.encoding)
-         (req "operation_list" (tup2 Block_hash.encoding int8))
+         (req "operation_hashes_for_block" (tup2 Block_hash.encoding int8))
-         (req "operations" (list Operation_hash.encoding))
+         (req "operation_hashes" (list Operation_hash.encoding))
-         (req "operation_list_path" Operation_list_list_hash.path_encoding))
+         (req "operation_hashes_path" Operation_list_list_hash.path_encoding))
-      (function Operation_list (net_id, block, ofs, ops, path) ->
+      (function Operation_hashes_for_block (net_id, block, ofs, ops, path) ->
          Some (net_id, (block, ofs), ops, path) | _ -> None)
       (fun (net_id, (block, ofs), ops, path) ->
-         Operation_list (net_id, block, ofs, ops, path)) ;
+         Operation_hashes_for_block (net_id, block, ofs, ops, path)) ;
+
+    case ~tag:0x60
+      (obj2
+         (req "net_id" Net_id.encoding)
+         (req "get_operations_for_blocks"
+            (list (tup2 Block_hash.encoding int8))))
+      (function
+        | Get_operations_for_blocks (net_id, keys) -> Some (net_id, keys)
+        | _ -> None)
+      (fun (net_id, keys) -> Get_operations_for_blocks (net_id, keys));
+
+    case ~tag:0x61
+      (obj4
+         (req "net_id" Net_id.encoding)
+         (req "operations_for_block" (tup2 Block_hash.encoding int8))
+         (req "operations" (list (dynamic_size Operation.encoding)))
+         (req "operations_path" Operation_list_list_hash.path_encoding))
+      (function Operations_for_block (net_id, block, ofs, ops, path) ->
+         Some (net_id, (block, ofs), ops, path) | _ -> None)
+      (fun (net_id, (block, ofs), ops, path) ->
+         Operations_for_block (net_id, block, ofs, ops, path)) ;
 
   ]
 
@@ -146,7 +174,7 @@ let versions =
   let open P2p.Version in
   [ { name = "TEZOS" ;
       major = 0 ;
-      minor = 5 ;
+      minor = 6 ;
     }
   ]
 

src/node/shell/distributed_db_message.mli

@@ -25,10 +25,16 @@ type t =
   | Get_protocols of Protocol_hash.t list
   | Protocol of Protocol.t
 
-  | Get_operation_list of Net_id.t * (Block_hash.t * int) list
+  | Get_operation_hashes_for_blocks of Net_id.t * (Block_hash.t * int) list
-  | Operation_list of Net_id.t * Block_hash.t * int *
+  | Operation_hashes_for_block of
+      Net_id.t * Block_hash.t * int *
       Operation_hash.t list * Operation_list_list_hash.path
 
+  | Get_operations_for_blocks of Net_id.t * (Block_hash.t * int) list
+  | Operations_for_block of
+      Net_id.t * Block_hash.t * int *
+      Operation.t list * Operation_list_list_hash.path
+
 val cfg : t P2p.message_config
 
 val pp_json : Format.formatter -> t -> unit

src/node/shell/node.ml

@@ -33,12 +33,12 @@ let inject_protocol state ?force:_ proto =
           "Compilation failed (%a)"
           Protocol_hash.pp_short hash
     | true ->
-        State.Protocol.store state hash proto >>= function
+        State.Protocol.store state proto >>= function
-        | false ->
+        | None ->
             failwith
               "Previously registred protocol (%a)"
               Protocol_hash.pp_short hash
-        | true -> return ()
+        | Some _ -> return ()
   in
   Lwt.return (hash, validation)
 
@@ -52,12 +52,12 @@ type t = {
   state: State.t ;
   distributed_db: Distributed_db.t ;
   validator: Validator.worker ;
-  mainnet_db: Distributed_db.net ;
+  mainnet_db: Distributed_db.net_db ;
   mainnet_net: State.Net.t ;
   mainnet_validator: Validator.t ;
   inject_block:
     ?force:bool ->
-    MBytes.t -> Operation_hash.t list list ->
+    MBytes.t -> Distributed_db.operation list list ->
     (Block_hash.t * unit tzresult Lwt.t) tzresult Lwt.t ;
   inject_operation:
     ?force:bool -> MBytes.t ->
@@ -151,21 +151,26 @@ module RPC = struct
     test_network: Context.test_network;
  }
 
-  let convert (block: State.Valid_block.t) =
+  let convert (block: State.Block.t) =
-    Lazy.force block.operation_hashes >>= fun operations ->
+    let hash = State.Block.hash block in
+    let header = State.Block.header block in
+    State.Block.all_operation_hashes block >>= fun operations ->
+    State.Block.context block >>= fun context ->
+    Context.get_protocol context >>= fun protocol ->
+    Context.get_test_network context >>= fun test_network ->
     Lwt.return {
-      hash = block.hash ;
+      hash ;
-      net_id = block.net_id ;
+      net_id = header.shell.net_id ;
-      level = block.level ;
+      level = header.shell.level ;
-      proto_level = block.proto_level ;
+      proto_level = header.shell.proto_level ;
-      predecessor = block.predecessor ;
+      predecessor = header.shell.predecessor ;
-      timestamp = block.timestamp ;
+      timestamp = header.shell.timestamp ;
-      operations_hash = block.operations_hash ;
+      operations_hash = header.shell.operations_hash ;
-      fitness = block.fitness ;
+      fitness = header.shell.fitness ;
-      data = block.proto_header ;
+      data = header.proto ;
       operations = Some operations ;
-      protocol = block.protocol_hash ;
+      protocol ;
-      test_network = block.test_network ;
+      test_network ;
     }
 
   let inject_block node = node.inject_block
@@ -173,10 +178,8 @@ module RPC = struct
   let inject_protocol node = node.inject_protocol
 
   let raw_block_info node hash =
-    Distributed_db.read_block node.distributed_db hash >>= function
+    State.read_block node.state hash >>= function
-    | Some (net_db, _block) ->
+    | Some block ->
-        let net = Distributed_db.state net_db in
-        State.Valid_block.read_exn net hash >>= fun block ->
         convert block
     | None ->
         Lwt.fail Not_found
@@ -201,89 +204,74 @@ module RPC = struct
         | Some (v, _) -> v
 
   let get_validator_per_hash node hash =
-    Distributed_db.read_block_exn
+    State.read_block_exn node.state hash >>= fun block ->
-      node.distributed_db hash >>= fun (_net_db, block) ->
+    let header = State.Block.header block in
     if Net_id.equal
         (State.Net.id node.mainnet_net)
-        block.shell.net_id then
+        header.shell.net_id then
       Lwt.return (Some (node.mainnet_validator, node.mainnet_db))
     else
       match Validator.test_validator node.mainnet_validator with
       | Some (test_validator, net_db)
         when Net_id.equal
             (State.Net.id (Validator.net_state test_validator))
-            block.shell.net_id ->
+            header.shell.net_id ->
           Lwt.return (Some (node.mainnet_validator, net_db))
       | _ -> Lwt.return_none
 
   let read_valid_block node h =
-    Distributed_db.read_block node.distributed_db h >>= function
+    State.read_block node.state h
-    | None -> Lwt.return_none
-    | Some (_net_db, block) ->
-        State.Net.get node.state block.shell.net_id >>= function
-        | Error _ -> Lwt.return_none
-        | Ok net ->
-            State.Valid_block.read_exn net h >>= fun block ->
-            Lwt.return (Some block)
 
   let read_valid_block_exn node h =
-    Distributed_db.read_block_exn
+    State.read_block_exn node.state h
-      node.distributed_db h >>= fun (net_db, _block) ->
-    let net = Distributed_db.state net_db in
-    State.Valid_block.read_exn net h >>= fun block ->
-    Lwt.return block
 
-  let get_pred net_db n (v: State.Valid_block.t) =
+  let rec predecessor net_db n v =
-    let rec loop net_db n h =
-      if n <= 0 then
-        Lwt.return h
-      else
-        Distributed_db.Block_header.read net_db h >>= function
-        | None -> Lwt.fail Not_found
-        | Some { shell = { predecessor } } ->
-            loop net_db (n-1) predecessor in
     if n <= 0 then
       Lwt.return v
     else
-      loop net_db n v.hash >>= fun hash ->
+      State.Block.predecessor v >>= function
-      let net_state = Distributed_db.state net_db in
+      | None -> Lwt.fail Not_found
-      State.Valid_block.read_exn net_state hash
+      | Some v -> predecessor net_db (n-1) v
 
   let block_info node (block: block) =
     match block with
     | `Genesis ->
-        State.Valid_block.Current.genesis node.mainnet_net >>= convert
+        Chain.genesis node.mainnet_net >>= convert
     | ( `Head n | `Test_head n ) as block ->
         let validator = get_validator node block in
         let net_db = Validator.net_db validator in
         let net_state = Validator.net_state validator in
-        State.Valid_block.Current.head net_state >>= fun head ->
+        Chain.head net_state >>= fun head ->
-        get_pred net_db n head >>= convert
+        predecessor net_db n head >>= convert
     | `Hash h ->
         read_valid_block_exn node h >>= convert
     | ( `Prevalidation | `Test_prevalidation ) as block ->
         let validator = get_validator node block in
         let pv = Validator.prevalidator validator in
         let net_state = Validator.net_state validator in
-        State.Valid_block.Current.head net_state >>= fun head ->
+        Chain.head net_state >>= fun head ->
+        let head_header = State.Block.header head in
+        let head_hash = State.Block.hash head in
+        State.Block.context head >>= fun head_context ->
+        Context.get_protocol head_context >>= fun head_protocol ->
         Prevalidator.context pv >>= function
         | Error _ -> Lwt.fail Not_found
         | Ok { context ; fitness } ->
             Context.get_protocol context >>= fun protocol ->
             Context.get_test_network context >>= fun test_network ->
             let proto_level =
-              if Protocol_hash.equal protocol head.protocol_hash then
+              if Protocol_hash.equal protocol head_protocol then
-                head.proto_level
+                head_header.shell.proto_level
               else
-                ((head.proto_level + 1) mod 256) in
+                ((head_header.shell.proto_level + 1) mod 256) in
             let operations =
               let pv_result, _ = Prevalidator.operations pv in
               [ pv_result.applied ] in
             Lwt.return
               { hash = prevalidation_hash ;
-                level = Int32.succ head.level ;
+                level = Int32.succ head_header.shell.level ;
                 proto_level ;
-                predecessor = head.hash ;
+                predecessor = head_hash ;
                 fitness ;
                 timestamp = Prevalidator.timestamp pv ;
                 protocol ;
@@ -292,60 +280,61 @@ module RPC = struct
                     (List.map Operation_list_hash.compute operations) ;
                 operations = Some operations ;
                 data = MBytes.of_string "" ;
-                net_id = head.net_id ;
+                net_id = head_header.shell.net_id ;
                 test_network ;
               }
 
-  let rpc_context (block : State.Valid_block.t) : Updater.rpc_context =
+  let rpc_context block : Updater.rpc_context Lwt.t =
-    { block_hash = block.hash ;
+    let block_hash = State.Block.hash block in
-      block_header = {
+    let block_header = State.Block.header block in
-        shell = {
+    State.Block.context block >|= fun context ->
-          net_id = block.net_id ;
+    { Updater.block_hash ;
-          level = block.level ;
+      block_header ;
-          proto_level = block.proto_level ;
+      operation_hashes = (fun () -> State.Block.all_operation_hashes block) ;
-          predecessor = block.predecessor ;
+      operations = (fun () -> State.Block.all_operations block) ;
-          timestamp = block.timestamp ;
+      context ;
-          operations_hash = block.operations_hash ;
-          fitness = block.fitness ;
-        } ;
-        proto = block.proto_header ;
-      } ;
-      operation_hashes = (fun () -> Lazy.force block.operation_hashes) ;
-      operations = (fun () -> Lazy.force block.operations) ;
-      context = block.context ;
     }
 
   let get_rpc_context node block =
     match block with
     | `Genesis ->
-        State.Valid_block.Current.genesis node.mainnet_net >>= fun block ->
+        Chain.genesis node.mainnet_net >>= fun block ->
-        Lwt.return (Some (rpc_context block))
+        rpc_context block >>= fun ctxt ->
+        Lwt.return (Some ctxt)
     | ( `Head n | `Test_head n ) as block ->
         let validator = get_validator node block in
         let net_state = Validator.net_state validator in
         let net_db = Validator.net_db validator in
-        State.Valid_block.Current.head net_state >>= fun head ->
+        Chain.head net_state >>= fun head ->
-        get_pred net_db n head >>= fun block ->
+        predecessor net_db n head >>= fun block ->
-        Lwt.return (Some (rpc_context block))
+        rpc_context block >>= fun ctxt ->
+        Lwt.return (Some ctxt)
     | `Hash hash-> begin
-        read_valid_block node hash >|= function
+        read_valid_block node hash >>= function
-        | None -> None
+        | None ->
-        | Some block -> Some (rpc_context block)
+            Lwt.return_none
+        | Some block ->
+            rpc_context block >>= fun ctxt ->
+            Lwt.return (Some ctxt)
       end
     | ( `Prevalidation | `Test_prevalidation ) as block ->
         let validator, net_db = get_net node block in
         let pv = Validator.prevalidator validator in
         let net_state = Validator.net_state validator in
-        State.Valid_block.Current.head net_state >>= fun head ->
+        Chain.head net_state >>= fun head ->
+        let head_header = State.Block.header head in
+        let head_hash = State.Block.hash head in
+        State.Block.context head >>= fun head_context ->
+        Context.get_protocol head_context >>= fun head_protocol ->
         Prevalidator.context pv >>= function
         | Error _ -> Lwt.fail Not_found
         | Ok { context ; fitness } ->
             Context.get_protocol context >>= fun protocol ->
             let proto_level =
-              if Protocol_hash.equal protocol head.protocol_hash then
+              if Protocol_hash.equal protocol head_protocol then
-                head.proto_level
+                head_header.shell.proto_level
               else
-                ((head.proto_level + 1) mod 256) in
+                ((head_header.shell.proto_level + 1) mod 256) in
             let operation_hashes =
               let pv_result, _ = Prevalidator.operations pv in
               [ pv_result.applied ] in
@@ -356,10 +345,10 @@ module RPC = struct
                 Updater.block_hash = prevalidation_hash ;
                 block_header = {
                   shell = {
-                    net_id = head.net_id ;
+                    net_id = head_header.shell.net_id ;
-                    level = Int32.succ head.level ;
+                    level = Int32.succ head_header.shell.level ;
                     proto_level ;
-                    predecessor = head.hash ;
+                    predecessor = head_hash ;
                     timestamp = Prevalidator.timestamp pv ;
                     operations_hash ;
                     fitness ;
@@ -376,18 +365,16 @@ module RPC = struct
                 context ;
               })
 
-  let operations node block =
+  let operation_hashes node block =
     match block with
-    | `Genesis ->
+    | `Genesis -> Lwt.return []
-        State.Valid_block.Current.genesis node.mainnet_net >>= fun { operation_hashes } ->
-        Lazy.force operation_hashes
     | ( `Head n | `Test_head n ) as block ->
         let validator = get_validator node block in
         let net_state = Validator.net_state validator in
         let net_db = Validator.net_db validator in
-        State.Valid_block.Current.head net_state >>= fun head ->
+        Chain.head net_state >>= fun head ->
-        get_pred net_db n head >>= fun { operation_hashes } ->
+        predecessor net_db n head >>= fun block ->
-        Lazy.force operation_hashes
+        State.Block.all_operation_hashes block
     | (`Prevalidation | `Test_prevalidation) as block ->
         let validator, _net = get_net node block in
         let pv = Validator.prevalidator validator in
@@ -396,12 +383,31 @@ module RPC = struct
     | `Hash hash ->
         read_valid_block node hash >>= function
         | None -> Lwt.return_nil
-        | Some { operation_hashes } ->
+        | Some block ->
-            Lazy.force operation_hashes
+            State.Block.all_operation_hashes block
 
-  let operation_content node hash =
+  let operations node block =
-    Distributed_db.read_operation node.distributed_db hash >>= fun op ->
+    match block with
-    Lwt.return (map_option ~f:snd op)
+    | `Genesis -> Lwt.return []
+    | ( `Head n | `Test_head n ) as block ->
+        let validator = get_validator node block in
+        let net_state = Validator.net_state validator in
+        let net_db = Validator.net_db validator in
+        Chain.head net_state >>= fun head ->
+        predecessor net_db n head >>= fun block ->
+        State.Block.all_operations block
+    | (`Prevalidation | `Test_prevalidation) as block ->
+        let validator, net_db = get_net node block in
+        let pv = Validator.prevalidator validator in
+        let { Prevalidation.applied }, _ = Prevalidator.operations pv in
+        Lwt_list.map_p
+          (Distributed_db.Operation.read_exn net_db) applied >>= fun applied ->
+        Lwt.return [applied]
+    | `Hash hash ->
+        read_valid_block node hash >>= function
+        | None -> Lwt.return_nil
+        | Some block ->
+            State.Block.all_operations block
 
   let pending_operations node (block: block) =
     match block with
@@ -415,13 +421,13 @@ module RPC = struct
         let prevalidator = Validator.prevalidator validator in
         let net_state = Validator.net_state validator in
         let net_db = Validator.net_db validator in
-        State.Valid_block.Current.head net_state >>= fun head ->
+        Chain.head net_state >>= fun head ->
-        get_pred net_db n head >>= fun b ->
+        predecessor net_db n head >>= fun b ->
         Prevalidator.pending ~block:b prevalidator >|= fun ops ->
         Prevalidation.empty_result, ops
     | `Genesis ->
         let net = node.mainnet_net in
-        State.Valid_block.Current.genesis net >>= fun b ->
+        Chain.genesis net >>= fun b ->
         let validator = get_validator node `Genesis in
         let prevalidator = Validator.prevalidator validator in
         Prevalidator.pending ~block:b prevalidator >|= fun ops ->
@@ -433,7 +439,7 @@ module RPC = struct
         | 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 ->
+            State.Block.read_exn net_state h >>= fun block ->
             Prevalidator.pending ~block prevalidator >|= fun ops ->
             Prevalidation.empty_result, ops
       end
@@ -450,18 +456,18 @@ module RPC = struct
       match block with
       | `Genesis ->
           let net = node.mainnet_net in
-          State.Valid_block.Current.genesis net >>= return
+          Chain.genesis net >>= return
       | ( `Head 0 | `Prevalidation
         | `Test_head 0 | `Test_prevalidation ) as block ->
           let validator = get_validator node block in
           let net_state = Validator.net_state validator in
-          State.Valid_block.Current.head net_state >>= return
+          Chain.head net_state >>= return
       | `Head n | `Test_head n as block -> begin
           let validator = get_validator node block in
           let net_state = Validator.net_state validator in
           let net_db = Validator.net_db validator in
-          State.Valid_block.Current.head net_state >>= fun head ->
+          Chain.head net_state >>= fun head ->
-          get_pred net_db n head >>= return
+          predecessor net_db n head >>= return
         end
       | `Hash hash ->
           read_valid_block node hash >>= function
@@ -469,12 +475,7 @@ module RPC = struct
           | Some data -> return data
     end >>=? fun predecessor ->
     let net_db = Validator.net_db node.mainnet_validator in
-    map_p
+    map_p (Distributed_db.resolve_operation net_db) ops >>=? fun rops ->
-      (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
@@ -506,62 +507,57 @@ module RPC = struct
         Lwt.return (Some (RPC.map (fun _ -> ()) dir))
 
   let heads node =
-    State.Valid_block.known_heads node.mainnet_net >>= fun heads ->
+    Chain.known_heads node.mainnet_net >>= fun heads ->
     begin
       match Validator.test_validator node.mainnet_validator with
       | None -> Lwt.return_nil
       | Some (_, net_db) ->
-          State.Valid_block.known_heads (Distributed_db.state net_db)
+          Chain.known_heads (Distributed_db.state net_db)
     end >>= fun test_heads ->
     Lwt_list.fold_left_s
       (fun map block ->
          convert block >|= fun bi ->
          Block_hash.Map.add
-           block.State.Valid_block.hash bi map)
+           (State.Block.hash block) bi map)
       Block_hash.Map.empty (test_heads @ heads)
 
   let predecessors node len head =
-    let rec loop net_db acc len hash (block: Block_header.t) =
+    let rec loop acc len block =
-      if Block_hash.equal block.shell.predecessor hash then
-        Lwt.return (List.rev acc)
-      else begin
       if len = 0 then
         Lwt.return (List.rev acc)
       else
-          let hash = block.shell.predecessor in
+        State.Block.predecessor block >>= function
-          Distributed_db.Block_header.read_exn net_db hash >>= fun block ->
+        | None -> Lwt.return (List.rev acc)
-          loop net_db (hash :: acc) (len-1) hash block
+        | Some block ->
-      end in
+            loop (State.Block.hash block :: acc) (len-1) block
+    in
     try
-      Distributed_db.read_block_exn
+      State.read_block_exn node.state head >>= fun block ->
-        node.distributed_db head >>= fun (net_db, block) ->
+      loop [] len block
-      loop net_db [] len head block
     with Not_found -> Lwt.return_nil
 
-  let predecessors_bi state ignored len head =
+  let predecessors_bi ignored len head =
     try
-      let rec loop acc len hash =
+      let rec loop acc len block =
-        State.Valid_block.read_exn state hash >>= fun block ->
         convert block >>= fun bi ->
-        if Block_hash.equal bi.predecessor hash then
+        State.Block.predecessor block >>= function
+        | None ->
             Lwt.return (List.rev (bi :: acc))
-        else begin
+        | Some pred ->
-          if len = 0
+            if len = 0 ||
-             || Block_hash.Set.mem hash ignored then
+               Block_hash.Set.mem (State.Block.hash block) ignored then
               Lwt.return (List.rev acc)
             else
-          loop (bi :: acc) (len-1) bi.predecessor
+              loop (bi :: acc) (len-1) pred
-        end in
+      in
       loop [] len head
     with Not_found -> Lwt.return_nil
 
   let list node len heads =
     Lwt_list.fold_left_s
       (fun (ignored, acc) head ->
-         Distributed_db.read_block_exn
+         State.read_block_exn node.state head >>= fun block ->
-           node.distributed_db head >>= fun (net_db, _block) ->
+         predecessors_bi ignored len block >>= fun predecessors ->
-         let net_state = Distributed_db.state net_db in
-         predecessors_bi net_state ignored len head >>= fun predecessors ->
          let ignored =
            List.fold_right
              (fun x s -> Block_hash.Set.add x.hash s)
@@ -572,9 +568,10 @@ module RPC = struct
       heads >>= fun (_, blocks) ->
     Lwt.return (List.rev blocks)
 
-  let block_watcher node = Distributed_db.watch_block node.distributed_db
+  let block_header_watcher node =
+    Distributed_db.watch_block_header node.distributed_db
 
-  let valid_block_watcher node =
+  let block_watcher node =
     let stream, shutdown = Validator.global_watcher node.validator in
     Lwt_stream.map_s (fun block -> convert block) stream,
     shutdown
@@ -597,12 +594,15 @@ module RPC = struct
     let rec next () =
       if !first_run then begin
         first_run := false ;
-        State.Valid_block.Current.head node.mainnet_net >>= fun head ->
+        Chain.head node.mainnet_net >>= fun head ->
-        Lwt.return (Some (head.hash, head.timestamp))
+        let head_hash = State.Block.hash head in
+        let head_header = State.Block.header head in
+        Lwt.return (Some (head_hash, head_header.shell.timestamp))
       end else begin
         Lwt.pick [
           ( Lwt_stream.get block_stream >|=
-            map_option ~f:(fun b -> (b.State.Valid_block.hash, b.timestamp)) ) ;
+            map_option ~f:(fun b ->
+                (State.Block.hash b, (State.Block.header b).shell.timestamp)) ) ;
           (Validator.bootstrapped node.mainnet_validator >|= fun () -> None) ;
         ]
       end in

src/node/shell/node.mli

@@ -27,7 +27,7 @@ module RPC : sig
 
   val inject_block:
     t -> ?force:bool ->
-    MBytes.t -> Operation_hash.t list list ->
+    MBytes.t -> Distributed_db.operation list list ->
     (Block_hash.t * unit tzresult Lwt.t) tzresult Lwt.t
   (** [inject_block node ?force bytes] tries to insert [bytes]
       (supposedly the serialization of a block header) inside
@@ -43,9 +43,9 @@ module RPC : sig
 
   val raw_block_info:
     t -> Block_hash.t -> block_info Lwt.t
-  val block_watcher:
+  val block_header_watcher:
     t -> (Block_hash.t * Block_header.t) Lwt_stream.t * Watcher.stopper
-  val valid_block_watcher:
+  val block_watcher:
     t -> (block_info Lwt_stream.t * Watcher.stopper)
   val heads: t -> block_info Block_hash.Map.t Lwt.t
 
@@ -58,10 +58,10 @@ module RPC : sig
   val block_info:
     t -> block -> block_info Lwt.t
 
-  val operations:
+  val operation_hashes:
     t -> block -> Operation_hash.t list list Lwt.t
-  val operation_content:
+  val operations:
-    t -> Operation_hash.t -> Operation.t option Lwt.t
+    t -> block -> Operation.t list list Lwt.t
   val operation_watcher:
     t -> (Operation_hash.t * Operation.t) Lwt_stream.t * Watcher.stopper
 
@@ -81,7 +81,7 @@ module RPC : sig
   val preapply:
     t -> block ->
     timestamp:Time.t -> sort:bool ->
-    Operation_hash.t list ->
+    Distributed_db.operation list ->
     (Fitness.t * 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.ml

@@ -16,6 +16,29 @@ let filter_bi operations (bi: Services.Blocks.block_info)  =
   let bi = if operations then bi else { bi with operations = None } in
   bi
 
+let monitor_operations node contents =
+  let stream, stopper = Node.RPC.operation_watcher node in
+  let shutdown () = Watcher.shutdown stopper in
+  let first_request = ref true in
+  let next () =
+    if not !first_request then
+      Lwt_stream.get stream >>= function
+      | None -> Lwt.return_none
+      | Some (h, op) when contents -> Lwt.return (Some [[h, Some op]])
+      | Some (h, _) -> Lwt.return (Some [[h, None]])
+      else begin
+        first_request := false ;
+        Node.RPC.operation_hashes node `Prevalidation >>= fun hashes ->
+        if contents then
+          Node.RPC.operations node `Prevalidation >>= fun ops ->
+          Lwt.return_some @@
+          List.map2 (List.map2 (fun h op -> h, Some op)) hashes ops
+        else
+          Lwt.return_some @@
+          List.map (List.map (fun h -> h, None)) hashes
+      end in
+  RPC.Answer.return_stream { next ; shutdown }
+
 let register_bi_dir node dir =
   let dir =
     let implementation b include_ops =
@@ -80,9 +103,20 @@ let register_bi_dir node dir =
     RPC.register1 dir
       Services.Blocks.test_network implementation in
   let dir =
-    let implementation b () =
+    let implementation b { Node_rpc_services.Blocks.contents ; monitor } =
-      Node.RPC.operations node b >>=
+      match b with
-      RPC.Answer.return in
+      | `Prevalidation when monitor ->
+          monitor_operations node contents
+      | _ ->
+          Node.RPC.operation_hashes node b >>= fun hashes ->
+          if contents then
+            Node.RPC.operations node b >>= fun ops ->
+            RPC.Answer.return @@
+            List.map2 (List.map2 (fun h op -> h, Some op)) hashes ops
+          else
+            RPC.Answer.return @@
+            List.map (List.map (fun h -> h, None)) hashes
+    in
     RPC.register1 dir
       Services.Blocks.operations implementation in
   let dir =
@@ -275,7 +309,7 @@ let list_blocks
         requested_blocks in
     RPC.Answer.return infos
   else begin
-    let (bi_stream, stopper) = Node.RPC.valid_block_watcher node in
+    let (bi_stream, stopper) = Node.RPC.block_watcher node in
     let stream =
       match delay with
       | None ->
@@ -298,47 +332,6 @@ let list_blocks
     RPC.Answer.return_stream { next ; shutdown }
   end
 
-let list_operations node {Services.Operations.monitor; contents} =
-  let monitor = match monitor with None -> false | Some x -> x in
-  let include_ops = match contents with None -> false | Some x -> x in
-  Node.RPC.operations node `Prevalidation >>= fun operationss ->
-  let fetch_operations_content operations =
-    if include_ops then
-      Lwt_list.map_s
-        (fun h ->
-           Node.RPC.operation_content node h >>= fun content ->
-           Lwt.return (h, content))
-        operations
-    else
-      Lwt.return @@ ListLabels.map operations ~f:(fun h -> h, None) in
-  Lwt_list.map_p fetch_operations_content operationss >>= fun operations ->
-  if not monitor then
-    RPC.Answer.return operations
-  else
-    let stream, stopper = Node.RPC.operation_watcher node in
-    let shutdown () = Watcher.shutdown stopper in
-    let first_request = ref true in
-    let next () =
-      if not !first_request then
-        Lwt_stream.get stream >>= function
-        | None -> Lwt.return_none
-        | Some (h, op) when include_ops -> Lwt.return (Some [[h, Some op]])
-        | Some (h, _) -> Lwt.return (Some [[h, None]])
-      else begin
-        first_request := false ;
-        Lwt.return (Some operations)
-      end in
-    RPC.Answer.return_stream { next ; shutdown }
-
-let get_operations node hashes () =
-  Lwt_list.map_p
-    (fun h ->
-       Node.RPC.operation_content node h >>= function
-       | None -> Lwt.fail Not_found
-       | Some h -> Lwt.return h)
-    hashes >>= fun ops ->
-  RPC.Answer.return ops
-
 let list_protocols node {Services.Protocols.monitor; contents} =
   let monitor = match monitor with None -> false | Some x -> x in
   let include_contents = match contents with None -> false | Some x -> x in
@@ -391,10 +384,6 @@ let build_rpc_directory node =
       ~descr:
         "All the RPCs which are specific to the protocol version."
       dir Services.Blocks.proto_path implementation in
-  let dir =
-    RPC.register0 dir Services.Operations.list (list_operations node) in
-  let dir =
-    RPC.register1 dir Services.Operations.contents (get_operations node) in
   let dir =
     RPC.register0 dir Services.Protocols.list (list_protocols node) in
   let dir =

src/node/shell/node_rpc_services.ml

@@ -46,6 +46,21 @@ module Error = struct
 
 end
 
+type operation = Distributed_db.operation =
+  | Blob of Operation.t
+  | Hash of Operation_hash.t
+
+let operation_encoding =
+  let open Data_encoding in
+  union [
+    case Operation.encoding
+      (function Blob op -> Some op | Hash _ -> None)
+      (fun op -> Blob op) ;
+    case Operation_hash.encoding
+      (function Hash oph -> Some oph | Blob _ -> None)
+      (fun oph -> Hash oph) ;
+  ]
+
 module Blocks = struct
 
   type block = [
@@ -75,28 +90,28 @@ module Blocks = struct
       (fun { hash ; net_id ; level ; proto_level ; predecessor ;
              fitness ; timestamp ; protocol ; operations_hash ; data ;
              operations ; test_network } ->
-        ({ Block_header.shell =
+        ((hash, operations, protocol, test_network),
+         { Block_header.shell =
              { net_id ; level ; proto_level ; predecessor ;
                timestamp ; operations_hash ; fitness } ;
-           proto = data },
+           proto = data }))
-         (hash, operations, protocol, test_network)))
+      (fun ((hash, operations, protocol, test_network),
-      (fun ({ Block_header.shell =
+            { Block_header.shell =
                 { net_id ; level ; proto_level ; predecessor ;
                   timestamp ; operations_hash ; fitness } ;
-              proto = data },
+              proto = data }) ->
-            (hash, operations, protocol, test_network)) ->
         { hash ; net_id ; level ; proto_level ; predecessor ;
           fitness ; timestamp ; protocol ; operations_hash ; data ;
           operations ; test_network })
       (dynamic_size
          (merge_objs
-            Block_header.encoding
             (obj4
                (req "hash" Block_hash.encoding)
                (opt "operations" (list (list Operation_hash.encoding)))
                (req "protocol" Protocol_hash.encoding)
                (dft "test_network"
-                  Context.test_network_encoding Context.Not_running))))
+                  Context.test_network_encoding Context.Not_running))
+            Block_header.encoding))
 
   let parse_block s =
     try
@@ -136,7 +151,7 @@ module Blocks = struct
     RPC.Arg.make ~name ~descr ~construct ~destruct ()
 
   type preapply_param = {
-    operations: Operation_hash.t list ;
+    operations: operation list ;
     sort: bool ;
     timestamp: Time.t option ;
   }
@@ -152,7 +167,7 @@ module Blocks = struct
             | Some x -> x in
           { operations ; sort ; timestamp })
        (obj3
-          (req "operations" (list Operation_hash.encoding))
+          (req "operations" (list (dynamic_size operation_encoding)))
           (opt "sort" bool)
           (opt "timestamp" Time.encoding)))
 
@@ -234,11 +249,31 @@ module Blocks = struct
       ~output: (obj1 (req "timestamp" Time.encoding))
       RPC.Path.(block_path / "timestamp")
 
+  type operations_param = {
+    contents: bool ;
+    monitor: bool ;
+  }
+
+  let operations_param_encoding =
+    let open Data_encoding in
+    conv
+      (fun { contents ; monitor } -> (contents, monitor))
+      (fun (contents, monitor) -> { contents ; monitor })
+      (obj2
+         (dft "contents" bool false)
+         (dft "monitor" bool false))
+
   let operations =
     RPC.service
       ~description:"List the block operations."
-      ~input: empty
+      ~input: operations_param_encoding
-      ~output: (obj1 (req "operations" (list (list Operation_hash.encoding))))
+      ~output: (obj1
+                  (req "operations"
+                     (list (list
+                              (obj2
+                                 (req "hash" Operation_hash.encoding)
+                                 (opt "contents"
+                                    (dynamic_size Operation.encoding)))))))
       RPC.Path.(block_path / "operations")
 
   let protocol =
@@ -393,58 +428,6 @@ module Blocks = struct
 
 end
 
-module Operations = struct
-
-  let operations_arg =
-    let name = "operation_id" in
-    let descr =
-      "A operation identifier in hexadecimal." in
-    let construct ops =
-      String.concat "," (List.map Operation_hash.to_b58check ops) in
-    let destruct h =
-      let ops = split ',' h in
-      try Ok (List.map Operation_hash.of_b58check_exn ops)
-      with _ -> Error "Can't parse hash" in
-    RPC.Arg.make ~name ~descr ~construct ~destruct ()
-
-  let contents =
-    RPC.service
-      ~input: empty
-      ~output: (list (dynamic_size Operation.encoding))
-      RPC.Path.(root / "operations" /: operations_arg)
-
-  type list_param = {
-    contents: bool option ;
-    monitor: bool option ;
-  }
-
-  let list_param_encoding =
-    conv
-      (fun {contents; monitor} -> (contents, monitor))
-      (fun (contents, monitor) -> {contents; monitor})
-      (obj2
-         (opt "contents" bool)
-         (opt "monitor" bool))
-
-  let list =
-    RPC.service
-      ~description:
-        "List operations in the mempool."
-      ~input: list_param_encoding
-      ~output:
-        (obj1
-           (req "operations"
-              (list
-                 (list
-                    (obj2
-                       (req "hash" Operation_hash.encoding)
-                       (opt "contents"
-                          (dynamic_size Operation.encoding)))
-              ))))
-      RPC.Path.(root / "operations")
-
-end
-
 module Protocols = struct
 
   let protocols_arg =
@@ -661,7 +644,7 @@ type inject_block_param = {
   raw: MBytes.t ;
   blocking: bool ;
   force: bool ;
-  operations: Operation_hash.t list list ;
+  operations: operation list list ;
 }
 
 let inject_block_param =
@@ -689,7 +672,7 @@ let inject_block_param =
        (req "operations"
           (describe
              ~description:"..."
-             (list (list Operation_hash.encoding)))))
+             (list (list (dynamic_size operation_encoding))))))
 
 let inject_block =
   RPC.service

src/node/shell/node_rpc_services.mli

@@ -13,6 +13,12 @@ module Error : sig
   val wrap: 'a Data_encoding.t -> 'a tzresult Data_encoding.encoding
 end
 
+type operation = Distributed_db.operation =
+  | Blob of Operation.t
+  | Hash of Operation_hash.t
+
+val operation_encoding: operation Data_encoding.t
+
 module Blocks : sig
 
   type block = [
@@ -57,8 +63,15 @@ module Blocks : sig
     (unit, unit * block, unit, Time.t) RPC.service
   val fitness:
     (unit, unit * block, unit, MBytes.t list) RPC.service
+
+  type operations_param = {
+    contents: bool ;
+    monitor: bool ;
+  }
   val operations:
-    (unit, unit * block, unit, Operation_hash.t list list) RPC.service
+    (unit, unit * block, operations_param,
+     (Operation_hash.t * Operation.t option) list list) RPC.service
+
   val protocol:
     (unit, unit * block, unit, Protocol_hash.t) RPC.service
   val test_network:
@@ -80,7 +93,7 @@ module Blocks : sig
     (unit, unit, list_param, block_info list list) RPC.service
 
   type preapply_param = {
-    operations: Operation_hash.t list ;
+    operations: operation list ;
     sort: bool ;
     timestamp: Time.t option ;
   }
@@ -98,25 +111,6 @@ module Blocks : sig
 
 end
 
-module Operations : sig
-
-  val contents:
-    (unit, unit * Operation_hash.t list,
-     unit, Operation.t list) RPC.service
-
-
-  type list_param = {
-    contents: bool option ;
-    monitor: bool option ;
-  }
-
-  val list:
-    (unit, unit,
-     list_param,
-     (Operation_hash.t * Operation.t option) list list) RPC.service
-
-end
-
 module Protocols : sig
 
   val contents:
@@ -135,6 +129,7 @@ module Protocols : sig
 end
 
 module Network : sig
+
   val stat :
     (unit, unit, unit, P2p.Stat.t) RPC.service
 
@@ -175,6 +170,7 @@ module Network : sig
     val events :
       (unit, unit * P2p.Peer_id.t, bool, P2p.RPC.Peer_id.Event.t list) RPC.service
   end
+
 end
 
 val forge_block:
@@ -190,7 +186,7 @@ type inject_block_param = {
   raw: MBytes.t ;
   blocking: bool ;
   force: bool ;
-  operations: Operation_hash.t list list ;
+  operations: operation list list ;
 }
 
 val inject_block:

src/node/shell/prevalidation.ml

@@ -131,16 +131,18 @@ and 'a proto =
     with type validation_state = 'a)
 
 let start_prevalidation
-    ~predecessor:
+    ~predecessor
-    { State.Valid_block.protocol ;
-      hash = predecessor ;
-      context = predecessor_context ;
-      timestamp = predecessor_timestamp ;
-      fitness = predecessor_fitness ;
-      level = predecessor_level }
     ~timestamp =
+  let { Block_header.shell =
+          { fitness = predecessor_fitness ;
+            timestamp = predecessor_timestamp ;
+            level = predecessor_level } } =
+    State.Block.header predecessor in
+  State.Block.context predecessor >>= fun predecessor_context ->
+  Context.get_protocol predecessor_context >>= fun protocol ->
+  let predecessor = State.Block.hash predecessor in
   let (module Proto) =
-    match protocol with
+    match Updater.get protocol with
     | None -> assert false (* FIXME, this should not happen! *)
     | Some protocol -> protocol in
   Context.reset_test_network

src/node/shell/prevalidation.mli

@@ -29,7 +29,7 @@ val preapply_result_encoding :
 type prevalidation_state
 
 val start_prevalidation :
-  predecessor: State.Valid_block.t ->
+  predecessor: State.Block.t ->
   timestamp: Time.t ->
   prevalidation_state tzresult Lwt.t
 

src/node/shell/prevalidator.ml

@@ -9,31 +9,31 @@
 
 open Logging.Node.Prevalidator
 
-let list_pendings net_db ~from_block ~to_block old_mempool =
+let list_pendings ~from_block ~to_block old_mempool =
-  let rec pop_blocks ancestor hash mempool =
+  let rec pop_blocks ancestor block mempool =
+    let hash = State.Block.hash block in
     if Block_hash.equal hash ancestor then
       Lwt.return mempool
     else
-      Distributed_db.Block_header.read_exn net_db hash >>= fun { shell } ->
+      State.Block.all_operation_hashes block >>= fun operations ->
-      Distributed_db.Operation_list.read_all_exn
-        net_db hash >>= fun operations ->
       let mempool =
         List.fold_left
           (List.fold_left (fun mempool h -> Operation_hash.Set.add h mempool))
           mempool operations in
-      pop_blocks ancestor shell.predecessor mempool
+      State.Block.predecessor block >>= function
+      | None -> assert false
+      | Some predecessor -> pop_blocks ancestor predecessor mempool
   in
-  let push_block mempool (hash, _shell) =
+  let push_block mempool block =
-      Distributed_db.Operation_list.read_all_exn
+    State.Block.all_operation_hashes block >|= fun operations ->
-        net_db hash >|= fun operations ->
     List.fold_left
       (List.fold_left (fun mempool h -> Operation_hash.Set.remove h mempool))
       mempool operations
   in
-  let net_state = Distributed_db.state net_db in
+  Chain_traversal.new_blocks ~from_block ~to_block >>= fun (ancestor, path) ->
-  State.Valid_block.Current.new_blocks
+  pop_blocks
-    net_state ~from_block ~to_block >>= fun (ancestor, path) ->
+    (State.Block.hash ancestor)
-  pop_blocks ancestor from_block.hash old_mempool >>= fun mempool ->
+    from_block old_mempool >>= fun mempool ->
   Lwt_list.fold_left_s push_block mempool path >>= fun new_mempool ->
   Lwt.return new_mempool
 
@@ -45,14 +45,14 @@ exception Invalid_operation of Operation_hash.t
 open Prevalidation
 
 type t = {
-  net_db: Distributed_db.net ;
+  net_db: Distributed_db.net_db ;
-  flush: State.Valid_block.t -> unit;
+  flush: State.Block.t -> unit;
   notify_operations: P2p.Peer_id.t -> Operation_hash.t list -> unit ;
   prevalidate_operations:
     bool -> Operation.t list ->
     (Operation_hash.t list * error preapply_result) tzresult Lwt.t ;
   operations: unit -> error preapply_result * Operation_hash.Set.t ;
-  pending: ?block:State.Valid_block.t -> unit -> Operation_hash.Set.t Lwt.t ;
+  pending: ?block:State.Block.t -> unit -> Operation_hash.Set.t Lwt.t ;
   timestamp: unit -> Time.t ;
   context: unit -> Updater.validation_result tzresult Lwt.t ;
   shutdown: unit -> unit Lwt.t ;
@@ -71,15 +71,14 @@ let create net_db =
   let cancelation, cancel, _on_cancel = Lwt_utils.canceler () in
   let push_to_worker, worker_waiter = Lwt_utils.queue () in
 
-  State.Valid_block.Current.head net_state >>= fun head ->
+  Chain.head net_state >>= fun head ->
-  State.Operation.list_pending net_state >>= fun initial_mempool ->
   let timestamp = ref (Time.now ()) in
   (start_prevalidation head !timestamp >|= ref) >>= fun validation_state ->
   let pending = Operation_hash.Table.create 53 in
   let head = ref head in
   let operations = ref empty_result in
   let running_validation = ref Lwt.return_unit in
-  let unprocessed = ref initial_mempool in
+  let unprocessed = ref Operation_hash.Set.empty in
   let broadcast_unprocessed = ref false in
 
   let set_validation_state state =
@@ -92,7 +91,8 @@ let create net_db =
     Lwt.return_unit in
 
   let broadcast_operation ops =
-    Distributed_db.broadcast_head net_db !head.hash ops in
+    let hash = State.Block.hash !head in
+    Distributed_db.broadcast_head net_db hash ops in
 
   let handle_unprocessed () =
     if Operation_hash.Set.is_empty !unprocessed then
@@ -108,7 +108,7 @@ let create net_db =
         begin
           Lwt_list.map_p
             (fun h ->
-               Distributed_db.Operation.read net_db h >>= function
+               Distributed_db.Operation.read_opt net_db h >>= function
                | None -> Lwt.return_none
                | Some po -> Lwt.return_some (h, po))
             (Operation_hash.Set.elements ops) >>= fun rops ->
@@ -184,28 +184,28 @@ let create net_db =
                     prevalidate validation_state ~sort:true rops >>=? fun (state, res) ->
                     let register h =
                       let op = Operation_hash.Map.find h ops in
-                      Distributed_db.Operation.inject
+                      Distributed_db.inject_operation
-                        net_db h op >>= fun _ ->
+                        net_db h op >>=? fun (_ : bool) ->
-                      Lwt.return_unit in
+                      return () in
-                    Lwt_list.iter_s
+                    iter_s
                       (fun h ->
-                         register h >>= fun () ->
+                         register h >>=? fun () ->
                          operations :=
                            { !operations with
                              applied = h :: !operations.applied };
-                         Lwt.return_unit )
+                         return () )
-                      res.applied >>= fun () ->
+                      res.applied >>=? fun () ->
                     broadcast_operation res.applied ;
                     begin
                       if force then
-                        Lwt_list.iter_p
+                        iter_p
                           (fun (h, _exns) -> register h)
                           (Operation_hash.Map.bindings
-                             res.branch_delayed) >>= fun () ->
+                             res.branch_delayed) >>=? fun () ->
-                        Lwt_list.iter_p
+                        iter_p
                           (fun (h, _exns) -> register h)
                           (Operation_hash.Map.bindings
-                             res.branch_refused) >>= fun () ->
+                             res.branch_refused) >>=? fun () ->
                         operations :=
                           { !operations with
                             branch_delayed =
@@ -215,10 +215,10 @@ let create net_db =
                               Operation_hash.Map.merge merge
                                 !operations.branch_refused res.branch_refused ;
                           } ;
-                        Lwt.return_unit
+                        return ()
                       else
-                        Lwt.return_unit
+                        return ()
-                    end >>= fun () ->
+                    end >>=? fun () ->
                     set_validation_state (Ok state) >>= fun () ->
                     return res
                   in
@@ -236,7 +236,7 @@ let create net_db =
                       (fun op -> Operation_hash.Table.mem pending op) new_ops in
                   let fetch op =
                     Distributed_db.Operation.fetch
-                      net_db ~peer:gid op >>= fun _op ->
+                      net_db ~peer:gid op () >>= fun _op ->
                     push_to_worker (`Handle op) ;
                     Lwt.return_unit
                   in
@@ -245,7 +245,7 @@ let create net_db =
                     unknown_ops ;
                   List.iter (fun op ->
                       Lwt.ignore_result
-                        (Distributed_db.Operation.fetch net_db ~peer:gid op))
+                        (Distributed_db.Operation.fetch net_db ~peer:gid op ()))
                     known_ops ;
                   Lwt.return_unit
               | `Handle op ->
@@ -255,12 +255,11 @@ let create net_db =
                   unprocessed := Operation_hash.Set.singleton op ;
                   lwt_debug "register %a" Operation_hash.pp_short op >>= fun () ->
                   Lwt.return_unit
-              | `Flush (new_head : State.Valid_block.t) ->
+              | `Flush (new_head : State.Block.t) ->
-                  list_pendings
+                  list_pendings ~from_block:!head ~to_block:new_head
-                    net_db ~from_block:!head ~to_block:new_head
                     (preapply_result_operations !operations) >>= fun new_mempool ->
                   lwt_debug "flush %a (mempool: %d)"
-                    Block_hash.pp_short new_head.hash
+                    Block_hash.pp_short (State.Block.hash new_head)
                     (Operation_hash.Set.cardinal new_mempool) >>= fun () ->
                   (* Reset the pre-validation context *)
                   head := new_head ;
@@ -306,8 +305,7 @@ let create net_db =
     let ops = preapply_result_operations !operations in
     match block with
     | None -> Lwt.return ops
-    | Some to_block ->
+    | Some to_block -> list_pendings ~from_block:!head ~to_block ops in
-        list_pendings net_db ~from_block:!head ~to_block ops in
   let context () =
     Lwt.return !validation_state >>=? fun prevalidation_state ->
     Prevalidation.end_prevalidation prevalidation_state in
@@ -345,7 +343,7 @@ let inject_operation pv ?(force = false) (op: Operation.t) =
     end >>=? fun errors ->
     Lwt.return (Error errors) in
   fail_unless (Net_id.equal net_id op.shell.net_id)
-    (Unclassified
+    (failure
        "Prevalidator.inject_operation: invalid network") >>=? fun () ->
   pv.prevalidate_operations force [op] >>=? function
   | ([h], { applied = [h'] }) when Operation_hash.equal h h' ->

src/node/shell/prevalidator.mli

@@ -29,7 +29,7 @@
 type t
 
 (** Creation and destruction of a "prevalidation" worker. *)
-val create: Distributed_db.net -> t Lwt.t
+val create: Distributed_db.net_db -> t Lwt.t
 val shutdown: t -> unit Lwt.t
 
 val notify_operations: t -> P2p.Peer_id.t -> Operation_hash.t list -> unit
@@ -38,12 +38,11 @@ val notify_operations: t -> P2p.Peer_id.t -> Operation_hash.t list -> unit
     be ignored when it is (strongly) refused This is the
     entry-point used by the P2P layer. The operation content has been
     previously stored on disk. *)
-val inject_operation:
+val inject_operation: t -> ?force:bool -> Operation.t -> unit tzresult Lwt.t
-  t -> ?force:bool -> Operation.t -> unit tzresult Lwt.t
 
-val flush: t -> State.Valid_block.t -> unit
+val flush: t -> State.Block.t -> unit
 val timestamp: t -> Time.t
 val operations: t -> error Prevalidation.preapply_result * Operation_hash.Set.t
 val context: t -> Updater.validation_result tzresult Lwt.t
 
-val pending: ?block:State.Valid_block.t -> t -> Operation_hash.Set.t Lwt.t
+val pending: ?block:State.Block.t -> t -> Operation_hash.Set.t Lwt.t

src/node/shell/state.mli

@@ -7,6 +7,8 @@
 (*                                                                        *)
 (**************************************************************************)
 
+type t
+type global_state = t
 (** An abstraction over all the disk storage used by the node.
 
     It encapsulates access to:
@@ -14,14 +16,7 @@
     - the index of validation contexts; and
     - the persistent state of the node:
       - the blockchain and its alternate heads of a "network";
-      - the pool of pending operations of a "network".
+      - the pool of pending operations of a "network". *)
-
- *)
-type t
-type global_state = t
-
-(** Read the internal state of the node and initialize
-    the blocks/operations/contexts databases. *)
 
 val read:
   ?patch_context:(Context.t -> Context.t Lwt.t) ->
@@ -29,6 +24,8 @@ val read:
   context_root:string ->
   unit ->
   global_state tzresult Lwt.t
+(** Read the internal state of the node and initialize
+    the databases. *)
 
 val close:
   global_state -> unit Lwt.t
@@ -36,17 +33,7 @@ val close:
 (** {2 Errors} **************************************************************)
 
 type error +=
-  | Invalid_fitness of { block: Block_hash.t ;
-                         expected: Fitness.t ;
-                         found: Fitness.t }
-  | Invalid_operations of { block: Block_hash.t ;
-                            expected: Operation_list_list_hash.t ;
-                            found: Operation_hash.t list list }
   | Unknown_network of Net_id.t
-  | Unknown_operation of Operation_hash.t
-  | Unknown_block of Block_hash.t
-  | Unknown_protocol of Protocol_hash.t
-  | Cannot_parse
 
 
 (** {2 Network} ************************************************************)
@@ -55,7 +42,7 @@ type error +=
 module Net : sig
 
   type t
-  type net = t
+  type net_state = t
 
   type genesis = {
     time: Time.t ;
@@ -64,329 +51,141 @@ module Net : sig
   }
   val genesis_encoding: genesis Data_encoding.t
 
-  (** Initialize a network for a given [genesis]. By default,
-      the network does accept forking test network. When
-      [~allow_forked_network:true] is provided, test network are allowed. *)
   val create:
     global_state ->
     ?allow_forked_network:bool ->
-    genesis -> net Lwt.t
+    genesis -> net_state Lwt.t
+  (** Initialize a network for a given [genesis]. By default,
+      the network does accept forking test network. When
+      [~allow_forked_network:true] is provided, test network are allowed. *)
 
+  val get: global_state -> Net_id.t -> net_state tzresult Lwt.t
   (** Look up for a network by the hash of its genesis block. *)
-  val get: global_state -> Net_id.t -> net tzresult Lwt.t
 
+  val all: global_state -> net_state list Lwt.t
   (** Returns all the known networks. *)
-  val all: global_state -> net list Lwt.t
 
+  val destroy: global_state -> net_state -> unit Lwt.t
   (** Destroy a network: this completly removes from the local storage all
       the data associated to the network (this includes blocks and
       operations). *)
-  val destroy: global_state -> net -> unit Lwt.t
 
+  val id: net_state -> Net_id.t
+  val genesis: net_state -> genesis
+  val expiration: net_state -> Time.t option
+  val allow_forked_network: net_state -> bool
   (** Accessors. Respectively access to;
       - the network id (the hash of its genesis block)
       - its optional expiration time
       - the associated global state. *)
-  val id: net -> Net_id.t
+
-  val genesis: net -> genesis
-  val expiration: net -> Time.t option
-  val allow_forked_network: net -> bool
 
 end
 
-(** Shared signature for the databases of block_headers,
+(** {2 Block database} ********************************************************)
-    operations and protocols. *)
-module type DATA_STORE = sig
 
-  type store
+module Block : sig
-  type key
-  type value
 
-  (** Is a value stored in the local database ? *)
+  type t
-  val known: store -> key -> bool Lwt.t
+  type block = t
 
-  (** Read a value in the local database. *)
+  val known_valid: Net.t -> Block_hash.t -> bool Lwt.t
-  val read: store -> key -> value tzresult Lwt.t
+  val known_invalid: Net.t -> Block_hash.t -> bool Lwt.t
-  val read_opt: store -> key -> value option Lwt.t
-  val read_exn: store -> key -> value Lwt.t
 
-  (** Read a value in the local database (without parsing). *)
+  val read: Net.t -> Block_hash.t -> block tzresult Lwt.t
-  val read_raw: store -> key -> MBytes.t tzresult Lwt.t
+  val read_opt: Net.t -> Block_hash.t -> block option Lwt.t
-  val read_raw_opt: store -> key -> MBytes.t option Lwt.t
+  val read_exn: Net.t -> Block_hash.t -> block Lwt.t
-  val read_raw_exn: store -> key -> MBytes.t Lwt.t
 
-  (** Read data discovery time (the time when `store` was called). *)
-  val read_discovery_time: store -> key -> Time.t tzresult Lwt.t
-  val read_discovery_time_opt: store -> key -> Time.t option Lwt.t
-  val read_discovery_time_exn: store -> key -> Time.t Lwt.t
-
-  (** Store a value in the local database (pre-parsed value).  It
-      returns [false] when the value is already stored, or [true]
-      otherwise. For a given value, only one call to `store` (or an
-      equivalent call to `store_raw`) might return [true].  *)
-  val store: store -> key -> value -> bool Lwt.t
-
-  (** Store a value in the local database (unparsed data).  It returns
-      [Ok None] when the data is already stored, or [Ok (Some (hash,
-      value))] otherwise. For a given data, only one call to
-      `store_raw` (or an equivalent call to `store`) might return [Ok
-      (Some _)]. It may return [Error] when the shell part of the value
-      cannot be parsed. *)
-  val store_raw: store -> key -> MBytes.t -> value option tzresult Lwt.t
-
-  (** Remove a value from the local database. *)
-  val remove: store -> key -> bool Lwt.t
-
-end
-
-
-(** {2 Block_header database} *************************************************)
-
-module Block_header : sig
-
-  include DATA_STORE with type store = Net.t
-                      and type key = Block_hash.t
-                      and type value := Block_header.t
-
-  val mark_invalid: Net.t -> Block_hash.t -> error list -> bool Lwt.t
-
-  val invalid: Net.t -> Block_hash.t -> error list option Lwt.t
-  val pending: Net.t -> Block_hash.t -> bool Lwt.t
-
-  val list_pending: Net.t -> Block_hash.Set.t Lwt.t
-  val list_invalid: Net.t -> Block_hash.Set.t Lwt.t
-
-  module Helpers : sig
-
-    (** If [h1] is an ancestor of [h2] in the current [state],
-        then [path state h1 h2] returns the chain of block from
-        [h1] (excluded) to [h2] (included). *)
-    val path:
-      Net.t -> Block_hash.t -> Block_hash.t ->
-      (Block_hash.t * Block_header.shell_header) list tzresult Lwt.t
-
-    (** [common_ancestor state h1 h2] returns the first common ancestors
-        in the history of blocks [h1] and [h2]. *)
-    val common_ancestor:
-      Net.t -> Block_hash.t -> Block_hash.t ->
-      (Block_hash.t * Block_header.shell_header) tzresult Lwt.t
-
-    (** [block_locator state max_length h] compute the sparse block locator
-        (/à la/ Bitcoin) for the block [h]. *)
-    val block_locator:
-      Net.t -> int -> Block_hash.t -> Block_hash.t list tzresult Lwt.t
-
-    (** [iter_predecessors state blocks f] iter [f] on [blocks] and
-        their recursive (known) predecessors. Blocks are visited with a
-        decreasing fitness (then decreasing timestamp). If the optional
-        argument [max] is provided, the iteration is stopped after [max]
-        visited block. If [min_fitness] id provided, blocks with a
-        fitness lower than [min_fitness] are ignored. If [min_date],
-        blocks with a fitness lower than [min_date] are ignored. *)
-    val iter_predecessors:
-      Net.t ->
-      ?max:int ->
-      ?min_fitness:Fitness.t ->
-      ?min_date:Time.t ->
-      Block_header.t list ->
-      f:(Block_header.t -> unit Lwt.t) ->
-      unit tzresult Lwt.t
-
-  end
-
-end
-
-module Operation_list : sig
-
-  type store = Net.t
-  type key = Block_hash.t * int
-  type value = Operation_hash.t list * Operation_list_list_hash.path
-
-  val known: store -> key -> bool Lwt.t
-  val read: store -> key -> value tzresult Lwt.t
-  val read_opt: store -> key -> value option Lwt.t
-  val read_exn: store -> key -> value Lwt.t
-  val store: store -> key -> value -> bool Lwt.t
-  val remove: store -> key -> bool Lwt.t
-
-  val read_count: store -> Block_hash.t -> int tzresult Lwt.t
-  val read_count_opt: store -> Block_hash.t -> int option Lwt.t
-  val read_count_exn: store -> Block_hash.t -> int Lwt.t
-  val store_count: store -> Block_hash.t -> int -> unit Lwt.t
-
-  val read_all:
-    store -> Block_hash.t -> Operation_hash.t list list tzresult Lwt.t
-  val store_all:
-    store -> Block_hash.t -> Operation_hash.t list  list -> unit Lwt.t
-
-end
-
-
-(** {2 Valid block} ***********************************************************)
-
-(** The local database of known-valid blocks. *)
-module Valid_block : sig
-
-  (** A validated block. *)
-  type t = private {
-    net_id: Net_id.t ;
-    (** The genesis of the chain this block belongs to. *)
-    hash: Block_hash.t ;
-    (** The block hash. *)
-    level: Int32.t ;
-    (** The number of preceding block in the chain. *)
-    proto_level: int ;
-    (** The number of protocol amendment block in the chain (modulo 256) *)
-    predecessor: Block_hash.t ;
-    (** The preceding block in the chain. *)
-    timestamp: Time.t ;
-    (** The date at which this block has been forged. *)
-    fitness: Fitness.t ;
-    (** The (validated) score of the block. *)
-    operations_hash: Operation_list_list_hash.t ;
-    operation_hashes: Operation_hash.t list list Lwt.t Lazy.t ;
-    operations: Operation.t list list Lwt.t Lazy.t ;
-    (** The sequence of operations and its (Merkle-)hash. *)
-    discovery_time: Time.t ;
-    (** The data at which the block was discorevered on the P2P network. *)
-    protocol_hash: Protocol_hash.t ;
-    (** The protocol to be used for validating the following blocks. *)
-    protocol: (module Updater.REGISTRED_PROTOCOL) option ;
-    (** The actual implementation of the protocol to be used for
-        validating the following blocks. *)
-    test_network: Context.test_network ;
-    (** The current test network associated to the block. *)
-    context: Context.t ;
-    (** The validation context that was produced by the block validation. *)
-    proto_header: MBytes.t;
-    (** The uninterpreted protocol dependent part of the header. *)
-  }
-  type valid_block = t
-
-  val known: Net.t -> Block_hash.t -> bool Lwt.t
-  val read: Net.t -> Block_hash.t -> valid_block tzresult Lwt.t
-  val read_opt: Net.t -> Block_hash.t -> valid_block option Lwt.t
-  val read_exn: Net.t -> Block_hash.t -> valid_block Lwt.t
   val store:
-    Net.t -> Block_hash.t -> Updater.validation_result ->
+    Net.t ->
-    valid_block option tzresult Lwt.t
+    Block_header.t ->
+    Operation.t list list ->
+    Updater.validation_result ->
+    block option tzresult Lwt.t
 
-  val watcher: Net.t -> valid_block Lwt_stream.t * Watcher.stopper
+  val store_invalid:
+    Net.t ->
+    Block_header.t ->
+    bool tzresult Lwt.t
 
-  (** The known valid heads of the network's blockchain. *)
+  val compare: t -> t -> int
-  val known_heads: Net.t -> valid_block list Lwt.t
+  val equal: t -> t -> bool
 
-  val fork_testnet:
+  val hash: t -> Block_hash.t
-    global_state ->
+  val header: t -> Block_header.t
-    Net.t -> valid_block ->
+  val shell_header: t -> Block_header.shell_header
-    Protocol_hash.t -> Time.t ->
+  val timestamp: t -> Time.t
+  val fitness: t -> Fitness.t
+  val operation_list_count: t -> int
+  val net_id: t -> Net_id.t
+  val level: t -> Int32.t
+  val message: t -> string
+
+  val predecessor: t -> block option Lwt.t
+
+  val context: t -> Context.t Lwt.t
+  val protocol_hash: t -> Protocol_hash.t Lwt.t
+  val test_network: t -> Context.test_network Lwt.t
+
+  val operation_hashes:
+    t -> int ->
+    (Operation_hash.t list * Operation_list_list_hash.path) Lwt.t
+  val all_operation_hashes: t -> Operation_hash.t list list Lwt.t
+
+  val operations:
+    t -> int -> (Operation.t list * Operation_list_list_hash.path) Lwt.t
+  val all_operations: t -> Operation.t list list Lwt.t
+
+  val watcher: Net.t -> block Lwt_stream.t * Watcher.stopper
+
+end
+
+val read_block:
+  global_state -> Block_hash.t -> Block.t option Lwt.t
+
+val read_block_exn:
+  global_state -> Block_hash.t -> Block.t Lwt.t
+
+val fork_testnet:
+  global_state -> Block.t -> Protocol_hash.t -> Time.t ->
   Net.t tzresult Lwt.t
 
-  module Current : sig
+type chain_data = {
+  current_head: Block.t ;
+}
 
-    (** The genesis block of the network's blockchain. On a test network,
+val read_chain_store:
-        the test protocol has been promoted as "main" protocol. *)
-    val genesis: Net.t -> valid_block Lwt.t
-
-    (** The current head of the network's blockchain. *)
-    val head: Net.t -> valid_block Lwt.t
-
-    (** The current protocol of the network's blockchain. *)
-    val protocol: Net.t -> (module Updater.REGISTRED_PROTOCOL) Lwt.t
-
-    (** Record a block as the current head of the network's blockchain. *)
-    val set_head: Net.t -> valid_block -> unit Lwt.t
-
-    val mem: Net.t -> Block_hash.t -> bool Lwt.t
-
-    (** Atomically change the current head of the network's blockchain.
-        This returns [true] whenever the change succeeded, or [false]
-        when the current head os not equal to the [old] argument. *)
-    val test_and_set_head:
-      Net.t -> old:valid_block -> valid_block -> bool Lwt.t
-
-    (** [find_new net locator max_length], where [locator] is a sparse block
-        locator (/à la/ Bitcoin), returns the missing block when compared
-        with the current branch of [net]. *)
-    val find_new:
-      Net.t -> Block_hash.t list -> int -> Block_hash.t list tzresult Lwt.t
-
-    val new_blocks:
-      Net.t -> from_block:valid_block -> to_block:valid_block ->
-      (Block_hash.t * (Block_hash.t * Tezos_data.Block_header.shell_header) list) Lwt.t
-
-  end
-
-  module Helpers : sig
-
-    (** If [h1] is an ancestor of [h2] in the current [state],
-        then [path state h1 h2] returns the chain of block from
-        [h1] (excluded) to [h2] (included). Returns [None] otherwise. *)
-    val path:
-      Net.t -> valid_block -> valid_block -> valid_block list option Lwt.t
-
-    (** [common_ancestor state h1 h2] returns the first common ancestors
-        in the history of blocks [h1] and [h2]. *)
-    val common_ancestor:
-      Net.t -> valid_block -> valid_block -> valid_block Lwt.t
-
-    (** [block_locator state max_length h] compute the sparse block locator
-        (/à la/ Bitcoin) for the block [h]. *)
-    val block_locator: Net.t -> int -> valid_block -> Block_hash.t list Lwt.t
-
-    (** [iter_predecessors state blocks f] iter [f] on [blocks] and
-        their recursive predecessors. Blocks are visited with a
-        decreasing fitness (then decreasing timestamp). If the optional
-        argument [max] is provided, the iteration is stopped after [max]
-        visited block. If [min_fitness] id provided, blocks with a
-        fitness lower than [min_fitness] are ignored. If [min_date],
-        blocks with a fitness lower than [min_date] are ignored. *)
-    val iter_predecessors:
   Net.t ->
-      ?max:int ->
+  (Store.Chain.store -> chain_data -> 'a Lwt.t) ->
-      ?min_fitness:Fitness.t ->
+  'a Lwt.t
-      ?min_date:Time.t ->
-      valid_block list ->
-      f:(valid_block -> unit Lwt.t) ->
-      unit tzresult Lwt.t
-
-  end
-
-end
-
-
-(** {2 Operation database} ****************************************************)
-
-module Operation : sig
-
-  include DATA_STORE with type store = Net.t
-                      and type key = Operation_hash.t
-                      and type value := Operation.t
-
-  val mark_invalid: Net.t -> Operation_hash.t -> error list -> bool Lwt.t
-
-  val in_chain: Net.t -> Operation_hash.t -> bool Lwt.t
-  val pending: Net.t -> Operation_hash.t -> bool Lwt.t
-  val invalid: Net.t -> Operation_hash.t -> error list option Lwt.t
-
-  val list_pending: Net.t -> Operation_hash.Set.t Lwt.t
-
-  val list_invalid: Net.t -> Operation_hash.Set.t Lwt.t
-
-end
 
+val update_chain_store:
+  Net.t ->
+  (Store.Chain.store -> chain_data -> (chain_data option * 'a) Lwt.t) ->
+  'a Lwt.t
 
 (** {2 Protocol database} ***************************************************)
 
 module Protocol : sig
-  include DATA_STORE with type store = global_state
+
-                      and type key = Protocol_hash.t
+  (** Is a value stored in the local database ? *)
-                      and type value := Protocol.t
+  val known: global_state -> Protocol_hash.t -> bool Lwt.t
+
+  (** Read a value in the local database. *)
+  val read: global_state -> Protocol_hash.t -> Protocol.t tzresult Lwt.t
+  val read_opt: global_state -> Protocol_hash.t -> Protocol.t option Lwt.t
+  val read_exn: global_state -> Protocol_hash.t -> Protocol.t Lwt.t
+
+  (** Read a value in the local database (without parsing). *)
+  val read_raw: global_state -> Protocol_hash.t -> MBytes.t tzresult Lwt.t
+  val read_raw_opt: global_state -> Protocol_hash.t -> MBytes.t option Lwt.t
+  val read_raw_exn: global_state -> Protocol_hash.t -> MBytes.t Lwt.t
+
+  val store: global_state -> Protocol.t -> Protocol_hash.t option Lwt.t
+
+  (** Remove a value from the local database. *)
+  val remove: global_state -> Protocol_hash.t -> bool Lwt.t
 
   val list: global_state -> Protocol_hash.Set.t Lwt.t
 
-  (* val mark_invalid: Net.t -> Protocol_hash.t -> error list -> bool Lwt.t *)
-  (* val list_invalid: Net.t -> Protocol_hash.Set.t Lwt.t *)
-
 end
-

src/node/shell/validator.ml

@@ -16,11 +16,11 @@ type worker = {
   deactivate: t -> unit Lwt.t ;
   inject_block:
     ?force:bool ->
-    MBytes.t -> Operation_hash.t list list ->
+    MBytes.t -> Distributed_db.operation list list ->
-    (Block_hash.t * State.Valid_block.t tzresult Lwt.t) tzresult Lwt.t ;
+    (Block_hash.t * State.Block.t tzresult Lwt.t) tzresult Lwt.t ;
   notify_block: Block_hash.t -> Block_header.t -> unit Lwt.t ;
   shutdown: unit -> unit Lwt.t ;
-  valid_block_input: State.Valid_block.t Watcher.input ;
+  valid_block_input: State.Block.t Watcher.input ;
   db: Distributed_db.t ;
 }
 
@@ -30,18 +30,18 @@ and t = {
   parent: t option ;
   mutable child: t option ;
   prevalidator: Prevalidator.t ;
-  net_db: Distributed_db.net ;
+  net_db: Distributed_db.net_db ;
   notify_block: Block_hash.t -> Block_header.t -> unit Lwt.t ;
-  fetch_block: Block_hash.t -> State.Valid_block.t tzresult Lwt.t ;
+  fetch_block: Block_hash.t -> State.Block.t tzresult Lwt.t ;
   create_child:
-    State.Valid_block.t -> Protocol_hash.t -> Time.t -> unit tzresult Lwt.t ;
+    State.Block.t -> Protocol_hash.t -> Time.t -> unit tzresult Lwt.t ;
   check_child:
     Block_hash.t -> Protocol_hash.t -> Time.t -> Time.t -> unit tzresult Lwt.t ;
   deactivate_child: unit -> unit Lwt.t ;
-  test_validator: unit -> (t * Distributed_db.net) option ;
+  test_validator: unit -> (t * Distributed_db.net_db) option ;
   shutdown: unit -> unit Lwt.t ;
-  valid_block_input: State.Valid_block.t Watcher.input ;
+  valid_block_input_for_net: State.Block.t Watcher.input ;
-  new_head_input: State.Valid_block.t Watcher.input ;
+  new_head_input: State.Block.t Watcher.input ;
   bootstrapped: unit Lwt.t ;
 }
 
@@ -66,13 +66,12 @@ let bootstrapped v = v.bootstrapped
 let fetch_protocol v hash =
   lwt_log_notice "Fetching protocol %a"
     Protocol_hash.pp_short hash >>= fun () ->
-  Distributed_db.Protocol.fetch v.worker.db hash >>= fun protocol ->
+  Distributed_db.Protocol.fetch v.worker.db hash () >>= fun protocol ->
   Updater.compile hash protocol >>= fun valid ->
   if valid then begin
     lwt_log_notice "Successfully compiled protocol %a"
       Protocol_hash.pp_short hash >>= fun () ->
-    Distributed_db.Protocol.commit
+    Distributed_db.commit_protocol v.worker.db hash >>=? fun _ ->
-      v.worker.db hash >>= fun () ->
     return true
   end else begin
     lwt_log_error "Failed to compile protocol %a"
@@ -80,43 +79,49 @@ let fetch_protocol v hash =
     failwith "Cannot compile the protocol %a" Protocol_hash.pp_short hash
   end
 
-let fetch_protocols v (block: State.Valid_block.t) =
+let fetch_protocols v (block: State.Block.t) =
+  State.Block.context block >>= fun context ->
   let proto_updated =
-    match block.protocol with
+    Context.get_protocol context >>= fun protocol_hash ->
+    match Updater.get protocol_hash with
     | Some _ -> return false
-    | None -> fetch_protocol v block.protocol_hash
+    | None -> fetch_protocol v protocol_hash
   and test_proto_updated =
-    match block.test_network with
+    Context.get_test_network context >>= function
     | Not_running -> return false
     | Forking { protocol }
     | Running { protocol } ->
-        Distributed_db.Protocol.known v.worker.db protocol >>= fun known ->
+        match Updater.get protocol with
-        if known then return false
+        | Some _ -> return false
-        else fetch_protocol v protocol in
+        | None -> fetch_protocol v protocol in
   proto_updated >>=? fun proto_updated ->
-  test_proto_updated >>=? fun _test_proto_updated ->
+  test_proto_updated >>=? fun test_proto_updated ->
-  if proto_updated then
+  return (proto_updated && test_proto_updated)
-    State.Valid_block.read_exn v.net block.hash >>= return
-  else
-    return block
 
-let rec may_set_head v (block: State.Valid_block.t) =
+let rec may_set_head v (block: State.Block.t) =
-  State.Valid_block.Current.head v.net >>= fun head ->
+  Chain.head v.net >>= fun head ->
-  if Fitness.compare head.fitness block.fitness >= 0 then
+  let head_header = State.Block.header head
+  and head_hash = State.Block.hash head
+  and block_header = State.Block.header block
+  and block_hash = State.Block.hash block in
+  if
+    Fitness.compare
+      head_header.shell.fitness block_header.shell.fitness >= 0
+  then
     Lwt.return_unit
   else begin
-    State.Valid_block.Current.test_and_set_head v.net
+    Chain.test_and_set_head v.net ~old:head block >>= function
-      ~old:head block >>= function
     | false -> may_set_head v block
     | true ->
-        Distributed_db.broadcast_head v.net_db block.hash [] ;
+        Distributed_db.broadcast_head v.net_db block_hash [] ;
         Prevalidator.flush v.prevalidator block ;
         begin
           begin
-            match block.test_network with
+            State.Block.test_network block >>= function
             | Not_running -> v.deactivate_child () >>= return
             | Running { genesis ; protocol ; expiration } ->
-                v.check_child genesis protocol expiration block.timestamp
+                v.check_child genesis protocol expiration
+                  block_header.shell.timestamp
             | Forking { protocol ; expiration } ->
                 v.create_child block protocol expiration
           end >>= function
@@ -127,11 +132,11 @@ let rec may_set_head v (block: State.Valid_block.t) =
         end >>= fun () ->
         Watcher.notify v.new_head_input block ;
         lwt_log_notice "update current head %a %a %a(%t)"
-          Block_hash.pp_short block.hash
+          Block_hash.pp_short block_hash
-          Fitness.pp block.fitness
+          Fitness.pp block_header.shell.fitness
-          Time.pp_hum block.timestamp
+          Time.pp_hum block_header.shell.timestamp
           (fun ppf ->
-             if Block_hash.equal head.hash block.predecessor then
+             if Block_hash.equal head_hash block_header.shell.predecessor then
                Format.fprintf ppf "same branch"
              else
                Format.fprintf ppf "changing branch") >>= fun () ->
@@ -142,12 +147,38 @@ let rec may_set_head v (block: State.Valid_block.t) =
 
 type error +=
    | Invalid_operation of Operation_hash.t
+   | Invalid_fitness of { block: Block_hash.t ;
+                          expected: Fitness.t ;
+                          found: Fitness.t }
+   | Unknown_protocol
    | Non_increasing_timestamp
    | Non_increasing_fitness
    | Wrong_level of Int32.t * Int32.t
    | Wrong_proto_level of int * int
 
 let () =
+  Error_monad.register_error_kind
+    `Permanent
+    ~id:"validator.invalid_fitness"
+    ~title:"Invalid fitness"
+    ~description:"The computed fitness differs from the fitness found \
+                 \ in the block header."
+    ~pp:(fun ppf (block, expected, found) ->
+        Format.fprintf ppf
+          "@[<v 2>Invalid fitness for block %a@ \
+           \ expected %a@ \
+          \ found %a"
+          Block_hash.pp_short block
+          Fitness.pp expected
+          Fitness.pp found)
+    Data_encoding.(obj3
+                     (req "block" Block_hash.encoding)
+                     (req "expected" Fitness.encoding)
+                     (req "found" Fitness.encoding))
+    (function Invalid_fitness { block ; expected ; found } ->
+       Some (block, expected, found) | _ -> None)
+    (fun (block, expected, found) ->
+       Invalid_fitness { block ; expected ; found }) ;
   register_error_kind
     `Permanent
     ~id:"validator.wrong_level"
@@ -175,47 +206,50 @@ let () =
     (function Wrong_proto_level (e, g)   -> Some (e, g) | _ -> None)
     (fun (e, g) -> Wrong_proto_level (e, g))
 
-let apply_block net db
+let apply_block net_state db
-    (pred: State.Valid_block.t) hash (block: Block_header.t) =
+    (pred: State.Block.t) hash (block: Block_header.t) =
-  let id = State.Net.id net in
+  let pred_header = State.Block.header pred
+  and pred_hash = State.Block.hash pred in
+  State.Block.context pred >>= fun pred_context ->
+  let id = State.Net.id net_state in
   lwt_log_notice "validate block %a (after %a), net %a"
     Block_hash.pp_short hash
     Block_hash.pp_short block.shell.predecessor
     Net_id.pp id
   >>= fun () ->
   fail_unless
-    (Int32.succ pred.level = block.shell.level)
+    (Int32.succ pred_header.shell.level = block.shell.level)
-    (Wrong_level (Int32.succ pred.level, block.shell.level)) >>=? fun () ->
+    (Wrong_level (Int32.succ pred_header.shell.level,
+                  block.shell.level)) >>=? fun () ->
   lwt_log_info "validation of %a: looking for dependencies..."
     Block_hash.pp_short hash >>= fun () ->
-  Distributed_db.Operation_list.fetch
+  Distributed_db.Operations.fetch
-    db (hash, 0) block.shell.operations_hash >>= fun operation_hashes ->
+    db (hash, 0) block.shell.operations_hash >>= fun operations ->
-  Lwt_list.map_p
+  let operation_hashes = List.map Operation.hash operations in
-    (fun op -> Distributed_db.Operation.fetch db op)
-    operation_hashes >>= fun operations ->
   lwt_debug "validation of %a: found operations"
     Block_hash.pp_short hash >>= fun () ->
   begin (* Are we validating a block in an expired test network ? *)
-    match State.Net.expiration net with
+    match State.Net.expiration net_state with
     | Some eol when Time.(eol <= block.shell.timestamp) ->
         failwith "This test network expired..."
     | None | Some _ -> return ()
   end >>=? fun () ->
   begin
-    if Time.(pred.timestamp >= block.shell.timestamp) then
+    if Time.(pred_header.shell.timestamp >= block.shell.timestamp) then
       fail Non_increasing_timestamp
     else
       return ()
   end >>=? fun () ->
   begin
-    if Fitness.compare pred.fitness block.shell.fitness >= 0 then
+    if Fitness.compare pred_header.shell.fitness block.shell.fitness >= 0 then
       fail Non_increasing_fitness
     else
       return ()
   end >>=? fun () ->
+  Context.get_protocol pred_context >>= fun pred_protocol_hash ->
   begin
-    match pred.protocol with
+    match Updater.get pred_protocol_hash with
-    | None -> fail (State.Unknown_protocol pred.protocol_hash)
+    | None -> fail Unknown_protocol
     | Some p -> return p
   end >>=? fun (module Proto) ->
   lwt_debug "validation of %a: Proto %a"
@@ -234,11 +268,11 @@ let apply_block net db
   lwt_debug "validation of %a: applying block..."
     Block_hash.pp_short hash >>= fun () ->
   Context.reset_test_network
-    pred.context pred.hash block.shell.timestamp >>= fun context ->
+    pred_context pred_hash block.shell.timestamp >>= fun context ->
   Proto.begin_application
     ~predecessor_context:context
-    ~predecessor_timestamp:pred.timestamp
+    ~predecessor_timestamp:pred_header.shell.timestamp
-    ~predecessor_fitness:pred.fitness
+    ~predecessor_fitness:pred_header.shell.fitness
     block >>=? fun state ->
   fold_left_s (fun state op ->
       Proto.apply_operation state op >>=? fun state ->
@@ -247,13 +281,20 @@ let apply_block net db
   Proto.finalize_block state >>=? fun new_context ->
   Context.get_protocol new_context.context >>= fun new_protocol ->
   let expected_proto_level =
-    if Protocol_hash.equal new_protocol pred.protocol_hash then
+    if Protocol_hash.equal new_protocol pred_protocol_hash then
-      pred.proto_level
+      pred_header.shell.proto_level
     else
-      (pred.proto_level + 1) mod 256 in
+      (pred_header.shell.proto_level + 1) mod 256 in
   fail_when (block.shell.proto_level <> expected_proto_level)
     (Wrong_proto_level (block.shell.proto_level, expected_proto_level))
   >>=? fun () ->
+  fail_unless
+    (Fitness.equal new_context.fitness block.shell.fitness)
+    (Invalid_fitness
+       { block = hash ;
+         expected = block.shell.fitness ;
+         found = new_context.fitness ;
+       }) >>=? fun () ->
   lwt_log_info "validation of %a: success"
     Block_hash.pp_short hash >>= fun () ->
   return new_context
@@ -263,14 +304,14 @@ let apply_block net db
 module Context_db = struct
 
     type key = Block_hash.t
-    type value = State.Valid_block.t
+    type value = State.Block.t
 
     type data =
       { validator: t ;
         state: [ `Inited of Block_header.t tzresult
                | `Initing of Block_header.t tzresult Lwt.t
-               | `Running of State.Valid_block.t tzresult Lwt.t ] ;
+               | `Running of State.Block.t tzresult Lwt.t ] ;
-        wakener: State.Valid_block.t tzresult Lwt.u }
+        wakener: State.Block.t tzresult Lwt.u }
 
     type context =
       { tbl : data Block_hash.Table.t ;
@@ -278,7 +319,7 @@ module Context_db = struct
         worker_trigger: unit -> unit;
         worker_waiter: unit -> unit Lwt.t ;
         worker: unit Lwt.t ;
-        net_db : Distributed_db.net ;
+        net_db : Distributed_db.net_db ;
         net_state : State.Net.t }
 
     let pending_requests { tbl } =
@@ -296,7 +337,7 @@ module Context_db = struct
       assert (not (Block_hash.Table.mem tbl hash));
       let waiter, wakener = Lwt.wait () in
       let data =
-        Distributed_db.Block_header.fetch net_db hash >>= return in
+        Distributed_db.Block_header.fetch net_db hash () >>= return in
       match Lwt.state data with
       | Lwt.Return data ->
           let state = `Inited data in
@@ -317,71 +358,61 @@ module Context_db = struct
 
     let prefetch validator ({ net_state ; tbl } as session) hash =
       Lwt.ignore_result
-        (State.Valid_block.known net_state hash >>= fun exists ->
+        (State.Block.known_valid net_state hash >>= fun exists ->
          if not exists && not (Block_hash.Table.mem tbl hash) then
            request validator session hash >>= fun _ -> Lwt.return_unit
          else
            Lwt.return_unit)
 
     let known { net_state } hash =
-      State.Valid_block.known net_state hash
+      State.Block.known_valid net_state hash
 
     let read { net_state } hash =
-      State.Valid_block.read net_state hash
+      State.Block.read net_state hash
 
     let fetch ({ net_state ; tbl } as session) validator hash =
       try Lwt.waiter_of_wakener (Block_hash.Table.find tbl hash).wakener
       with Not_found ->
-        State.Valid_block.read_opt net_state hash >>= function
+        State.Block.known_invalid net_state hash >>= fun known_invalid ->
+        if known_invalid then
+          Lwt.return (Error [failure "Invalid predecessor"])
+        else
+          State.Block.read_opt net_state hash >>= function
           | Some op ->
               Lwt.return (Ok op)
           | None ->
               try Lwt.waiter_of_wakener (Block_hash.Table.find tbl hash).wakener
               with Not_found -> request validator session hash
 
-    let store { net_state ; net_db ; tbl } hash data =
+    let store { net_db ; tbl } hash data =
       begin
         match data with
-        | Ok data ->
+        | Ok data -> begin
-            Distributed_db.Block_header.commit net_db hash >>= fun () ->
+            Distributed_db.commit_block net_db hash 1 data >>=? function
-            Distributed_db.Operation_list.commit_all
-              net_db hash 1 >>= fun () ->
-            begin
-              State.Valid_block.store net_state hash data >>=? function
             | None ->
-                  State.Valid_block.read net_state hash >>=? fun block ->
+                (* Should not happen if the block is not validated twice *)
-                  Lazy.force block.operation_hashes >>= fun ophs ->
+                assert false
-                  Lwt_list.iter_p
-                    (Lwt_list.iter_p (fun hash ->
-                         Distributed_db.Operation.commit net_db hash))
-                    ophs >>= fun () ->
-                  return (Ok block, false)
             | Some block ->
-                  Lazy.force block.operation_hashes >>= fun ophs ->
+                return (Ok block)
-                  Lwt_list.iter_p
-                    (Lwt_list.iter_p (fun hash ->
-                         Distributed_db.Operation.commit net_db hash))
-                    ophs >>= fun () ->
-                  return (Ok block, true)
             end
         | Error err ->
-            State.Block_header.mark_invalid
+            Distributed_db.commit_invalid_block net_db hash 1 >>=? fun changed ->
-              net_state hash err >>= fun changed ->
+            assert changed ;
-            return (Error err, changed)
+            return (Error err)
       end >>= function
-      | Ok (block, changed) ->
+      | Ok block ->
           let wakener = (Block_hash.Table.find tbl hash).wakener in
           Block_hash.Table.remove tbl hash;
           Lwt.wakeup wakener block ;
-          Lwt.return changed
+          Lwt.return_unit
       | Error _ as err ->
           let wakener = (Block_hash.Table.find tbl hash).wakener in
           Block_hash.Table.remove tbl hash;
           Lwt.wakeup wakener err ;
-          Lwt.return false
+          Lwt.return_unit
 
   let process (v:t) ~get_context ~set_context hash block =
-    let state = Distributed_db.state v.net_db in
+    let net_state = Distributed_db.state v.net_db in
     get_context v block.Block_header.shell.predecessor >>= function
     | Error _ as error ->
         set_context v hash (Error [(* TODO *)]) >>= fun () ->
@@ -389,14 +420,15 @@ module Context_db = struct
     | Ok _context ->
         lwt_debug "process %a" Block_hash.pp_short hash >>= fun () ->
         begin
-          State.Valid_block.Current.genesis state >>= fun genesis ->
+          Chain.genesis net_state >>= fun genesis ->
-          if Block_hash.equal genesis.hash block.shell.predecessor then
+          if Block_hash.equal (State.Block.hash genesis)
+                              block.shell.predecessor then
             Lwt.return genesis
           else
-            State.Valid_block.read_exn state block.shell.predecessor
+            State.Block.read_exn net_state block.shell.predecessor
         end >>= fun pred ->
-        apply_block state v.net_db pred hash block >>= function
+        apply_block net_state v.net_db pred hash block >>= function
-        | Error ([State.Unknown_protocol _] as err) as error ->
+        | Error ([Unknown_protocol] as err) as error ->
             lwt_log_error
               "@[<v 2>Ignoring block %a@ %a@]"
               Block_hash.pp_short hash
@@ -411,10 +443,10 @@ module Context_db = struct
         | Ok new_context ->
             (* The sanity check `set_context` detects differences
                between the computed fitness and the fitness announced
-               in the block header. Then `Valid_block.read` will
+               in the block header. Then `Block.read` will
                return an error. *)
             set_context v hash (Ok new_context) >>= fun () ->
-            State.Valid_block.read state hash >>= function
+            State.Block.read net_state hash >>= function
             | Error err as error ->
                 lwt_log_error
                   "@[<v 2>Ignoring block %a@ %a@]"
@@ -426,8 +458,8 @@ module Context_db = struct
                   "validation of %a: reevaluate current block"
                   Block_hash.pp_short hash >>= fun () ->
                 Watcher.notify v.worker.valid_block_input block ;
-                Watcher.notify v.valid_block_input block ;
+                Watcher.notify v.valid_block_input_for_net block ;
-                fetch_protocols v block >>=? fun block ->
+                fetch_protocols v block >>=? fun _fetched ->
                 may_set_head v block >>= fun () ->
                 return block
 
@@ -523,15 +555,15 @@ let rec create_validator ?max_ttl ?parent worker state db net =
       Lwt.async (fun () -> Lwt_pipe.push queue (`Branch (gid, locator)))
     end ;
     current_branch = begin fun size ->
-      State.Valid_block.Current.head net >>= fun head ->
+      Chain.head net >>= fun head ->
-      State.Valid_block.Helpers.block_locator net size head
+      Chain_traversal.block_locator head size
     end ;
     notify_head =  begin fun gid block ops ->
       Lwt.async (fun () -> Lwt_pipe.push queue (`Head (gid, block, ops))) ;
     end ;
     current_head = begin fun size ->
-      State.Valid_block.Current.head net >>= fun head ->
+      Chain.head net >>= fun head ->
-      Lwt.return (head.hash, Utils.list_sub (!current_ops ()) size)
+      Lwt.return (State.Block.hash head, Utils.list_sub (!current_ops ()) size)
     end ;
     disconnection = (fun _gid -> ()) ;
   } in
@@ -558,24 +590,24 @@ let rec create_validator ?max_ttl ?parent worker state db net =
     ]
   in
 
-  let valid_block_input = Watcher.create_input () in
+  let valid_block_input_for_net = Watcher.create_input () in
   let new_head_input = Watcher.create_input () in
 
   let bootstrapped =
     (* TODO improve by taking current peers count and current
        locators into account... *)
     let stream, stopper =
-      Watcher.create_stream valid_block_input in
+      Watcher.create_stream valid_block_input_for_net in
     let rec wait () =
       Lwt.pick [ ( Lwt_stream.get stream ) ;
                  ( Lwt_unix.sleep 30. >|= fun () -> None) ] >>= function
-      | Some block
+      | Some block when
-        when Time.(block.State.Valid_block.timestamp < add (Time.now ()) (-60L)) ->
+          Time.((State.Block.header block).shell.timestamp < add (Time.now ()) (-60L)) ->
             wait ()
       | _ ->
-          State.Valid_block.Current.head net >>= fun head ->
+          Chain.head net >>= fun head ->
-          State.Valid_block.Current.genesis net >>= fun genesis ->
+          Chain.genesis net >>= fun genesis ->
-          if Block_hash.equal head.hash genesis.hash then
+          if State.Block.equal head genesis then
             wait ()
           else
             Lwt.return_unit in
@@ -602,14 +634,15 @@ let rec create_validator ?max_ttl ?parent worker state db net =
     test_validator ;
     bootstrapped ;
     new_head_input ;
-    valid_block_input ;
+    valid_block_input_for_net ;
   }
 
   and notify_block hash block =
     lwt_debug "-> Validator.notify_block %a"
       Block_hash.pp_short hash >>= fun () ->
-    State.Valid_block.Current.head net >>= fun head ->
+    Chain.head net >>= fun head ->
-    if Fitness.compare head.fitness block.shell.fitness <= 0 then
+    let head_header = State.Block.header head in
+    if Fitness.compare head_header.shell.fitness block.shell.fitness <= 0 then
       Context_db.prefetch v session hash ;
     Lwt.return_unit
 
@@ -623,9 +656,9 @@ let rec create_validator ?max_ttl ?parent worker state db net =
         State.Net.get state net_id >>= function
         | Ok net_store -> return net_store
         | Error _ ->
-            State.Valid_block.fork_testnet
+            State.fork_testnet
-              state net block protocol expiration >>=? fun net_store ->
+              state block protocol expiration >>=? fun net_store ->
-            State.Valid_block.Current.head net_store >>= fun block ->
+            Chain.head net_store >>= fun block ->
             Watcher.notify v.worker.valid_block_input block ;
             return net_store
       end >>=? fun net_store ->
@@ -654,7 +687,7 @@ let rec create_validator ?max_ttl ?parent worker state db net =
       match max_ttl with
       | None -> Lwt.return expiration
       | Some ttl ->
-          Distributed_db.Block_header.fetch net_db genesis >>= fun genesis ->
+          Distributed_db.Block_header.fetch net_db genesis () >>= fun genesis ->
           Lwt.return
             (Time.min expiration
                (Time.add genesis.shell.timestamp (Int64.of_int ttl)))
@@ -796,29 +829,23 @@ let create_worker ?max_ttl state db =
   let inject_block ?(force = false) bytes operations =
     Distributed_db.inject_block db bytes operations >>=? fun (hash, block) ->
     get block.shell.net_id >>=? fun net ->
-(*
-    Lwt_list.filter_map_s
-      (fun bytes ->
-         let hash = Operation_hash.hash_bytes [bytes] in
-         match Data_encoding.
-         Distributed_db.Operation.inject net.net_db hash bytes >>= function
-         | false -> Lwt.return_none
-         | true ->
-             if List.exists
-                 (List.exists (Operation_hash.equal hash))
-                 operations then
-               Lwt.return (Some hash)
-             else
-               Lwt.return_none)
-      injected_operations >>= fun injected_operations ->
-*)
     let validation =
-      State.Valid_block.Current.head net.net >>= fun head ->
+      protect
-      if force
+        ~on_error: begin fun err ->
-      || Fitness.compare head.fitness block.shell.fitness <= 0 then
+          Distributed_db.remove_block
+            net.net_db hash (List.length operations) >>= fun () ->
+          Lwt.return (Error err)
+        end
+        begin fun () ->
+          Chain.head net.net >>= fun head ->
+          let head_header = State.Block.header head in
+          if force ||
+             Fitness.compare head_header.shell.fitness block.shell.fitness <= 0
+          then
             fetch_block net hash
           else
-        failwith "Fitness is below the current one" in
+            failwith "Fitness is below the current one"
+      end in
     return (hash, validation) in
 
   let rec activate ?parent net =
@@ -846,11 +873,11 @@ let create_worker ?max_ttl state db =
 
   worker
 
-let new_head_watcher ({ new_head_input } : t) =
+let new_head_watcher { new_head_input } =
   Watcher.create_stream new_head_input
 
-let watcher ({ valid_block_input } : t) =
+let watcher { valid_block_input_for_net } =
-  Watcher.create_stream valid_block_input
+  Watcher.create_stream valid_block_input_for_net
 
 let global_watcher ({ valid_block_input } : worker) =
   Watcher.create_stream valid_block_input

src/node/shell/validator.mli

@@ -26,21 +26,21 @@ val get_exn: worker -> Net_id.t -> t Lwt.t
 val deactivate: t -> unit Lwt.t
 
 val net_state: t -> State.Net.t
-val net_db: t -> Distributed_db.net
+val net_db: t -> Distributed_db.net_db
 
 val fetch_block:
-  t -> Block_hash.t -> State.Valid_block.t tzresult Lwt.t
+  t -> Block_hash.t -> State.Block.t tzresult Lwt.t
 
 val inject_block:
   worker -> ?force:bool ->
-  MBytes.t -> Operation_hash.t list list ->
+  MBytes.t -> Distributed_db.operation list list ->
-  (Block_hash.t * State.Valid_block.t tzresult Lwt.t) tzresult Lwt.t
+  (Block_hash.t * State.Block.t tzresult Lwt.t) tzresult Lwt.t
 
 val prevalidator: t -> Prevalidator.t
-val test_validator: t -> (t * Distributed_db.net) option
+val test_validator: t -> (t * Distributed_db.net_db) option
 
-val watcher: t -> State.Valid_block.t Lwt_stream.t * Watcher.stopper
+val watcher: t -> State.Block.t Lwt_stream.t * Watcher.stopper
-val new_head_watcher: t -> State.Valid_block.t Lwt_stream.t * Watcher.stopper
+val new_head_watcher: t -> State.Block.t Lwt_stream.t * Watcher.stopper
-val global_watcher: worker -> State.Valid_block.t Lwt_stream.t * Watcher.stopper
+val global_watcher: worker -> State.Block.t Lwt_stream.t * Watcher.stopper
 
 val bootstrapped: t -> unit Lwt.t

src/utils/error_monad.ml

@@ -210,6 +210,17 @@ module Make() = struct
         map_s f t >>=? fun rt ->
         return (rh :: rt)
 
+  let mapi_s f l =
+    let rec mapi_s f i l =
+      match l with
+      | [] -> return []
+      | h :: t ->
+          f i h >>=? fun rh ->
+          mapi_s f (i+1) t >>=? fun rt ->
+          return (rh :: rt)
+    in
+    mapi_s f 0 l
+
   let rec map_p f l =
     match l with
     | [] ->
@@ -224,6 +235,22 @@ module Make() = struct
         | Ok _, Error exn
         | Error exn, Ok _ -> Lwt.return (Error exn)
 
+  let mapi_p f l =
+    let rec mapi_p f i l =
+      match l with
+      | [] ->
+          return []
+      | x :: l ->
+          let tx = f i x and tl = mapi_p f (i+1) l in
+          tx >>= fun x ->
+          tl >>= fun l ->
+          match x, l with
+          | Ok x, Ok l -> Lwt.return (Ok (x :: l))
+          | Error exn1, Error exn2 -> Lwt.return (Error (exn1 @ exn2))
+          | Ok _, Error exn
+          | Error exn, Ok _ -> Lwt.return (Error exn) in
+    mapi_p f 0 l
+
   let rec map2_s f l1 l2 =
     match l1, l2 with
     | [], [] -> return []

src/utils/error_monad_sig.ml

@@ -122,6 +122,8 @@ module type S = sig
   (** A {!List.map} in the monad *)
   val map_s : ('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t
   val map_p : ('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t
+  val mapi_s : (int -> 'a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t
+  val mapi_p : (int -> 'a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t
 
   (** A {!List.map2} in the monad *)
   val map2 :

test/Makefile.shared

@@ -52,11 +52,38 @@ CLIENTLIB := ${SRCDIR}/client.cmxa \
 ${MINUTILSLIB} ${UTILSLIB} ${COMPILERLIB} ${NODELIB} ${CLIENTLIB}:
 	${MAKE} -C ${SRCDIR} $@
 
-${SRCDIR}/minutils/%: ${MINUTILSLIB}
+${SRCDIR}/minutils/%.cmi: ${SRCDIR}/minutils/%.mli
-${SRCDIR}/utils/%: ${UTILSLIB}
+	${MAKE} -C ${SRCDIR} minutils.cmxa
-${SRCDIR}/compiler/%: ${COMPILERLIB}
+${SRCDIR}/minutils/%.cmx : ${SRCDIR}/minutils/%.ml
-${SRCDIR}/node/%: ${NODELIB}
+	${MAKE} -C ${SRCDIR} minutils.cmxa
-${SRCDIR}/client/%: ${CLIENTLIB}
+${SRCDIR}/utils/%.cmi: ${SRCDIR}/utils/%.mli
+	${MAKE} -C ${SRCDIR} utils.cmxa
+${SRCDIR}/utils/%.cmx : ${SRCDIR}/utils/%.ml
+	${MAKE} -C ${SRCDIR} utils.cmxa
+${SRCDIR}/compiler/%.cmi: ${SRCDIR}/compiler/%.mli
+	${MAKE} -C ${SRCDIR} compiler.cmxa
+${SRCDIR}/compiler/%.cmx : ${SRCDIR}/compiler/%.ml
+	${MAKE} -C ${SRCDIR} compiler.cmxa
+${SRCDIR}/node/db/%.cmi: ${SRCDIR}/node/db/%.mli
+	${MAKE} -C ${SRCDIR} node.cmxa
+${SRCDIR}/node/db/%.cmx : ${SRCDIR}/node/db/%.ml
+	${MAKE} -C ${SRCDIR} node.cmxa
+${SRCDIR}/node/net/%.cmi: ${SRCDIR}/node/net/%.mli
+	${MAKE} -C ${SRCDIR} node.cmxa
+${SRCDIR}/node/net/%.cmx : ${SRCDIR}/node/net/%.ml
+	${MAKE} -C ${SRCDIR} node.cmxa
+${SRCDIR}/node/shell/%.cmi: ${SRCDIR}/node/shell/%.mli
+	${MAKE} -C ${SRCDIR} node.cmxa
+${SRCDIR}/node/shell/%.cmx : ${SRCDIR}/node/shell/%.ml
+	${MAKE} -C ${SRCDIR} node.cmxa
+${SRCDIR}/node/updater/%.cmi: ${SRCDIR}/node/updater/%.mli
+	${MAKE} -C ${SRCDIR} node.cmxa
+${SRCDIR}/node/updater/%.cmx : ${SRCDIR}/node/updater/%.ml
+	${MAKE} -C ${SRCDIR} node.cmxa
+${SRCDIR}/client/%.cmi: ${SRCDIR}/client/%.mli
+	${MAKE} -C ${SRCDIR} client.cmxa
+${SRCDIR}/client/%.cmx : ${SRCDIR}/client/%.ml
+	${MAKE} -C ${SRCDIR} client.cmxa
 
 ############################################################################
 ## Generic rules
@@ -82,7 +109,7 @@ partial-clean::
 	-find . \( -name \*.cm\* -or -name \*.cmp -or -name \*.out -or -name \*~ -or -name \*.o -or -name \*.a \) -delete
 
 -include .depend
-.depend: $(shell find . -name \*.ml -or -name \*.ml)
+.depend: $(shell find . -name \*.mli -or -name \*.ml)
 	@echo OCAMLDEP "(test/$(notdir $(shell echo $$PWD)))"
 	@$(OCAMLDEP) -native $(INCLUDES) $^ > .depend
 

test/proto_alpha/Makefile

@@ -29,6 +29,15 @@ OPENED_MODULES := \
   ${CLIENT_OPENED_MODULES} \
   Environment Client_embedded_proto_alpha Tezos_context
 
+${SRCDIR}/client/embedded/alpha/_tzbuild/%.cmi: ${SRCDIR}/proto/alpha/%.mli
+	${MAKE} -C ${SRCDIR} proto/client_embedded_proto_alpha.cmxa
+${SRCDIR}/client/embedded/alpha/_tzbuild/%.cmx: ${SRCDIR}/proto/alpha/%.ml
+	${MAKE} -C ${SRCDIR} proto/client_embedded_proto_alpha.cmxa
+${SRCDIR}/client/embedded/alpha/%.cmi: ${SRCDIR}/client/embedded/alpha/%.mli
+	${MAKE} -C ${SRCDIR} client/embedded/client_alpha.cmx
+${SRCDIR}/client/embedded/alpha/%.cmx: ${SRCDIR}/client/embedded/alpha/%.ml
+	${MAKE} -C ${SRCDIR} client/embedded/client_alpha.cmx
+
 ############################################################################
 ## Transactions
 
@@ -37,11 +46,11 @@ run-test-transaction:
 	@echo
 	./test-transaction
 
-TEST_CONNECTION_IMPLS := \
+TEST_TRANSACTION_IMPLS := \
   proto_alpha_helpers.ml \
   test_transaction.ml
 
-test-transaction: ${LIB} ${TEST_CONNECTION_IMPLS:.ml=.cmx}
+test-transaction: ${LIB} ${TEST_TRANSACTION_IMPLS:.ml=.cmx}
 	@echo COMPILE $(notdir $@)
 	@${OCAMLOPT} -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^
 
@@ -56,11 +65,11 @@ run-test-origination:
 	@echo
 	./test-origination
 
-TEST_CONNECTION_IMPLS := \
+TEST_ORIGINATION_IMPLS := \
   proto_alpha_helpers.ml \
   test_origination.ml
 
-test-origination: ${LIB} ${TEST_CONNECTION_IMPLS:.ml=.cmx}
+test-origination: ${LIB} ${TEST_ORIGINATION_IMPLS:.ml=.cmx}
 	@echo COMPILE $(notdir $@)
 	@${OCAMLOPT} -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^
 
@@ -75,11 +84,11 @@ run-test-endorsement:
 	@echo
 	./test-endorsement
 
-TEST_CONNECTION_IMPLS := \
+TEST_ENDORSEMENT_IMPLS := \
   proto_alpha_helpers.ml \
   test_endorsement.ml
 
-test-endorsement: ${LIB} ${TEST_CONNECTION_IMPLS:.ml=.cmx}
+test-endorsement: ${LIB} ${TEST_ENDORSEMENT_IMPLS:.ml=.cmx}
 	@echo COMPILE $(notdir $@)
 	@${OCAMLOPT} -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^
 
@@ -94,11 +103,11 @@ run-test-vote:
 	@echo
 	./test-vote
 
-TEST_CONNECTION_IMPLS := \
+TEST_VOTE_IMPLS := \
   proto_alpha_helpers.ml \
   test_vote.ml
 
-test-vote: ${LIB} ${TEST_CONNECTION_IMPLS:.ml=.cmx}
+test-vote: ${LIB} ${TEST_VOTE_IMPLS:.ml=.cmx}
 	@echo COMPILE $(notdir $@)
 	@${OCAMLOPT} -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^
 

test/proto_alpha/proto_alpha_helpers.ml

@@ -15,7 +15,7 @@ let (//) = Filename.concat
 
 let rpc_config : Client_rpcs.config = {
   host = "localhost" ;
-  port = 18732 ;
+  port = 8192 + Random.int 8192 ;
   tls = false ;
   logger = Client_rpcs.null_logger ;
 }
@@ -476,7 +476,7 @@ module Mining = struct
       () >>=? fun unsigned_header ->
     let signed_header = Environment.Ed25519.Signature.append src_sk unsigned_header in
     Client_node_rpcs.inject_block rpc_config
-      ?force signed_header [operation_list] >>=? fun block_hash ->
+      ?force signed_header [List.map (fun h -> Client_node_rpcs.Hash h) operation_list] >>=? fun block_hash ->
     return block_hash
 
   let mine

test/shell/test_state.ml

@@ -102,81 +102,42 @@ let equal_block ?msg st1 st2 =
         Hash.Block_hash.to_hex (Block_header.hash st) in
   Assert.equal ?msg ~prn ~eq st1 st2
 
-let build_chain state tbl otbl pred names =
+let block _state ?(operations = []) (pred: State.Block.t) name
-  Lwt_list.fold_left_s
-    (fun (pred_hash, pred) name ->
-       begin
-         let oph, op, _bytes = operation name in
-         State.Operation.store state oph op >>= fun created ->
-         Assert.is_true ~msg:__LOC__ created ;
-         State.Operation.read_opt state oph >>= fun op' ->
-         equal_operation ~msg:__LOC__ (Some op) op' ;
-         State.Operation.mark_invalid state oph [] >>= fun store_invalid ->
-         Assert.is_true ~msg:__LOC__ store_invalid ;
-         Hashtbl.add otbl name (oph, Error []) ;
-         let block = block ~operations:[oph] state pred_hash pred name in
-         let hash = Block_header.hash block in
-         State.Block_header.store state hash block >>= fun created ->
-         Assert.is_true ~msg:__LOC__ created ;
-         State.Block_header.read_opt state hash >>= fun block' ->
-         equal_block ~msg:__LOC__ (Some block) block' ;
-         State.Block_header.mark_invalid state hash [] >>= fun store_invalid ->
-         Assert.is_true ~msg:__LOC__ store_invalid ;
-         Hashtbl.add tbl name (hash, block) ;
-         return (hash, block)
-       end >>= function
-       | Ok v -> Lwt.return v
-       | Error err ->
-           Error_monad.pp_print_error Format.err_formatter err ;
-           assert false)
-    pred
-    names >>= fun _ ->
-  Lwt.return ()
-
-let block _state ?(operations = []) (pred: State.Valid_block.t) name
   : Block_header.t =
   let operations_hash =
     Operation_list_list_hash.compute
       [Operation_list_hash.compute operations] in
-  let fitness = incr_fitness pred.fitness in
+  let pred_header = State.Block.shell_header pred in
-  let timestamp = incr_timestamp pred.timestamp in
+  let fitness = incr_fitness pred_header.fitness in
-  { shell = { net_id = pred.net_id ;
+  let timestamp = incr_timestamp pred_header.timestamp in
-              level = Int32.succ pred.level ;
+  { shell = { net_id = pred_header.net_id ;
-              proto_level = pred.proto_level ;
+              level = Int32.succ pred_header.level ;
-              predecessor = pred.hash ;
+              proto_level = pred_header.proto_level ;
+              predecessor = State.Block.hash pred ;
               timestamp ; operations_hash ; fitness } ;
     proto = MBytes.of_string name ;
   }
 
-let build_valid_chain state tbl vtbl otbl pred names =
+let build_valid_chain state vtbl pred names =
   Lwt_list.fold_left_s
     (fun pred name ->
        begin
          let oph, op, _bytes = operation name in
-         State.Operation.store state oph op >>= fun created ->
-         Assert.is_true ~msg:__LOC__ created ;
-         State.Operation.read_opt state oph >>= fun op' ->
-         equal_operation ~msg:__LOC__ (Some op) op' ;
-         Hashtbl.add otbl name (oph, Ok op) ;
          let block = block state ~operations:[oph] pred name in
-         let hash = Tezos_data.Block_header.hash block in
+         let hash = Block_header.hash block in
-         State.Block_header.store state hash block >>= fun created ->
+         let pred_header = State.Block.header pred in
-         Assert.is_true ~msg:__LOC__ created ;
+         State.Block.context pred >>= fun predecessor_context ->
-         State.Operation_list.store_all state hash [[oph]] >>= fun () ->
-         State.Block_header.read_opt state hash >>= fun block' ->
-         equal_block ~msg:__LOC__ (Some block) block' ;
-         Hashtbl.add tbl name (hash, block) ;
          begin
            Proto.begin_application
-             ~predecessor_context: pred.context
+             ~predecessor_context
-             ~predecessor_timestamp: pred.timestamp
+             ~predecessor_timestamp: pred_header.shell.timestamp
-             ~predecessor_fitness: pred.fitness
+             ~predecessor_fitness: pred_header.shell.fitness
              block >>=? fun vstate ->
            (* no operations *)
            Proto.finalize_block vstate
          end >>=? fun ctxt ->
-         State.Valid_block.store state hash ctxt >>=? fun _vblock ->
+         State.Block.store state block [[op]] ctxt >>=? fun _vblock ->
-         State.Valid_block.read state hash >>=? fun vblock ->
+         State.Block.read state hash >>=? fun vblock ->
          Hashtbl.add vtbl name vblock ;
          return vblock
        end >>= function
@@ -189,63 +150,31 @@ let build_valid_chain state tbl vtbl otbl pred names =
   Lwt.return ()
 
 let build_example_tree net =
-  let tbl = Hashtbl.create 23 in
   let vtbl = Hashtbl.create 23 in
-  let otbl = Hashtbl.create 23 in
+  Chain.genesis net >>= fun genesis ->
-  State.Valid_block.Current.genesis net >>= fun genesis ->
-  State.Block_header.read_exn net genesis.hash >>= fun genesis_header ->
   Hashtbl.add vtbl "Genesis" genesis ;
-  Hashtbl.add tbl "Genesis" (genesis.hash, genesis_header ) ;
   let chain = [ "A1" ; "A2" ; "A3" ; "A4" ; "A5" ; "A6" ; "A7" ; "A8" ] in
-  build_valid_chain net tbl vtbl otbl genesis chain >>= fun () ->
+  build_valid_chain net vtbl genesis chain >>= fun () ->
   let a3 = Hashtbl.find vtbl "A3" in
   let chain = [ "B1" ; "B2" ; "B3" ; "B4" ; "B5" ; "B6" ; "B7" ; "B8" ] in
-  build_valid_chain net tbl vtbl otbl a3 chain >>= fun () ->
+  build_valid_chain net vtbl a3 chain >>= fun () ->
-  let b7 = Hashtbl.find tbl "B7" in
+  Lwt.return vtbl
-  let chain = [ "C1" ; "C2" ; "C3" ; "C4" ; "C5" ; "C6" ; "C7" ; "C8" ] in
-  build_chain net tbl otbl b7 chain >>= fun () ->
-  let pending_op = "PP" in
-  let oph, op, _bytes = operation pending_op in
-  State.Operation.store net oph op >>= fun _ ->
-  State.Operation.read_opt net oph >>= fun op' ->
-  equal_operation ~msg:__LOC__ (Some op) op' ;
-  Hashtbl.add otbl pending_op (oph, Ok op) ;
-  Lwt.return (tbl, vtbl, otbl)
 
 type state = {
-  block: (string, Block_hash.t * Block_header.t) Hashtbl.t ;
+  vblock: (string, State.Block.t) Hashtbl.t ;
-  operation: (string, Operation_hash.t * Operation.t tzresult) Hashtbl.t ;
-  vblock: (string, State.Valid_block.t) Hashtbl.t ;
   state: State.t ;
   net: State.Net.t ;
   init: unit -> State.t tzresult Lwt.t;
 }
 
-let block s = Hashtbl.find s.block
 let vblock s = Hashtbl.find s.vblock
-let operation s = Hashtbl.find s.operation
 
 exception Found of string
-let rev_find s h =
-  try
-    Hashtbl.iter (fun k (bh,_) ->
-        if Block_hash.equal bh h then raise (Found k))
-      s.block ;
-    Format.asprintf "genesis(%a)" Block_hash.pp_short h
-  with Found s -> s
-
-let blocks s =
-  Hashtbl.fold (fun k v acc -> (k,v) :: acc) s.block []
-  |> List.sort Pervasives.compare
 
 let vblocks s =
   Hashtbl.fold (fun k v acc -> (k,v) :: acc) s.vblock []
   |> List.sort Pervasives.compare
 
-let operations s =
-  Hashtbl.fold (fun k v acc -> (k,v) :: acc) s.operation []
-  |> List.sort Pervasives.compare
-
 let wrap_state_init f base_dir =
   begin
     let store_root = base_dir // "store" in
@@ -257,81 +186,36 @@ let wrap_state_init f base_dir =
         () in
     init () >>=? fun state ->
     State.Net.create state genesis >>= fun net ->
-    build_example_tree net >>= fun (block, vblock, operation) ->
+    build_example_tree net >>= fun vblock ->
-    f { state ; net ; block ; vblock ; operation ; init } >>=? fun () ->
+    f { state ; net ; vblock ; init } >>=? fun () ->
     return ()
   end
 
 let test_init (_ : state) =
   return ()
 
-let test_read_operation (s: state) =
-  Lwt_list.iter_s (fun (name, (oph, op)) ->
-      State.Operation.invalid s.net oph >>= function
-      | Some err ->
-          begin match op with
-            | Ok _ ->
-                Assert.fail_msg "Incorrect invalid operation read %s" name
-            | Error e ->
-                if e <> err then
-                  Assert.fail_msg "Incorrect operation read %s" name ;
-                Lwt.return_unit
-          end
-      | None ->
-          State.Operation.read_opt s.net oph >>= function
-          | None ->
-              Assert.fail_msg "Cannot read block %s" name
-          | Some data ->
-              begin match op with
-                | Error _ ->
-                    Assert.fail_msg "Incorrect valid operation read %s" name
-                | Ok op ->
-                    if op.Operation.proto <> data.proto then
-                      Assert.fail_msg "Incorrect operation read %s %s" name
-                        (MBytes.to_string data.Operation.proto) ;
-                    Lwt.return_unit
-              end)
-    (operations s) >>= fun () ->
-  return ()
-
 
 
 (****************************************************************************)
 
-(** State. *)
+(** State.Block.read *)
 
 let test_read_block (s: state) =
-  Lwt_list.iter_s (fun (name, (hash, block)) ->
+  Lwt_list.iter_s (fun (name, vblock) ->
-      begin
+      let hash = State.Block.hash vblock in
-        State.Block_header.read_opt s.net hash >>= function
+      State.Block.read s.net hash >>= function
-        | None ->
-            Assert.fail_msg "Cannot read block %s" name
-        | Some block' ->
-            if not (Block_header.equal block block') then
-              Assert.fail_msg "Error while reading block %s" name ;
-            Lwt.return_unit
-      end >>= fun () ->
-      let vblock =
-        try Some (vblock s name)
-        with Not_found -> None in
-      State.Valid_block.read s.net hash >>= function
       | Error _ ->
-          if vblock <> None then
+          Assert.fail_msg "Error while reading valid block %s" name
-            Assert.fail_msg "Error while reading valid block %s" name ;
-          Lwt.return_unit
       | Ok _vblock' ->
-          match vblock with
+          (* FIXME COMPARE read operations ??? *)
-          | None ->
-              Assert.fail_msg "Error while reading invalid block %s" name
-          | Some _vblock ->
           Lwt.return_unit
-    ) (blocks s) >>= fun () ->
+    ) (vblocks s) >>= fun () ->
   return ()
 
 
 (****************************************************************************)
 
-(** State.path *)
+(** Chain_traversal.path *)
 
 let rec compare_path p1 p2 = match p1, p2 with
   | [], [] -> true
@@ -340,32 +224,12 @@ let rec compare_path p1 p2 = match p1, p2 with
 
 let test_path (s: state) =
   let check_path h1 h2 p2 =
-    State.Block_header.Helpers.path s.net (fst @@ block s h1) (fst @@ block s h2) >>= function
+    Chain_traversal.path (vblock s h1) (vblock s h2) >>= function
-    | Error _ ->
-        Assert.fail_msg "cannot compute path %s -> %s" h1 h2
-    | Ok p1 ->
-        let p1 = List.map (fun b -> fst b) p1 in
-        let p2 = List.map (fun b -> fst (block s b)) p2 in
-        if not (compare_path p1 p2) then
-          Assert.fail_msg "bad path %s -> %s" h1 h2 ;
-        Lwt.return_unit in
-  check_path "Genesis" "Genesis" [] >>= fun () ->
-  check_path "A1" "A1" [] >>= fun () ->
-  check_path "A2" "A6" ["A3"; "A4"; "A5"; "A6"] >>= fun () ->
-  check_path "B2" "B6" ["B3"; "B4"; "B5"; "B6"] >>= fun () ->
-  check_path "A1" "B3" ["A2"; "A3"; "B1"; "B2"; "B3"] >>= fun () ->
-  check_path "A1" "C2" ["A2"; "A3"; "B1"; "B2"; "B3" ; "B4" ;
-                        "B5" ; "B6" ; "B7" ; "C1" ; "C2" ] >>= fun () ->
-  return ()
-
-let test_valid_path (s: state) =
-  let check_path h1 h2 p2 =
-    State.Valid_block.Helpers.path s.net (vblock s h1) (vblock s h2) >>= function
     | None ->
         Assert.fail_msg "cannot compute path %s -> %s" h1 h2 ;
-    | Some (p: State.Valid_block.t list) ->
+    | Some (p: State.Block.t list) ->
-        let p = List.map (fun b -> b.State.Valid_block.hash) p in
+        let p = List.map State.Block.hash p in
-        let p2 = List.map (fun b -> (vblock s b).hash) p2 in
+        let p2 = List.map (fun b -> State.Block.hash (vblock s b)) p2 in
         if not (compare_path p p2) then
           Assert.fail_msg "bad path %s -> %s" h1 h2 ;
         Lwt.return_unit in
@@ -379,107 +243,59 @@ let test_valid_path (s: state) =
 
 (****************************************************************************)
 
-(** State.ancestor *)
+(** Chain_traversal.common_ancestor *)
 
 let test_ancestor s =
   let check_ancestor h1 h2 expected =
-    State.Block_header.Helpers.common_ancestor
+    Chain_traversal.common_ancestor
-      s.net (fst @@ block s h1) (fst @@ block s h2) >>= function
+      (vblock s h1) (vblock s h2) >>= fun a ->
-    | Error _ ->
+    if not (Block_hash.equal (State.Block.hash a) (State.Block.hash expected)) then
-        Assert.fail_msg "Cannot compure ancestor for %s %s" h1 h2 ;
-    | Ok (a, _) ->
-        if not (Block_hash.equal a (fst expected)) then
-          Assert.fail_msg
-            "bad ancestor %s %s: found %s, expected %s"
-            h1 h2 (rev_find s a) (rev_find s @@ fst expected) ;
-        Lwt.return_unit in
-  let check_valid_ancestor h1 h2 expected =
-    State.Valid_block.Helpers.common_ancestor
-      s.net (vblock s h1) (vblock s h2) >>= fun a ->
-    if not (Block_hash.equal a.hash expected.State.Valid_block.hash) then
       Assert.fail_msg "bad ancestor %s %s" h1 h2 ;
     Lwt.return_unit in
-  check_ancestor "Genesis" "Genesis" (block s "Genesis") >>= fun () ->
+  check_ancestor "Genesis" "Genesis" (vblock s "Genesis") >>= fun () ->
-  check_ancestor "Genesis" "A3" (block s "Genesis") >>= fun () ->
+  check_ancestor "Genesis" "A3" (vblock s "Genesis") >>= fun () ->
-  check_ancestor "A3" "Genesis" (block s "Genesis") >>= fun () ->
+  check_ancestor "A3" "Genesis" (vblock s "Genesis") >>= fun () ->
-  check_ancestor "A1" "A1" (block s "A1") >>= fun () ->
+  check_ancestor "A1" "A1" (vblock s "A1") >>= fun () ->
-  check_ancestor "A1" "A3" (block s "A1") >>= fun () ->
+  check_ancestor "A1" "A3" (vblock s "A1") >>= fun () ->
-  check_ancestor "A3" "A1" (block s "A1") >>= fun () ->
+  check_ancestor "A3" "A1" (vblock s "A1") >>= fun () ->
-  check_ancestor "A6" "B6" (block s "A3") >>= fun () ->
+  check_ancestor "A6" "B6" (vblock s "A3") >>= fun () ->
-  check_ancestor "B6" "A6" (block s "A3") >>= fun () ->
+  check_ancestor "B6" "A6" (vblock s "A3") >>= fun () ->
-  check_ancestor "A4" "B1" (block s "A3") >>= fun () ->
+  check_ancestor "A4" "B1" (vblock s "A3") >>= fun () ->
-  check_ancestor "B1" "A4" (block s "A3") >>= fun () ->
+  check_ancestor "B1" "A4" (vblock s "A3") >>= fun () ->
-  check_ancestor "A3" "B1" (block s "A3") >>= fun () ->
+  check_ancestor "A3" "B1" (vblock s "A3") >>= fun () ->
-  check_ancestor "B1" "A3" (block s "A3") >>= fun () ->
+  check_ancestor "B1" "A3" (vblock s "A3") >>= fun () ->
-  check_ancestor "A2" "B1" (block s "A2") >>= fun () ->
+  check_ancestor "A2" "B1" (vblock s "A2") >>= fun () ->
-  check_ancestor "B1" "A2" (block s "A2") >>= fun () ->
+  check_ancestor "B1" "A2" (vblock s "A2") >>= fun () ->
-  check_ancestor "C4" "B8" (block s "B7") >>= fun () ->
-  check_ancestor "B8" "C4" (block s "B7") >>= fun () ->
-  check_ancestor "C4" "A8" (block s "A3") >>= fun () ->
-  check_ancestor "A8" "C4" (block s "A3") >>= fun () ->
-  check_valid_ancestor "A6" "B6" (vblock s "A3") >>= fun () ->
-  check_valid_ancestor "B6" "A6" (vblock s "A3") >>= fun () ->
-  check_valid_ancestor "A4" "B1" (vblock s "A3") >>= fun () ->
-  check_valid_ancestor "B1" "A4" (vblock s "A3") >>= fun () ->
-  check_valid_ancestor "A3" "B1" (vblock s "A3") >>= fun () ->
-  check_valid_ancestor "B1" "A3" (vblock s "A3") >>= fun () ->
-  check_valid_ancestor "A2" "B1" (vblock s "A2") >>= fun () ->
-  check_valid_ancestor "B1" "A2" (vblock s "A2") >>= fun () ->
   return ()
 
 
 (****************************************************************************)
 
-(** State.locator *)
+(** Chain_traversal.block_locator *)
 
 let test_locator s =
   let check_locator h1 expected =
-    State.Block_header.Helpers.block_locator
+    Chain_traversal.block_locator
-      s.net (List.length expected) (fst @@ block s h1) >>= function
+      (vblock s h1) (List.length expected) >>= fun l ->
-    | Error _ ->
-        Assert.fail_msg "Cannot compute locator for %s" h1
-    | Ok l ->
     if List.length l <> List.length expected then
       Assert.fail_msg
         "Invalid locator length %s (found: %d, expected: %d)"
         h1 (List.length l) (List.length expected) ;
     List.iter2
       (fun h h2 ->
-             if not (Block_hash.equal h (fst @@ block s h2)) then
+         if not (Block_hash.equal h (State.Block.hash @@ vblock s h2)) then
-               Assert.fail_msg "Invalid locator %s (expectd: %s)" h1 h2)
-          l expected;
-        Lwt.return_unit in
-  let check_valid_locator h1 expected =
-    State.Valid_block.Helpers.block_locator
-      s.net (List.length expected) (vblock s h1) >>= fun l ->
-    if List.length l <> List.length expected then
-      Assert.fail_msg
-        "Invalid locator length %s (found: %d, expected: %d)"
-        h1 (List.length l) (List.length expected) ;
-    List.iter2
-      (fun h h2 ->
-         if not (Block_hash.equal h (fst @@ block s h2)) then
            Assert.fail_msg "Invalid locator %s (expectd: %s)" h1 h2)
       l expected ;
     Lwt.return_unit in
-  check_locator "A8" ["A8";"A7";"A6";"A5";"A4";"A3";"A2";"A1"] >>= fun () ->
+  check_locator "A8" ["A8";"A7";"A6";"A5";"A4";"A3";"A2"] >>= fun () ->
-  check_locator "B8"
+  check_locator "B8" ["B8";"B7";"B6";"B5";"B4";"B3";"B2";"B1";"A3"] >>= fun () ->
-    ["B8";"B7";"B6";"B5";"B4";"B3";"B2";"B1";"A3"] >>= fun () ->
+  check_locator "B8" ["B8";"B7";"B6";"B5";"B4"] >>= fun () ->
-  check_locator "C8"
-    ["C8";"C7";"C6";"C5";"C4";"C3";"C2";"C1";
-     "B7";"B6";"B4";"B2";"A3";"A1"] >>= fun () ->
-  check_locator "C8" ["C8";"C7";"C6";"C5";"C4"] >>= fun () ->
-  check_valid_locator "A8"
-    ["A8";"A7";"A6";"A5";"A4";"A3";"A2"] >>= fun () ->
-  check_valid_locator "B8"
-    ["B8";"B7";"B6";"B5";"B4";"B3";"B2";"B1";"A3"] >>= fun () ->
-  check_valid_locator "B8" ["B8";"B7";"B6";"B5";"B4"] >>= fun () ->
   return ()
 
 
 (****************************************************************************)
 
-(** State.known_heads *)
+(** Chain.known_heads *)
 
 let compare s name heads l =
   if List.length heads <> List.length l then
@@ -488,39 +304,39 @@ let compare s name heads l =
       name (List.length heads) (List.length l) ;
   List.iter
     (fun bname ->
-       let hash = (vblock s bname).hash in
+       let hash = State.Block.hash (vblock s bname) in
-       if not (List.exists (fun b -> Block_hash.equal hash b.State.Valid_block.hash) heads) then
+       if not (List.exists (fun b -> Block_hash.equal hash (State.Block.hash b)) heads) then
          Assert.fail_msg "missing block in known_heads (%s: %s)" name bname)
     l
 
 let test_known_heads s =
-  State.Valid_block.known_heads s.net >>= fun heads ->
+  Chain.known_heads s.net >>= fun heads ->
   compare s "initial" heads ["A8";"B8"] ;
   return ()
 
 
 (****************************************************************************)
 
-(** State.head/set_head *)
+(** Chain.head/set_head *)
 
 let test_head s =
-  State.Valid_block.Current.head s.net >>= fun head ->
+  Chain.head s.net >>= fun head ->
-  if not (Block_hash.equal head.hash genesis_block) then
+  if not (Block_hash.equal (State.Block.hash head) genesis_block) then
     Assert.fail_msg "unexpected head" ;
-  State.Valid_block.Current.set_head s.net (vblock s "A6") >>= fun _ ->
+  Chain.set_head s.net (vblock s "A6") >>= fun _ ->
-  State.Valid_block.Current.head s.net >>= fun head ->
+  Chain.head s.net >>= fun head ->
-  if not (Block_hash.equal head.hash (vblock s "A6").hash) then
+  if not (Block_hash.equal (State.Block.hash head) (State.Block.hash @@ vblock s "A6")) then
     Assert.fail_msg "unexpected head" ;
   return ()
 
 
 (****************************************************************************)
 
-(** State.mem *)
+(** Chain.mem *)
 
 let test_mem s =
   let mem s x =
-    State.Valid_block.Current.mem s.net (fst @@ block s x) in
+    Chain.mem s.net (State.Block.hash @@ vblock s x) in
   let test_mem s x =
     mem s x >>= function
     | true -> Lwt.return_unit
@@ -535,21 +351,21 @@ let test_mem s =
   test_not_mem s "B1" >>= fun () ->
   test_not_mem s "B6" >>= fun () ->
   test_not_mem s "B8" >>= fun () ->
-  State.Valid_block.Current.set_head s.net (vblock s "A8") >>= fun _ ->
+  Chain.set_head s.net (vblock s "A8") >>= fun _ ->
   test_mem s "A3" >>= fun () ->
   test_mem s "A6" >>= fun () ->
   test_mem s "A8" >>= fun () ->
   test_not_mem s "B1" >>= fun () ->
   test_not_mem s "B6" >>= fun () ->
   test_not_mem s "B8" >>= fun () ->
-  State.Valid_block.Current.set_head s.net (vblock s "A6") >>= fun _ ->
+  Chain.set_head s.net (vblock s "A6") >>= fun _ ->
   test_mem s "A3" >>= fun () ->
   test_mem s "A6" >>= fun () ->
   test_not_mem s "A8" >>= fun () ->
   test_not_mem s "B1" >>= fun () ->
   test_not_mem s "B6" >>= fun () ->
   test_not_mem s "B8" >>= fun () ->
-  State.Valid_block.Current.set_head s.net (vblock s "B6") >>= fun _ ->
+  Chain.set_head s.net (vblock s "B6") >>= fun _ ->
   test_mem s "A3" >>= fun () ->
   test_not_mem s "A4" >>= fun () ->
   test_not_mem s "A6" >>= fun () ->
@@ -557,7 +373,7 @@ let test_mem s =
   test_mem s "B1" >>= fun () ->
   test_mem s "B6" >>= fun () ->
   test_not_mem s "B8" >>= fun () ->
-  State.Valid_block.Current.set_head s.net (vblock s "B8") >>= fun _ ->
+  Chain.set_head s.net (vblock s "B8") >>= fun _ ->
   test_mem s "A3" >>= fun () ->
   test_not_mem s "A4" >>= fun () ->
   test_not_mem s "A6" >>= fun () ->
@@ -570,28 +386,53 @@ let test_mem s =
 
 (****************************************************************************)
 
-(** State.new *)
+(** Chain_traversal.new_blocks *)
 
-let test_new s =
+let test_new_blocks s =
-  let test s h expected =
+  let test s head h expected_ancestor expected =
-    State.Valid_block.Helpers.block_locator s.net 50 (vblock s h) >>= fun loc ->
+    let to_block = vblock s head
-    State.Valid_block.Current.find_new s.net loc (List.length expected) >>= function
+    and from_block = vblock s h in
-    | Error _ ->
+    Chain_traversal.new_blocks ~from_block ~to_block >>= fun (ancestor, blocks) ->
-        Assert.fail_msg "Failed to compute new blocks %s" h
+    if not (Block_hash.equal (State.Block.hash ancestor) (State.Block.hash @@ vblock s expected_ancestor)) then
-    | Ok blocks ->
+      Assert.fail_msg "Invalid locator %s (expected: %s)" h expected_ancestor ;
     if List.length blocks <> List.length expected then
       Assert.fail_msg
         "Invalid locator length %s (found: %d, expected: %d)"
         h (List.length blocks) (List.length expected) ;
     List.iter2
       (fun h1 h2 ->
-             if not (Block_hash.equal h1 (vblock s h2).hash) then
+         if not (Block_hash.equal (State.Block.hash h1) (State.Block.hash @@ vblock s h2)) then
+           Assert.fail_msg "Invalid locator %s (expected: %s)" h h2)
+      blocks expected ;
+    Lwt.return_unit
+  in
+  test s "A6" "A6" "A6" [] >>= fun () ->
+  test s "A8" "A6" "A6" ["A7";"A8"] >>= fun () ->
+  test s "A8" "B7" "A3" ["A4";"A5";"A6";"A7";"A8"] >>= fun () ->
+  return ()
+
+
+(****************************************************************************)
+
+(** Chain.find_new *)
+
+let test_find_new s =
+  let test s h expected =
+    Chain_traversal.block_locator (vblock s h) 50 >>= fun loc ->
+    Chain.find_new s.net loc (List.length expected) >>= fun blocks ->
+    if List.length blocks <> List.length expected then
+      Assert.fail_msg
+        "Invalid locator length %s (found: %d, expected: %d)"
+        h (List.length blocks) (List.length expected) ;
+    List.iter2
+      (fun h1 h2 ->
+         if not (Block_hash.equal h1 (State.Block.hash @@ vblock s h2)) then
            Assert.fail_msg "Invalid locator %s (expected: %s)" h h2)
       blocks expected ;
     Lwt.return_unit
   in
   test s "A6" [] >>= fun () ->
-  State.Valid_block.Current.set_head s.net (vblock s "A8") >>= fun _ ->
+  Chain.set_head s.net (vblock s "A8") >>= fun _ ->
   test s "A6" ["A7";"A8"] >>= fun () ->
   test s "A6" ["A7"] >>= fun () ->
   test s "B4" ["A4"] >>= fun () ->
@@ -601,74 +442,18 @@ let test_new s =
 
 (****************************************************************************)
 
-(** State.mempool *)
-
-let compare s name mempool l =
-  let mempool_sz = Operation_hash.Set.cardinal mempool in
-  let l_sz = List.length l in
-  if mempool_sz <> l_sz then
-    Assert.fail
-      (string_of_int mempool_sz)
-      (string_of_int l_sz)
-      "unexpected mempool size (%s)" name ;
-  List.iter
-    (fun oname ->
-       try
-         let oph = fst @@ operation s oname  in
-         if not (Operation_hash.Set.mem oph mempool) then
-           Assert.fail_msg "missing operation in mempool (%s: %s)" name oname
-       with Not_found ->
-         Assert.fail_msg "Read value not found in mempool (%s: %s)" name oname)
-    l
-
-let test_mempool s =
-  State.Operation.list_pending s.net >>= fun mempool ->
-  compare s "initial" mempool
-    ["PP";
-     "A1" ; "A2" ; "A3" ; "A4" ; "A5" ; "A6" ; "A7" ; "A8" ;
-     "B1" ; "B2" ; "B3" ; "B4" ; "B5" ; "B6" ; "B7" ; "B8" ] ;
-  State.Valid_block.Current.set_head s.net (vblock s "A8") >>= fun _ ->
-  State.Operation.list_pending s.net >>= fun mempool ->
-  compare s "A8" mempool
-    ["PP"; "B1" ; "B2" ; "B3" ; "B4" ; "B5" ; "B6" ; "B7" ; "B8" ] ;
-  State.Valid_block.Current.set_head s.net (vblock s "A6") >>= fun _ ->
-  State.Operation.list_pending s.net >>= fun mempool ->
-  compare s "A6" mempool
-    ["PP";
-     "A7" ; "A8" ;
-     "B1" ; "B2" ; "B3" ; "B4" ; "B5" ; "B6" ; "B7" ; "B8" ] ;
-  State.Valid_block.Current.set_head s.net (vblock s "B6") >>= fun _ ->
-  State.Operation.list_pending s.net >>= fun mempool ->
-  compare s "B6" mempool
-    ["PP";
-     "A4" ; "A5" ; "A6" ; "A7" ; "A8" ;
-     "B7" ; "B8" ] ;
-  State.Operation.mark_invalid s.net (fst @@ operation s "PP") [] >>= fun rm_status ->
-  Assert.is_true ~msg:__LOC__ rm_status ;
-  State.Operation.mark_invalid s.net (fst @@ operation s "PP") [] >>= fun rm_status ->
-  Assert.is_false ~msg:__LOC__ rm_status ;
-  State.Operation.list_pending s.net >>= fun mempool ->
-  compare s "B6.remove" mempool
-    ["A4" ; "A5" ; "A6" ; "A7" ; "A8" ;
-     "B7" ; "B8" ] ;
-  return ()
-
-(****************************************************************************)
-
 
 let tests : (string * (state -> unit tzresult Lwt.t)) list = [
   "init", test_init ;
-  "read_operation", test_read_operation;
   "read_block", test_read_block ;
   "path", test_path ;
-  "valid_path", test_valid_path ;
   "ancestor", test_ancestor ;
   "locator", test_locator ;
   "known_heads", test_known_heads ;
   "head", test_head ;
   "mem", test_mem ;
-  "new", test_new ;
+  "new_blocks", test_new_blocks ;
-  "mempool", test_mempool;
+  "find_new", test_find_new ;
 ]
 
 let () =

test/shell/test_store.ml

@@ -70,21 +70,6 @@ let oph1 = Tezos_data.Operation.hash op1
 let op2 = make (MBytes.of_string "Kivu")
 let oph2 = Tezos_data.Operation.hash op2
 
-let check_operation s h b =
-  Operation.Contents.read (s, h) >>= function
-  | Ok b' when Tezos_data.Operation.equal b b' -> Lwt.return_unit
-  | _ ->
-      Printf.eprintf "Error while reading operation %s\n%!"
-        (Operation_hash.to_hex h);
-      exit 1
-
-let test_operation s =
-  let s = Store.Net.get s net_id in
-  let s = Store.Operation.get s in
-  Operation.Contents.store (s, oph1) op1 >>= fun () ->
-  Operation.Contents.store (s, oph2) op2 >>= fun () ->
-  check_operation s oph1 op1 >>= fun () ->
-  check_operation s oph2 op2
 
 (** Block store *)
 
@@ -92,7 +77,8 @@ let lolblock ?(operations = []) header =
   let operations_hash =
     Operation_list_list_hash.compute
       [Operation_list_hash.compute operations] in
-  { Tezos_data.Block_header.shell =
+  { Store.Block.header =
+      { Block_header.shell =
           { timestamp = Time.of_seconds (Random.int64 1500L) ;
             level = 0l ; (* dummy *)
             proto_level = 0 ; (* dummy *)
@@ -101,48 +87,57 @@ let lolblock ?(operations = []) header =
             fitness = [MBytes.of_string @@ string_of_int @@ String.length header;
                        MBytes.of_string @@ string_of_int @@ 12] } ;
         proto = MBytes.of_string header ;
+      } ;
+    operation_list_count = Random.int 32 ;
+    message = ""
   }
 
 let b1 = lolblock "Blop !"
-let bh1 = Tezos_data.Block_header.hash b1
+let bh1 = Block_header.hash b1.header
 let b2 = lolblock "Tacatlopo"
-let bh2 = Tezos_data.Block_header.hash b2
+let bh2 = Block_header.hash b2.header
 let b3 = lolblock ~operations:[oph1;oph2] "Persil"
-let bh3 = Tezos_data.Block_header.hash b3
+let bh3 = Block_header.hash b3.header
 let bh3' =
   let raw = Bytes.of_string @@ Block_hash.to_string bh3 in
   Bytes.set raw 31 '\000' ;
   Bytes.set raw 30 '\000' ;
   Block_hash.of_string_exn @@ Bytes.to_string raw
 
+let equal (b1: Store.Block.contents) (b2: Store.Block.contents) =
+  Block_header.equal b1.header b2.header &&
+  b1.message = b2.message &&
+  b1.operation_list_count = b2.operation_list_count
+
 let check_block s h b =
-  Block_header.Contents.read_opt (s, h) >>= function
+  Store.Block.Contents.read (s, h) >>= function
-  | Some b' when Tezos_data.Block_header.equal b b' -> Lwt.return_unit
+  | Ok b' when equal b b' -> Lwt.return_unit
-  | Some _ ->
+  | Ok _ ->
       Printf.eprintf "Error while reading block %s\n%!" (Block_hash.to_hex h);
       exit 1
-  | None ->
+  | Error err ->
-      Printf.eprintf "Error while reading block %s (not found)\n%!"
+      Format.eprintf "@[Error while reading block %s:@ %a\n@]"
-        (Block_hash.to_hex h);
+        (Block_hash.to_hex h)
+        pp_print_error err;
       exit 1
 
 let test_block s =
   let s = Store.Net.get s net_id in
-  let s = Store.Block_header.get s in
+  let s = Store.Block.get s in
-  Block_header.Contents.store (s, bh1) b1 >>= fun () ->
+  Block.Contents.store (s, bh1) b1 >>= fun () ->
-  Block_header.Contents.store (s, bh2) b2 >>= fun () ->
+  Block.Contents.store (s, bh2) b2 >>= fun () ->
-  Block_header.Contents.store (s, bh3) b3 >>= fun () ->
+  Block.Contents.store (s, bh3) b3 >>= fun () ->
   check_block s bh1 b1 >>= fun () ->
   check_block s bh2 b2 >>= fun () ->
   check_block s bh3 b3
 
 let test_expand s =
   let s = Store.Net.get s net_id in
-  let s = Store.Block_header.get s in
+  let s = Store.Block.get s in
-  Block_header.Contents.store (s, bh1) b1 >>= fun () ->
+  Block.Contents.store (s, bh1) b1 >>= fun () ->
-  Block_header.Contents.store (s, bh2) b2 >>= fun () ->
+  Block.Contents.store (s, bh2) b2 >>= fun () ->
-  Block_header.Contents.store (s, bh3) b3 >>= fun () ->
+  Block.Contents.store (s, bh3) b3 >>= fun () ->
-  Block_header.Contents.store (s, bh3') b3 >>= fun () ->
+  Block.Contents.store (s, bh3') b3 >>= fun () ->
   Base58.complete (Block_hash.to_short_b58check bh1) >>= fun res ->
   Assert.equal_string_list ~msg:__LOC__ res [Block_hash.to_b58check bh1] ;
   Base58.complete (Block_hash.to_short_b58check bh2) >>= fun res ->
@@ -434,10 +429,8 @@ let tests_raw : (string * (Raw_store.t -> unit Lwt.t)) list = [
 
 ]
 
-
 let tests : (string * (Store.t -> unit Lwt.t)) list = [
   "expand", test_expand ;
-  "operation", test_operation ;
   "block", test_block ;
 ]
 

test/utils/Makefile

@@ -9,7 +9,7 @@ TESTS := \
 
 include ../Makefile.shared
 
-SOURCE_DIRECTORIES := ${UTILS_SOURCE_DIRECTORIES} ../lib
+SOURCE_DIRECTORIES := ${COMPILER_SOURCE_DIRECTORIES} ../lib
 
 LIB := ${MINUTILSLIB} ${UTILSLIB} ${TESTLIB}