Context: quick-and-dirty leveldb backend for Irmin

This is a dirty and non-optimized backend, it is still faster than the
current git backend.

Main drawbacks:
- the leveldb binding is non-coopertive, the node will
  block while committing a block to the disk ;
- the leveldb use 'string' while internally we use 'cstruct',
  this implies a lot of time-consuming 'memcpy'.

scripts/Dockerfile.build.in

@@ -3,6 +3,7 @@ FROM $base_image
 COPY src tezos/src
 COPY test tezos/test
 COPY scripts tezos/scripts
+COPY vendors tezos/vendors
 COPY Makefile jbuild .ocp-indent tezos/
 
 RUN sudo chown -R opam /home/opam/tezos && \

src/node/db/context.ml

@@ -24,16 +24,25 @@ module MBytesContent = struct
   let of_string s = Ok (MBytes.of_string s)
 end
 
+module Metadata = struct
+  type t = unit
+  let t = Irmin.Type.unit
+  let default = ()
+  let merge = Irmin.Merge.default t
+end
+
 module GitStore =
-  Irmin_unix.Git.FS.Make
+  Irmin_leveldb.Make
-    (MBytesContent) (Irmin.Path.String_list) (Irmin.Branch.String)
+    (Metadata)
+    (MBytesContent)
+    (Irmin.Path.String_list)
+    (Irmin.Branch.String)
+    (Irmin.Hash.SHA1)
 
 type index = {
   path: string ;
   repo: GitStore.Repo.t ;
   patch_context: context -> context Lwt.t ;
-  mutable commits: int ;
-  repack_scheduler: Lwt_utils.Idle_waiter.t ;
 }
 
 and context = {
@@ -73,13 +82,11 @@ let current_protocol_key = ["protocol"]
 let current_test_network_key = ["test_network"]
 
 let exists index key =
-  Lwt_utils.Idle_waiter.task index.repack_scheduler @@ fun () ->
   GitStore.Commit.of_hash index.repo key >>= function
   | None -> Lwt.return_false
   | Some _ -> Lwt.return_true
 
 let checkout index key =
-  Lwt_utils.Idle_waiter.task index.repack_scheduler @@ fun () ->
   GitStore.Commit.of_hash index.repo key >>= function
   | None -> Lwt.return_none
   | Some commit ->
@@ -101,37 +108,8 @@ let raw_commit ~time ~message context =
     context.index.repo ~info ~parents:context.parents context.tree
 
 let commit ~time ~message context =
-  begin
+  raw_commit ~time ~message context >>= fun commit ->
-    Lwt_utils.Idle_waiter.task context.index.repack_scheduler @@ fun () ->
+  Lwt.return (GitStore.Commit.hash commit)
-    raw_commit ~time ~message context >>= fun commit ->
-    Lwt.return (GitStore.Commit.hash commit)
-  end >>= fun commit ->
-  context.index.commits <- context.index.commits + 1 ;
-  if context.index.commits mod 200 <> 0 then Lwt.return commit
-  else begin
-    Lwt_utils.Idle_waiter.force_idle
-      context.index.repack_scheduler
-      begin fun () ->
-        let open Logging.Db in
-        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
-      end
-  end >>= fun () ->
-    Lwt.return commit
 
 (*-- Generic Store Primitives ------------------------------------------------*)
 
@@ -144,39 +122,32 @@ type key = string list
 type value = MBytes.t
 
 let mem ctxt key =
-  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 =
-  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 =
-  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 =
-  Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () ->
   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 =
-  Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () ->
   GitStore.Tree.remove ctxt.tree key >>= fun tree ->
   Lwt.return { ctxt with tree }
 let del t key = raw_del t (data_key key)
 
 let remove_rec ctxt key =
-  Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () ->
   GitStore.Tree.remove ctxt.tree (data_key key) >>= fun tree ->
   Lwt.return { ctxt with tree }
 
 let fold ctxt key ~init ~f =
-  Lwt_utils.Idle_waiter.task ctxt.index.repack_scheduler @@ fun () ->
   GitStore.Tree.list ctxt.tree (data_key key) >>= fun keys ->
   Lwt_list.fold_left_s
     begin fun acc (name, kind) ->
@@ -274,12 +245,10 @@ let fork_test_network v ~protocol ~expiration =
 
 let init ?patch_context ~root =
   GitStore.Repo.v
-    (Irmin_git.config ~bare:true root) >>= fun repo ->
+    (Irmin_leveldb.config root) >>= fun repo ->
   Lwt.return {
-    commits = 0 ;
     path = root ;
     repo ;
-    repack_scheduler = Lwt_utils.Idle_waiter.create () ;
     patch_context =
       match patch_context with
       | None -> (fun ctxt -> Lwt.return ctxt)
@@ -290,7 +259,6 @@ let get_branch net_id = Format.asprintf "%a" Net_id.pp net_id
 
 
 let commit_genesis index ~net_id ~time ~protocol =
-  Lwt_utils.Idle_waiter.task index.repack_scheduler @@ fun () ->
   let tree = GitStore.Tree.empty in
   let ctxt = { index ; tree ; parents = [] } in
   index.patch_context ctxt >>= fun ctxt ->
@@ -306,7 +274,6 @@ let compute_testnet_genesis forked_block =
   net_id, genesis
 
 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 branch = get_branch net_id in
   let message = Format.asprintf "Forking testnet: %s." branch in
@@ -330,12 +297,10 @@ let reset_test_network ctxt forked_block timestamp =
 
 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
@@ -343,7 +308,6 @@ let set_head index net_id 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 ->

src/node/db/jbuild

@@ -3,7 +3,7 @@
 (library
  ((name node_db)
   (public_name tezos.node.db)
-  (libraries (utils minutils leveldb irmin irmin-unix))
+  (libraries (utils minutils irmin-leveldb))
   (flags (:standard -w -9+27-30-32-40@8
                     -safe-string
                     -open Error_monad

vendors/irmin-leveldb/irmin-leveldb.opam

@@ -0,0 +1,22 @@
+opam-version: "1.2"
+maintainer:   "gregoire.henry@tezos.com"
+authors:      ["Grégoire Henry"]
+license:      "ISC"
+homepage:     "https://gitlab.com/tezos/irmin-leveldb"
+bug-reports:  "https://gitlab.com/tezos/irmin-leveldb/issues"
+dev-repo:     "https://gitlab.com/tezos/irmin-leveldb.git"
+doc:          "https://tezos.gitlab.io/irmin-leveldb/"
+
+build: [
+ ["jbuilder" "subst"] {pinned}
+ ["jbuilder" "build" "-p" name "-j" jobs]
+]
+build-test: ["jbuilder" "runtest" "-p" name]
+
+depends: [
+  "jbuilder" {build & >= "1.0+beta10"}
+  "irmin"    {>= "1.2.0"}
+  "leveldb"  {>= "1.1.1"}
+]
+
+available: [ocaml-version >= "4.01.0"]

vendors/irmin-leveldb/irmin_leveldb.ml

@@ -0,0 +1,596 @@
+(*
+ * Copyright (c) 2013-2017 Thomas Gazagnaire <thomas@gazagnaire.org>
+ *
+ * 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
+
+type t = {
+  db: LevelDB.db ;
+  root: string ;
+}
+type leveldb = t
+
+let src = Logs.Src.create "irmin.leveldb" ~doc:"Irmin in a LevelDB store"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+module Conf = struct
+
+  let root = Irmin.Private.Conf.root
+
+end
+
+let config ?(config=Irmin.Private.Conf.empty) file =
+  let module C = Irmin.Private.Conf in
+  let config = C.add config Conf.root (Some file) in
+  config
+
+module Irmin_value_store
+    (M: Irmin.Metadata.S)
+    (H: Irmin.Hash.S)
+    (C: Irmin.Contents.S)
+    (P: Irmin.Path.S) = struct
+
+  module XContents = struct
+
+    type t = leveldb
+    type key = H.t
+    type value = C.t
+
+    let leveldb_of_key h =
+      "contents/" ^ Cstruct.to_string (H.to_raw h)
+
+    let mem { db ; _ } key =
+      let key = leveldb_of_key key in
+      Lwt.return (LevelDB.mem db key)
+
+    let find { db ; _ } key =
+      let key = leveldb_of_key key in
+      match LevelDB.get db key with
+      | None   -> Lwt.return_none
+      | Some v ->
+          match C.of_string v with
+          | Ok v -> Lwt.return_some v
+          | Error _ -> Lwt.return_none
+
+    let to_string = Fmt.to_to_string C.pp
+    let add { db ; _ } v =
+      let k = H.digest C.t v in
+      LevelDB.put db (leveldb_of_key k) (to_string v) ;
+      Lwt.return k
+    module Val = C
+    module Key = H
+  end
+  module Contents = Irmin.Contents.Store(XContents)
+
+  module XNode = struct
+    module Key = H
+    module Path = P
+
+    module Val = struct
+      module Metadata = M
+
+      type kind = [ `Node | `Contents of M.t ]
+      type metadata = M.t
+      type entry = { kind : kind; name : string; node : H.t; }
+      type t = entry list
+      type contents = Contents.key
+      type node = Key.t
+      type step = Path.step
+      type value = [`Node of node | `Contents of contents * metadata ]
+      let metadata_t = M.t
+      let contents_t = Contents.Key.t
+      let node_t = Key.t
+      let step_t = Path.step_t
+
+      let entry_t =
+        let open Irmin.Type in
+        record "Tree.entry"
+          (fun kind name node ->
+             let kind =
+               match kind with
+               | None -> `Node
+               | Some m -> `Contents m in
+             { kind ; name ; node } )
+        |+ field "kind" (option M.t) (function
+            | { kind = `Node ; _ } -> None
+            | { kind = `Contents m ; _ } -> Some m)
+        |+ field "name" string (fun { name ; _ } -> name)
+        |+ field "node" H.t (fun { node ; _ } -> node)
+        |> sealr
+
+      let value_t =
+        let open Irmin.Type in
+        variant "Tree.value" (fun node contents -> function
+            | `Node n          -> node n
+            | `Contents (c, m) -> contents (c, m))
+        |~ case1 "node"     node_t     (fun n -> `Node n)
+        |~ case1 "contents" (pair contents_t M.t) (fun (c, m) -> `Contents (c, m))
+        |> sealv
+
+      let of_step = Fmt.to_to_string P.pp_step
+
+      let to_step str = match P.step_of_string str with
+        | Ok x           -> x
+        | Error (`Msg e) -> failwith e
+
+      let to_entry kind (name, node) =
+        { kind; name = of_step name; node }
+
+      let list t  =
+        List.fold_left (fun acc { kind; name; node } ->
+            let name = to_step name in
+            match kind with
+            | `Node       -> (name, `Node node) :: acc
+            | `Contents m -> (name, `Contents (node, m)) :: acc
+          ) [] t
+        |> List.rev
+
+      let find t s =
+        let s = of_step s in
+        let rec aux = function
+          | [] -> None
+          | x::xs when x.name <> s -> aux xs
+          | { kind; node; _ } :: _ ->
+              match kind with
+              | `Node     -> Some (`Node node)
+              | `Contents m -> Some (`Contents (node, m))
+        in
+        aux t
+
+      type compare_result = LT | EQ | GT
+
+      module Sort_key: sig
+        type t
+        val of_entry: entry -> t
+        val of_contents: string -> t
+        val of_node: string -> t
+        val order: t -> t -> compare_result
+        val compare: t -> t -> int
+      end = struct
+
+        type t =
+          | Contents: string -> t
+          | Node    : string -> t
+
+        exception Result of int
+
+        let str = function Contents s | Node s -> s
+
+        let compare x y = match x, y with
+          | Contents x, Contents y -> String.compare x y
+          | _  ->
+              let xs = str x and ys = str y in
+              let lenx = String.length xs in
+              let leny = String.length ys in
+              let i = ref 0 in
+              try
+                while !i < lenx && !i < leny do
+                  match
+                    Char.compare
+                      (String.unsafe_get xs !i) (String.unsafe_get ys !i)
+                  with
+                  | 0 -> incr i
+                  | i -> raise (Result i)
+                done;
+                let get len s i =
+                  if i < len then String.unsafe_get (str s) i
+                  else if i = len then match s with
+                    | Node _     -> '/'
+                    | Contents _ -> '\000'
+                  else '\000'
+                in
+                match Char.compare (get lenx x !i) (get leny y !i) with
+                | 0 -> Char.compare (get lenx x (!i + 1)) (get leny y (!i + 1))
+                | i -> i
+              with Result i ->
+                i
+
+        let order a b = match compare a b with
+          | 0 -> EQ
+          | x when x > 0 -> GT
+          | _ -> LT
+
+        let of_contents c = Contents c
+        let of_node n = Node n
+
+        let of_entry = function
+          | {name = n; kind = `Node; _} -> of_node n
+          | {name = n; kind = `Contents _; _} -> of_contents n
+      end
+
+      let compare_entries a b =
+        Sort_key.(compare (of_entry a) (of_entry b))
+
+      (* the order is always:
+
+         [ ...; foo (content key); ...; foo/ (node key);  ... ]
+
+         So always scan until the 'node' key.
+      *)
+
+      let remove t step =
+        let step = of_step step in
+        let node_key = Sort_key.of_node step in
+        let contents_key = Sort_key.of_contents step in
+        let return ~acc rest = List.rev_append acc rest in
+        let rec aux acc = function
+          | []     -> t
+          | h :: l ->
+              let entry_key = Sort_key.of_entry h in
+              if Sort_key.order contents_key entry_key = EQ then
+                return ~acc l
+              else match Sort_key.order node_key entry_key with
+                | GT -> aux (h :: acc) l
+                | EQ -> return ~acc l
+                | LT -> t
+        in
+        aux [] t
+
+      let hash_of_v = function
+        | `Contents (x, _) | `Node x -> x
+
+      let update t step v =
+        let step = of_step step in
+        let node_key = Sort_key.of_node step in
+        let contents_key = Sort_key.of_contents step in
+        let return ~acc rest =
+          let kind, node = match v with
+            | `Node n          -> `Node, n
+            | `Contents (c, m) -> `Contents m, c
+          in
+          let e = { kind; name = step; node} in
+          List.rev_append acc (e :: rest)
+        in
+        let rec aux acc = function
+          | [] -> return ~acc []
+          | { node; _ } as h :: l ->
+              let entry_key = Sort_key.of_entry h in
+              (* Remove any contents entry with the same name. This will always
+                 come before the new succ entry. *)
+              if Sort_key.order contents_key entry_key = EQ then
+                aux acc l
+              else match Sort_key.order node_key entry_key with
+                | GT -> aux (h :: acc) l
+                | LT -> return ~acc (h::l)
+                | EQ when Cstruct.equal (H.to_raw (hash_of_v v)) (H.to_raw node) -> t
+                | EQ -> return ~acc l
+        in
+        aux [] t
+
+      let empty = []
+
+      let is_empty = function
+        | [] -> true
+        | _  -> false
+
+      let v alist =
+        let alist = List.map (fun (l, x) ->
+            let v k = l, k in
+            match x with
+            | `Node n             -> to_entry `Node (v n)
+            | `Contents (c, m) -> to_entry (`Contents m) (v c)
+          ) alist
+        in
+        List.fast_sort compare_entries alist
+
+      let alist t =
+        let mk_n k = `Node k in
+        let mk_c k m= `Contents (k, m) in
+        List.map (function
+            | { kind = `Node; name; node } -> (to_step name, mk_n node)
+            | { kind = `Contents m; name; node; _ } ->
+                (to_step name, mk_c node m)
+          ) t
+
+      module N = Irmin.Private.Node.Make (H)(H)(P)(M)
+      let to_n t = N.v (alist t)
+      let of_n n = v (N.list n)
+      let t = Irmin.Type.like N.t of_n to_n
+    end
+
+    module AO = struct
+
+      type t = leveldb
+      type key = H.t
+      type value = Val.t
+
+      let leveldb_of_key h =
+        "node/" ^ Cstruct.to_string (H.to_raw h)
+
+      let mem { db ; _ } key =
+        let key = leveldb_of_key key in
+        Lwt.return (LevelDB.mem db key)
+
+      let of_string v =
+        Irmin.Type.decode_cstruct
+          (Irmin.Type.list Val.entry_t)
+          (Cstruct.of_string v)
+
+      let find { db ; _ } key =
+        let key = leveldb_of_key key in
+        match LevelDB.get db key with
+        | None   -> Lwt.return_none
+        | Some v ->
+            match of_string v with
+            | Ok v -> Lwt.return_some v
+            | Error _ -> Lwt.return_none
+
+      let add { db ; _ } v =
+        let v = Irmin.Type.encode_cstruct (Irmin.Type.list Val.entry_t) v in
+        let k = H.digest Irmin.Type.cstruct v in
+        LevelDB.put db (leveldb_of_key k) (Cstruct.to_string v) ;
+        Lwt.return k
+    end
+    include AO
+
+  end
+  module Node = Irmin.Private.Node.Store(Contents)(P)(M)(XNode)
+
+  module XCommit = struct
+    module Val = struct
+      type t = {
+        node: H.t ;
+        parents: H.t list ;
+        info: Irmin.Info.t ;
+      }
+      type commit = H.t
+      type node = H.t
+
+      let commit_t = H.t
+      let node_t = H.t
+
+      let v ~info ~node ~parents = { info ; node ; parents }
+      let xnode { node; _ } = node
+      let node t = xnode t
+      let parents { parents; _ } = parents
+      let info { info; _ } = info
+
+      module C = Irmin.Private.Commit.Make(H)(H)
+
+      let of_c c = v ~info:(C.info c) ~node:(C.node c) ~parents:(C.parents c)
+
+      let to_c { info ; node ; parents } =
+        C.v ~info ~node ~parents
+
+      let t = Irmin.Type.like C.t of_c to_c
+    end
+
+    module Key = H
+
+    module AO = struct
+
+      let leveldb_of_key h =
+        "commit/" ^ Cstruct.to_string (H.to_raw h)
+
+      type t = leveldb
+      type key = H.t
+      type value = Val.t
+
+      let mem { db ; _ } key =
+        let key = leveldb_of_key key in
+        Lwt.return (LevelDB.mem db key)
+
+      let of_string v =
+        Irmin.Type.decode_cstruct
+          Val.t
+          (Cstruct.of_string v)
+
+      let find { db ; _ } key =
+        let key = leveldb_of_key key in
+        match LevelDB.get db key with
+        | None   -> Lwt.return_none
+        | Some v ->
+            match of_string v with
+            | Ok v -> Lwt.return_some v
+            | Error _ -> Lwt.return_none
+
+      let add { db ; _ } v =
+        let v = Irmin.Type.encode_cstruct Val.t v in
+        let k = H.digest Irmin.Type.cstruct v in
+        LevelDB.put db (leveldb_of_key k) (Cstruct.to_string v) ;
+        Lwt.return k
+
+    end
+    include AO
+
+  end
+  module Commit = Irmin.Private.Commit.Store(Node)(XCommit)
+
+end
+
+module type Branch = sig
+  include Irmin.Branch.S
+  val pp_ref: t Fmt.t
+  val of_ref: string -> (t, [`Msg of string]) result
+end
+
+module Branch (B: Irmin.Branch.S): Branch with type t = B.t = struct
+  open Astring
+  include B
+  let pp_ref ppf b = Fmt.pf ppf "heads/%a" B.pp b
+
+  let of_ref str = match String.cuts ~sep:"/" str with
+    | "heads" :: b -> B.of_string (String.concat ~sep:"/" b)
+    | _ -> Error (`Msg (Fmt.strf "%s is not a valid branch" str))
+end
+
+
+module Irmin_branch_store (B: Branch) (H: Irmin.Hash.S) = struct
+
+  module Key = B
+  module Val = H
+
+  module W = Irmin.Private.Watch.Make(Key)(Val)
+
+  type t = {
+    db: leveldb;
+    w: W.t;
+  }
+
+  let watches = Hashtbl.create 10
+
+  type key = Key.t
+  type value = Val.t
+  type watch = W.watch * (unit -> unit Lwt.t)
+
+  (* let branch_of_leveldb r = *)
+  (* let str = String.trim @@ Git.Reference.to_raw r in *)
+  (* match B.of_ref str with *)
+  (* | Ok r           -> Some r *)
+  (* | Error (`Msg _) -> None *)
+
+  let leveldb_of_branch r = Fmt.to_to_string B.pp_ref r
+
+  let mem { db; _ } r =
+    Lwt.return (LevelDB.mem db.db (leveldb_of_branch r))
+
+  let find { db; _ } r =
+    match LevelDB.get db.db (leveldb_of_branch r) with
+    | None -> Lwt.return_none
+    | Some k -> Lwt.return_some (H.of_raw (Cstruct.of_string k))
+
+  let listen_dir _ =
+    Lwt.return (fun () -> Lwt.return_unit)
+
+  let watch_key t key ?init f =
+    listen_dir t >>= fun stop ->
+    W.watch_key t.w key ?init f >|= fun w ->
+    (w, stop)
+
+  let watch t ?init f =
+    listen_dir t >>= fun stop ->
+    W.watch t.w ?init f >|= fun w ->
+    (w, stop)
+
+  let unwatch t (w, stop) =
+    stop () >>= fun () ->
+    W.unwatch t.w w
+
+  let v (db : leveldb) (* ~head *) =
+    let w =
+      try Hashtbl.find watches db.root
+      with Not_found ->
+        let w = W.v () in
+        (* FIXME: we might want to use a weak table *)
+        Hashtbl.add watches db.root w;
+        w
+    in
+    Lwt.return { db ; w }
+
+  let list _ = Lwt.return_nil (* TODO, or not *)
+
+  (* let write_index _t _gr _gk = *)
+  (* Lwt.return_unit *)
+
+  let set _t r _k =
+    Log.debug (fun f -> f "update %a" B.pp r);
+    Lwt.return_unit
+  (* let gr = git_of_branch r in *)
+  (* let gk = git_of_commit k in *)
+  (* G.write_reference t.t gr gk >>= fun () -> *)
+  (* W.notify t.w r (Some k) >>= fun () -> *)
+  (* write_index t gr (Git.Hash.to_commit gk) *)
+
+  let remove _t r =
+    Log.debug (fun f -> f "remove %a" B.pp r);
+    Lwt.return_unit
+  (* G.remove_reference t.t (git_of_branch r) >>= fun () -> *)
+  (* W.notify t.w r None *)
+
+  let test_and_set _t _r ~test:_ ~set:_ =
+    Log.debug (fun f -> f "test_and_set");
+    Lwt.return_true
+    (* let gr = git_of_branch r in *)
+    (* let c = function None -> None | Some h -> Some (git_of_commit h) in *)
+    (* G.test_and_set_reference t.t gr ~test:(c test) ~set:(c set) >>= fun b -> *)
+    (* (if b then W.notify t.w r set else Lwt.return_unit) >>= fun () -> *)
+    (* begin *)
+    (* We do not protect [write_index] because it can take a log
+       time and we don't want to hold the lock for too long. Would
+       be safer to grab a lock, although the expanded filesystem
+       is not critical for Irmin consistency (it's only a
+       convenience for the user). *)
+    (* if b then match set with *)
+    (* | None   -> Lwt.return_unit *)
+    (* | Some v -> write_index t gr (Git.Hash.to_commit (git_of_commit v)) *)
+    (* else *)
+    (* Lwt.return_unit *)
+    (* end >|= fun () -> *)
+    (* b *)
+
+end
+
+
+module Make
+    (M: Irmin.Metadata.S)
+    (C: Irmin.Contents.S)
+    (P: Irmin.Path.S)
+    (B: Irmin.Branch.S)
+    (H: Irmin.Hash.S) = struct
+
+  module P = struct
+
+    module Branch = Irmin_branch_store(Branch(B))(H)
+    include Irmin_value_store(M)(H)(C)(P)
+    module Slice = Irmin.Private.Slice.Make(Contents)(Node)(Commit)
+    module Sync = struct
+      type t = unit
+      type commit = H.t
+      type branch = B.t
+      let fetch _ ?depth:_ ~uri:_  _ = Lwt.return_error `Not_available
+      let push _ ?depth:_ ~uri:_ _ = Lwt.return_error `Not_available
+      let v _ = Lwt.return_unit
+    end
+
+    module Repo = struct
+      type t = {
+        config: Irmin.config;
+        db: leveldb;
+        branch: Branch.t ;
+      }
+      let branch_t t : Branch.t = t.branch
+      let contents_t t : Contents.t = t.db
+      let node_t t : Node.t = contents_t t, t.db
+      let commit_t t : Commit.t = node_t t, t.db
+
+      type config = {
+        root   : string option ;
+        (* TODO *)
+        (* ?write_buffer_size:int -> *)
+        (* ?max_open_files:int -> *)
+        (* ?block_size:int -> *)
+        (* ?block_restart_interval:int -> *)
+        (* ?cache_size:int *)
+      }
+
+      let config c =
+        let root = Irmin.Private.Conf.get c Conf.root in
+        { root }
+
+      let v conf =
+        let { root } = config conf in
+        let root = match root with None -> "irmin.ldb" | Some root -> root in
+        let db = { db = LevelDB.open_db root ; root } in
+        Branch.v db >>= fun branch ->
+        Lwt.return { db; branch; config = conf }
+
+    end
+  end
+
+  include Irmin.Make_ext(P)
+
+end
+
+include Conf

vendors/irmin-leveldb/irmin_leveldb.mli

@@ -0,0 +1,23 @@
+(*
+ * Copyright (c) 2013-2017 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2017 Dynamic Ledger Solutions <contact@tezos.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.
+ *)
+
+(** Quick-and-dirty LevelDB backend for Irmin. *)
+
+val config:
+  ?config:Irmin.config -> string -> Irmin.config
+
+module Make : Irmin.S_MAKER

vendors/irmin-leveldb/jbuild

@@ -0,0 +1,6 @@
+(jbuild_version 1)
+
+(library
+ ((name        irmin_leveldb)
+  (public_name irmin-leveldb)
+  (libraries   (irmin leveldb git))))