Update to irmin.1.3

scripts/install_build_deps.sh

@@ -45,13 +45,10 @@ set -e
 set -x
 
 if "$pin"; then
-    opam pin --yes remove --no-action --dev-repo ocplib-resto || true
     opam pin --yes add --no-action --dev-repo sodium
     opam pin --yes add --no-action --dev-repo ocp-ocamlres
     opam pin --yes add --no-action --dev-repo ocplib-json-typed
     opam pin --yes add --no-action --dev-repo ocplib-resto
-    opam pin --yes add --no-action ocp-build 1.99.18-beta ## TMP fix
-    opam pin add typerex-build --dev --no-action
     ## Force opam to take account of the new `tezos-deps.opam`
     opam pin --yes remove tezos-deps
     opam pin --yes add --no-action tezos-deps $src_dir/src
@@ -63,9 +60,5 @@ if "$depext"; then
 fi
 
 if "$install"; then
-    if opam list --installed tezos-deps ; then
+    opam install tezos-deps
-	opam upgrade $(opam list -s --required-by tezos-deps | grep -ve '^ocaml *$')
-    else
-	opam install tezos-deps
-    fi
 fi

src/.merlin

@@ -32,7 +32,10 @@ PKG cstruct
 PKG dynlink
 PKG ezjsonm
 PKG git
+PKG git-unix
 PKG ipv6-multicast
+PKG irmin-unix
+PKG irmin-git
 PKG irmin
 PKG lwt
 PKG magic-mime

src/Makefile.files

@@ -207,16 +207,15 @@ NODE_LIB_INTFS := \
   node/net/p2p.mli \
   node/net/RPC_server.mli \
   \
+  node/db/persist.mli \
+  node/db/context.mli \
+  \
   node/db/store_sigs.mli \
   node/db/raw_store.mli \
   node/db/store_sigs.mli \
   node/db/store_helpers.mli \
   node/db/store.mli \
   \
-  node/db/ir_funview.mli \
-  node/db/persist.mli \
-  node/db/context.mli \
-  \
   node/updater/protocol_sigs.mli \
   node/updater/updater.mli \
   node/updater/proto_environment.mli \
@@ -254,15 +253,14 @@ FULL_NODE_LIB_IMPLS := \
   \
   node/net/RPC_server.ml \
   \
+  node/db/persist.ml \
+  node/db/context.ml \
+  \
   node/db/raw_store.ml \
   node/db/store_sigs.mli \
   node/db/store_helpers.ml \
   node/db/store.ml \
   \
-  node/db/ir_funview.ml \
-  node/db/persist.ml \
-  node/db/context.ml \
-  \
   node/updater/protocol_sigs.mli \
   node/updater/updater.ml \
   node/updater/environment.ml \
@@ -312,7 +310,7 @@ NODE_PACKAGES := \
   dynlink \
   git \
   ipv6-multicast \
-  irmin.unix \
+  irmin-unix \
   ocplib-resto.directory \
   ssl \
   threads.posix \

src/node/db/context.ml

@@ -9,159 +9,105 @@
 
 (** Tezos - Versioned (key x value) store (over Irmin) *)
 
+open Hash
 open Logging.Db
 
 module IrminPath = Irmin.Path.String_list
 
 module MBytesContent = struct
-  module Tc_S0 =
+  type t = MBytes.t
-    (val Tc.biject Tc.cstruct Cstruct.to_bigarray Cstruct.of_bigarray)
+  let t =
-  include Tc_S0
+    Irmin.Type.(like cstruct)
-  module Path = Irmin.Path.String_list
+      (fun x -> Cstruct.to_bigarray x)
-  let merge =
+      (fun x -> Cstruct.of_bigarray x)
-    let fn = Irmin.Merge.(option (module Tc_S0) (default (module Tc_S0))) in
+  let merge = Irmin.Merge.default Irmin.Type.(option t)
-    fun _path -> fn
+  let pp ppf b = Format.pp_print_string ppf (MBytes.to_string b)
+  let of_string s = Ok (MBytes.of_string s)
 end
 
-module GitStore = struct
+module GitStore =
-
+  Irmin_unix.Git.FS.Make
-  module Store =
+    (MBytesContent) (Irmin.Path.String_list) (Irmin.Branch.String)
-    Irmin_unix.Irmin_git.FS
-      (MBytesContent) (Irmin.Ref.String) (Irmin.Hash.SHA1)
-
-  include Store
-
-  module View = Irmin.View (Store)
-
-  module FunView = struct
-    include Ir_funview.Make (Store)
-    type v = t * Lwt_utils.Idle_waiter.t
-    let get (t, w) k =
-      Lwt_utils.Idle_waiter.task w @@ fun () ->
-      read t k
-    let mem (t, w) k =
-      Lwt_utils.Idle_waiter.task w @@ fun () ->
-      mem t k
-    let dir_mem (t, w) k =
-      Lwt_utils.Idle_waiter.task w @@ fun () ->
-      dir_mem t k
-    let del (t, w) k =
-      Lwt_utils.Idle_waiter.task w @@ fun () ->
-      remove t k >>= fun t ->
-      Lwt.return (t, w)
-    let remove_rec (t, w) k =
-      Lwt_utils.Idle_waiter.task w @@ fun () ->
-      remove_rec t k >>= fun t ->
-      Lwt.return (t, w)
-    let set (t, w) k v =
-      Lwt_utils.Idle_waiter.task w @@ fun () ->
-      update t k v >>= fun t ->
-      Lwt.return (t, w)
-    let update_path db k (t, w) =
-      Lwt_utils.Idle_waiter.task w @@ fun () ->
-      update_path db k t
-    let list (t, w) k =
-      Lwt_utils.Idle_waiter.task w @@ fun () ->
-      Lwt_list.map_p (list t) k >|= List.flatten
-  end
-
-end
 
 type index = {
   path: string ;
   repo: GitStore.Repo.t ;
   patch_context: context -> context Lwt.t ;
   mutable commits: int ;
-  repack_scheduler : Lwt_utils.Idle_waiter.t ;
+  repack_scheduler: Lwt_utils.Idle_waiter.t ;
 }
+
 and context = {
   index: index ;
-  store: GitStore.t ;
+  parents: GitStore.Commit.t list ;
-  view: GitStore.FunView.v ;
+  tree: GitStore.tree ;
 }
 type t = context
 
+type commit = GitStore.Commit.Hash.t
+
+let dummy_commit =
+  match
+    GitStore.Commit.Hash.of_string "0000000000000000000000000000000000000000"
+  with
+  | Ok c -> c
+  | Error _ -> assert false
+
+let commit_encoding : commit Data_encoding.t =
+  let open Data_encoding in
+  conv
+    (fun c -> Cstruct.to_bigarray (Irmin.Type.encode_cstruct GitStore.Commit.Hash.t c))
+    (fun c ->
+       match
+         Irmin.Type.decode_cstruct
+           GitStore.Commit.Hash.t
+           (Cstruct.of_bigarray c)
+       with
+       | Ok x -> x
+       | _ -> assert false
+    )
+    bytes
+
 (*-- Version Access and Update -----------------------------------------------*)
 
 let current_protocol_key = ["protocol"]
 let current_test_network_key = ["test_network"]
 
-let exists { repo } key =
+let exists index key =
-  GitStore.of_branch_id
+  Lwt_utils.Idle_waiter.task index.repack_scheduler @@ fun () ->
-    Irmin.Task.none (Block_hash.to_b58check key) repo >>= fun t ->
+  GitStore.Commit.of_hash index.repo key >>= function
-  let store = t () in
+  | None -> Lwt.return_false
-  GitStore.read store current_protocol_key >>= function
+  | Some _ -> Lwt.return_true
-  | Some _ ->
-      Lwt.return true
-  | None ->
-      Lwt.return false
 
 let checkout index key =
-  lwt_debug "-> Context.checkout %a"
+  Lwt_utils.Idle_waiter.task index.repack_scheduler @@ fun () ->
-    Block_hash.pp_short key >>= fun () ->
+  GitStore.Commit.of_hash index.repo key >>= function
-  exists index key >>= fun exists ->
+  | None -> Lwt.return_none
-  if not exists then
+  | Some commit ->
-    Lwt.return None
+      GitStore.Commit.tree commit >>= fun tree ->
-  else
+      let ctxt = { index ; tree ; parents = [commit] } in
-    GitStore.of_branch_id
+      index.patch_context ctxt >>= fun ctxt ->
-      Irmin.Task.none (Block_hash.to_b58check key) index.repo >>= fun t ->
+      Lwt.return (Some ctxt)
-    let store = t () in
-    GitStore.FunView.of_path store [] >>= fun view ->
-    let view = (view, index.repack_scheduler) in
-    let ctxt = { index ; store ; view } in
-    index.patch_context ctxt >>= fun ctxt ->
-    lwt_debug "<- Context.checkout %a OK"
-      Block_hash.pp_short key >>= fun () ->
-    Lwt.return (Some ctxt)
 
 let checkout_exn index key =
   checkout index key >>= function
   | None -> Lwt.fail Not_found
   | Some p -> Lwt.return p
 
-let exists index key =
-  lwt_debug "-> Context.exists %a"
-    Block_hash.pp_short key >>= fun () ->
-  exists index key >>= fun exists ->
-  lwt_debug "<- Context.exists %a %B"
-    Block_hash.pp_short key exists >>= fun () ->
-  Lwt.return exists
 
 exception Preexistent_context of Block_hash.t
 exception Empty_head of Block_hash.t
 
-let commit key ~time ~message context =
+let raw_commit ~time ~message context =
-  let task = Irmin.Task.create ~date:(Time.to_seconds time) ~owner:"Tezos" in
+  let info =
-  GitStore.clone task context.store (Block_hash.to_b58check key) >>= function
+    Irmin.Info.v ~date:(Time.to_seconds time) ~author:"Tezos" message in
-  | `Empty_head -> Lwt.fail (Empty_head key)
+  GitStore.Commit.v
-  | `Duplicated_branch -> Lwt.fail (Preexistent_context key)
+    context.index.repo ~info ~parents:context.parents context.tree
-  | `Ok store ->
+
-      GitStore.FunView.update_path
+let commit ~time ~message context =
-        (store message) [] context.view >>= fun () ->
+  Lwt_utils.Idle_waiter.task context.index.repack_scheduler @@ fun () ->
-     context.index.commits <- context.index.commits + 1 ;
+  raw_commit ~time ~message context >>= fun commit ->
-     if context.index.commits mod 200 = 0 then
+  Lwt.return (GitStore.Commit.hash commit)
-       Lwt_utils.Idle_waiter.force_idle
-         context.index.repack_scheduler
-         (fun () ->
-            lwt_debug "begin git repack" >>= fun () ->
-            let command =
-              "git",
-              [| "git" ; "-C" ; context.index.path ;
-                 "repack" ; "-a" ; "-d" |] in
-            let t0 = Unix.gettimeofday () in
-            Lwt_process.exec
-              ~stdout: `Dev_null ~stderr: `Dev_null
-              command >>= fun res ->
-            let dt = Unix.gettimeofday () -. t0 in
-            match res with
-            | WEXITED 0 ->
-                lwt_log_notice "git repack complete in %0.2f sec" dt
-            | WEXITED code | WSTOPPED code | WSIGNALED code ->
-                lwt_log_error "git repack failed with code %d after  %0.2f sec"
-                  code dt) >>= fun () ->
-       Lwt.return ()
-     else
-       Lwt.return ()
 
 (*-- Generic Store Primitives ------------------------------------------------*)
 
@@ -173,33 +119,44 @@ let undata_key = function
   | _ -> assert false
 
 let mem ctxt key =
-  GitStore.FunView.mem ctxt.view (data_key key) >>= fun v ->
+  Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () ->
+  GitStore.Tree.mem ctxt.tree (data_key key) >>= fun v ->
   Lwt.return v
 
 let dir_mem ctxt key =
-  GitStore.FunView.dir_mem ctxt.view (data_key key) >>= fun v ->
+  Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () ->
+  GitStore.Tree.mem_tree ctxt.tree (data_key key) >>= fun v ->
   Lwt.return v
 
-let raw_get ctxt key = GitStore.FunView.get ctxt.view key
+let raw_get ctxt key =
+  Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () ->
+  GitStore.Tree.find ctxt.tree key
 let get t key = raw_get t (data_key key)
 
 let raw_set ctxt key data =
-  GitStore.FunView.set ctxt.view key data >>= fun view ->
+  Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () ->
-  Lwt.return { ctxt with view }
+  GitStore.Tree.add ctxt.tree key data >>= fun tree ->
+  Lwt.return { ctxt with tree }
 let set t key data = raw_set t (data_key key) data
 
 let raw_del ctxt key =
-  GitStore.FunView.del ctxt.view key >>= fun view ->
+  Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () ->
-  Lwt.return { ctxt with view }
+  GitStore.Tree.remove ctxt.tree key >>= fun tree ->
+  Lwt.return { ctxt with tree }
 let del t key = raw_del t (data_key key)
 
+let list_one ctxt key =
+  Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () ->
+  GitStore.Tree.list ctxt.tree (data_key key) >>= fun keys ->
+  Lwt.return (List.map (fun (k,_) -> key @ [k]) keys)
+
 let list ctxt keys =
-  GitStore.FunView.list ctxt.view (List.map data_key keys) >>= fun keys ->
+  Lwt_list.map_p (list_one ctxt) keys >|= List.flatten
-  Lwt.return (List.map undata_key keys)
 
 let remove_rec ctxt key =
-  GitStore.FunView.remove_rec ctxt.view (data_key key) >>= fun view ->
+  Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () ->
-  Lwt.return { ctxt with view }
+  GitStore.Tree.remove ctxt.tree (data_key key) >>= fun tree ->
+  Lwt.return { ctxt with tree }
 
 (*-- Predefined Fields -------------------------------------------------------*)
 
@@ -275,50 +232,46 @@ let fork_test_network v ~protocol ~expiration =
 (*-- Initialisation ----------------------------------------------------------*)
 
 let init ?patch_context ~root =
-  GitStore.Repo.create
+  GitStore.Repo.v
-    (Irmin_unix.Irmin_git.config ~root ~bare:true ()) >>= fun repo ->
+    (Irmin_git.config ~bare:true root) >>= fun repo ->
   Lwt.return {
     commits = 0 ;
-    repack_scheduler = Lwt_utils.Idle_waiter.create () ;
     path = root ;
     repo ;
+    repack_scheduler = Lwt_utils.Idle_waiter.create () ;
     patch_context =
       match patch_context with
       | None -> (fun ctxt -> Lwt.return ctxt)
       | Some patch_context -> patch_context
   }
 
-let commit_genesis index ~id:block ~time ~protocol =
+let get_branch net_id = Format.asprintf "%a" Net_id.pp net_id
-  let task = Irmin.Task.create ~date:(Time.to_seconds time) ~owner:"Tezos" in
+
-  GitStore.of_branch_id
+
-    task (Block_hash.to_b58check block)
+let commit_genesis index ~net_id ~time ~protocol =
-    index.repo >>= fun t ->
+  Lwt_utils.Idle_waiter.task index.repack_scheduler @@ fun () ->
-  let store = t "Genesis" in
+  let tree = GitStore.Tree.empty in
-  GitStore.FunView.of_path store [] >>= fun view ->
+  let ctxt = { index ; tree ; parents = [] } in
-  let view = (view, index.repack_scheduler) in
+  index.patch_context ctxt >>= fun ctxt ->
-  let ctxt = { index ; store ; view } in
   set_protocol ctxt protocol >>= fun ctxt ->
   set_test_network ctxt Not_running >>= fun ctxt ->
-  index.patch_context ctxt >>= fun ctxt ->
+  raw_commit ~time ~message:"Genesis" ctxt >>= fun commit ->
-  GitStore.FunView.update_path ctxt.store [] ctxt.view >>= fun () ->
+  GitStore.Branch.set index.repo (get_branch net_id) commit >>= fun () ->
-  Lwt.return ctxt
+  Lwt.return (GitStore.Commit.hash commit)
 
 let compute_testnet_genesis forked_block =
   let genesis = Block_hash.hash_bytes [Block_hash.to_bytes forked_block] in
   let net_id = Net_id.of_block_hash genesis in
   net_id, genesis
 
-let commit_test_network_genesis forked_block time ctxt =
+let commit_test_network_genesis index forked_block time ctxt =
+  Lwt_utils.Idle_waiter.task index.repack_scheduler @@ fun () ->
   let net_id, genesis = compute_testnet_genesis forked_block in
-  let task = Irmin.Task.create ~date:(Time.to_seconds time) ~owner:"Tezos" in
+  let branch = get_branch net_id in
-  GitStore.clone task ctxt.store (Block_hash.to_b58check genesis) >>= function
+  let message = Format.asprintf "Forking testnet: %s." branch in
-  | `Empty_head -> fail (Exn (Empty_head genesis))
+  raw_commit ~time ~message ctxt >>= fun commit ->
-  | `Duplicated_branch -> fail (Exn (Preexistent_context genesis))
+  GitStore.Branch.set index.repo branch commit >>= fun () ->
-  | `Ok store ->
+  return (net_id, genesis, GitStore.Commit.hash commit)
-      let msg =
-        Format.asprintf "Forking testnet: %a." Net_id.pp_short net_id in
-      GitStore.FunView.update_path (store msg) [] ctxt.view >>= fun () ->
-      return (net_id, genesis)
 
 let reset_test_network ctxt forked_block timestamp =
   get_test_network ctxt >>= function
@@ -333,3 +286,24 @@ let reset_test_network ctxt forked_block timestamp =
       set_test_network ctxt
         (Running { net_id ; genesis ;
                    protocol ; expiration })
+
+let clear_test_network index net_id =
+  (* TODO remove commits... ??? *)
+  Lwt_utils.Idle_waiter.task index.repack_scheduler @@ fun () ->
+  let branch = get_branch net_id in
+  GitStore.Branch.remove index.repo branch
+
+let set_head index net_id commit =
+  Lwt_utils.Idle_waiter.task index.repack_scheduler @@ fun () ->
+  let branch = get_branch net_id in
+  GitStore.Commit.of_hash index.repo commit >>= function
+  | None -> assert false
+  | Some commit ->
+      GitStore.Branch.set index.repo branch commit
+
+let set_master index commit =
+  Lwt_utils.Idle_waiter.task index.repack_scheduler @@ fun () ->
+  GitStore.Commit.of_hash index.repo commit >>= function
+  | None -> assert false
+  | Some commit ->
+      GitStore.Branch.set index.repo GitStore.Branch.master commit

src/node/db/context.mli

@@ -16,6 +16,11 @@ type index
 type t
 type context = t
 
+type commit
+
+val dummy_commit: commit
+val commit_encoding: commit Data_encoding.t
+
 (** Open or initialize a versioned store at a given path. *)
 val init:
   ?patch_context:(context -> context Lwt.t) ->
@@ -24,14 +29,14 @@ val init:
 
 val commit_genesis:
   index ->
-  id:Block_hash.t ->
+  net_id:Net_id.t ->
   time:Time.t ->
   protocol:Protocol_hash.t ->
-  context Lwt.t
+  commit Lwt.t
 
 val commit_test_network_genesis:
-  Block_hash.t -> Time.t -> context ->
+  index -> Block_hash.t -> Time.t -> context ->
-  (Net_id.t * Block_hash.t) tzresult Lwt.t
+  (Net_id.t * Block_hash.t * commit) tzresult Lwt.t
 
 (** {2 Generic interface} ****************************************************)
 
@@ -39,15 +44,16 @@ include Persist.STORE with type t := context
 
 (** {2 Accessing and Updating Versions} **************************************)
 
-exception Preexistent_context of Block_hash.t
+val exists: index -> commit -> bool Lwt.t
-val exists: index -> Block_hash.t -> bool Lwt.t
+val checkout: index -> commit -> context option Lwt.t
-val checkout: index -> Block_hash.t -> context option Lwt.t
+val checkout_exn: index -> commit -> context Lwt.t
-val checkout_exn: index -> Block_hash.t -> context Lwt.t
 val commit:
-  Block_hash.t ->
   time:Time.t ->
   message:string ->
-  context -> unit Lwt.t
+  context ->
+  commit Lwt.t
+val set_head: index -> Net_id.t -> commit -> unit Lwt.t
+val set_master: index -> commit -> unit Lwt.t
 
 (** {2 Predefined Fields} ****************************************************)
 
@@ -77,3 +83,4 @@ val reset_test_network: context -> Block_hash.t -> Time.t -> context Lwt.t
 
 val fork_test_network:
   context -> protocol:Protocol_hash.t -> expiration:Time.t -> context Lwt.t
+val clear_test_network: index -> Net_id.t -> unit Lwt.t

src/node/db/ir_funview.ml

@@ -1,689 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*    Copyright (c) 2014 - 2016.                                          *)
-(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
-(*                                                                        *)
-(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
-(*                                                                        *)
-(**************************************************************************)
-
-(*
- * Copyright (c) 2013-2015 Thomas Gazagnaire <thomas@gazagnaire.org>
- * Copyright (c) 2016 Grégoire Henry <gregoire.henry@ocamlpro.com>
- *
- * Permission to use, copy, modify, and distribute this software for any
- * purpose with or without fee is hereby granted, provided that the above
- * copyright notice and this permission notice appear in all copies.
- *
- * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
- * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
- * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
- * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
- * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
- * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
- * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
- *)
-
-open Lwt.Infix
-
-(* Import Ir_hum.S *)
-module type Hum = sig
-  include Tc.S0
-  val to_hum: t -> string
-  val of_hum: string -> t
-end
-
-
-(***** views *)
-
-module type NODE = sig
-  type t
-  type node
-  type contents
-  module Contents: Tc.S0 with type t = contents
-  module Path : sig
-    (* Import Ir_S.PATH *)
-    include Hum
-    type step
-    val empty: t
-    val create: step list -> t
-    val is_empty: t -> bool
-    val cons: step -> t -> t
-    val rcons: t -> step -> t
-    val decons: t -> (step * t) option
-    val rdecons: t -> (t * step) option
-    val map: t -> (step -> 'a) -> 'a list
-    module Step: Hum with type t = step
-  end
-
-  val empty: unit -> t
-  val is_empty: t -> bool Lwt.t
-
-  val read: t -> node option Lwt.t
-
-  val read_contents: t -> Path.step -> contents option Lwt.t
-
-  val with_contents: t -> Path.step -> contents option -> t option Lwt.t
-  (* Return [true] iff the contents has actually changed. Used for
-     invalidating the view cache if needed. *)
-
-  val read_succ: node -> Path.step -> t option
-
-  val with_succ: t -> Path.step -> t option -> t option Lwt.t
-  (* Return [true] iff the successors has actually changes. Used for
-     invalidating the view cache if needed. *)
-
-  val steps: t -> Path.step list Lwt.t
-end
-
-module Ir_misc = struct
-  module Set (K: Tc.S0) = struct
-
-    include Set.Make(K)
-
-    let of_list l =
-      List.fold_left (fun set elt -> add elt set) empty l
-
-    let to_list = elements
-
-    include Tc.As_L0(struct
-        type u = t
-        type t = u
-        module K = K
-        let to_list = to_list
-        let of_list = of_list
-      end)
-  end
-  (* assume l1 and l2 are key-sorted *)
-  let alist_iter2 compare_k f l1 l2 =
-    let rec aux l1 l2 = match l1, l2 with
-      | [], t -> List.iter (fun (key, v) -> f key (`Right v)) t
-      | t, [] -> List.iter (fun (key, v) -> f key (`Left v)) t
-      | (k1,v1)::t1, (k2,v2)::t2 ->
-          match compare_k k1 k2 with
-          | 0 ->
-              f k1 (`Both (v1, v2));
-              aux t1 t2
-          | x -> if x < 0 then (
-              f k1 (`Left v1);
-              aux t1 l2
-            ) else (
-                f k2 (`Right v2);
-                aux l1 t2
-              )
-    in
-    aux l1 l2
-  module Map_ext (M: Map.S) (K: Tc.S0 with type t = M.key) = struct
-
-    include M
-
-    let keys m =
-      List.map fst (bindings m)
-
-    let of_alist l =
-      List.fold_left (fun map (k, v)  -> add k v map) empty l
-
-    let to_alist = bindings
-
-    let add_multi key data t =
-      try
-        let l = find key t in
-        add key (data :: l) t
-      with Not_found ->
-        add key [data] t
-
-    let iter2 f t1 t2 =
-      alist_iter2 K.compare f (bindings t1) (bindings t2)
-
-    module Lwt = struct
-      open Lwt
-
-      let iter2 f m1 m2 =
-        let m3 = ref [] in
-        iter2 (fun key data ->
-            m3 := f key data :: !m3
-          ) m1 m2;
-        Lwt_list.iter_p
-          (fun b -> b >>= fun () -> return_unit) (List.rev !m3)
-
-      let merge f m1 m2 =
-        let l3 = ref [] in
-        let f key data =
-          f key data >>= function
-          | None   -> return_unit
-          | Some v -> l3 := (key, v) :: !l3; return_unit
-        in
-        iter2 f m1 m2 >>= fun () ->
-        let m3 = of_alist !l3 in
-        return m3
-
-    end
-
-    include Tc.As_AL1(struct
-        type 'a r = 'a t
-        type 'a t = 'a r
-        module K = K
-        let of_alist = of_alist
-        let to_alist = to_alist
-      end)
-  end
-  module Map (S: Tc.S0) = Map_ext (Map.Make(S))(S)
-
-end
-
-module Make (S: Irmin.S) = struct
-
-  module P = S.Private
-  module Path = S.Key
-  module PathSet = Ir_misc.Set(Path)
-
-  module Step = Path.Step
-  module StepMap = Ir_misc.Map(Path.Step)
-  module StepSet = Ir_misc.Set(Path.Step)
-
-  module Contents = struct
-
-    type key = S.Repo.t * S.Private.Contents.key
-
-    type contents_or_key =
-      | Key of key
-      | Contents of S.value
-      | Both of key * S.value
-
-    type t = contents_or_key ref
-    (* Same as [Contents.t] but can either be a raw contents or a key
-       that will be fetched lazily. *)
-
-    let create c =
-      ref (Contents c)
-
-    let export c =
-      match !c with
-      | Both ((_, k), _)
-      | Key (_, k) -> k
-      | Contents _ -> Pervasives.failwith "Contents.export"
-
-    let key db k =
-      ref (Key (db, k))
-
-    let read t =
-      match !t with
-      | Both (_, c)
-      | Contents c -> Lwt.return (Some c)
-      | Key (db, k as key) ->
-        P.Contents.read (P.Repo.contents_t db) k >>= function
-        | None   -> Lwt.return_none
-        | Some c ->
-          t := Both (key, c);
-          Lwt.return (Some c)
-
-    let equal (x:t) (y:t) =
-      x == y
-      ||
-      match !x, !y with
-      | (Key (_,x) | Both ((_,x),_)), (Key (_,y) | Both ((_,y),_)) ->
-        P.Contents.Key.equal x y
-      | (Contents x | Both (_, x)), (Contents y | Both (_, y)) ->
-        P.Contents.Val.equal x y
-      | _ -> false
-
-  end
-
-  module Node = struct
-
-    type contents = S.value
-    type key = S.Repo.t * P.Node.key
-
-    type node = {
-      contents: Contents.t StepMap.t;
-      succ    : t StepMap.t;
-      alist   : (Path.step * [`Contents of Contents.t | `Node of t ]) list Lazy.t;
-    }
-
-    and t = {
-      mutable node: node option ;
-      mutable key: key option ;
-    }
-
-    let rec equal (x:t) (y:t) =
-      match x, y with
-      | { key = Some (_,x) ; _ }, { key = Some (_,y) ; _ } ->
-        P.Node.Key.equal x y
-      | { node = Some x ; _ }, { node = Some y ; _ } ->
-        List.length (Lazy.force x.alist) = List.length (Lazy.force y.alist)
-        && List.for_all2 (fun (s1, n1) (s2, n2) ->
-            Step.equal s1 s2
-            && match n1, n2 with
-            | `Contents n1, `Contents n2 -> Contents.equal n1 n2
-            | `Node n1, `Node n2 -> equal n1 n2
-            | _ -> false) (Lazy.force x.alist) (Lazy.force y.alist)
-      | _ -> false
-
-    let mk_alist contents succ =
-      lazy (
-        StepMap.fold
-          (fun step c acc -> (step, `Contents c) :: acc)
-          contents @@
-        StepMap.fold
-          (fun step c acc -> (step, `Node c) :: acc)
-          succ
-          [])
-    let mk_index alist =
-      List.fold_left (fun (contents, succ) (l, x) ->
-          match x with
-          | `Contents c -> StepMap.add l c contents, succ
-          | `Node n     -> contents, StepMap.add l n succ
-        ) (StepMap.empty, StepMap.empty) alist
-
-    let create_node contents succ =
-      let alist = mk_alist contents succ in
-      { contents; succ; alist }
-
-    let create contents succ =
-      { key = None ; node = Some (create_node contents succ) }
-
-    let key db k =
-      { key = Some (db, k) ; node = None }
-
-    let both db k v =
-      { key = Some (db, k) ; node = Some v }
-
-    let empty () = create StepMap.empty StepMap.empty
-
-    let import t n =
-      let alist = P.Node.Val.alist n in
-      let alist = List.map (fun (l, x) ->
-          match x with
-          | `Contents (c, _meta) -> (l, `Contents (Contents.key t c))
-          | `Node n     -> (l, `Node (key t n))
-        ) alist in
-      let contents, succ = mk_index alist in
-      create_node contents succ
-
-    let export n =
-      match n.key with
-      | Some (_, k) -> k
-      | None -> Pervasives.failwith "Node.export"
-
-    let export_node n =
-      let alist = List.map (fun (l, x) ->
-          match x with
-          | `Contents c -> (l, `Contents (Contents.export c,
-                                          P.Node.Val.Metadata.default))
-          | `Node n     -> (l, `Node (export n))
-        ) (Lazy.force n.alist)
-      in
-      P.Node.Val.create alist
-
-    let read t =
-      match t with
-      | { key = None ; node = None } -> assert false
-      | { node = Some n ; _ } -> Lwt.return (Some n)
-      | { key = Some (db, k) ; _ } ->
-        P.Node.read (P.Repo.node_t db) k >>= function
-        | None   -> Lwt.return_none
-        | Some n ->
-          let n = import db n in
-          t.node <- Some n;
-          Lwt.return (Some n)
-
-    let is_empty t =
-      read t >>= function
-      | None   -> Lwt.return false
-      | Some n -> Lwt.return (Lazy.force n.alist = [])
-
-    let steps t =
-      read t >>= function
-      | None    -> Lwt.return_nil
-      | Some  n ->
-        let steps = ref StepSet.empty in
-        List.iter
-          (fun (l, _) -> steps := StepSet.add l !steps)
-          (Lazy.force n.alist);
-        Lwt.return (StepSet.to_list !steps)
-
-    let read_contents t step =
-      read t >>= function
-      | None   -> Lwt.return_none
-      | Some t ->
-        try
-          StepMap.find step t.contents
-          |> Contents.read
-        with Not_found ->
-          Lwt.return_none
-
-    let read_succ t step =
-      try Some (StepMap.find step t.succ)
-      with Not_found -> None
-
-    let with_contents t step contents =
-      read t >>= function
-      | None -> begin
-          match contents with
-          | None   -> Lwt.return_none
-          | Some c ->
-              let contents = StepMap.singleton step (Contents.create c) in
-              Lwt.return (Some (create contents StepMap.empty))
-        end
-      | Some n -> begin
-          match contents with
-          | None ->
-              if StepMap.mem step n.contents then
-                let contents = StepMap.remove step n.contents in
-                Lwt.return (Some (create contents n.succ))
-              else
-                Lwt.return_none
-          | Some c ->
-              try
-                let previous = StepMap.find step n.contents in
-                if not (Contents.equal (Contents.create c) previous) then
-                  raise Not_found;
-                Lwt.return_none
-              with Not_found ->
-                let contents =
-                  StepMap.add step (Contents.create c) n.contents in
-                Lwt.return (Some (create contents n.succ))
-        end
-
-    let with_succ t step succ =
-      read t >>= function
-      | None -> begin
-          match succ with
-          | None   -> Lwt.return_none
-          | Some c ->
-              let succ = StepMap.singleton step c in
-              Lwt.return (Some (create StepMap.empty succ))
-        end
-      | Some n -> begin
-          match succ with
-          | None ->
-              if StepMap.mem step n.succ then
-                let succ = StepMap.remove step n.succ in
-                Lwt.return (Some (create n.contents succ))
-              else
-                Lwt.return_none
-          | Some c ->
-              try
-                let previous = StepMap.find step n.succ in
-                if c != previous then raise Not_found;
-                Lwt.return_none
-              with Not_found ->
-                let succ = StepMap.add step c n.succ in
-                Lwt.return (Some (create n.contents succ))
-        end
-
-  end
-
-  type key = Path.t
-  type value = Node.contents
-
-  type t = [`Empty | `Node of Node.t | `Contents of Node.contents]
-
-  module CO = Tc.Option(P.Contents.Val)
-  module PL = Tc.List(Path)
-
-  let empty = `Empty
-
-  let sub t path =
-    let rec aux node path =
-      match Path.decons path with
-      | None        -> Lwt.return (Some node)
-      | Some (h, p) ->
-        Node.read node >>= function
-        | None -> Lwt.return_none
-        | Some t ->
-          match Node.read_succ t h with
-          | None   -> Lwt.return_none
-          | Some v -> aux v p
-    in
-    match t with
-    | `Empty      -> Lwt.return_none
-    | `Node n     -> aux n path
-    | `Contents _ -> Lwt.return_none
-
-  let read_contents t path =
-    match t, Path.rdecons path with
-    | `Contents c, None -> Lwt.return (Some c)
-    | _          , None -> Lwt.return_none
-    | _          , Some (path, file) ->
-      sub t path >>= function
-      | None   -> Lwt.return_none
-      | Some n -> Node.read_contents n file
-
-  let read t k = read_contents t k
-
-  let err_not_found n k =
-    Printf.ksprintf
-      invalid_arg "Irmin.View.%s: %s not found" n (Path.to_hum k)
-
-  let read_exn t k =
-    read t k >>= function
-    | None   -> err_not_found "read" k
-    | Some v -> Lwt.return v
-
-  let mem t k =
-    read t k >>= function
-    | None  -> Lwt.return false
-    | _     -> Lwt.return true
-
-  let dir_mem t k =
-    sub t k >>= function
-    | Some _ -> Lwt.return true
-    | None -> Lwt.return false
-
-  let list_aux t path =
-    sub t path >>= function
-    | None   -> Lwt.return []
-    | Some n ->
-      Node.steps n >>= fun steps ->
-      let paths =
-        List.fold_left (fun set p ->
-            PathSet.add (Path.rcons path p) set
-          ) PathSet.empty steps
-      in
-      Lwt.return (PathSet.to_list paths)
-
-  let list t path =
-    list_aux t path
-
-  let iter t fn =
-    let rec aux = function
-      | []       -> Lwt.return_unit
-      | path::tl ->
-        list t path >>= fun childs ->
-        let todo = childs @ tl in
-        mem t path >>= fun exists ->
-        begin
-          if not exists then Lwt.return_unit
-          else fn path (fun () -> read_exn t path)
-        end >>= fun () ->
-        aux todo
-    in
-    list t Path.empty >>= aux
-
-  let update_contents_aux t k v =
-    match Path.rdecons k with
-    | None -> begin
-        match t, v with
-        | `Empty, None -> Lwt.return t
-        | `Contents c, Some v when P.Contents.Val.equal c v -> Lwt.return t
-        | _, None -> Lwt.return `Empty
-        | _, Some c -> Lwt.return (`Contents c)
-      end
-    | Some (path, file) ->
-      let rec aux view path =
-        match Path.decons path with
-        | None        -> Node.with_contents view file v
-        | Some (h, p) ->
-          Node.read view >>= function
-          | None ->
-            if v = None then Lwt.return_none
-            else err_not_found "update_contents" k (* XXX ?*)
-          | Some n ->
-            match Node.read_succ n h with
-            | Some child -> begin
-              aux child p >>= function
-              | None -> Lwt.return_none
-              | Some child -> begin
-                  if v = None then
-                    (* remove empty dirs *)
-                    Node.is_empty child >>= function
-                    | true  -> Lwt.return_none
-                    | false -> Lwt.return (Some child)
-                  else
-                    Lwt.return (Some child)
-                end >>= fun child ->
-                Node.with_succ view h child
-              end
-            | None ->
-              if v = None then
-                Lwt.return_none
-              else
-                aux (Node.empty ()) p >>= function
-                | None -> assert false
-                | Some _ as child -> Node.with_succ view h child
-      in
-      let n = match t with `Node n -> n | _ -> Node.empty () in
-      aux n path >>= function
-      | None -> Lwt.return t
-      | Some node ->
-        Node.is_empty node >>= function
-        | true  -> Lwt.return `Empty
-        | false -> Lwt.return (`Node node)
-
-  let update_contents t k v =
-    update_contents_aux t k v
-
-  let update t k v = update_contents t k (Some v)
-
-  let remove t k = update_contents t k None
-
-  let remove_rec t k =
-    match Path.decons k with
-    | None -> Lwt.return t
-    | _    ->
-      match t with
-      | `Contents _ -> Lwt.return `Empty
-      | `Empty -> Lwt.return t
-      | `Node n ->
-        let rec aux view path =
-          match Path.decons path with
-          | None       -> assert false
-          | Some (h,p) ->
-            if Path.is_empty p then
-              Node.with_succ view h None
-            else
-              Node.read view >>= function
-              | None   -> Lwt.return_none
-              | Some n ->
-                match Node.read_succ n h with
-                | None       ->
-                      Lwt.return_none
-                | Some child ->
-                    aux child p >>= function
-                    | None -> Lwt.return_none
-                    | Some child -> begin
-                        (* remove empty dirs *)
-                        Node.is_empty child >>= function
-                        | true  -> Lwt.return_none
-                        | false -> Lwt.return (Some child)
-                      end >>= fun child ->
-                        Node.with_succ view h child
-        in
-        aux n k >>= function
-      | None -> Lwt.return t
-      | Some node ->
-        Node.is_empty node >>= function
-        | true  -> Lwt.return `Empty
-        | false -> Lwt.return (`Node node)
-
-  type db = S.t
-
-  let import db key =
-    let repo = S.repo db in
-    begin P.Node.read (P.Repo.node_t repo) key >|= function
-    | None   -> `Empty
-    | Some n -> `Node (Node.both repo key (Node.import repo n))
-    end
-
-  let export repo t =
-    let node n = P.Node.add (P.Repo.node_t repo) (Node.export_node n) in
-    let todo = Stack.create () in
-    let rec add_to_todo n =
-      match n with
-      | { Node.key = Some _ ; _ } -> ()
-      | { Node.key = None ; node = None } -> assert false
-      | { Node.key = None ; node = Some x } ->
-        (* 1. we push the current node job on the stack. *)
-        Stack.push (fun () ->
-            node x >>= fun k ->
-            n.Node.key <- Some (repo, k);
-            n.Node.node <- None; (* Clear cache ?? *)
-            Lwt.return_unit
-          ) todo;
-        (* 2. we push the contents job on the stack. *)
-        List.iter (fun (_, x) ->
-            match x with
-            | `Node _ -> ()
-            | `Contents c ->
-              match !c with
-              | Contents.Both _
-              | Contents.Key _       -> ()
-              | Contents.Contents x  ->
-                Stack.push (fun () ->
-                    P.Contents.add (P.Repo.contents_t repo) x >>= fun k ->
-                    c := Contents.Key (repo, k);
-                    Lwt.return_unit
-                  ) todo
-          ) (Lazy.force x.Node.alist);
-        (* 3. we push the children jobs on the stack. *)
-        List.iter (fun (_, x) ->
-            match x with
-            | `Contents _ -> ()
-            | `Node n ->
-              Stack.push (fun () -> add_to_todo n; Lwt.return_unit) todo
-          ) (Lazy.force x.Node.alist);
-    in
-    let rec loop () =
-      let task =
-        try Some (Stack.pop todo)
-        with Stack.Empty -> None
-      in
-      match task with
-      | None   -> Lwt.return_unit
-      | Some t -> t () >>= loop
-    in
-    match t with
-    | `Empty      -> Lwt.return `Empty
-    | `Contents c -> Lwt.return (`Contents c)
-    | `Node n ->
-      add_to_todo n;
-      loop () >|= fun () ->
-      `Node (Node.export n)
-
-  let of_path db path =
-    P.read_node db path >>= function
-    | None   -> Lwt.return `Empty
-    | Some n -> import db n
-
-  let update_path db path view =
-    let repo = S.repo db in
-    export repo view >>= function
-    | `Empty      -> P.remove_node db path
-    | `Contents c -> S.update db path c
-    | `Node node  -> P.update_node db path node
-
-end
-
-module type S = sig
-  include Irmin.RO
-  val dir_mem: t -> key -> bool Lwt.t
-  val update: t -> key -> value -> t Lwt.t
-  val remove: t -> key -> t Lwt.t
-  val list: t -> key -> key list Lwt.t
-  val remove_rec: t -> key -> t Lwt.t
-  val empty: t
-  type db
-  val of_path: db -> key -> t Lwt.t
-  val update_path: db -> key -> t -> unit Lwt.t
-end

src/node/db/ir_funview.mli

@@ -1,26 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*    Copyright (c) 2014 - 2016.                                          *)
-(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
-(*                                                                        *)
-(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
-(*                                                                        *)
-(**************************************************************************)
-
-module type S = sig
-  include Irmin.RO
-  val dir_mem: t -> key -> bool Lwt.t
-  val update: t -> key -> value -> t Lwt.t
-  val remove: t -> key -> t Lwt.t
-  val list: t -> key -> key list Lwt.t
-  val remove_rec: t -> key -> t Lwt.t
-  val empty: t
-  type db
-  val of_path: db -> key -> t Lwt.t
-  val update_path: db -> key -> t -> unit Lwt.t
-end
-
-module Make (S: Irmin.S):
-  S with type db = S.t
-     and type key = S.key
-     and type value = S.value

src/node/db/store.ml

@@ -87,6 +87,7 @@ module Block = struct
     message: string ;
     operation_list_count: int ;
     max_operations_ttl: int ;
+    context: Context.commit ;
   }
 
   module Contents =
@@ -99,15 +100,18 @@ module Block = struct
            let open Data_encoding in
            conv
              (fun { header ; message ; operation_list_count ;
-                    max_operations_ttl } ->
+                    max_operations_ttl ; context } ->
-               (message, operation_list_count, max_operations_ttl, header))
+               (message, operation_list_count, max_operations_ttl,
+                context, header))
              (fun (message, operation_list_count,
-                   max_operations_ttl, header) ->
+                   max_operations_ttl, context, header) ->
-                { header ; message ; max_operations_ttl ; operation_list_count })
+               { header ; message ; max_operations_ttl ;
-             (obj4
+                 operation_list_count ; context })
+             (obj5
                 (req "message" string)
                 (req "operation_list_count" uint8)
                 (req "max_operations_ttl" uint16)
+                (req "context" Context.commit_encoding)
                 (req "header" Block_header.encoding))
        end))
 

src/node/db/store.mli

@@ -90,6 +90,7 @@ module Block : sig
     message: string ;
     operation_list_count: int ;
     max_operations_ttl: int ;
+    context: Context.commit ;
   }
 
   module Contents : SINGLE_STORE

src/node/shell/state.ml

@@ -95,9 +95,10 @@ type t = global_state
 
 module Locked_block = struct
 
-  let store_genesis context_index store genesis =
+  let store_genesis store genesis commit =
+    let net_id = Net_id.of_block_hash genesis.block in
     let shell : Block_header.shell_header = {
-      net_id = Net_id.of_block_hash genesis.block;
+      net_id ;
       level = 0l ;
       proto_level = 0 ;
       predecessor = genesis.block ;
@@ -108,12 +109,8 @@ module Locked_block = struct
     let header : Block_header.t = { shell ; proto = MBytes.create 0 } in
     Store.Block.Contents.store (store, genesis.block)
       { Store.Block.header ; message = "Genesis" ;
-        operation_list_count = 0 ; max_operations_ttl = 0 } >>= fun () ->
+        operation_list_count = 0 ; max_operations_ttl = 0 ;
-    Context.commit_genesis
+        context = commit } >>= fun () ->
-      context_index
-      ~id:genesis.block
-      ~time:genesis.time
-      ~protocol:genesis.protocol >>= fun _context ->
     Lwt.return header
 
 end
@@ -168,7 +165,7 @@ module Net = struct
 
   let locked_create
       data ?expiration ?(allow_forked_network = false)
-      net_id genesis =
+      net_id genesis commit =
     let net_store = Store.Net.get data.global_store net_id in
     let block_store = Store.Block.get net_store
     and chain_store = Store.Chain.get net_store in
@@ -189,7 +186,7 @@ module Net = struct
         Lwt.return_unit
     end >>= fun () ->
     Locked_block.store_genesis
-      data.context_index block_store genesis >>= fun _genesis_header ->
+      block_store genesis commit >>= fun _genesis_header ->
     allocate
       ~genesis
       ~current_head:genesis.block
@@ -205,8 +202,13 @@ module Net = struct
       if Net_id.Table.mem data.nets net_id then
         Pervasives.failwith "State.Net.create"
       else
+        Context.commit_genesis
+          data.context_index
+          ~net_id
+          ~time:genesis.time
+          ~protocol:genesis.protocol >>= fun commit ->
         locked_create
-          data ?allow_forked_network net_id genesis >>= fun net ->
+          data ?allow_forked_network net_id genesis commit >>= fun net ->
         Net_id.Table.add data.nets net_id net ;
         Lwt.return net
     end
@@ -356,19 +358,22 @@ module Block = struct
             Block_hash.pp_short hash
             block_header.shell.level
             Fitness.pp fitness in
-    let contents = {
-      Store.Block.header = block_header ;
-      message ;
-      operation_list_count = List.length operations ;
-      max_operations_ttl ;
-    } in
     Shared.use net_state.block_store begin fun store ->
       Store.Block.Invalid_block.known store hash >>= fun known_invalid ->
       fail_when known_invalid (failure "Known invalid") >>=? fun () ->
       Store.Block.Contents.known (store, hash) >>= fun known ->
       if known then
-        return false
+        return None
       else begin
+        Context.commit
+          ~time:block_header.shell.timestamp ~message context >>= fun commit ->
+        let contents = {
+          Store.Block.header = block_header ;
+          message ;
+          operation_list_count = List.length operations ;
+          max_operations_ttl ;
+          context = commit ;
+        } in
         Store.Block.Contents.store (store, hash) contents >>= fun () ->
         let hashes = List.map (List.map Operation.hash) operations in
         let list_hashes = List.map Operation_list_hash.compute hashes in
@@ -382,24 +387,18 @@ module Block = struct
         Lwt_list.iteri_p
           (fun i ops -> Store.Block.Operations.store (store, hash) i ops)
           operations >>= fun () ->
-        Context.commit
+        (* Update the chain state. *)
-          hash block_header.shell.timestamp message context >>= fun () ->
+        Shared.use net_state.chain_state begin fun chain_state ->
-        return true
+          let store = chain_state.chain_store in
+          let predecessor = block_header.shell.predecessor in
+          Store.Chain.Known_heads.remove store predecessor >>= fun () ->
+          Store.Chain.Known_heads.store store hash
+        end >>= fun () ->
+        let block = { net_state ; hash ; contents } in
+        Watcher.notify net_state.block_watcher block ;
+        return (Some block)
       end
-    end >>=? fun commited ->
+    end
-    if not commited then
-      return None
-    else
-      (* Update the chain state. *)
-      Shared.use net_state.chain_state begin fun chain_state ->
-        let store = chain_state.chain_store in
-        let predecessor = block_header.shell.predecessor in
-        Store.Chain.Known_heads.remove store predecessor >>= fun () ->
-        Store.Chain.Known_heads.store store hash
-      end >>= fun () ->
-      let block = { net_state ; hash ; contents } in
-      Watcher.notify net_state.block_watcher block ;
-      return (Some block)
 
   let store_invalid net_state block_header =
     let bytes = Block_header.to_bytes block_header in
@@ -452,21 +451,20 @@ module Block = struct
     end
 
   let context { net_state ; hash } =
+    Shared.use net_state.block_store begin fun block_store ->
+      Store.Block.Contents.read_exn (block_store, hash)
+    end  >>= fun { context = commit } ->
     Shared.use net_state.context_index begin fun context_index ->
-      Context.checkout_exn context_index hash
+      Context.checkout_exn context_index commit
     end
 
-  let protocol_hash { net_state ; hash } =
+  let protocol_hash block =
-    Shared.use net_state.context_index begin fun context_index ->
+    context block >>= fun context ->
-      Context.checkout_exn context_index hash >>= fun context ->
+    Context.get_protocol context
-      Context.get_protocol context
-    end
 
-  let test_network { net_state ; hash } =
+  let test_network block =
-    Shared.use net_state.context_index begin fun context_index ->
+    context block >>= fun context ->
-      Context.checkout_exn context_index hash >>= fun context ->
+    Context.get_test_network context
-      Context.get_test_network context
-    end
 
 end
 
@@ -495,15 +493,15 @@ let fork_testnet state block protocol expiration =
     Context.set_test_network context Not_running >>= fun context ->
     Context.set_protocol context protocol >>= fun context ->
     Context.commit_test_network_genesis
-      block.hash block.contents.header.shell.timestamp
+      data.context_index block.hash block.contents.header.shell.timestamp
-      context >>=? fun (net_id, genesis) ->
+      context >>=? fun (net_id, genesis, commit) ->
     let genesis = {
       block = genesis ;
       time = Time.add block.contents.header.shell.timestamp 1L ;
       protocol ;
     } in
     Net.locked_create data
-      net_id ~expiration genesis >>= fun net ->
+      net_id ~expiration genesis commit >>= fun net ->
     return net
   end
 

src/tezos-deps.opam

@@ -19,12 +19,12 @@ depends: [
   "calendar"
   "cohttp" {>= "0.21" }
   "conduit"
-  "ezjsonm" {= "0.4.3" }
+  "ezjsonm" {>= "0.5.0" }
   "git"
   "git-unix"
   "ipv6-multicast"
-  "irmin-watcher" (* for `irmin.unix` *)
+  "irmin" {>= "1.3" }
-  "irmin" {>= "0.12" & < "1.0" }
+  "irmin-unix"
   "lwt" {>= "3.0.0" }
   "lwt_ssl"
   "menhir"

test/p2p/test_p2p_connection.ml

@@ -35,7 +35,7 @@ let rec listen ?port addr =
   let main_socket = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in
   Lwt_unix.(setsockopt main_socket SO_REUSEADDR true) ;
   Lwt.catch begin fun () ->
-    Lwt_unix.Versioned.bind_2 main_socket
+    Lwt_unix.bind main_socket
       (ADDR_INET (uaddr, tentative_port)) >>= fun () ->
     Lwt_unix.listen main_socket 1 ;
     Lwt.return (main_socket, tentative_port)

test/p2p/test_p2p_io_scheduler.ml

@@ -22,7 +22,7 @@ let rec listen ?port addr =
   let main_socket = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in
   Lwt_unix.(setsockopt main_socket SO_REUSEADDR true) ;
   Lwt.catch begin fun () ->
-    Lwt_unix.Versioned.bind_2 main_socket
+    Lwt_unix.bind main_socket
       (ADDR_INET (uaddr, tentative_port)) >>= fun () ->
     Lwt_unix.listen main_socket 50 ;
     Lwt.return (main_socket, tentative_port)

test/shell/test_context.ml

@@ -43,28 +43,28 @@ let block2 =
   Block_hash.of_hex_exn
     "2222222222222222222222222222222222222222222222222222222222222222"
 
-let create_block2 idx =
+let create_block2 idx genesis_commit =
-  checkout idx genesis_block >>= function
+  checkout idx genesis_commit >>= function
   | None ->
       Assert.fail_msg "checkout genesis_block"
   | Some ctxt ->
       set ctxt ["a"; "b"] (MBytes.of_string "Novembre") >>= fun ctxt ->
       set ctxt ["a"; "c"] (MBytes.of_string "Juin") >>= fun ctxt ->
       set ctxt ["version";] (MBytes.of_string "0.0") >>= fun ctxt ->
-      commit block2 ctxt
+      commit ctxt
 
 let block3a =
   Block_hash.of_hex_exn
     "3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a"
 
-let create_block3a idx =
+let create_block3a idx block2_commit =
-  checkout idx block2 >>= function
+  checkout idx block2_commit >>= function
   | None  ->
       Assert.fail_msg "checkout block2"
   | Some ctxt ->
       del ctxt ["a"; "b"] >>= fun ctxt ->
       set ctxt ["a"; "d"] (MBytes.of_string "Mars") >>= fun ctxt ->
-      commit block3a ctxt
+      commit ctxt
 
 let block3b =
   Block_hash.of_hex_exn
@@ -74,26 +74,34 @@ let block3c =
   Block_hash.of_hex_exn
     "3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c"
 
-let create_block3b idx =
+let create_block3b idx block2_commit =
-  checkout idx block2 >>= function
+  checkout idx block2_commit >>= function
   | None ->
       Assert.fail_msg "checkout block3b"
   | Some ctxt ->
       del ctxt ["a"; "c"] >>= fun ctxt ->
       set ctxt ["a"; "d"] (MBytes.of_string "Février") >>= fun ctxt ->
-      commit block3b ctxt
+      commit ctxt
+
+type t = {
+  idx: Context.index ;
+  genesis: Context.commit ;
+  block2: Context.commit ;
+  block3a: Context.commit ;
+  block3b: Context.commit ;
+}
 
 let wrap_context_init f base_dir =
   let root = base_dir // "context" in
   Context.init root >>= fun idx ->
   Context.commit_genesis idx
-    ~id:genesis.block
+    ~net_id
     ~time:genesis.time
-    ~protocol:genesis.protocol >>= fun _ ->
+    ~protocol:genesis.protocol >>= fun genesis ->
-  create_block2 idx >>= fun () ->
+  create_block2 idx genesis >>= fun block2 ->
-  create_block3a idx >>= fun () ->
+  create_block3a idx block2 >>= fun block3a ->
-  create_block3b idx >>= fun () ->
+  create_block3b idx block2  >>= fun block3b ->
-  f idx >>= fun result ->
+  f { idx; genesis; block2 ; block3a; block3b } >>= fun result ->
   Error_monad.return result
 
 (** Simple test *)
@@ -102,7 +110,7 @@ let c = function
   | None -> None
   | Some s -> Some (MBytes.to_string s)
 
-let test_simple idx =
+let test_simple { idx ; block2 } =
   checkout idx block2 >>= function
   | None ->
       Assert.fail_msg "checkout block2"
@@ -115,7 +123,7 @@ let test_simple idx =
       Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ;
       Lwt.return ()
 
-let test_continuation idx =
+let test_continuation { idx ; block3a } =
   checkout idx block3a >>= function
   | None  ->
       Assert.fail_msg "checkout block3a"
@@ -130,7 +138,7 @@ let test_continuation idx =
       Assert.equal_string_option ~msg:__LOC__  (Some "Mars") (c mars) ;
       Lwt.return ()
 
-let test_fork idx =
+let test_fork { idx ; block3b } =
   checkout idx block3b >>= function
   | None  ->
       Assert.fail_msg "checkout block3b"
@@ -145,8 +153,8 @@ let test_fork idx =
       Assert.equal_string_option ~msg:__LOC__ (Some "Février") (c mars) ;
       Lwt.return ()
 
-let test_replay idx =
+let test_replay { idx ; genesis }  =
-  checkout idx genesis_block >>= function
+  checkout idx genesis >>= function
   | None  ->
       Assert.fail_msg "checkout genesis_block"
   | Some ctxt0 ->
@@ -168,8 +176,8 @@ let test_replay idx =
       Assert.equal_string_option ~msg:__LOC__ (Some "Juillet") (c juillet) ;
       Lwt.return ()
 
-let test_list idx =
+let test_list { idx ; genesis } =
-  checkout idx genesis_block >>= function
+  checkout idx genesis >>= function
   | None ->
       Assert.fail_msg "checkout genesis_block"
   | Some ctxt ->
@@ -197,7 +205,7 @@ let test_list idx =
 
 (******************************************************************************)
 
-let tests : (string * (index -> unit Lwt.t)) list = [
+let tests : (string * (t -> unit Lwt.t)) list = [
   "simple", test_simple ;
   "continuation", test_continuation ;
   "fork", test_fork ;

test/shell/test_store.ml

@@ -91,6 +91,7 @@ let lolblock ?(operations = []) header =
     operation_list_count = Random.int 32 ;
     max_operations_ttl = 0 ;
     message = "" ;
+    context = Context.dummy_commit ;
   }
 
 let b1 = lolblock "Blop !"