Vendors: import irmin-lmdb
This commit is contained in:
parent
cbef4c4d0c
commit
be459ef312
@ -490,27 +490,32 @@ opam:49:ocplib-ezresto-directory:
|
||||
variables:
|
||||
package: ocplib-ezresto-directory
|
||||
|
||||
opam:50:tezos-baker-alpha:
|
||||
opam:50:irmin-lmdb:
|
||||
<<: *opam_definition
|
||||
variables:
|
||||
package: irmin-lmdb
|
||||
|
||||
opam:51:tezos-baker-alpha:
|
||||
<<: *opam_definition
|
||||
variables:
|
||||
package: tezos-baker-alpha
|
||||
|
||||
opam:51:tezos-protocol-demo:
|
||||
opam:52:tezos-protocol-demo:
|
||||
<<: *opam_definition
|
||||
variables:
|
||||
package: tezos-protocol-demo
|
||||
|
||||
opam:52:tezos-signer:
|
||||
opam:53:tezos-signer:
|
||||
<<: *opam_definition
|
||||
variables:
|
||||
package: tezos-signer
|
||||
|
||||
opam:53:tezos-node:
|
||||
opam:54:tezos-node:
|
||||
<<: *opam_definition
|
||||
variables:
|
||||
package: tezos-node
|
||||
|
||||
opam:54:ocplib-json-typed-browser:
|
||||
opam:55:ocplib-json-typed-browser:
|
||||
<<: *opam_definition
|
||||
variables:
|
||||
package: ocplib-json-typed-browser
|
||||
|
22
vendors/irmin-lmdb/irmin-lmdb.opam
vendored
Normal file
22
vendors/irmin-lmdb/irmin-lmdb.opam
vendored
Normal file
@ -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-lmdb"
|
||||
bug-reports: "https://gitlab.com/tezos/irmin-lmdb/issues"
|
||||
dev-repo: "https://gitlab.com/tezos/irmin-lmdb.git"
|
||||
doc: "https://tezos.gitlab.io/irmin-lmdb/"
|
||||
|
||||
build: [
|
||||
["jbuilder" "subst"] {pinned}
|
||||
["jbuilder" "build" "-p" name "-j" jobs]
|
||||
]
|
||||
build-test: ["jbuilder" "runtest" "-p" name]
|
||||
|
||||
depends: [
|
||||
"jbuilder" {build & >= "1.0+beta10"}
|
||||
"irmin" {>= "1.3.0"}
|
||||
"lmdb" {>= "0.1"}
|
||||
]
|
||||
|
||||
available: [ocaml-version >= "4.01.0"]
|
647
vendors/irmin-lmdb/irmin_lmdb.ml
vendored
Normal file
647
vendors/irmin-lmdb/irmin_lmdb.ml
vendored
Normal file
@ -0,0 +1,647 @@
|
||||
(*
|
||||
* 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.
|
||||
*)
|
||||
|
||||
module Option = struct
|
||||
let of_result = function
|
||||
| Ok v -> Some v
|
||||
| _ -> None
|
||||
|
||||
let value_map ~default ~f = function
|
||||
| None -> default
|
||||
| Some v -> f v
|
||||
end
|
||||
|
||||
module Result = struct
|
||||
let map ~f = function
|
||||
| Ok v -> Ok (f v)
|
||||
| Error err -> Error err
|
||||
end
|
||||
|
||||
let cstruct_of_ba_copy ba =
|
||||
let cs = Cstruct.of_bigarray ba in
|
||||
let len = Cstruct.len cs in
|
||||
let cs_copy = Cstruct.create_unsafe len in
|
||||
Cstruct.blit cs 0 cs_copy 0 len ;
|
||||
cs_copy
|
||||
|
||||
open Lwt.Infix
|
||||
|
||||
type t = {
|
||||
db: Lmdb.t ;
|
||||
root: string ;
|
||||
}
|
||||
|
||||
let of_result = function
|
||||
| Ok v -> Lwt.return v
|
||||
| Error err -> Lwt.fail_with (Lmdb.string_of_error err)
|
||||
|
||||
let src = Logs.Src.create "irmin.lmdb" ~doc:"Irmin in a Lmdb store"
|
||||
module Log = (val Logs.src_log src : Logs.LOG)
|
||||
|
||||
let int64_of_string s =
|
||||
try Ok (Int64.of_string s)
|
||||
with Failure _ ->
|
||||
Error (`Msg (Printf.sprintf "%s is not the representation of an int64" s))
|
||||
|
||||
let int64_converter = int64_of_string, Fmt.uint64
|
||||
|
||||
module Conf = struct
|
||||
|
||||
let root = Irmin.Private.Conf.root
|
||||
let mapsize =
|
||||
Irmin.Private.Conf.key "mapsize" int64_converter 40_960_000_000L
|
||||
|
||||
end
|
||||
|
||||
let config
|
||||
?(config=Irmin.Private.Conf.empty) ?mapsize file =
|
||||
let module C = Irmin.Private.Conf in
|
||||
let config = C.add config Conf.root (Some file) in
|
||||
Option.value_map mapsize ~default:config ~f:(C.add config Conf.mapsize)
|
||||
|
||||
let mem db k =
|
||||
Lmdb.with_ro_db db ~f:(fun txn db -> Lmdb.mem txn db k) |>
|
||||
of_result
|
||||
|
||||
let find_bind db k ~f =
|
||||
match Lmdb.with_ro_db db
|
||||
~f:(fun txn db -> Result.map ~f (Lmdb.get txn db k)) with
|
||||
| Error KeyNotFound -> Lwt.return_none
|
||||
| Error err -> Lwt.fail_with (Lmdb.string_of_error err)
|
||||
| Ok v -> Lwt.return v
|
||||
|
||||
let add db k v =
|
||||
Lmdb.with_rw_db db ~f:begin fun txn db ->
|
||||
Lmdb.put_string txn db k v ;
|
||||
end |> of_result
|
||||
|
||||
let add_cstruct db k v =
|
||||
Lmdb.with_rw_db db ~f:begin fun txn db ->
|
||||
Lmdb.put txn db k (Cstruct.to_bigarray v) ;
|
||||
end |> of_result
|
||||
|
||||
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 nonrec t = t
|
||||
type key = H.t
|
||||
type value = C.t
|
||||
|
||||
let lmdb_of_key h =
|
||||
"contents/" ^ Cstruct.to_string (H.to_raw h)
|
||||
|
||||
let mem { db ; _ } key =
|
||||
let key = lmdb_of_key key in
|
||||
mem db key
|
||||
|
||||
let find { db ; _ } key =
|
||||
let key = lmdb_of_key key in
|
||||
find_bind db key ~f:begin fun v ->
|
||||
Option.of_result (C.of_string Cstruct.(to_string (of_bigarray v)))
|
||||
end
|
||||
|
||||
let to_string = Fmt.to_to_string C.pp
|
||||
|
||||
let add { db ; _ } v =
|
||||
let k = H.digest C.t v in
|
||||
let k_lmdb = lmdb_of_key k in
|
||||
let v = to_string v in
|
||||
add db k_lmdb v >|= fun () -> 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 nonrec t = t
|
||||
type key = H.t
|
||||
type value = Val.t
|
||||
|
||||
let lmdb_of_key h =
|
||||
"node/" ^ Cstruct.to_string (H.to_raw h)
|
||||
|
||||
let mem { db ; _ } key =
|
||||
let key = lmdb_of_key key in
|
||||
mem db key
|
||||
|
||||
let of_cstruct v =
|
||||
Irmin.Type.decode_cstruct (Irmin.Type.list Val.entry_t) v |>
|
||||
Option.of_result
|
||||
|
||||
let find { db ; _ } key =
|
||||
let key = lmdb_of_key key in
|
||||
find_bind db key ~f:(fun v -> of_cstruct (cstruct_of_ba_copy v))
|
||||
|
||||
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
|
||||
let k_lmdb = lmdb_of_key k in
|
||||
add_cstruct db k_lmdb v >|= fun () -> 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 lmdb_of_key h =
|
||||
"commit/" ^ Cstruct.to_string (H.to_raw h)
|
||||
|
||||
type nonrec t = t
|
||||
type key = H.t
|
||||
type value = Val.t
|
||||
|
||||
let mem { db ; _ } key =
|
||||
let key = lmdb_of_key key in
|
||||
mem db key
|
||||
|
||||
let of_cstruct v =
|
||||
Irmin.Type.decode_cstruct Val.t v |>
|
||||
Option.of_result
|
||||
|
||||
let find { db ; _ } key =
|
||||
let key = lmdb_of_key key in
|
||||
find_bind db key ~f:(fun v -> of_cstruct (cstruct_of_ba_copy v))
|
||||
|
||||
let add { db ; _ } v =
|
||||
let v = Irmin.Type.encode_cstruct Val.t v in
|
||||
let k = H.digest Irmin.Type.cstruct v in
|
||||
let k_lmdb = lmdb_of_key k in
|
||||
add_cstruct db k_lmdb v >|= fun () -> 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 nonrec t = {
|
||||
db: t;
|
||||
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_lmdb 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 lmdb_of_branch r = Fmt.to_to_string B.pp_ref r
|
||||
|
||||
let mem { db ; _ } r =
|
||||
mem db.db (lmdb_of_branch r)
|
||||
|
||||
let find { db ; _ } r =
|
||||
find_bind db.db (lmdb_of_branch r)
|
||||
~f:(fun v -> Some (H.of_raw (cstruct_of_ba_copy v)))
|
||||
|
||||
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 (* ~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 nonrec t = {
|
||||
config: Irmin.config ;
|
||||
db: t ;
|
||||
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 ;
|
||||
mapsize : int64 ;
|
||||
(* 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
|
||||
let mapsize = Irmin.Private.Conf.get c Conf.mapsize in
|
||||
{ root ; mapsize }
|
||||
|
||||
let v conf =
|
||||
let { root ; mapsize } = config conf in
|
||||
let root = match root with None -> "irmin.ldb" | Some root -> root in
|
||||
if not (Sys.file_exists root) then Unix.mkdir root 0o755 ;
|
||||
match Lmdb.opendir ~mapsize ~flags:[NoTLS] root 0o644 with
|
||||
| Error err -> Lwt.fail_with (Lmdb.string_of_error err)
|
||||
| Ok db ->
|
||||
let db = { db ; root } in
|
||||
Branch.v db >|= fun branch ->
|
||||
{ db; branch; config = conf }
|
||||
|
||||
end
|
||||
end
|
||||
|
||||
include Irmin.Make_ext(P)
|
||||
|
||||
end
|
||||
|
||||
include Conf
|
23
vendors/irmin-lmdb/irmin_lmdb.mli
vendored
Normal file
23
vendors/irmin-lmdb/irmin_lmdb.mli
vendored
Normal file
@ -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 -> ?mapsize:int64 -> string -> Irmin.config
|
||||
|
||||
module Make : Irmin.S_MAKER
|
7
vendors/irmin-lmdb/jbuild
vendored
Normal file
7
vendors/irmin-lmdb/jbuild
vendored
Normal file
@ -0,0 +1,7 @@
|
||||
(jbuild_version 1)
|
||||
|
||||
(library
|
||||
((name irmin_lmdb)
|
||||
(public_name irmin-lmdb)
|
||||
(libraries (irmin lmdb))
|
||||
(flags (:standard -safe-string))))
|
Loading…
Reference in New Issue
Block a user