From 485d8bc26acdd98304b10720f4f446c7f7dd1899 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Sun, 19 Nov 2017 21:25:28 +0100 Subject: [PATCH] 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 | 1 + src/node/db/context.ml | 68 +-- src/node/db/jbuild | 2 +- vendors/irmin-leveldb/irmin-leveldb.opam | 22 + vendors/irmin-leveldb/irmin_leveldb.ml | 596 +++++++++++++++++++++++ vendors/irmin-leveldb/irmin_leveldb.mli | 23 + vendors/irmin-leveldb/jbuild | 6 + 7 files changed, 665 insertions(+), 53 deletions(-) create mode 100644 vendors/irmin-leveldb/irmin-leveldb.opam create mode 100644 vendors/irmin-leveldb/irmin_leveldb.ml create mode 100644 vendors/irmin-leveldb/irmin_leveldb.mli create mode 100644 vendors/irmin-leveldb/jbuild diff --git a/scripts/Dockerfile.build.in b/scripts/Dockerfile.build.in index a230e4f91..bfc808fa7 100644 --- a/scripts/Dockerfile.build.in +++ b/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 && \ diff --git a/src/node/db/context.ml b/src/node/db/context.ml index ceecbbc75..541be4af8 100644 --- a/src/node/db/context.ml +++ b/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 - (MBytesContent) (Irmin.Path.String_list) (Irmin.Branch.String) + Irmin_leveldb.Make + (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 - Lwt_utils.Idle_waiter.task context.index.repack_scheduler @@ fun () -> - 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 + raw_commit ~time ~message context >>= fun commit -> + Lwt.return (GitStore.Commit.hash 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 -> diff --git a/src/node/db/jbuild b/src/node/db/jbuild index 5d96ea7c3..eed488e8d 100644 --- a/src/node/db/jbuild +++ b/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 diff --git a/vendors/irmin-leveldb/irmin-leveldb.opam b/vendors/irmin-leveldb/irmin-leveldb.opam new file mode 100644 index 000000000..cdc7dcba0 --- /dev/null +++ b/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"] diff --git a/vendors/irmin-leveldb/irmin_leveldb.ml b/vendors/irmin-leveldb/irmin_leveldb.ml new file mode 100644 index 000000000..9567ff9b8 --- /dev/null +++ b/vendors/irmin-leveldb/irmin_leveldb.ml @@ -0,0 +1,596 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * + * 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 diff --git a/vendors/irmin-leveldb/irmin_leveldb.mli b/vendors/irmin-leveldb/irmin_leveldb.mli new file mode 100644 index 000000000..dedee1961 --- /dev/null +++ b/vendors/irmin-leveldb/irmin_leveldb.mli @@ -0,0 +1,23 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * Copyright (c) 2017 Dynamic Ledger Solutions + * + * 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 diff --git a/vendors/irmin-leveldb/jbuild b/vendors/irmin-leveldb/jbuild new file mode 100644 index 000000000..21ff70af7 --- /dev/null +++ b/vendors/irmin-leveldb/jbuild @@ -0,0 +1,6 @@ +(jbuild_version 1) + +(library + ((name irmin_leveldb) + (public_name irmin-leveldb) + (libraries (irmin leveldb git))))