From 5f03f9151e1d713aee7cf2c452ae80485eb26998 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Mon, 26 Aug 2019 23:05:12 +0200 Subject: [PATCH 01/17] vendors: import irminv2 and irmin-pack (and remove irmin-lmdb) --- vendors/index/.gitignore | 3 + vendors/index/.ocamlformat | 2 + vendors/index/LICENSE | 21 + vendors/index/index.opam | 22 + vendors/index/src/dune | 5 + vendors/index/src/index.ml | 458 ++ vendors/index/src/index.mli | 115 + vendors/index/src/io.mli | 29 + vendors/index/src/unix/dune | 4 + vendors/index/src/unix/index_unix.ml | 250 ++ vendors/index/src/unix/index_unix.mli | 2 + vendors/irmin-lmdb/dune | 5 - vendors/irmin-lmdb/irmin-lmdb.opam | 20 - vendors/irmin-lmdb/irmin_lmdb.ml | 708 ---- vendors/irmin-pack/IO.ml | 290 ++ vendors/irmin-pack/IO.mli | 52 + vendors/irmin-pack/dict.ml | 110 + vendors/irmin-pack/dict.mli | 31 + vendors/irmin-pack/dune | 4 + vendors/irmin-pack/inode.ml | 783 ++++ vendors/irmin-pack/inode.mli | 53 + vendors/irmin-pack/irmin-pack.opam | 23 + vendors/irmin-pack/irmin_pack.ml | 430 ++ vendors/irmin-pack/irmin_pack.mli | 67 + vendors/irmin-pack/lru.ml | 118 + vendors/irmin-pack/lru.mli | 26 + vendors/irmin-pack/pack.ml | 339 ++ vendors/irmin-pack/pack.mli | 86 + vendors/irmin-pack/pack_dict.ml | 9 + vendors/irmin-pack/pack_index.ml | 102 + vendors/irmin-pack/pack_index.mli | 40 + vendors/irmin/bheap.ml | 116 + vendors/irmin/bheap.mli | 59 + vendors/irmin/branch.ml | 35 + vendors/irmin/branch.mli | 19 + vendors/irmin/commit.ml | 543 +++ vendors/irmin/commit.mli | 49 + vendors/irmin/conf.ml | 149 + vendors/irmin/conf.mli | 81 + vendors/irmin/contents.ml | 316 ++ vendors/irmin/contents.mli | 63 + vendors/irmin/diff.ml | 27 + vendors/irmin/diff.mli | 19 + vendors/irmin/dot.ml | 219 + vendors/irmin/dot.mli | 32 + vendors/irmin/dune | 4 + vendors/irmin/hash.ml | 82 + vendors/irmin/hash.mli | 40 + vendors/irmin/info.ml | 45 + vendors/irmin/info.mli | 37 + vendors/irmin/irmin.ml | 255 ++ vendors/irmin/irmin.mli | 3693 +++++++++++++++++ vendors/irmin/irmin.opam | 38 + vendors/irmin/lock.ml | 72 + .../irmin_lmdb.mli => irmin/lock.mli} | 16 +- vendors/irmin/lru.ml | 1 + vendors/irmin/merge.ml | 443 ++ vendors/irmin/merge.mli | 127 + vendors/irmin/node.ml | 473 +++ vendors/irmin/node.mli | 75 + vendors/irmin/object_graph.ml | 236 ++ vendors/irmin/object_graph.mli | 89 + vendors/irmin/path.ml | 56 + vendors/irmin/path.mli | 19 + vendors/irmin/s.ml | 1148 +++++ vendors/irmin/slice.ml | 83 + vendors/irmin/slice.mli | 21 + vendors/irmin/store.ml | 1131 +++++ vendors/irmin/store.mli | 46 + vendors/irmin/sync.ml | 33 + vendors/irmin/sync.mli | 23 + vendors/irmin/sync_ext.ml | 198 + vendors/irmin/sync_ext.mli | 22 + vendors/irmin/tree.ml | 1780 ++++++++ vendors/irmin/tree.mli | 51 + vendors/irmin/type.ml | 1659 ++++++++ vendors/irmin/type.mli | 212 + vendors/irmin/version.ml | 1 + vendors/irmin/watch.ml | 341 ++ vendors/irmin/watch.mli | 72 + 80 files changed, 17818 insertions(+), 738 deletions(-) create mode 100644 vendors/index/.gitignore create mode 100644 vendors/index/.ocamlformat create mode 100644 vendors/index/LICENSE create mode 100644 vendors/index/index.opam create mode 100644 vendors/index/src/dune create mode 100644 vendors/index/src/index.ml create mode 100644 vendors/index/src/index.mli create mode 100644 vendors/index/src/io.mli create mode 100644 vendors/index/src/unix/dune create mode 100644 vendors/index/src/unix/index_unix.ml create mode 100644 vendors/index/src/unix/index_unix.mli delete mode 100644 vendors/irmin-lmdb/dune delete mode 100644 vendors/irmin-lmdb/irmin-lmdb.opam delete mode 100644 vendors/irmin-lmdb/irmin_lmdb.ml create mode 100644 vendors/irmin-pack/IO.ml create mode 100644 vendors/irmin-pack/IO.mli create mode 100644 vendors/irmin-pack/dict.ml create mode 100644 vendors/irmin-pack/dict.mli create mode 100644 vendors/irmin-pack/dune create mode 100644 vendors/irmin-pack/inode.ml create mode 100644 vendors/irmin-pack/inode.mli create mode 100644 vendors/irmin-pack/irmin-pack.opam create mode 100644 vendors/irmin-pack/irmin_pack.ml create mode 100644 vendors/irmin-pack/irmin_pack.mli create mode 100644 vendors/irmin-pack/lru.ml create mode 100644 vendors/irmin-pack/lru.mli create mode 100644 vendors/irmin-pack/pack.ml create mode 100644 vendors/irmin-pack/pack.mli create mode 100644 vendors/irmin-pack/pack_dict.ml create mode 100644 vendors/irmin-pack/pack_index.ml create mode 100644 vendors/irmin-pack/pack_index.mli create mode 100644 vendors/irmin/bheap.ml create mode 100644 vendors/irmin/bheap.mli create mode 100644 vendors/irmin/branch.ml create mode 100644 vendors/irmin/branch.mli create mode 100644 vendors/irmin/commit.ml create mode 100644 vendors/irmin/commit.mli create mode 100644 vendors/irmin/conf.ml create mode 100644 vendors/irmin/conf.mli create mode 100644 vendors/irmin/contents.ml create mode 100644 vendors/irmin/contents.mli create mode 100644 vendors/irmin/diff.ml create mode 100644 vendors/irmin/diff.mli create mode 100644 vendors/irmin/dot.ml create mode 100644 vendors/irmin/dot.mli create mode 100644 vendors/irmin/dune create mode 100644 vendors/irmin/hash.ml create mode 100644 vendors/irmin/hash.mli create mode 100644 vendors/irmin/info.ml create mode 100644 vendors/irmin/info.mli create mode 100644 vendors/irmin/irmin.ml create mode 100644 vendors/irmin/irmin.mli create mode 100644 vendors/irmin/irmin.opam create mode 100644 vendors/irmin/lock.ml rename vendors/{irmin-lmdb/irmin_lmdb.mli => irmin/lock.mli} (76%) create mode 100644 vendors/irmin/lru.ml create mode 100644 vendors/irmin/merge.ml create mode 100644 vendors/irmin/merge.mli create mode 100644 vendors/irmin/node.ml create mode 100644 vendors/irmin/node.mli create mode 100644 vendors/irmin/object_graph.ml create mode 100644 vendors/irmin/object_graph.mli create mode 100644 vendors/irmin/path.ml create mode 100644 vendors/irmin/path.mli create mode 100644 vendors/irmin/s.ml create mode 100644 vendors/irmin/slice.ml create mode 100644 vendors/irmin/slice.mli create mode 100644 vendors/irmin/store.ml create mode 100644 vendors/irmin/store.mli create mode 100644 vendors/irmin/sync.ml create mode 100644 vendors/irmin/sync.mli create mode 100644 vendors/irmin/sync_ext.ml create mode 100644 vendors/irmin/sync_ext.mli create mode 100644 vendors/irmin/tree.ml create mode 100644 vendors/irmin/tree.mli create mode 100644 vendors/irmin/type.ml create mode 100644 vendors/irmin/type.mli create mode 100644 vendors/irmin/version.ml create mode 100644 vendors/irmin/watch.ml create mode 100644 vendors/irmin/watch.mli diff --git a/vendors/index/.gitignore b/vendors/index/.gitignore new file mode 100644 index 000000000000..231dab4b1edf --- /dev/null +++ b/vendors/index/.gitignore @@ -0,0 +1,3 @@ +_build +*.install +*.merlin diff --git a/vendors/index/.ocamlformat b/vendors/index/.ocamlformat new file mode 100644 index 000000000000..c74708f6a4e7 --- /dev/null +++ b/vendors/index/.ocamlformat @@ -0,0 +1,2 @@ +version = 0.10 +profile = conventional diff --git a/vendors/index/LICENSE b/vendors/index/LICENSE new file mode 100644 index 000000000000..30046ee86c6f --- /dev/null +++ b/vendors/index/LICENSE @@ -0,0 +1,21 @@ +The MIT License + +Copyright (c) 2019 Clément Pascutto, Thomas Gazagnaire + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/vendors/index/index.opam b/vendors/index/index.opam new file mode 100644 index 000000000000..7d909786230f --- /dev/null +++ b/vendors/index/index.opam @@ -0,0 +1,22 @@ +opam-version: "2.0" +maintainer: "Clement Pascutto" +authors: ["Clement Pascutto" "Thomas Gazagnaire"] +license: "MIT" +homepage: "https://github.com/mirage/index" +bug-reports: "https://github.com/mirage/index/issues" +dev-repo: "git+https://github.com/mirage/index.git" + +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name] {with-test} +] + +depends: [ + "ocaml" {>= "4.03.0"} + "dune" {build & >= "1.7.0"} + "bloomf" + "fmt" + "logs" +] +synopsis: "Scalable indexes for Ocaml" diff --git a/vendors/index/src/dune b/vendors/index/src/dune new file mode 100644 index 000000000000..1b3c2ff2c88c --- /dev/null +++ b/vendors/index/src/dune @@ -0,0 +1,5 @@ +(library + (public_name index) + (name index) + (modules_without_implementation io) + (libraries bloomf logs fmt)) diff --git a/vendors/index/src/index.ml b/vendors/index/src/index.ml new file mode 100644 index 000000000000..6469fda1a51c --- /dev/null +++ b/vendors/index/src/index.ml @@ -0,0 +1,458 @@ +module type Key = sig + type t + + val equal : t -> t -> bool + + val hash : t -> int + + val hash_size : int + + val encode : t -> string + + val decode : string -> int -> t + + val encoded_size : int + + val pp : t Fmt.t +end + +module type Value = sig + type t + + val encode : t -> string + + val decode : string -> int -> t + + val encoded_size : int + + val pp : t Fmt.t +end + +module type IO = Io.S + +module type S = sig + type t + + type key + + type value + + val v : + ?fresh:bool -> + ?readonly:bool -> + ?shared:bool -> + log_size:int -> + fan_out_size:int -> + string -> + t + + val clear : t -> unit + + val find_all : t -> key -> value list + + val mem : t -> key -> bool + + val add : t -> key -> value -> unit + + val iter : (key -> value -> unit) -> t -> unit + + val flush : t -> unit +end + +let may f = function None -> () | Some bf -> f bf + +exception RO_Not_Allowed + +let src = Logs.Src.create "index" ~doc:"Index" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Make (K : Key) (V : Value) (IO : IO) = struct + type key = K.t + + type value = V.t + + type entry = { key : key; value : value } + + let entry_size = K.encoded_size + V.encoded_size + + let entry_sizef = float_of_int entry_size + + let entry_sizeL = Int64.of_int entry_size + + module Fan = struct + type t = { size : int; fans : int64 array; mask : int; shift : int } + + let v n = + let size = n in + let nb_fans = 1 lsl size in + let fans = Array.make nb_fans (-1L) in + let shift = K.hash_size - size in + let mask = (nb_fans - 1) lsl shift in + { size; fans; mask; shift } + + let fan t h = (h land t.mask) lsr t.shift + + let clear t = Array.fill t.fans 0 (Array.length t.fans) (-1L) + + let search t h = + let fan = fan t h in + let low = if fan = 0 then 0L else t.fans.(fan - 1) in + (low, t.fans.(fan)) + + let update t hash off = + let fan = fan t hash in + t.fans.(fan) <- off + + let flatten t = + let rec loop curr i = + if i = Array.length t.fans then () + else ( + if t.fans.(i) = -1L then t.fans.(i) <- curr; + loop t.fans.(i) (i + 1) ) + in + loop 0L 0 + end + + let append_entry io e = + IO.append io (K.encode e.key); + IO.append io (V.encode e.value) + + let decode_entry bytes off = + let string = Bytes.unsafe_to_string bytes in + let key = K.decode string off in + let value = V.decode string (off + K.encoded_size) in + { key; value } + + module Tbl = Hashtbl.Make (K) + + type config = { log_size : int; readonly : bool } + + type t = { + config : config; + root : string; + mutable generation : int64; + fan_out : Fan.t; + mutable index : IO.t; + log : IO.t; + log_mem : entry Tbl.t; + entries : key Bloomf.t option; + } + + let clear t = + Log.debug (fun l -> l "clear %S" t.root); + t.generation <- 0L; + IO.clear t.log; + may Bloomf.clear t.entries; + Tbl.clear t.log_mem; + Fan.clear t.fan_out; + IO.clear t.index + + let ( // ) = Filename.concat + + let log_path root = root // "index.log" + + let index_path root = root // "index" // "index" + + let page_size = Int64.mul entry_sizeL 1_000L + + let iter_io_off ?(min = 0L) ?max f io = + let max = match max with None -> IO.offset io | Some m -> m in + let rec aux offset = + let remaining = Int64.sub max offset in + if remaining <= 0L then () + else + let size = Stdlib.min remaining page_size in + let raw = Bytes.create (Int64.to_int size) in + let n = IO.read io ~off:offset raw in + let rec read_page page off = + if off = n then () + else + let entry = decode_entry page off in + f Int64.(add (of_int off) offset) entry; + (read_page [@tailcall]) page (off + entry_size) + in + read_page raw 0; + (aux [@tailcall]) Int64.(add offset page_size) + in + (aux [@tailcall]) min + + let iter_io ?min ?max f io = iter_io_off ?min ?max (fun _ e -> f e) io + + let get_entry t off = + let buf = Bytes.create entry_size in + let _ = IO.read t.index ~off buf in + decode_entry buf 0 + + let with_cache ~v ~clear = + let roots = Hashtbl.create 0 in + let f ?(fresh = false) ?(readonly = false) ?(shared = true) ~log_size + ~fan_out_size root = + if not shared then ( + Log.debug (fun l -> + l "[%s] v fresh=%b shared=%b readonly=%b" (Filename.basename root) + fresh shared readonly); + v ~fresh ~readonly ~log_size ~fan_out_size root ) + else + try + if not (Sys.file_exists root) then ( + Log.debug (fun l -> + l "[%s] does not exist anymore, cleaning up the fd cache" + (Filename.basename root)); + Hashtbl.remove roots root; + raise Not_found ); + let t = Hashtbl.find roots root in + Log.debug (fun l -> l "%s found in cache" root); + if fresh then clear t; + t + with Not_found -> + Log.debug (fun l -> + l "[%s] v fresh=%b shared=%b readonly=%b" + (Filename.basename root) fresh shared readonly); + let t = v ~fresh ~readonly ~log_size ~fan_out_size root in + Hashtbl.add roots root t; + t + in + `Staged f + + let v_no_cache ~fresh ~readonly ~log_size ~fan_out_size root = + let config = { log_size = log_size * entry_size; readonly } in + let log_path = log_path root in + let index_path = index_path root in + let entries = + if readonly then None + else Some (Bloomf.create ~error_rate:0.01 100_000_000) + in + let log_mem = Tbl.create 1024 in + let log = IO.v ~fresh ~readonly ~generation:0L log_path in + let index = IO.v ~fresh ~readonly ~generation:0L index_path in + let generation = IO.get_generation log in + let fan_out = Fan.v fan_out_size in + let t = + { config; generation; fan_out; log_mem; root; log; index; entries } + in + if not fresh then ( + iter_io + (fun e -> + Tbl.add t.log_mem e.key e; + may (fun bf -> Bloomf.add bf e.key) t.entries) + t.log; + iter_io_off + (fun off e -> + let hash = K.hash e.key in + Fan.update t.fan_out hash off; + may (fun bf -> Bloomf.add bf e.key) t.entries) + t.index; + Fan.flatten t.fan_out ); + t + + let (`Staged v) = with_cache ~v:v_no_cache ~clear + + let get_entry_iff_needed t off = function + | Some e -> e + | None -> get_entry t off + + let look_around t init key h_key off = + let rec search acc op curr = + let off = op curr entry_sizeL in + if off < 0L || off >= IO.offset t.index then acc + else + let e = get_entry t off in + let h_e = K.hash e.key in + if h_e <> h_key then acc + else + let new_acc = if K.equal e.key key then e.value :: acc else acc in + search new_acc op off + in + let before = search init Int64.add off in + search before Int64.sub off + + let interpolation_search t key = + let hashed_key = K.hash key in + let low, high = Fan.search t.fan_out hashed_key in + let rec search low high lowest_entry highest_entry = + if high < low then [] + else + let lowest_entry = get_entry_iff_needed t low lowest_entry in + if high = low then + if K.equal lowest_entry.key key then [ lowest_entry.value ] else [] + else + let lowest_hash = K.hash lowest_entry.key in + if lowest_hash > hashed_key then [] + else + let highest_entry = get_entry_iff_needed t high highest_entry in + let highest_hash = K.hash highest_entry.key in + if highest_hash < hashed_key then [] + else + let lowest_hashf = float_of_int lowest_hash in + let highest_hashf = float_of_int highest_hash in + let hashed_keyf = float_of_int hashed_key in + let lowf = Int64.to_float low in + let highf = Int64.to_float high in + let doff = + floor + ( (highf -. lowf) + *. (hashed_keyf -. lowest_hashf) + /. (highest_hashf -. lowest_hashf) ) + in + let off = lowf +. doff -. mod_float doff entry_sizef in + let offL = Int64.of_float off in + let e = get_entry t offL in + let hashed_e = K.hash e.key in + if hashed_key = hashed_e then + let init = if K.equal key e.key then [ e.value ] else [] in + look_around t init key hashed_key offL + else if hashed_e < hashed_key then + (search [@tailcall]) + (Int64.add offL entry_sizeL) + high None (Some highest_entry) + else + (search [@tailcall]) low + (Int64.sub offL entry_sizeL) + (Some lowest_entry) None + in + if high < 0L then [] else (search [@tailcall]) low high None None + + let sync_log t = + let generation = IO.get_generation t.log in + let log_offset = IO.offset t.log in + let new_log_offset = IO.force_offset t.log in + let add_log_entry e = + Tbl.add t.log_mem e.key e; + may (fun bf -> Bloomf.add bf e.key) t.entries + in + if t.generation <> generation then ( + Tbl.clear t.log_mem; + iter_io add_log_entry t.log; + let index_path = index_path t.root in + let index = IO.v ~fresh:false ~readonly:true ~generation index_path in + let _ = IO.force_offset index in + Fan.clear t.fan_out; + iter_io_off + (fun off e -> + let hash = K.hash e.key in + Fan.update t.fan_out hash off) + index; + Fan.flatten t.fan_out; + t.index <- index; + t.generation <- generation ) + else if log_offset < new_log_offset then + iter_io add_log_entry t.log ~min:log_offset + else if log_offset > new_log_offset then assert false + + let find_all t key = + Log.debug (fun l -> l "find %a" K.pp key); + if t.config.readonly then sync_log t; + let look_on_disk () = + let in_index = interpolation_search t key in + let in_log = List.map (fun e -> e.value) (Tbl.find_all t.log_mem key) in + in_index @ in_log + in + match t.entries with + | None -> look_on_disk () + | Some bf -> if not (Bloomf.mem bf key) then [] else look_on_disk () + + let mem t key = + Log.debug (fun l -> l "mem %a" K.pp key); + match find_all t key with [] -> false | _ -> true + + let append_entry_fanout t h io e = + Fan.update t.fan_out h (IO.offset io); + append_entry io e + + let merge_with log t tmp = + Fan.clear t.fan_out; + let offset = ref 0L in + let get_index_entry = function + | Some e -> Some e + | None -> + if !offset >= IO.offset t.index then None + else + let e = get_entry t !offset in + offset := Int64.add !offset entry_sizeL; + Some e + in + let rec go last_read l = + match get_index_entry last_read with + | None -> + List.iter + (fun v -> + let hashed_v = K.hash v.key in + append_entry_fanout t hashed_v tmp v) + l + | Some e -> ( + let hashed_e = K.hash e.key in + match l with + | v :: r -> + let last, rst = + let hashed_v = K.hash v.key in + if hashed_e = hashed_v then ( + append_entry_fanout t hashed_e tmp e; + append_entry_fanout t hashed_v tmp v; + (None, r) ) + else if hashed_e < hashed_v then ( + append_entry_fanout t hashed_e tmp e; + (None, l) ) + else ( + append_entry_fanout t hashed_v tmp v; + (Some e, r) ) + in + if !offset >= IO.offset t.index && last = None then + List.iter + (fun v -> + let hashed_v = K.hash v.key in + append_entry_fanout t hashed_v tmp v) + rst + else (go [@tailcall]) last rst + | [] -> + append_entry_fanout t hashed_e tmp e; + iter_io + (fun e -> + let hashed_e = K.hash e.key in + append_entry_fanout t hashed_e tmp e) + t.index ~min:!offset ) + in + (go [@tailcall]) None log + + module EntrySet = Set.Make (struct + type t = entry + + let compare e e' = + let c = compare (K.hash e.key) (K.hash e'.key) in + if c = 0 then 1 else c + end) + + let merge t = + Log.debug (fun l -> l "merge %S" t.root); + let tmp_path = t.root // "tmp" // "index" in + let generation = Int64.succ t.generation in + let tmp = IO.v ~readonly:false ~fresh:true ~generation tmp_path in + let log = + Tbl.fold (fun _ e acc -> EntrySet.add e acc) t.log_mem EntrySet.empty + |> EntrySet.elements + in + merge_with log t tmp; + IO.rename ~src:tmp ~dst:t.index; + Fan.flatten t.fan_out; + IO.clear t.log; + Tbl.clear t.log_mem; + IO.set_generation t.log generation; + t.generation <- generation + + let add t key value = + Log.debug (fun l -> l "add %a %a" K.pp key V.pp value); + if t.config.readonly then raise RO_Not_Allowed; + let entry = { key; value } in + append_entry t.log entry; + Tbl.add t.log_mem key entry; + may (fun bf -> Bloomf.add bf key) t.entries; + if Int64.compare (IO.offset t.log) (Int64.of_int t.config.log_size) > 0 + then merge t + + (* XXX: Perform a merge beforehands to ensure duplicates are not hit twice. *) + let iter f t = + Tbl.iter (fun _ e -> f e.key e.value) t.log_mem; + iter_io (fun e -> f e.key e.value) t.index + + let flush t = IO.sync t.log +end diff --git a/vendors/index/src/index.mli b/vendors/index/src/index.mli new file mode 100644 index 000000000000..43007df5f8bc --- /dev/null +++ b/vendors/index/src/index.mli @@ -0,0 +1,115 @@ +(** Deudex + + deudex is a scalable implementation of persistent indexes in Ocaml. + + deudex is append-only, which means it provides [append], [find] and [mem] + primitives. + Multiples IOs are created when using the index : + - A `log` IO contains all the recently added bindings, it is also kept in + memory. + - When the `log` IO is full, it is merged into multiple `index` IOs. + Search is done first in `log` then in `index`, which makes recently added + bindings search faster. +*) + +(** The input of [Make] for keys. *) +module type Key = sig + type t + (** The type for keys. *) + + val equal : t -> t -> bool + (** The equality function for keys. *) + + val hash : t -> int + (** Note: Unevenly distributed hash functions may result in performance + drops. *) + + val hash_size : int + (** The maximum number of bits used to encode hashes. `Hashtbl.hash` uses 30 + bits. *) + + val encode : t -> string + (** [encode] is an encoding function. The encoded resulting values must be of + fixed size. *) + + val decode : string -> int -> t + (** [decode] is a decoding function such that [decode (encode t) 0 = t]. *) + + val encoded_size : int + (** [encoded_size] is the size of the encoded keys, expressed in number of + bytes. *) + + val pp : t Fmt.t + (** Formatter for keys *) +end + +(** The input of [Make] for values. The same requirements as for [Key] + applies. *) +module type Value = sig + type t + + val encode : t -> string + + val decode : string -> int -> t + + val encoded_size : int + + val pp : t Fmt.t +end + +module type IO = Io.S + +exception RO_Not_Allowed +(** The exception raised when illegal operation is attempted on a read_only + index. *) + +(** Index module signature. *) +module type S = sig + type t + (** The type for indexes. *) + + type key + (** The type for keys. *) + + type value + (** The type for values. *) + + val v : + ?fresh:bool -> + ?readonly:bool -> + ?shared:bool -> + log_size:int -> + fan_out_size:int -> + string -> + t + (** The constructor for indexes. + @param fresh + @param read_only whether read-only mode is enabled for this index. + @param log_size the maximum number of bindings in the `log` IO. + @param fan_out_size the number of bits of the fan out for index IO. + *) + + val clear : t -> unit + (** [clear t] clears [t] so that there are no more bindings in it. *) + + val find_all : t -> key -> value list + (** [find t k] are all the bindings of [k] in [t]. The order is not + specified *) + + val mem : t -> key -> bool + (** [mem t k] is [true] iff [k] is bound in [t]. *) + + val add : t -> key -> value -> unit + (** [add t k v] binds [k] to [v] in [t]. *) + + val iter : (key -> value -> unit) -> t -> unit + (** Iterates over the index bindings. Order is not specified. + In case of recent replacements of existing values (after the last merge), + this will hit both the new and old bindings. *) + + val flush : t -> unit + (** Flushes all buffers to the disk. *) +end + +module Make (K : Key) (V : Value) (IO : IO) : + S with type key = K.t and type value = V.t diff --git a/vendors/index/src/io.mli b/vendors/index/src/io.mli new file mode 100644 index 000000000000..02ecfdb9f937 --- /dev/null +++ b/vendors/index/src/io.mli @@ -0,0 +1,29 @@ +module type S = sig + type t + + val v : readonly:bool -> fresh:bool -> generation:int64 -> string -> t + + val name : t -> string + + val offset : t -> int64 + + val force_offset : t -> int64 + + val readonly : t -> bool + + val read : t -> off:int64 -> bytes -> int + + val clear : t -> unit + + val sync : t -> unit + + val version : t -> string + + val set_generation : t -> int64 -> unit + + val get_generation : t -> int64 + + val rename : src:t -> dst:t -> unit + + val append : t -> string -> unit +end diff --git a/vendors/index/src/unix/dune b/vendors/index/src/unix/dune new file mode 100644 index 000000000000..4744ee748595 --- /dev/null +++ b/vendors/index/src/unix/dune @@ -0,0 +1,4 @@ +(library + (public_name index.unix) + (name index_unix) + (libraries unix index)) diff --git a/vendors/index/src/unix/index_unix.ml b/vendors/index/src/unix/index_unix.ml new file mode 100644 index 000000000000..4c04a5b6b3a1 --- /dev/null +++ b/vendors/index/src/unix/index_unix.ml @@ -0,0 +1,250 @@ +exception RO_Not_Allowed + +let current_version = "00000001" + +module IO : Index.IO = struct + let ( ++ ) = Int64.add + + let ( -- ) = Int64.sub + + external set_64 : Bytes.t -> int -> int64 -> unit = "%caml_string_set64u" + + external get_64 : string -> int -> int64 = "%caml_string_get64" + + external swap64 : int64 -> int64 = "%bswap_int64" + + let encode_int64 i = + let set_uint64 s off v = + if not Sys.big_endian then set_64 s off (swap64 v) else set_64 s off v + in + let b = Bytes.create 8 in + set_uint64 b 0 i; + Bytes.unsafe_to_string b + + let decode_int64 buf = + let get_uint64 s off = + if not Sys.big_endian then swap64 (get_64 s off) else get_64 s off + in + get_uint64 buf 0 + + module Raw = struct + type t = { fd : Unix.file_descr; mutable cursor : int64 } + + let v fd = { fd; cursor = 0L } + + let really_write fd buf = + let rec aux off len = + let w = Unix.write fd buf off len in + if w = 0 then () else (aux [@tailcall]) (off + w) (len - w) + in + (aux [@tailcall]) 0 (Bytes.length buf) + + let really_read fd len buf = + let rec aux off len = + let r = Unix.read fd buf off len in + if r = 0 then off (* end of file *) + else if r = len then off + r + else (aux [@tailcall]) (off + r) (len - r) + in + (aux [@tailcall]) 0 len + + let lseek t off = + if off = t.cursor then () + else + let _ = Unix.LargeFile.lseek t.fd off Unix.SEEK_SET in + t.cursor <- off + + let unsafe_write t ~off buf = + lseek t off; + let buf = Bytes.unsafe_of_string buf in + really_write t.fd buf; + t.cursor <- off ++ Int64.of_int (Bytes.length buf) + + let unsafe_read t ~off ~len buf = + lseek t off; + let n = really_read t.fd len buf in + t.cursor <- off ++ Int64.of_int n; + n + + let unsafe_set_offset t n = + let buf = encode_int64 n in + unsafe_write t ~off:0L buf + + let unsafe_get_offset t = + let buf = Bytes.create 8 in + let n = unsafe_read t ~off:0L ~len:8 buf in + assert (n = 8); + decode_int64 (Bytes.unsafe_to_string buf) + + let unsafe_get_version t = + let buf = Bytes.create 8 in + let n = unsafe_read t ~off:8L ~len:8 buf in + assert (n = 8); + Bytes.unsafe_to_string buf + + let unsafe_set_version t = unsafe_write t ~off:8L current_version + + let unsafe_get_generation t = + let buf = Bytes.create 8 in + let n = unsafe_read t ~off:16L ~len:8 buf in + assert (n = 8); + decode_int64 (Bytes.unsafe_to_string buf) + + let unsafe_set_generation t gen = + let buf = encode_int64 gen in + unsafe_write t ~off:16L buf + end + + type t = { + file : string; + mutable raw : Raw.t; + mutable offset : int64; + mutable flushed : int64; + readonly : bool; + version : string; + buf : Buffer.t; + } + + let header = 24L (* offset + version + generation *) + + let sync t = + if t.readonly then raise RO_Not_Allowed; + let buf = Buffer.contents t.buf in + let offset = t.offset in + Buffer.clear t.buf; + if buf = "" then () + else ( + Raw.unsafe_write t.raw ~off:t.flushed buf; + Raw.unsafe_set_offset t.raw offset; + + (* concurrent append might happen so here t.offset might differ + from offset *) + if not (t.flushed ++ Int64.of_int (String.length buf) = header ++ offset) + then + Fmt.failwith "sync error: %s flushed=%Ld buf=%Ld offset+header=%Ld\n%!" + t.file t.flushed + (Int64.of_int (String.length buf)) + (offset ++ header); + t.flushed <- offset ++ header ) + + let name t = t.file + + let rename ~src ~dst = + sync src; + Unix.close dst.raw.fd; + Unix.rename src.file dst.file; + dst.offset <- src.offset; + dst.flushed <- src.flushed; + dst.raw <- src.raw + + let auto_flush_limit = 1_000_000L + + let append t buf = + if t.readonly then raise RO_Not_Allowed; + Buffer.add_string t.buf buf; + let len = Int64.of_int (String.length buf) in + t.offset <- t.offset ++ len; + if t.offset -- t.flushed > auto_flush_limit then sync t + + let read t ~off buf = + if not t.readonly then assert (header ++ off <= t.flushed); + Raw.unsafe_read t.raw ~off:(header ++ off) ~len:(Bytes.length buf) buf + + let offset t = t.offset + + let force_offset t = + t.offset <- Raw.unsafe_get_offset t.raw; + t.offset + + let version t = t.version + + let get_generation t = Raw.unsafe_get_generation t.raw + + let set_generation t gen = Raw.unsafe_set_generation t.raw gen + + let readonly t = t.readonly + + let protect_unix_exn = function + | Unix.Unix_error _ as e -> failwith (Printexc.to_string e) + | e -> raise e + + let ignore_enoent = function + | Unix.Unix_error (Unix.ENOENT, _, _) -> () + | e -> raise e + + let protect f x = try f x with e -> protect_unix_exn e + + let safe f x = try f x with e -> ignore_enoent e + + let mkdir dirname = + let rec aux dir k = + if Sys.file_exists dir && Sys.is_directory dir then k () + else ( + if Sys.file_exists dir then safe Unix.unlink dir; + (aux [@tailcall]) (Filename.dirname dir) @@ fun () -> + protect (Unix.mkdir dir) 0o755; + k () ) + in + (aux [@tailcall]) dirname (fun () -> ()) + + let clear t = + t.offset <- 0L; + t.flushed <- header; + Raw.unsafe_set_generation t.raw 0L; + Raw.unsafe_set_offset t.raw t.offset; + Buffer.clear t.buf + + let buffers = Hashtbl.create 256 + + let buffer file = + try + let buf = Hashtbl.find buffers file in + Buffer.clear buf; + buf + with Not_found -> + let buf = Buffer.create (4 * 1024) in + Hashtbl.add buffers file buf; + buf + + let () = assert (String.length current_version = 8) + + let v ~readonly ~fresh ~generation file = + let v ~offset ~version raw = + { + version; + file; + offset; + raw; + readonly; + buf = buffer file; + flushed = header ++ offset; + } + in + let mode = Unix.(if readonly then O_RDONLY else O_RDWR) in + mkdir (Filename.dirname file); + match Sys.file_exists file with + | false -> + if readonly then raise RO_Not_Allowed; + let x = Unix.openfile file Unix.[ O_CREAT; mode ] 0o644 in + let raw = Raw.v x in + Raw.unsafe_set_offset raw 0L; + Raw.unsafe_set_version raw; + Raw.unsafe_set_generation raw generation; + v ~offset:0L ~version:current_version raw + | true -> + let x = Unix.openfile file Unix.[ O_EXCL; mode ] 0o644 in + let raw = Raw.v x in + if readonly && fresh then + Fmt.failwith "IO.v: cannot reset a readonly file" + else if fresh then ( + Raw.unsafe_set_offset raw 0L; + Raw.unsafe_set_version raw; + Raw.unsafe_set_generation raw generation; + v ~offset:0L ~version:current_version raw ) + else + let offset = Raw.unsafe_get_offset raw in + let version = Raw.unsafe_get_version raw in + v ~offset ~version raw +end + +module Make (K : Index.Key) (V : Index.Value) = Index.Make (K) (V) (IO) diff --git a/vendors/index/src/unix/index_unix.mli b/vendors/index/src/unix/index_unix.mli new file mode 100644 index 000000000000..6a58e56ebfee --- /dev/null +++ b/vendors/index/src/unix/index_unix.mli @@ -0,0 +1,2 @@ +module Make (K : Index.Key) (V : Index.Value) : + Index.S with type key = K.t and type value = V.t diff --git a/vendors/irmin-lmdb/dune b/vendors/irmin-lmdb/dune deleted file mode 100644 index ab0458feb96d..000000000000 --- a/vendors/irmin-lmdb/dune +++ /dev/null @@ -1,5 +0,0 @@ -(library - (name irmin_lmdb) - (public_name irmin-lmdb) - (libraries irmin lmdb) - (flags (:standard -safe-string))) diff --git a/vendors/irmin-lmdb/irmin-lmdb.opam b/vendors/irmin-lmdb/irmin-lmdb.opam deleted file mode 100644 index d141ad00eeb9..000000000000 --- a/vendors/irmin-lmdb/irmin-lmdb.opam +++ /dev/null @@ -1,20 +0,0 @@ -opam-version: "2.0" -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: "git+https://gitlab.com/tezos/irmin-lmdb.git" -doc: "https://tezos.gitlab.io/irmin-lmdb/" -synopsis: "LMDB backend for Irmin" - -build: [ - ["dune" "subst"] {pinned} - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] -depends: [ - "dune" {build & >= "1.7"} - "irmin" {>= "1.4.0"} - "lmdb" {>= "0.1"} -] diff --git a/vendors/irmin-lmdb/irmin_lmdb.ml b/vendors/irmin-lmdb/irmin_lmdb.ml deleted file mode 100644 index 964216e9cb34..000000000000 --- a/vendors/irmin-lmdb/irmin_lmdb.ml +++ /dev/null @@ -1,708 +0,0 @@ -(* - * 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. - *) - -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 ; - mutable wtxn: (Lmdb.rw Lmdb.txn * Lmdb.db) option; -} - -let of_result = function - | Ok v -> Lwt.return v - | Error err -> Lwt.fail_with (Lmdb.string_of_error err) - -let (|>>) v f = - match v with - | Ok v -> f v - | Error e -> Error e - -let get_wtxn db = - match db.wtxn with - | Some t -> Ok t - | None -> - Lmdb.create_rw_txn db.db |>> fun txn -> - Lmdb.opendb txn |>> fun ddb -> - db.wtxn <- Some (txn, ddb); - Ok (txn, ddb) - -let commit_wtxn db = - match db.wtxn with - | None -> Ok () - | Some (t, _ddb) -> - db.wtxn <- None; - Lmdb.commit_txn t - -let add db k v = - get_wtxn db |>> fun (txn, ddb) -> - Lmdb.put_string txn ddb k v - -let add db k v = - of_result @@ add db k v - -let add_cstruct db k v = - get_wtxn db |>> fun (txn, ddb) -> - Lmdb.put txn ddb k (Cstruct.to_bigarray v) - -let add_cstruct db k v = - of_result @@ add_cstruct db k v - -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 bool_of_string s = - try Ok (bool_of_string s) - with Failure _ -> - Error (`Msg (Printf.sprintf "%s is not the representation of a boolean" s)) - -let int64_converter = int64_of_string, Fmt.uint64 -let bool_converter = bool_of_string, Fmt.bool - -module Conf = struct - - let root = Irmin.Private.Conf.root - let mapsize = - Irmin.Private.Conf.key "mapsize" int64_converter 409_600_000_000L - let readonly = - Irmin.Private.Conf.key "readonly" bool_converter false - -end - -let config - ?(config=Irmin.Private.Conf.empty) ?mapsize ?(readonly=false) file = - let module C = Irmin.Private.Conf in - let config = C.add config Conf.root (Some file) in - let config = C.add config Conf.readonly readonly in - Option.value_map mapsize ~default:config ~f:(C.add config Conf.mapsize) - -type ('r) reader = { f : 'k. 'k Lmdb.txn -> Lmdb.db -> ('r, Lmdb.error) result } [@@unboxed] - -let with_read_db db ~f = - match db.wtxn with - | None -> - Lmdb.with_ro_db db.db ~f:f.f - | Some (txn, ddb) -> - f.f txn ddb - -let mem db k = - with_read_db db ~f:{ f = fun txn db -> Lmdb.mem txn db k } |> - of_result - -let find_bind db k ~f = - match with_read_db db ~f:{ 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 - -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 () -> - of_result @@ commit_wtxn db >|= 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 ; - readonly : bool ; - (* 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 - let readonly = Irmin.Private.Conf.get c Conf.readonly in - { root ; mapsize ; readonly } - - let v conf = - let { root ; mapsize ; readonly } = 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 ; - let flags = if readonly then [ Lmdb.RdOnly ] else [] in - let sync_flag = - match Sys.getenv_opt "TEZOS_CONTEXT_SYNC" with - | None -> [] - | Some s -> - match String.lowercase_ascii s with - | "nosync" -> [ Lmdb.NoSync ] - | "nometasync" -> [ Lmdb.NoMetaSync ] - | _ -> - Printf.eprintf "Unrecognized TEZOS_CONTEXT_SYNC option : %s\n\ - allowed: nosync nometasync" s; - [] - in - let flags = sync_flag @ Lmdb.NoRdAhead :: Lmdb.NoTLS :: flags in - let file_flags = if readonly then 0o444 else 0o644 in - match Lmdb.opendir ~mapsize ~flags root file_flags with - | Error err -> Lwt.fail_with (Lmdb.string_of_error err) - | Ok db -> - let db = { db ; root ; wtxn = None } in - Branch.v db >|= fun branch -> - { db; branch; config = conf } - - end - end - - include Irmin.Make_ext(P) - -end - -include Conf diff --git a/vendors/irmin-pack/IO.ml b/vendors/irmin-pack/IO.ml new file mode 100644 index 000000000000..d7cac9304f7a --- /dev/null +++ b/vendors/irmin-pack/IO.ml @@ -0,0 +1,290 @@ +(* + * Copyright (c) 2013-2019 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. + *) + +let src = Logs.Src.create "irmin.pack.io" ~doc:"IO for irmin-pack" + +module Log = (val Logs.src_log src : Logs.LOG) + +module type S = sig + type t + + exception RO_Not_Allowed + + val v : fresh:bool -> version:string -> readonly:bool -> string -> t + + val name : t -> string + + val clear : t -> unit + + val append : t -> string -> unit + + val set : t -> off:int64 -> string -> unit + + val read : t -> off:int64 -> bytes -> int + + val offset : t -> int64 + + val force_offset : t -> int64 + + val readonly : t -> bool + + val version : t -> string + + val sync : t -> unit +end + +let ( ++ ) = Int64.add + +let ( -- ) = Int64.sub + +module Unix : S = struct + exception RO_Not_Allowed + + module Raw = struct + type t = { fd : Unix.file_descr; mutable cursor : int64 } + + let v fd = { fd; cursor = 0L } + + let really_write fd buf = + let rec aux off len = + let w = Unix.write fd buf off len in + if w = 0 then () else (aux [@tailcall]) (off + w) (len - w) + in + (aux [@tailcall]) 0 (Bytes.length buf) + + let really_read fd len buf = + let rec aux off len = + let r = Unix.read fd buf off len in + if r = 0 then off (* end of file *) + else if r = len then off + r + else (aux [@tailcall]) (off + r) (len - r) + in + (aux [@tailcall]) 0 len + + let lseek t off = + if off = t.cursor then () + else + let _ = Unix.LargeFile.lseek t.fd off Unix.SEEK_SET in + t.cursor <- off + + let unsafe_write t ~off buf = + lseek t off; + let buf = Bytes.unsafe_of_string buf in + really_write t.fd buf; + t.cursor <- off ++ Int64.of_int (Bytes.length buf) + + let unsafe_read t ~off ~len buf = + lseek t off; + let n = really_read t.fd len buf in + t.cursor <- off ++ Int64.of_int n; + n + + let unsafe_set_offset t n = + let buf = Irmin.Type.(to_bin_string int64) n in + unsafe_write t ~off:0L buf + + let unsafe_get_offset t = + let buf = Bytes.create 8 in + let n = unsafe_read t ~off:0L ~len:8 buf in + assert (n = 8); + match Irmin.Type.(of_bin_string int64) (Bytes.unsafe_to_string buf) with + | Ok t -> t + | Error (`Msg e) -> Fmt.failwith "get_offset: %s" e + + let unsafe_get_version t = + let buf = Bytes.create 8 in + let n = unsafe_read t ~off:8L ~len:8 buf in + assert (n = 8); + Bytes.unsafe_to_string buf + + let unsafe_set_version t v = unsafe_write t ~off:8L v + end + + type t = { + file : string; + mutable raw : Raw.t; + mutable offset : int64; + mutable flushed : int64; + readonly : bool; + version : string; + buf : Buffer.t + } + + let name t = t.file + + let header = 16L (* offset + version *) + + let sync t = + if t.readonly then raise RO_Not_Allowed; + Log.debug (fun l -> l "IO sync %s" t.file); + let buf = Buffer.contents t.buf in + let offset = t.offset in + Buffer.clear t.buf; + if buf = "" then () + else ( + Raw.unsafe_write t.raw ~off:t.flushed buf; + Raw.unsafe_set_offset t.raw offset; + (* concurrent append might happen so here t.offset might differ + from offset *) + if not (t.flushed ++ Int64.of_int (String.length buf) = header ++ offset) + then + Fmt.failwith "sync error: %s flushed=%Ld offset+header=%Ld\n%!" t.file + t.flushed (offset ++ header); + t.flushed <- offset ++ header ) + + let auto_flush_limit = 1_000_000L + + let append t buf = + Buffer.add_string t.buf buf; + let len = Int64.of_int (String.length buf) in + t.offset <- t.offset ++ len; + if t.offset -- t.flushed > auto_flush_limit then sync t + + let set t ~off buf = + if t.readonly then raise RO_Not_Allowed; + sync t; + Raw.unsafe_write t.raw ~off:(header ++ off) buf; + let len = Int64.of_int (String.length buf) in + let off = header ++ off ++ len in + assert (off <= t.flushed) + + let read t ~off buf = + if not t.readonly then assert (header ++ off <= t.flushed); + Raw.unsafe_read t.raw ~off:(header ++ off) ~len:(Bytes.length buf) buf + + let offset t = t.offset + + let force_offset t = + t.offset <- Raw.unsafe_get_offset t.raw; + t.offset + + let version t = t.version + + let readonly t = t.readonly + + let protect_unix_exn = function + | Unix.Unix_error _ as e -> failwith (Printexc.to_string e) + | e -> raise e + + let ignore_enoent = function + | Unix.Unix_error (Unix.ENOENT, _, _) -> () + | e -> raise e + + let protect f x = try f x with e -> protect_unix_exn e + + let safe f x = try f x with e -> ignore_enoent e + + let mkdir dirname = + let rec aux dir k = + if Sys.file_exists dir && Sys.is_directory dir then k () + else ( + if Sys.file_exists dir then safe Unix.unlink dir; + (aux [@tailcall]) (Filename.dirname dir) @@ fun () -> + protect (Unix.mkdir dir) 0o755; + k () ) + in + (aux [@tailcall]) dirname (fun () -> ()) + + let clear t = + t.offset <- 0L; + t.flushed <- header; + Buffer.clear t.buf + + let buffers = Hashtbl.create 256 + + let buffer file = + try + let buf = Hashtbl.find buffers file in + Buffer.clear buf; + buf + with Not_found -> + let buf = Buffer.create (4 * 1024) in + Hashtbl.add buffers file buf; + buf + + let v ~fresh ~version:current_version ~readonly file = + assert (String.length current_version = 8); + let v ~offset ~version raw = + { version; + file; + offset; + raw; + readonly; + buf = buffer file; + flushed = header ++ offset + } + in + let mode = Unix.(if readonly then O_RDONLY else O_RDWR) in + mkdir (Filename.dirname file); + match Sys.file_exists file with + | false -> + if readonly then raise RO_Not_Allowed; + let x = Unix.openfile file Unix.[ O_CREAT; mode ] 0o644 in + let raw = Raw.v x in + Raw.unsafe_set_offset raw 0L; + Raw.unsafe_set_version raw current_version; + v ~offset:0L ~version:current_version raw + | true -> + let x = Unix.openfile file Unix.[ O_EXCL; mode ] 0o644 in + let raw = Raw.v x in + if fresh then ( + Raw.unsafe_set_offset raw 0L; + Raw.unsafe_set_version raw current_version; + v ~offset:0L ~version:current_version raw ) + else + let offset = Raw.unsafe_get_offset raw in + let version = Raw.unsafe_get_version raw in + assert (version = current_version); + v ~offset ~version raw +end + +let ( // ) = Filename.concat + +let with_cache ~v ~clear file = + let files = Hashtbl.create 13 in + let cached_constructor extra_args ?(fresh = false) ?(shared = true) + ?(readonly = false) root = + let file = root // file in + if fresh && readonly then invalid_arg "Read-only IO cannot be fresh"; + if not shared then ( + Log.debug (fun l -> + l "[%s] v fresh=%b shared=%b readonly=%b" (Filename.basename file) + fresh shared readonly ); + let t = v extra_args ~fresh ~shared ~readonly file in + if fresh then clear t; + t ) + else + try + if not (Sys.file_exists file) then ( + Log.debug (fun l -> + l "[%s] does not exist anymore, cleaning up the fd cache" + (Filename.basename file) ); + Hashtbl.remove files file; + raise Not_found ); + let t = Hashtbl.find files file in + Log.debug (fun l -> l "%s found in cache" file); + if fresh then clear t; + t + with Not_found -> + Log.debug (fun l -> + l "[%s] v fresh=%b shared=%b readonly=%b" (Filename.basename file) + fresh shared readonly ); + let t = v extra_args ~fresh ~shared ~readonly file in + if fresh then clear t; + Hashtbl.add files file t; + t + in + `Staged cached_constructor diff --git a/vendors/irmin-pack/IO.mli b/vendors/irmin-pack/IO.mli new file mode 100644 index 000000000000..67e6043c203b --- /dev/null +++ b/vendors/irmin-pack/IO.mli @@ -0,0 +1,52 @@ +(* + * Copyright (c) 2013-2019 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. + *) + +module type S = sig + type t + + exception RO_Not_Allowed + + val v : fresh:bool -> version:string -> readonly:bool -> string -> t + + val name : t -> string + + val clear : t -> unit + + val append : t -> string -> unit + + val set : t -> off:int64 -> string -> unit + + val read : t -> off:int64 -> bytes -> int + + val offset : t -> int64 + + val force_offset : t -> int64 + + val readonly : t -> bool + + val version : t -> string + + val sync : t -> unit +end + +module Unix : S + +val with_cache : + v:('a -> fresh:bool -> shared:bool -> readonly:bool -> string -> 'b) -> + clear:('b -> unit) -> + string -> + [ `Staged of + 'a -> ?fresh:bool -> ?shared:bool -> ?readonly:bool -> string -> 'b ] diff --git a/vendors/irmin-pack/dict.ml b/vendors/irmin-pack/dict.ml new file mode 100644 index 000000000000..51fb9e607cc5 --- /dev/null +++ b/vendors/irmin-pack/dict.ml @@ -0,0 +1,110 @@ +(* + * Copyright (c) 2013-2019 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. + *) + +let src = + Logs.Src.create "irmin.pack.dict" ~doc:"irmin-pack backend dictionaries" + +module Log = (val Logs.src_log src : Logs.LOG) + +let current_version = "00000001" + +let ( -- ) = Int64.sub + +module type S = sig + type t + + val find : t -> int -> string option + + val index : t -> string -> int option + + val sync : t -> unit + + val v : ?fresh:bool -> ?readonly:bool -> ?capacity:int -> string -> t + + val clear : t -> unit +end + +module Make (IO : IO.S) : S = struct + type t = { + capacity : int; + cache : (string, int) Hashtbl.t; + index : (int, string) Hashtbl.t; + io : IO.t + } + + let append_string t v = + let len = Int32.of_int (String.length v) in + let buf = Irmin.Type.(to_bin_string int32 len) ^ v in + IO.append t.io buf + + let refill ~from t = + let len = Int64.to_int (IO.offset t.io -- from) in + let raw = Bytes.create len in + let n = IO.read t.io ~off:from raw in + assert (n = len); + let raw = Bytes.unsafe_to_string raw in + let rec aux n offset = + if offset >= len then () + else + let _, v = Irmin.Type.(decode_bin int32) raw offset in + let len = Int32.to_int v in + let v = String.sub raw (offset + 4) len in + Hashtbl.add t.cache v n; + Hashtbl.add t.index n v; + (aux [@tailcall]) (n + 1) (offset + 4 + len) + in + (aux [@tailcall]) (Hashtbl.length t.cache) 0 + + let sync_offset t = + let former_log_offset = IO.offset t.io in + let log_offset = IO.force_offset t.io in + if log_offset > former_log_offset then refill ~from:former_log_offset t + + let sync t = IO.sync t.io + + let index t v = + Log.debug (fun l -> l "[dict] index %S" v); + if IO.readonly t.io then sync_offset t; + try Some (Hashtbl.find t.cache v) + with Not_found -> + let id = Hashtbl.length t.cache in + if id > t.capacity then None + else ( + if IO.readonly t.io then raise IO.RO_Not_Allowed; + append_string t v; + Hashtbl.add t.cache v id; + Hashtbl.add t.index id v; + Some id ) + + let find t id = + if IO.readonly t.io then sync_offset t; + Log.debug (fun l -> l "[dict] find %d" id); + let v = try Some (Hashtbl.find t.index id) with Not_found -> None in + v + + let clear t = + IO.clear t.io; + Hashtbl.clear t.cache; + Hashtbl.clear t.index + + let v ?(fresh = true) ?(readonly = false) ?(capacity = 100_000) file = + let io = IO.v ~fresh ~version:current_version ~readonly file in + let cache = Hashtbl.create 997 in + let index = Hashtbl.create 997 in + let t = { capacity; index; cache; io } in + refill ~from:0L t; + t +end diff --git a/vendors/irmin-pack/dict.mli b/vendors/irmin-pack/dict.mli new file mode 100644 index 000000000000..136f4e94ef6d --- /dev/null +++ b/vendors/irmin-pack/dict.mli @@ -0,0 +1,31 @@ +(* + * Copyright (c) 2013-2019 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. + *) + +module type S = sig + type t + + val find : t -> int -> string option + + val index : t -> string -> int option + + val sync : t -> unit + + val v : ?fresh:bool -> ?readonly:bool -> ?capacity:int -> string -> t + + val clear : t -> unit +end + +module Make (IO : IO.S) : S diff --git a/vendors/irmin-pack/dune b/vendors/irmin-pack/dune new file mode 100644 index 000000000000..99c2bca379e4 --- /dev/null +++ b/vendors/irmin-pack/dune @@ -0,0 +1,4 @@ +(library + (public_name irmin-pack) + (name irmin_pack) + (libraries irmin logs lwt.unix index.unix)) diff --git a/vendors/irmin-pack/inode.ml b/vendors/irmin-pack/inode.ml new file mode 100644 index 000000000000..2bef9731dadf --- /dev/null +++ b/vendors/irmin-pack/inode.ml @@ -0,0 +1,783 @@ +(* + * Copyright (c) 2013-2019 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 + +let src = + Logs.Src.create "irmin.pack.i" ~doc:"inodes for the irmin-pack backend" + +module Log = (val Logs.src_log src : Logs.LOG) + +module type S = sig + include Irmin.CONTENT_ADDRESSABLE_STORE + + type index + + val v : + ?fresh:bool -> + ?shared:bool -> + ?readonly:bool -> + ?lru_size:int -> + index:index -> + string -> + [ `Read ] t Lwt.t + + val batch : [ `Read ] t -> ([ `Read | `Write ] t -> 'a Lwt.t) -> 'a Lwt.t + + module Key : Irmin.Hash.S with type t = key + + module Val : Irmin.Private.Node.S with type t = value and type hash = key +end + +module type CONFIG = sig + val entries : int + + val stable_hash : int +end + +module Make + (Conf : CONFIG) + (H : Irmin.Hash.S) + (Pack : Pack.MAKER with type key = H.t) + (Node : Irmin.Private.Node.S with type hash = H.t) = +struct + type index = Pack.index + + module Node = struct + include Node + module H = Irmin.Hash.Typed (H) (Node) + + let hash = H.hash + end + + module T = struct + type hash = H.t + + type step = Node.step + + type metadata = Node.metadata + + let step_t = Node.step_t + + let hash_t = H.t + + let metadata_t = Node.metadata_t + + let default = Node.default + + type value = Node.value + + let value_t = Node.value_t + + let pp_hash = Irmin.Type.(pp hash_t) + end + + module Inode = struct + module StepMap = struct + include Map.Make (struct + type t = T.step + + let compare = Irmin.Type.compare T.step_t + end) + + let of_list l = List.fold_left (fun acc (k, v) -> add k v acc) empty l + + let t a = + let open Irmin.Type in + map (list (pair T.step_t a)) of_list bindings + end + + (* Binary representation, useful to compute hashes *) + module Bin = struct + open T + + type inode = { index : int; hash : H.t } + + type inodes = { seed : int; length : int; entries : inode list } + + type v = Values of (step * value) list | Inodes of inodes + + let inode : inode Irmin.Type.t = + let open Irmin.Type in + record "Bin.inode" (fun index hash -> { index; hash }) + |+ field "index" int (fun t -> t.index) + |+ field "hash" H.t (fun (t : inode) -> t.hash) + |> sealr + + let inodes : inodes Irmin.Type.t = + let open Irmin.Type in + record "Bin.inodes" (fun seed length entries -> + { seed; length; entries } ) + |+ field "seed" int (fun t -> t.seed) + |+ field "length" int (fun t -> t.length) + |+ field "entries" (list inode) (fun t -> t.entries) + |> sealr + + let v_t : v Irmin.Type.t = + let open Irmin.Type in + variant "Bin.v" (fun values inodes -> function + | Values l -> values l | Inodes i -> inodes i ) + |~ case1 "Values" (list (pair step_t value_t)) (fun t -> Values t) + |~ case1 "Inodes" inodes (fun t -> Inodes t) + |> sealv + + module V = + Irmin.Hash.Typed + (H) + (struct + type t = v + + let t = v_t + end) + + type t = { hash : H.t Lazy.t; stable : bool; v : v } + + let t : t Irmin.Type.t = + let open Irmin.Type in + let pre_hash x = Irmin.Type.pre_hash v_t x.v in + record "Bin.t" (fun hash stable v -> { hash = lazy hash; stable; v }) + |+ field "hash" H.t (fun t -> Lazy.force t.hash) + |+ field "stable" bool (fun t -> t.stable) + |+ field "v" v_t (fun t -> t.v) + |> sealr |> like ~pre_hash + + let node ~hash v = { stable = true; hash; v } + + let inode ~hash v = { stable = false; hash; v } + + let hash t = Lazy.force t.hash + end + + (* Compressed binary representation *) + module Compress = struct + open T + + type name = Indirect of int | Direct of step + + type address = Indirect of int64 | Direct of H.t + + let address : address Irmin.Type.t = + let open Irmin.Type in + variant "Compress.address" (fun i d -> function + | Indirect x -> i x | Direct x -> d x ) + |~ case1 "Indirect" int64 (fun x -> Indirect x) + |~ case1 "Direct" H.t (fun x -> Direct x) + |> sealv + + type inode = { index : int; hash : address } + + let inode : inode Irmin.Type.t = + let open Irmin.Type in + record "Compress.inode" (fun index hash -> { index; hash }) + |+ field "index" int (fun t -> t.index) + |+ field "hash" address (fun t -> t.hash) + |> sealr + + type inodes = { seed : int; length : int; entries : inode list } + + let inodes : inodes Irmin.Type.t = + let open Irmin.Type in + record "Compress.inodes" (fun seed length entries -> + { seed; length; entries } ) + |+ field "seed" int (fun t -> t.seed) + |+ field "length" int (fun t -> t.length) + |+ field "entries" (list inode) (fun t -> t.entries) + |> sealr + + type value = + | Contents of name * address * metadata + | Node of name * address + + let is_default = Irmin.Type.equal T.metadata_t T.default + + let value : value Irmin.Type.t = + let open Irmin.Type in + variant "Compress.value" + (fun contents_ii + contents_x_ii + node_ii + contents_id + contents_x_id + node_id + contents_di + contents_x_di + node_di + contents_dd + contents_x_dd + node_dd + -> function + | Contents (Indirect n, Indirect h, m) -> + if is_default m then contents_ii (n, h) + else contents_x_ii (n, h, m) + | Node (Indirect n, Indirect h) -> node_ii (n, h) + | Contents (Indirect n, Direct h, m) -> + if is_default m then contents_id (n, h) + else contents_x_id (n, h, m) + | Node (Indirect n, Direct h) -> node_id (n, h) + | Contents (Direct n, Indirect h, m) -> + if is_default m then contents_di (n, h) + else contents_x_di (n, h, m) + | Node (Direct n, Indirect h) -> node_di (n, h) + | Contents (Direct n, Direct h, m) -> + if is_default m then contents_dd (n, h) + else contents_x_dd (n, h, m) + | Node (Direct n, Direct h) -> node_dd (n, h) ) + |~ case1 "contents-ii" (pair int int64) (fun (n, i) -> + Contents (Indirect n, Indirect i, T.default) ) + |~ case1 "contents-x-ii" (triple int int64 metadata_t) + (fun (n, i, m) -> Contents (Indirect n, Indirect i, m)) + |~ case1 "node-ii" (pair int int64) (fun (n, i) -> + Node (Indirect n, Indirect i) ) + |~ case1 "contents-id" (pair int H.t) (fun (n, h) -> + Contents (Indirect n, Direct h, T.default) ) + |~ case1 "contents-x-id" (triple int H.t metadata_t) (fun (n, h, m) -> + Contents (Indirect n, Direct h, m) ) + |~ case1 "node-id" (pair int H.t) (fun (n, h) -> + Node (Indirect n, Direct h) ) + |~ case1 "contents-di" (pair step_t int64) (fun (n, i) -> + Contents (Direct n, Indirect i, T.default) ) + |~ case1 "contents-x-di" (triple step_t int64 metadata_t) + (fun (n, i, m) -> Contents (Direct n, Indirect i, m)) + |~ case1 "node-di" (pair step_t int64) (fun (n, i) -> + Node (Direct n, Indirect i) ) + |~ case1 "contents-dd" (pair step_t H.t) (fun (n, i) -> + Contents (Direct n, Direct i, T.default) ) + |~ case1 "contents-x-dd" (triple step_t H.t metadata_t) + (fun (n, i, m) -> Contents (Direct n, Direct i, m)) + |~ case1 "node-dd" (pair step_t H.t) (fun (n, i) -> + Node (Direct n, Direct i) ) + |> sealv + + type v = Values of value list | Inodes of inodes + + let v_t : v Irmin.Type.t = + let open Irmin.Type in + variant "Compress.v" (fun values inodes -> function + | Values x -> values x | Inodes x -> inodes x ) + |~ case1 "Values" (list value) (fun x -> Values x) + |~ case1 "Inodes" inodes (fun x -> Inodes x) + |> sealv + + type t = { hash : H.t; stable : bool; v : v } + + let node ~hash v = { hash; stable = true; v } + + let inode ~hash v = { hash; stable = false; v } + + let magic_node = 'N' + + let magic_inode = 'I' + + let stable : bool Irmin.Type.t = + Irmin.Type.(map char) + (fun n -> n = magic_node) + (function true -> magic_node | false -> magic_inode) + + let t = + let open Irmin.Type in + record "Compress.t" (fun hash stable v -> { hash; stable; v }) + |+ field "hash" H.t (fun t -> t.hash) + |+ field "stable" stable (fun t -> t.stable) + |+ field "v" v_t (fun t -> t.v) + |> sealr + end + + module Val = struct + open T + + type inode = { i_hash : hash Lazy.t; mutable tree : t option } + + and entry = Empty | Inode of inode + + and inodes = { seed : int; length : int; entries : entry array } + + and v = Values of value StepMap.t | Inodes of inodes + + and t = { hash : hash Lazy.t; stable : bool; v : v } + + let hash_of_inode (i : inode) = Lazy.force i.i_hash + + let inode_t t : inode Irmin.Type.t = + let same_hash x y = + Irmin.Type.equal hash_t (hash_of_inode x) (hash_of_inode y) + in + let open Irmin.Type in + record "Node.inode" (fun hash tree -> { i_hash = lazy hash; tree }) + |+ field "hash" hash_t (fun t -> Lazy.force t.i_hash) + |+ field "tree" (option t) (fun t -> t.tree) + |> sealr |> like ~equal:same_hash + + let entry_t inode : entry Irmin.Type.t = + let open Irmin.Type in + variant "Node.entry" (fun empty inode -> function + | Empty -> empty | Inode i -> inode i ) + |~ case0 "Empty" Empty + |~ case1 "Inode" inode (fun i -> Inode i) + |> sealv + + let inodes entry : inodes Irmin.Type.t = + let open Irmin.Type in + record "Node.entries" (fun seed length entries -> + { seed; length; entries } ) + |+ field "seed" int (fun t -> t.seed) + |+ field "length" int (fun t -> t.length) + |+ field "entries" (array entry) (fun t -> t.entries) + |> sealr + + let length t = + match t.v with + | Values vs -> StepMap.cardinal vs + | Inodes vs -> vs.length + + let get_tree ~find t = + match t.tree with + | Some t -> t + | None -> ( + let h = hash_of_inode t in + match find h with + | None -> Fmt.failwith "%a: unknown key" pp_hash h + | Some x -> + t.tree <- Some x; + x ) + + let rec list_entry ~find acc = function + | Empty -> acc + | Inode i -> list_values ~find acc (get_tree ~find i) + + and list_inodes ~find acc t = + Array.fold_left (list_entry ~find) acc t.entries + + and list_values ~find acc t = + match t.v with + | Values vs -> StepMap.bindings vs @ acc + | Inodes t -> list_inodes ~find acc t + + let compare_step a b = Irmin.Type.compare step_t a b + + let compare_entry x y = compare_step (fst x) (fst y) + + let list ~find t = + let entries = list_values ~find [] t in + List.fast_sort compare_entry entries + + let to_bin_v = function + | Values vs -> + let vs = StepMap.bindings vs in + Bin.Values vs + | Inodes t -> + let _, entries = + Array.fold_left + (fun (i, acc) -> function Empty -> (i + 1, acc) + | Inode inode -> + let hash = hash_of_inode inode in + (i + 1, { Bin.index = i; hash } :: acc) ) + (0, []) t.entries + in + let entries = List.rev entries in + Bin.Inodes { seed = t.seed; length = t.length; entries } + + let to_bin t = + let v = to_bin_v t.v in + if t.stable then Bin.node ~hash:t.hash v else Bin.inode ~hash:t.hash v + + let hash t = Lazy.force t.hash + + let stabilize ~find t = + if t.stable then t + else + let n = length t in + if n > Conf.stable_hash then t + else + let hash = + lazy + (let vs = list ~find t in + Node.hash (Node.v vs)) + in + { hash; stable = true; v = t.v } + + let index ~seed k = + abs (Irmin.Type.short_hash step_t ~seed k) mod Conf.entries + + let inode ?tree i_hash = Inode { tree; i_hash } + + let of_bin t = + let v = + match t.Bin.v with + | Bin.Values vs -> + let vs = StepMap.of_list vs in + Values vs + | Inodes t -> + let entries = Array.make Conf.entries Empty in + List.iter + (fun { Bin.index; hash } -> + entries.(index) <- inode (lazy hash) ) + t.entries; + Inodes { seed = t.Bin.seed; length = t.length; entries } + in + { hash = t.Bin.hash; stable = t.Bin.stable; v } + + let v_t t : v Irmin.Type.t = + let open Irmin.Type in + let pre_hash x = pre_hash Bin.v_t (to_bin_v x) in + let entry = entry_t (inode_t t) in + variant "Inode.t" (fun values inodes -> function + | Values v -> values v | Inodes i -> inodes i ) + |~ case1 "Values" (StepMap.t value_t) (fun t -> Values t) + |~ case1 "Inodes" (inodes entry) (fun t -> Inodes t) + |> sealv |> like ~pre_hash + + let t : t Irmin.Type.t = + let open Irmin.Type in + mu @@ fun t -> + let v = v_t t in + let t = + record "hash" (fun hash stable v -> { hash = lazy hash; stable; v }) + |+ field "hash" H.t (fun t -> Lazy.force t.hash) + |+ field "stable" bool (fun t -> t.stable) + |+ field "v" v (fun t -> t.v) + |> sealr + in + let pre_hash x = Irmin.Type.pre_hash v x.v in + like ~pre_hash t + + let empty = + let hash = lazy (Node.hash Node.empty) in + { stable = true; hash; v = Values StepMap.empty } + + let values vs = + let length = StepMap.cardinal vs in + if length = 0 then empty + else + let v = Values vs in + let hash = lazy (Bin.V.hash (to_bin_v v)) in + { hash; stable = false; v } + + let inodes is = + let v = Inodes is in + let hash = lazy (Bin.V.hash (to_bin_v v)) in + { hash; stable = false; v } + + let of_values l = values (StepMap.of_list l) + + let is_empty t = + match t.v with Values vs -> StepMap.is_empty vs | Inodes _ -> false + + let find_value ~seed ~find t s = + let rec aux ~seed = function + | Values vs -> ( + try Some (StepMap.find s vs) with Not_found -> None ) + | Inodes t -> ( + let i = index ~seed s in + let x = t.entries.(i) in + match x with + | Empty -> None + | Inode i -> aux ~seed:(seed + 1) (get_tree ~find i).v ) + in + aux ~seed t.v + + let find ~find t s = find_value ~seed:0 ~find t s + + let rec add ~seed ~find ~copy t s v k = + match find_value ~seed ~find t s with + | Some v' when Irmin.Type.equal value_t v v' -> k t + | v' -> ( + match t.v with + | Values vs -> + let length = + match v' with + | None -> StepMap.cardinal vs + 1 + | Some _ -> StepMap.cardinal vs + in + let t = + if length <= Conf.entries then values (StepMap.add s v vs) + else + let vs = StepMap.bindings (StepMap.add s v vs) in + let empty = + inodes + { length = 0; + seed; + entries = Array.make Conf.entries Empty + } + in + let aux t (s, v) = + (add [@tailcall]) ~seed ~find ~copy:false t s v (fun x -> x) + in + List.fold_left aux empty vs + in + k t + | Inodes t -> ( + let length = + match v' with None -> t.length + 1 | Some _ -> t.length + in + let entries = if copy then Array.copy t.entries else t.entries in + let i = index ~seed s in + match entries.(i) with + | Empty -> + let tree = values (StepMap.singleton s v) in + entries.(i) <- inode ~tree tree.hash; + let t = inodes { seed; length; entries } in + k t + | Inode n -> + let t = get_tree ~find n in + add ~seed:(seed + 1) ~find ~copy t s v @@ fun tree -> + let inode = inode ~tree tree.hash in + entries.(i) <- inode; + let t = inodes { seed; length; entries } in + k t ) ) + + let add ~find ~copy t s v = + add ~seed:0 ~find ~copy t s v (stabilize ~find) + + let rec remove ~seed ~find t s k = + match find_value ~seed ~find t s with + | None -> k t + | Some _ -> ( + match t.v with + | Values vs -> + let t = values (StepMap.remove s vs) in + k t + | Inodes t -> ( + let length = t.length - 1 in + if length <= Conf.entries then + let vs = list_inodes ~find [] t in + let vs = StepMap.of_list vs in + let vs = StepMap.remove s vs in + let t = values vs in + k t + else + let entries = Array.copy t.entries in + let i = index ~seed s in + match entries.(i) with + | Empty -> assert false + | Inode t -> + let t = get_tree ~find t in + remove ~seed:(seed + 1) ~find t s @@ fun tree -> + entries.(i) <- inode ~tree (lazy (hash tree)); + let t = inodes { seed; length; entries } in + k t ) ) + + let remove ~find t s = remove ~find ~seed:0 t s (stabilize ~find) + + let v l : t = + let len = List.length l in + let find _ = assert false in + let t = + if len <= Conf.entries then of_values l + else + let aux acc (s, v) = add ~find ~copy:false acc s v in + List.fold_left aux empty l + in + stabilize ~find t + + let add ~find t s v = add ~find ~copy:true t s v + + let save ~add ~mem t = + let rec aux ~seed t = + Log.debug (fun l -> l "save seed:%d" seed); + match t.v with + | Values _ -> add (Lazy.force t.hash) (to_bin t) + | Inodes n -> + Array.iter + (function + | Empty | Inode { tree = None; _ } -> () + | Inode ({ tree = Some t; _ } as i) -> + let hash = hash_of_inode i in + if mem hash then () else aux ~seed:(seed + 1) t ) + n.entries; + add (Lazy.force t.hash) (to_bin t) + in + aux ~seed:0 t + end + + include Pack.Make (struct + type t = Bin.t + + let t = Bin.t + + let magic (t : t) = + if t.stable then Compress.magic_node else Compress.magic_inode + + let hash t = Bin.hash t + + let encode_bin ~dict ~offset (t : t) k = + let step s : Compress.name = + let str = Irmin.Type.to_bin_string T.step_t s in + if String.length str <= 3 then Direct s + else match dict str with Some i -> Indirect i | None -> Direct s + in + let hash h : Compress.address = + match offset h with + | None -> Compress.Direct h + | Some off -> Compress.Indirect off + in + let inode : Bin.inode -> Compress.inode = + fun n -> + let hash = hash n.hash in + { index = n.index; hash } + in + let value : T.step * T.value -> Compress.value = function + | s, `Contents (c, m) -> + let s = step s in + let v = hash c in + Compress.Contents (s, v, m) + | s, `Node n -> + let s = step s in + let v = hash n in + Compress.Node (s, v) + in + (* List.map is fine here as the number of entries is small *) + let v : Bin.v -> Compress.v = function + | Values vs -> Values (List.map value vs) + | Inodes { seed; length; entries } -> + let entries = List.map inode entries in + Inodes { Compress.seed; length; entries } + in + let t = + if t.stable then Compress.node ~hash:k (v t.v) + else Compress.inode ~hash:k (v t.v) + in + Irmin.Type.encode_bin Compress.t t + + exception Exit of [ `Msg of string ] + + let decode_bin ~dict ~hash t off : t = + let _, i = Irmin.Type.decode_bin ~headers:false Compress.t t off in + let step : Compress.name -> T.step = function + | Direct n -> n + | Indirect s -> ( + match dict s with + | None -> raise_notrace (Exit (`Msg "dict")) + | Some s -> ( + match Irmin.Type.of_bin_string T.step_t s with + | Error e -> raise_notrace (Exit e) + | Ok v -> v ) ) + in + let hash : Compress.address -> H.t = function + | Indirect off -> hash off + | Direct n -> n + in + let inode : Compress.inode -> Bin.inode = + fun n -> + let hash = hash n.hash in + { index = n.index; hash } + in + let value : Compress.value -> T.step * T.value = function + | Contents (n, h, metadata) -> + let name = step n in + let node = hash h in + (name, `Contents (node, metadata)) + | Node (n, h) -> + let name = step n in + let node = hash h in + (name, `Node node) + in + let t : Compress.v -> Bin.v = function + | Values vs -> Values (List.map value vs) + | Inodes { seed; length; entries } -> + let entries = List.map inode entries in + Inodes { seed; length; entries } + in + if i.stable then Bin.node ~hash:(lazy i.hash) (t i.v) + else Bin.inode ~hash:(lazy i.hash) (t i.v) + end) + end + + module Val = struct + include T + module I = Inode.Val + + type t = { mutable find : H.t -> I.t option; v : I.t } + + let niet _ = assert false + + let v l = { find = niet; v = I.v l } + + let list t = I.list ~find:t.find t.v + + let empty = { find = niet; v = Inode.Val.empty } + + let is_empty t = I.is_empty t.v + + let find t s = I.find ~find:t.find t.v s + + let add t s v = + let v = I.add ~find:t.find t.v s v in + if v == t.v then t else { find = t.find; v } + + let remove t s = + let v = I.remove ~find:t.find t.v s in + if v == t.v then t else { find = t.find; v } + + let t : t Irmin.Type.t = + let pre_hash x = + if not x.v.stable then Irmin.Type.pre_hash I.t x.v + else + let vs = list x in + Irmin.Type.pre_hash Node.t (Node.v vs) + in + Irmin.Type.map I.t ~pre_hash (fun v -> { find = niet; v }) (fun t -> t.v) + end + + module Key = H + + type 'a t = 'a Inode.t + + type key = Key.t + + type value = Val.t + + let mem t k = Inode.mem t k + + let unsafe_find t k = + match Inode.unsafe_find t k with + | None -> None + | Some v -> + let v = Inode.Val.of_bin v in + Some v + + let find t k = + Inode.find t k >|= function + | None -> None + | Some v -> + let v = Inode.Val.of_bin v in + let find = unsafe_find t in + Some { Val.find; v } + + let save t v = + let add k v = Inode.unsafe_append t k v in + Inode.Val.save ~add ~mem:(Inode.unsafe_mem t) v + + let hash v = Lazy.force v.Val.v.Inode.Val.hash + + let add t v = + save t v.Val.v; + Lwt.return (hash v) + + let check_hash expected got = + if Irmin.Type.equal H.t expected got then () + else + Fmt.invalid_arg "corrupted value: got %a, expecting %a" T.pp_hash + expected T.pp_hash got + + let unsafe_add t k v = + check_hash k (hash v); + save t v.Val.v; + Lwt.return () + + let batch = Inode.batch + + let v = Inode.v +end diff --git a/vendors/irmin-pack/inode.mli b/vendors/irmin-pack/inode.mli new file mode 100644 index 000000000000..273314e09a71 --- /dev/null +++ b/vendors/irmin-pack/inode.mli @@ -0,0 +1,53 @@ +(* + * Copyright (c) 2013-2019 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. + *) + +module type CONFIG = sig + val entries : int + + val stable_hash : int +end + +module type S = sig + include Irmin.CONTENT_ADDRESSABLE_STORE + + type index + + val v : + ?fresh:bool -> + ?shared:bool -> + ?readonly:bool -> + ?lru_size:int -> + index:index -> + string -> + [ `Read ] t Lwt.t + + val batch : [ `Read ] t -> ([ `Read | `Write ] t -> 'a Lwt.t) -> 'a Lwt.t + + module Key : Irmin.Hash.S with type t = key + + module Val : Irmin.Private.Node.S with type t = value and type hash = key +end + +module Make + (Conf : CONFIG) + (H : Irmin.Hash.S) + (P : Pack.MAKER with type key = H.t and type index = Pack_index.Make(H).t) + (Node : Irmin.Private.Node.S with type hash = H.t) : + S + with type key = H.t + and type Val.metadata = Node.metadata + and type Val.step = Node.step + and type index = Pack_index.Make(H).t diff --git a/vendors/irmin-pack/irmin-pack.opam b/vendors/irmin-pack/irmin-pack.opam new file mode 100644 index 000000000000..d3c35990ff9a --- /dev/null +++ b/vendors/irmin-pack/irmin-pack.opam @@ -0,0 +1,23 @@ +opam-version: "2.0" +maintainer: "thomas@gazagnaire.org" +authors: ["Thomas Gazagnaire"] +license: "ISC" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +dev-repo: "git+https://github.com/mirage/irmin.git" + +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name] {with-test} +] + +depends: [ + "ocaml" {>= "4.01.0"} + "dune" {build & >= "1.1.0"} + "index" + "irmin" {>= "1.3.0"} + "lwt" +] + +synopsis: "Irmin backend which stores values in a pack file" diff --git a/vendors/irmin-pack/irmin_pack.ml b/vendors/irmin-pack/irmin_pack.ml new file mode 100644 index 000000000000..710ed6547c96 --- /dev/null +++ b/vendors/irmin-pack/irmin_pack.ml @@ -0,0 +1,430 @@ +(* + * Copyright (c) 2013-2019 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. + *) + +let src = Logs.Src.create "irmin.pack" ~doc:"irmin-pack backend" + +module Log = (val Logs.src_log src : Logs.LOG) + +let current_version = "00000001" + +let fresh_key = + Irmin.Private.Conf.key ~doc:"Start with a fresh disk." "fresh" + Irmin.Private.Conf.bool false + +let lru_size_key = + Irmin.Private.Conf.key ~doc:"Size of the LRU cache for pack entries." + "lru-size" Irmin.Private.Conf.int 10_000 + +let index_log_size_key = + Irmin.Private.Conf.key ~doc:"Size of index logs." "index-log-size" + Irmin.Private.Conf.int 10_000 + +let readonly_key = + Irmin.Private.Conf.key ~doc:"Start with a read-only disk." "readonly" + Irmin.Private.Conf.bool false + +let shared_key = + Irmin.Private.Conf.key + ~doc: + "Share resources (file-descriptors, caches) with other instances when \ + possible." + "shared" Irmin.Private.Conf.bool false + +let fresh config = Irmin.Private.Conf.get config fresh_key + +let lru_size config = Irmin.Private.Conf.get config lru_size_key + +let readonly config = Irmin.Private.Conf.get config readonly_key + +let shared config = Irmin.Private.Conf.get config shared_key + +let index_log_size config = Irmin.Private.Conf.get config index_log_size_key + +let root_key = Irmin.Private.Conf.root + +let root config = + match Irmin.Private.Conf.get config root_key with + | None -> failwith "no root set" + | Some r -> r + +let config ?(fresh = false) ?(shared = true) ?(readonly = false) + ?(lru_size = 10_000) ?(index_log_size = 10_000) root = + let config = Irmin.Private.Conf.empty in + let config = Irmin.Private.Conf.add config fresh_key fresh in + let config = Irmin.Private.Conf.add config root_key (Some root) in + let config = Irmin.Private.Conf.add config lru_size_key lru_size in + let config = + Irmin.Private.Conf.add config index_log_size_key index_log_size + in + let config = Irmin.Private.Conf.add config readonly_key readonly in + let config = Irmin.Private.Conf.add config shared_key shared in + config + +let ( ++ ) = Int64.add + +let with_cache = IO.with_cache + +open Lwt.Infix +module Pack = Pack +module Dict = Pack_dict +module Index = Pack_index +module IO = IO.Unix + +exception RO_Not_Allowed = IO.RO_Not_Allowed + +module Table (K : Irmin.Type.S) = Hashtbl.Make (struct + type t = K.t + + let hash (t : t) = Irmin.Type.short_hash K.t t + + let equal (x : t) (y : t) = Irmin.Type.equal K.t x y +end) + +module Atomic_write (K : Irmin.Type.S) (V : Irmin.Hash.S) = struct + module Tbl = Table (K) + module W = Irmin.Private.Watch.Make (K) (V) + + type key = K.t + + type value = V.t + + type watch = W.watch + + type t = { + index : int64 Tbl.t; + cache : V.t Tbl.t; + block : IO.t; + lock : Lwt_mutex.t; + w : W.t + } + + let read_length32 ~off block = + let buf = Bytes.create 4 in + let n = IO.read block ~off buf in + assert (n = 4); + let n, v = Irmin.Type.(decode_bin int32) (Bytes.unsafe_to_string buf) 0 in + assert (n = 4); + Int32.to_int v + + let entry = Irmin.Type.(pair (string_of `Int32) V.t) + + let set_entry t ?off k v = + let k = Irmin.Type.to_bin_string K.t k in + let buf = Irmin.Type.to_bin_string entry (k, v) in + match off with + | None -> IO.append t.block buf + | Some off -> IO.set t.block buf ~off + + let pp_branch = Irmin.Type.pp K.t + + let unsafe_find t k = + Log.debug (fun l -> l "[branches] find %a" pp_branch k); + try Lwt.return (Some (Tbl.find t.cache k)) + with Not_found -> Lwt.return None + + let find t k = Lwt_mutex.with_lock t.lock (fun () -> unsafe_find t k) + + let unsafe_mem t k = + Log.debug (fun l -> l "[branches] mem %a" pp_branch k); + try Lwt.return (Tbl.mem t.cache k) with Not_found -> Lwt.return false + + let mem t v = Lwt_mutex.with_lock t.lock (fun () -> unsafe_mem t v) + + let zero = + match Irmin.Type.of_bin_string V.t (String.make V.hash_size '\000') with + | Ok x -> x + | Error _ -> assert false + + let unsafe_remove t k = + Tbl.remove t.cache k; + try + let off = Tbl.find t.index k in + set_entry t ~off k zero + with Not_found -> () + + let remove t k = + Log.debug (fun l -> l "[branches] remove %a" pp_branch k); + Lwt_mutex.with_lock t.lock (fun () -> + unsafe_remove t k; + Lwt.return () ) + >>= fun () -> W.notify t.w k None + + let unsafe_clear t = + Lwt.async (fun () -> W.clear t.w); + IO.clear t.block; + Tbl.clear t.cache; + Tbl.clear t.index + + let create = Lwt_mutex.create () + + let watches = W.v () + + let unsafe_v ~fresh ~shared:_ ~readonly file = + let block = IO.v ~fresh ~version:current_version ~readonly file in + let cache = Tbl.create 997 in + let index = Tbl.create 997 in + let len = IO.offset block in + let rec aux offset k = + if offset >= len then k () + else + let len = read_length32 ~off:offset block in + let buf = Bytes.create (len + V.hash_size) in + let off = offset ++ 4L in + let n = IO.read block ~off buf in + assert (n = Bytes.length buf); + let buf = Bytes.unsafe_to_string buf in + let h = + let h = String.sub buf 0 len in + match Irmin.Type.of_bin_string K.t h with + | Ok k -> k + | Error (`Msg e) -> failwith e + in + let n, v = Irmin.Type.decode_bin V.t buf len in + assert (n = String.length buf); + if not (Irmin.Type.equal V.t v zero) then Tbl.add cache h v; + Tbl.add index h offset; + (aux [@tailcall]) (off ++ Int64.(of_int @@ (len + V.hash_size))) k + in + (aux [@tailcall]) 0L @@ fun () -> + { cache; index; block; w = watches; lock = Lwt_mutex.create () } + + let (`Staged unsafe_v) = + with_cache ~clear:unsafe_clear ~v:(fun () -> unsafe_v) "store.branches" + + let v ?fresh ?shared ?readonly file = + Lwt_mutex.with_lock create (fun () -> + let v = unsafe_v () ?fresh ?shared ?readonly file in + Lwt.return v ) + + let unsafe_set t k v = + try + let off = Tbl.find t.index k in + Tbl.replace t.cache k v; + set_entry t ~off k v + with Not_found -> + let offset = IO.offset t.block in + set_entry t k v; + Tbl.add t.cache k v; + Tbl.add t.index k offset + + let set t k v = + Log.debug (fun l -> l "[branches] set %a" pp_branch k); + Lwt_mutex.with_lock t.lock (fun () -> + unsafe_set t k v; + Lwt.return () ) + >>= fun () -> W.notify t.w k (Some v) + + let unsafe_test_and_set t k ~test ~set = + let v = try Some (Tbl.find t.cache k) with Not_found -> None in + if not (Irmin.Type.(equal (option V.t)) v test) then Lwt.return false + else + let return () = Lwt.return true in + match set with + | None -> unsafe_remove t k |> return + | Some v -> unsafe_set t k v |> return + + let test_and_set t k ~test ~set = + Log.debug (fun l -> l "[branches] test-and-set %a" pp_branch k); + Lwt_mutex.with_lock t.lock (fun () -> unsafe_test_and_set t k ~test ~set) + >>= function + | true -> W.notify t.w k set >|= fun () -> true + | false -> Lwt.return false + + let list t = + Log.debug (fun l -> l "[branches] list"); + let keys = Tbl.fold (fun k _ acc -> k :: acc) t.cache [] in + Lwt.return keys + + let watch_key t = W.watch_key t.w + + let watch t = W.watch t.w + + let unwatch t = W.unwatch t.w +end + +module type CONFIG = Inode.CONFIG + +module Make_ext + (Config : CONFIG) + (M : Irmin.Metadata.S) + (C : Irmin.Contents.S) + (P : Irmin.Path.S) + (B : Irmin.Branch.S) + (H : Irmin.Hash.S) + (Node : Irmin.Private.Node.S + with type metadata = M.t + and type hash = H.t + and type step = P.step) + (Commit : Irmin.Private.Commit.S with type hash = H.t) = +struct + module Index = Pack_index.Make (H) + module Pack = Pack.File (Index) (H) + + module X = struct + module Hash = H + + type 'a value = { magic : char; hash : H.t; v : 'a } + + let value a = + let open Irmin.Type in + record "value" (fun hash magic v -> { magic; hash; v }) + |+ field "hash" H.t (fun v -> v.hash) + |+ field "magic" char (fun v -> v.magic) + |+ field "v" a (fun v -> v.v) + |> sealr + + module Contents = struct + module CA = struct + module Key = H + module Val = C + + include Pack.Make (struct + include Val + module H = Irmin.Hash.Typed (H) (Val) + + let hash = H.hash + + let magic = 'B' + + let value = value Val.t + + let encode_bin ~dict:_ ~offset:_ v hash = + Irmin.Type.encode_bin value { magic; hash; v } + + let decode_bin ~dict:_ ~hash:_ s off = + let _, t = Irmin.Type.decode_bin ~headers:false value s off in + t.v + + let magic _ = magic + end) + end + + include Irmin.Contents.Store (CA) + end + + module Node = struct + module CA = Inode.Make (Config) (H) (Pack) (Node) + include Irmin.Private.Node.Store (Contents) (P) (M) (CA) + end + + module Commit = struct + module CA = struct + module Key = H + module Val = Commit + + include Pack.Make (struct + include Val + module H = Irmin.Hash.Typed (H) (Val) + + let hash = H.hash + + let value = value Val.t + + let magic = 'C' + + let encode_bin ~dict:_ ~offset:_ v hash = + Irmin.Type.encode_bin value { magic; hash; v } + + let decode_bin ~dict:_ ~hash:_ s off = + let _, v = Irmin.Type.decode_bin ~headers:false value s off in + v.v + + let magic _ = magic + end) + end + + include Irmin.Private.Commit.Store (Node) (CA) + end + + module Branch = struct + module Key = B + module Val = H + include Atomic_write (Key) (Val) + end + + module Slice = Irmin.Private.Slice.Make (Contents) (Node) (Commit) + module Sync = Irmin.Private.Sync.None (H) (B) + + module Repo = struct + type t = { + config : Irmin.Private.Conf.t; + contents : [ `Read ] Contents.CA.t; + node : [ `Read ] Node.CA.t; + commit : [ `Read ] Commit.CA.t; + branch : Branch.t; + index : Index.t + } + + let contents_t t : 'a Contents.t = t.contents + + let node_t t : 'a Node.t = (contents_t t, t.node) + + let commit_t t : 'a Commit.t = (node_t t, t.commit) + + let branch_t t = t.branch + + let batch t f = + Commit.CA.batch t.commit (fun commit -> + Node.CA.batch t.node (fun node -> + Contents.CA.batch t.contents (fun contents -> + let contents : 'a Contents.t = contents in + let node : 'a Node.t = (contents, node) in + let commit : 'a Commit.t = (node, commit) in + f contents node commit ) ) ) + + let v config = + let root = root config in + let fresh = fresh config in + let lru_size = lru_size config in + let readonly = readonly config in + let shared = shared config in + let log_size = index_log_size config in + let index = + Index.v ~fresh ~shared ~readonly ~log_size ~fan_out_size:16 root + in + Contents.CA.v ~fresh ~shared ~readonly ~lru_size ~index root + >>= fun contents -> + Node.CA.v ~fresh ~shared ~readonly ~lru_size ~index root + >>= fun node -> + Commit.CA.v ~fresh ~shared ~readonly ~lru_size ~index root + >>= fun commit -> + Branch.v ~fresh ~shared ~readonly root >|= fun branch -> + { contents; node; commit; branch; config; index } + end + end + + include Irmin.Of_private (X) +end + +module Hash = Irmin.Hash.BLAKE2B +module Path = Irmin.Path.String_list +module Metadata = Irmin.Metadata.None + +module Make + (Config : CONFIG) + (M : Irmin.Metadata.S) + (C : Irmin.Contents.S) + (P : Irmin.Path.S) + (B : Irmin.Branch.S) + (H : Irmin.Hash.S) = +struct + module XNode = Irmin.Private.Node.Make (H) (P) (M) + module XCommit = Irmin.Private.Commit.Make (H) + include Make_ext (Config) (M) (C) (P) (B) (H) (XNode) (XCommit) +end + +module KV (Config : CONFIG) (C : Irmin.Contents.S) = + Make (Config) (Metadata) (C) (Path) (Irmin.Branch.String) (Hash) diff --git a/vendors/irmin-pack/irmin_pack.mli b/vendors/irmin-pack/irmin_pack.mli new file mode 100644 index 000000000000..39a1d7a1c872 --- /dev/null +++ b/vendors/irmin-pack/irmin_pack.mli @@ -0,0 +1,67 @@ +(* + * 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. + *) + +val config : + ?fresh:bool -> + ?shared:bool -> + ?readonly:bool -> + ?lru_size:int -> + ?index_log_size:int -> + string -> + Irmin.config + +module Pack = Pack +module Dict = Pack_dict +module Index = Pack_index + +exception RO_Not_Allowed + +module type CONFIG = sig + val entries : int + + val stable_hash : int +end + +module Make_ext + (Config : CONFIG) + (Metadata : Irmin.Metadata.S) + (Contents : Irmin.Contents.S) + (Path : Irmin.Path.S) + (Branch : Irmin.Branch.S) + (Hash : Irmin.Hash.S) + (N : Irmin.Private.Node.S + with type metadata = Metadata.t + and type hash = Hash.t + and type step = Path.step) + (CT : Irmin.Private.Commit.S with type hash = Hash.t) : + Irmin.S + with type key = Path.t + and type contents = Contents.t + and type branch = Branch.t + and type hash = Hash.t + and type step = Path.step + and type metadata = Metadata.t + and type Key.step = Path.step + +module Make (Config : CONFIG) : Irmin.S_MAKER + +module KV (Config : CONFIG) : Irmin.KV_MAKER + +module Atomic_write (K : Irmin.Type.S) (V : Irmin.Hash.S) : sig + include Irmin.ATOMIC_WRITE_STORE with type key = K.t and type value = V.t + + val v : ?fresh:bool -> ?shared:bool -> ?readonly:bool -> string -> t Lwt.t +end diff --git a/vendors/irmin-pack/lru.ml b/vendors/irmin-pack/lru.ml new file mode 100644 index 000000000000..a4fbb4b960af --- /dev/null +++ b/vendors/irmin-pack/lru.ml @@ -0,0 +1,118 @@ +(* Permission to use, copy, modify, and/or 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. *) + +(* Extracted from https://github.com/pqwy/lru + Copyright (c) 2016 David Kaloper Meršinjak *) + +module Make (H : Hashtbl.HashedType) = struct + module HT = Hashtbl.Make (H) + + module Q = struct + type 'a node = { + value : 'a; + mutable next : 'a node option; + mutable prev : 'a node option + } + + type 'a t = { + mutable first : 'a node option; + mutable last : 'a node option + } + + let detach t n = + let np = n.prev and nn = n.next in + ( match np with + | None -> t.first <- nn + | Some x -> + x.next <- nn; + n.prev <- None ); + match nn with + | None -> t.last <- np + | Some x -> + x.prev <- np; + n.next <- None + + let append t n = + let on = Some n in + match t.last with + | Some x as l -> + x.next <- on; + t.last <- on; + n.prev <- l + | None -> + t.first <- on; + t.last <- on + + let node x = { value = x; prev = None; next = None } + + let create () = { first = None; last = None } + end + + type key = HT.key + + type 'a t = { + ht : (key * 'a) Q.node HT.t; + q : (key * 'a) Q.t; + mutable cap : int; + mutable w : int + } + + let weight t = t.w + + let create cap = { cap; w = 0; ht = HT.create cap; q = Q.create () } + + let drop_lru t = + match t.q.first with + | None -> () + | Some ({ Q.value = k, _; _ } as n) -> + t.w <- t.w - 1; + HT.remove t.ht k; + Q.detach t.q n + + let remove t k = + try + let n = HT.find t.ht k in + t.w <- t.w - 1; + HT.remove t.ht k; + Q.detach t.q n + with Not_found -> () + + let add t k v = + if t.w = 0 then () + else ( + remove t k; + let n = Q.node (k, v) in + t.w <- t.w + 1; + if weight t > t.cap then drop_lru t; + HT.add t.ht k n; + Q.append t.q n ) + + let promote t k = + try + let n = HT.find t.ht k in + Q.( + detach t.q n; + append t.q n) + with Not_found -> () + + let find t k = + let v = HT.find t.ht k in + promote t k; + snd v.value + + let mem t k = + match HT.mem t.ht k with + | false -> false + | true -> + promote t k; + true +end diff --git a/vendors/irmin-pack/lru.mli b/vendors/irmin-pack/lru.mli new file mode 100644 index 000000000000..510c7395a220 --- /dev/null +++ b/vendors/irmin-pack/lru.mli @@ -0,0 +1,26 @@ +(* Permission to use, copy, modify, and/or 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. *) + +(* Extracted from https://github.com/pqwy/lru + Copyright (c) 2016 David Kaloper Meršinjak *) + +module Make (H : Hashtbl.HashedType) : sig + type 'a t + + val create : int -> 'a t + + val add : 'a t -> H.t -> 'a -> unit + + val find : 'a t -> H.t -> 'a + + val mem : 'a t -> H.t -> bool +end diff --git a/vendors/irmin-pack/pack.ml b/vendors/irmin-pack/pack.ml new file mode 100644 index 000000000000..bf95efabe220 --- /dev/null +++ b/vendors/irmin-pack/pack.ml @@ -0,0 +1,339 @@ +(* + * Copyright (c) 2013-2019 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. + *) + +let src = Logs.Src.create "irmin.pack" ~doc:"irmin-pack backend" + +module Log = (val Logs.src_log src : Logs.LOG) + +let current_version = "00000001" + +let ( -- ) = Int64.sub + +type all_stats = { + mutable pack_finds : int; + mutable pack_cache_misses : int; + mutable appended_hashes : int; + mutable appended_offsets : int +} + +let fresh_stats () = + { pack_finds = 0; + pack_cache_misses = 0; + appended_hashes = 0; + appended_offsets = 0 + } + +let stats = fresh_stats () + +let reset_stats () = + stats.pack_finds <- 0; + stats.pack_cache_misses <- 0; + stats.appended_hashes <- 0; + stats.appended_offsets <- 0; + () + +module type ELT = sig + include Irmin.Type.S + + type hash + + val hash : t -> hash + + val magic : t -> char + + val encode_bin : + dict:(string -> int option) -> + offset:(hash -> int64 option) -> + t -> + hash -> + (string -> unit) -> + unit + + val decode_bin : + dict:(int -> string option) -> hash:(int64 -> hash) -> string -> int -> t +end + +module type S = sig + include Irmin.CONTENT_ADDRESSABLE_STORE + + type index + + val v : + ?fresh:bool -> + ?shared:bool -> + ?readonly:bool -> + ?lru_size:int -> + index:index -> + string -> + [ `Read ] t Lwt.t + + val batch : [ `Read ] t -> ([ `Read | `Write ] t -> 'a Lwt.t) -> 'a Lwt.t + + val unsafe_append : 'a t -> key -> value -> unit + + val unsafe_mem : 'a t -> key -> bool + + val unsafe_find : 'a t -> key -> value option + + val sync : 'a t -> unit +end + +module type MAKER = sig + type key + + type index + + module Make (V : ELT with type hash := key) : + S with type key = key and type value = V.t and type index = index +end + +open Lwt.Infix + +module Table (K : Irmin.Type.S) = Hashtbl.Make (struct + type t = K.t + + let hash (t : t) = Irmin.Type.short_hash K.t t + + let equal (x : t) (y : t) = Irmin.Type.equal K.t x y +end) + +module Cache (K : Irmin.Type.S) = Lru.Make (struct + type t = K.t + + let hash (t : t) = Irmin.Type.short_hash K.t t + + let equal (x : t) (y : t) = Irmin.Type.equal K.t x y +end) + +let with_cache = IO.with_cache + +module IO = IO.Unix + +module File (Index : Pack_index.S) (K : Irmin.Hash.S with type t = Index.key) = +struct + module Tbl = Table (K) + module Dict = Pack_dict + + type index = Index.t + + type 'a t = { + block : IO.t; + index : Index.t; + dict : Dict.t; + lock : Lwt_mutex.t + } + + let clear t = + IO.clear t.block; + Index.clear t.index; + Dict.clear t.dict + + let unsafe_v ~index ~fresh ~shared:_ ~readonly file = + let root = Filename.dirname file in + let lock = Lwt_mutex.create () in + let dict = Dict.v ~fresh ~readonly root in + let block = IO.v ~fresh ~version:current_version ~readonly file in + if IO.version block <> current_version then + Fmt.failwith "invalid version: got %S, expecting %S" (IO.version block) + current_version; + { block; index; lock; dict } + + let (`Staged v) = + with_cache ~clear ~v:(fun index -> unsafe_v ~index) "store.pack" + + type key = K.t + + module Make (V : ELT with type hash := K.t) = struct + module Tbl = Table (K) + module Lru = Cache (K) + + type nonrec 'a t = { pack : 'a t; lru : V.t Lru.t; staging : V.t Tbl.t } + + type key = K.t + + type value = V.t + + type index = Index.t + + let clear t = + clear t.pack; + Tbl.clear t.staging + + (* we need another cache here, as we want to share the LRU and + staging caches too. *) + + let roots = Hashtbl.create 10 + + let create = Lwt_mutex.create () + + let unsafe_v_no_cache ~fresh ~readonly ~shared ~lru_size ~index root = + let pack = v index ~fresh ~shared ~readonly root in + let staging = Tbl.create 127 in + let lru = Lru.create lru_size in + { staging; lru; pack } + + let unsafe_v ?(fresh = false) ?(shared = true) ?(readonly = false) + ?(lru_size = 10_000) ~index root = + if not shared then + unsafe_v_no_cache ~fresh ~readonly ~shared ~lru_size ~index root + else + try + let t = Hashtbl.find roots root in + if fresh then clear t; + t + with Not_found -> + let t = + unsafe_v_no_cache ~fresh ~readonly ~shared ~lru_size ~index root + in + if fresh then clear t; + Hashtbl.add roots root t; + t + + let v ?fresh ?shared ?readonly ?lru_size ~index root = + Lwt_mutex.with_lock create (fun () -> + let t = unsafe_v ?fresh ?shared ?readonly ?lru_size ~index root in + Lwt.return t ) + + let pp_hash = Irmin.Type.pp K.t + + let io_read_and_decode_hash ~off t = + let buf = Bytes.create K.hash_size in + let n = IO.read t.pack.block ~off buf in + assert (n = K.hash_size); + let _, v = + Irmin.Type.decode_bin ~headers:false K.t (Bytes.unsafe_to_string buf) 0 + in + v + + let unsafe_mem t k = + Log.debug (fun l -> l "[pack] mem %a" pp_hash k); + Tbl.mem t.staging k || Lru.mem t.lru k || Index.mem t.pack.index k + + let mem t k = + Lwt_mutex.with_lock create (fun () -> + let b = unsafe_mem t k in + Lwt.return b ) + + let check_key k v = + let k' = V.hash v in + if Irmin.Type.equal K.t k k' then () + else + Fmt.failwith "corrupted value: got %a, expecting %a." pp_hash k' + pp_hash k + + let io_read_and_decode ~off ~len t = + if not (IO.readonly t.pack.block) then + assert (off <= IO.offset t.pack.block); + let buf = Bytes.create len in + let n = IO.read t.pack.block ~off buf in + assert (n = len); + let hash off = io_read_and_decode_hash ~off t in + let dict = Dict.find t.pack.dict in + V.decode_bin ~hash ~dict (Bytes.unsafe_to_string buf) 0 + + let unsafe_find t k = + Log.debug (fun l -> l "[pack] find %a" pp_hash k); + stats.pack_finds <- succ stats.pack_finds; + match Tbl.find t.staging k with + | v -> + Lru.add t.lru k v; + Some v + | exception Not_found -> ( + match Lru.find t.lru k with + | v -> Some v + | exception Not_found -> ( + stats.pack_cache_misses <- succ stats.pack_cache_misses; + match Index.find t.pack.index k with + | None -> None + | Some (off, len, _) -> + let v = io_read_and_decode ~off ~len t in + check_key k v; + Lru.add t.lru k v; + Some v ) ) + + let find t k = + Lwt_mutex.with_lock t.pack.lock (fun () -> + let v = unsafe_find t k in + Lwt.return v ) + + let cast t = (t :> [ `Read | `Write ] t) + + let sync t = + Dict.sync t.pack.dict; + Index.flush t.pack.index; + IO.sync t.pack.block; + Tbl.clear t.staging + + let batch t f = + f (cast t) >>= fun r -> + if Tbl.length t.staging = 0 then Lwt.return r + else ( + sync t; + Lwt.return r ) + + let auto_flush = 1024 + + let unsafe_append t k v = + match unsafe_mem t k with + | true -> () + | false -> + Log.debug (fun l -> l "[pack] append %a" pp_hash k); + let offset k = + match Index.find t.pack.index k with + | None -> + stats.appended_hashes <- stats.appended_hashes + 1; + None + | Some (off, _, _) -> + stats.appended_offsets <- stats.appended_offsets + 1; + Some off + in + let dict = Dict.index t.pack.dict in + let off = IO.offset t.pack.block in + V.encode_bin ~offset ~dict v k (IO.append t.pack.block); + let len = Int64.to_int (IO.offset t.pack.block -- off) in + Index.add t.pack.index k (off, len, V.magic v); + if Tbl.length t.staging >= auto_flush then sync t + else Tbl.add t.staging k v; + Lru.add t.lru k v + + let append t k v = + Lwt_mutex.with_lock t.pack.lock (fun () -> + unsafe_append t k v; + Lwt.return () ) + + let add t v = + let k = V.hash v in + append t k v >|= fun () -> k + + let unsafe_add t k v = append t k v + end +end + +let div_or_zero a b = if b = 0 then 0. else float_of_int a /. float_of_int b + +type stats = { + pack_cache_misses : float; + offset_ratio : float; + offset_significance : int +} + +let stats () = + { pack_cache_misses = div_or_zero stats.pack_cache_misses stats.pack_finds; + offset_ratio = + div_or_zero stats.appended_offsets + (stats.appended_offsets + stats.appended_hashes); + offset_significance = stats.appended_offsets + stats.appended_hashes + } diff --git a/vendors/irmin-pack/pack.mli b/vendors/irmin-pack/pack.mli new file mode 100644 index 000000000000..1aa64acb4719 --- /dev/null +++ b/vendors/irmin-pack/pack.mli @@ -0,0 +1,86 @@ +(* + * Copyright (c) 2013-2019 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. + *) + +module type ELT = sig + include Irmin.Type.S + + type hash + + val hash : t -> hash + + val magic : t -> char + + val encode_bin : + dict:(string -> int option) -> + offset:(hash -> int64 option) -> + t -> + hash -> + (string -> unit) -> + unit + + val decode_bin : + dict:(int -> string option) -> hash:(int64 -> hash) -> string -> int -> t +end + +module type S = sig + include Irmin.CONTENT_ADDRESSABLE_STORE + + type index + + val v : + ?fresh:bool -> + ?shared:bool -> + ?readonly:bool -> + ?lru_size:int -> + index:index -> + string -> + [ `Read ] t Lwt.t + + val batch : [ `Read ] t -> ([ `Read | `Write ] t -> 'a Lwt.t) -> 'a Lwt.t + + val unsafe_append : 'a t -> key -> value -> unit + + val unsafe_mem : 'a t -> key -> bool + + val unsafe_find : 'a t -> key -> value option + + val sync : 'a t -> unit +end + +module type MAKER = sig + type key + + type index + + (** Save multiple kind of values in the same pack file. Values will + be distinguished using [V.magic], so they have to all be + different. *) + module Make (V : ELT with type hash := key) : + S with type key = key and type value = V.t and type index = index +end + +module File (Index : Pack_index.S) (K : Irmin.Hash.S with type t = Index.key) : + MAKER with type key = K.t and type index = Index.t + +type stats = { + pack_cache_misses : float; + offset_ratio : float; + offset_significance : int +} + +val reset_stats : unit -> unit + +val stats : unit -> stats diff --git a/vendors/irmin-pack/pack_dict.ml b/vendors/irmin-pack/pack_dict.ml new file mode 100644 index 000000000000..da370cb7a4bd --- /dev/null +++ b/vendors/irmin-pack/pack_dict.ml @@ -0,0 +1,9 @@ +include Dict.Make (IO.Unix) + +(* Add IO caching around Dict.v *) +let (`Staged v) = + let v_no_cache ~fresh ~shared:_ ~readonly = v ~fresh ~readonly in + IO.with_cache ~clear ~v:(fun capacity -> v_no_cache ~capacity) "store.dict" + +let v ?fresh ?readonly ?shared ?(capacity = 100_000) root = + v capacity ?fresh ?shared ?readonly root diff --git a/vendors/irmin-pack/pack_index.ml b/vendors/irmin-pack/pack_index.ml new file mode 100644 index 000000000000..448d6f6b8d30 --- /dev/null +++ b/vendors/irmin-pack/pack_index.ml @@ -0,0 +1,102 @@ +(* Permission to use, copy, modify, and/or 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 type S = sig + type t + + type key + + type value = int64 * int * char + + val v : + ?fresh:bool -> + ?readonly:bool -> + ?shared:bool -> + log_size:int -> + fan_out_size:int -> + string -> + t + + val clear : t -> unit + + val flush : t -> unit + + val add : t -> key -> value -> unit + + val mem : t -> key -> bool + + val find : t -> key -> value option +end + +module Make (K : Irmin.Hash.S) = struct + module Key = struct + type t = K.t + + let pp ppf t = Irmin.Type.pp K.t ppf t + + let hash t = Irmin.Type.short_hash K.t t + + let hash_size = 60 + + let equal x y = Irmin.Type.equal K.t x y + + let encode x = Irmin.Type.to_bin_string K.t x + + let encoded_size = K.hash_size + + let decode s off = + let _, v = Irmin.Type.decode_bin ~headers:false K.t s off in + v + end + + module Val = struct + type t = int64 * int * char + + let pp = Irmin.Type.(pp (triple int64 int char)) + + let encode (off, len, kind) = + Irmin.Type.(to_bin_string (triple int64 int32 char)) + (off, Int32.of_int len, kind) + + let decode s off = + let off, len, kind = + snd (Irmin.Type.(decode_bin (triple int64 int32 char)) s off) + in + (off, Int32.to_int len, kind) + + let encoded_size = (64 / 8) + (32 / 8) + 1 + end + + module Index = Index_unix.Make (Key) (Val) + + type t = Index.t + + type key = K.t + + type value = Val.t + + let v = Index.v + + let clear = Index.clear + + let flush = Index.flush + + let add t k v = if not (Index.mem t k) then Index.add t k v + + let mem = Index.mem + + let find t k = + match Index.find_all t k with + | [] -> None + | [ h ] -> Some h + | _ -> assert false +end diff --git a/vendors/irmin-pack/pack_index.mli b/vendors/irmin-pack/pack_index.mli new file mode 100644 index 000000000000..f09934ed073a --- /dev/null +++ b/vendors/irmin-pack/pack_index.mli @@ -0,0 +1,40 @@ +(* Permission to use, copy, modify, and/or 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 type S = sig + type t + + type key + + type value = int64 * int * char + + val v : + ?fresh:bool -> + ?readonly:bool -> + ?shared:bool -> + log_size:int -> + fan_out_size:int -> + string -> + t + + val clear : t -> unit + + val flush : t -> unit + + val add : t -> key -> value -> unit + + val mem : t -> key -> bool + + val find : t -> key -> value option +end + +module Make (K : Irmin.Hash.S) : S with type key = K.t diff --git a/vendors/irmin/bheap.ml b/vendors/irmin/bheap.ml new file mode 100644 index 000000000000..e37019b65069 --- /dev/null +++ b/vendors/irmin/bheap.ml @@ -0,0 +1,116 @@ +(**************************************************************************) +(* *) +(* Copyright (C) Jean-Christophe Filliatre *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(*s Heaps *) + +module type Ordered = sig + type t + + val compare : t -> t -> int +end + +exception Empty + +module Make (X : Ordered) = struct + (* The heap is encoded in the array [data], where elements are stored + from [0] to [size - 1]. From an element stored at [i], the left + (resp. right) subtree, if any, is rooted at [2*i+1] (resp. [2*i+2]). *) + + type t = { mutable size : int; mutable data : X.t array } + + (* When [create n] is called, we cannot allocate the array, since there is + no known value of type [X.t]; we'll wait for the first addition to + do it, and we remember this situation with a negative size. *) + + let create n = + if n <= 0 then invalid_arg "create"; + { size = -n; data = [||] } + + let is_empty h = h.size <= 0 + + (* [resize] doubles the size of [data] *) + + let resize h = + let n = h.size in + assert (n > 0); + let n' = 2 * n in + let d = h.data in + let d' = Array.make n' d.(0) in + Array.blit d 0 d' 0 n; + h.data <- d' + + let add h x = + (* first addition: we allocate the array *) + if h.size < 0 then ( + h.data <- Array.make (-h.size) x; + h.size <- 0 ); + let n = h.size in + (* resizing if needed *) + if n == Array.length h.data then resize h; + let d = h.data in + (* moving [x] up in the heap *) + let rec moveup i = + let fi = (i - 1) / 2 in + if i > 0 && X.compare d.(fi) x < 0 then ( + d.(i) <- d.(fi); + moveup fi ) + else d.(i) <- x + in + moveup n; + h.size <- n + 1 + + let maximum h = + if h.size <= 0 then raise Empty; + h.data.(0) + + let remove h = + if h.size <= 0 then raise Empty; + let n = h.size - 1 in + h.size <- n; + let d = h.data in + let x = d.(n) in + (* moving [x] down in the heap *) + let rec movedown i = + let j = (2 * i) + 1 in + if j < n then + let j = + let j' = j + 1 in + if j' < n && X.compare d.(j') d.(j) > 0 then j' else j + in + if X.compare d.(j) x > 0 then ( + d.(i) <- d.(j); + movedown j ) + else d.(i) <- x + else d.(i) <- x + in + movedown 0 + + let pop_maximum h = + let m = maximum h in + remove h; + m + + let iter f h = + let d = h.data in + for i = 0 to h.size - 1 do + f d.(i) + done + + let fold f h x0 = + let n = h.size in + let d = h.data in + let rec foldrec x i = if i >= n then x else foldrec (f d.(i) x) (succ i) in + foldrec x0 0 +end diff --git a/vendors/irmin/bheap.mli b/vendors/irmin/bheap.mli new file mode 100644 index 000000000000..df19fab9ad1d --- /dev/null +++ b/vendors/irmin/bheap.mli @@ -0,0 +1,59 @@ +(**************************************************************************) +(* *) +(* Copyright (C) Jean-Christophe Filliatre *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* Traditional implementation of a binary heap using an array *) + +module type Ordered = sig + type t + + val compare : t -> t -> int +end + +exception Empty + +module Make (X : Ordered) : sig + (* Type of imperative heaps. + (In the following [n] refers to the number of elements in the heap) *) + + type t + + (* [create c] creates a new heap, with initial capacity of [c] *) + val create : int -> t + + (* [is_empty h] checks the emptiness of [h] *) + val is_empty : t -> bool + + (* [add x h] adds a new element [x] in heap [h]; size of [h] is doubled + when maximum capacity is reached; complexity $O(log(n))$ *) + val add : t -> X.t -> unit + + (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap] + when [h] is empty; complexity $O(1)$ *) + val maximum : t -> X.t + + (* [remove h] removes the maximum element of [h]; raises [EmptyHeap] + when [h] is empty; complexity $O(log(n))$ *) + val remove : t -> unit + + (* [pop_maximum h] removes the maximum element of [h] and returns it; + raises [EmptyHeap] when [h] is empty; complexity $O(log(n))$ *) + val pop_maximum : t -> X.t + + (* usual iterators and combinators; elements are presented in + arbitrary order *) + val iter : (X.t -> unit) -> t -> unit + + val fold : (X.t -> 'a -> 'a) -> t -> 'a -> 'a +end diff --git a/vendors/irmin/branch.ml b/vendors/irmin/branch.ml new file mode 100644 index 000000000000..a53578507962 --- /dev/null +++ b/vendors/irmin/branch.ml @@ -0,0 +1,35 @@ +(* + * 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. + *) + +module String = struct + type t = string + + let t = Type.string + + let master = "master" + + let is_valid s = + let ok = ref true in + let n = String.length s in + let i = ref 0 in + while !i < n do + ( match s.[!i] with + | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '-' | '_' | '.' -> () + | _ -> ok := false ); + incr i + done; + !ok +end diff --git a/vendors/irmin/branch.mli b/vendors/irmin/branch.mli new file mode 100644 index 000000000000..a607e1e614d0 --- /dev/null +++ b/vendors/irmin/branch.mli @@ -0,0 +1,19 @@ +(* + * 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. + *) + +(** Handling of branches. *) + +module String : S.BRANCH with type t = string diff --git a/vendors/irmin/commit.ml b/vendors/irmin/commit.ml new file mode 100644 index 000000000000..7ab32e3baa26 --- /dev/null +++ b/vendors/irmin/commit.ml @@ -0,0 +1,543 @@ +(* + * 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 +open Merge.Infix + +let src = Logs.Src.create "irmin.commit" ~doc:"Irmin commits" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Make (K : Type.S) = struct + type hash = K.t + + type t = { node : hash; parents : hash list; info : Info.t } + + let parents t = t.parents + + let node t = t.node + + let info t = t.info + + let v ~info ~node ~parents = + let parents = List.fast_sort (Type.compare K.t) parents in + { node; parents; info } + + let t = + let open Type in + record "commit" (fun node parents info -> { node; parents; info }) + |+ field "node" K.t (fun t -> t.node) + |+ field "parents" (list K.t) (fun t -> t.parents) + |+ field "info" Info.t (fun t -> t.info) + |> sealr + + let hash_t = K.t +end + +module Store + (N : S.NODE_STORE) (S : sig + include S.CONTENT_ADDRESSABLE_STORE with type key = N.key + + module Key : S.HASH with type t = key + + module Val : S.COMMIT with type t = value and type hash = key + end) = +struct + module Node = N + + type 'a t = 'a N.t * 'a S.t + + type key = S.key + + type value = S.value + + let add (_, t) = S.add t + + let unsafe_add (_, t) = S.unsafe_add t + + let mem (_, t) = S.mem t + + let find (_, t) = S.find t + + let merge_node (t, _) = Merge.f (N.merge t) + + let pp_key = Type.pp S.Key.t + + let err_not_found k = + Fmt.kstrf invalid_arg "Commit.get: %a not found" pp_key k + + let get (_, t) k = + S.find t k >>= function None -> err_not_found k | Some v -> Lwt.return v + + let empty_if_none (n, _) = function + | None -> N.add n N.Val.empty + | Some node -> Lwt.return node + + let equal_opt_keys = Type.(equal (option S.Key.t)) + + let merge_commit info t ~old k1 k2 = + get t k1 >>= fun v1 -> + get t k2 >>= fun v2 -> + if List.mem k1 (S.Val.parents v2) then Merge.ok k2 + else if List.mem k2 (S.Val.parents v1) then Merge.ok k1 + else + (* If we get an error while looking the the lca, then we + assume that there is no common ancestor. Maybe we want to + expose this to the user in a more structured way. But maybe + that's too much low-level details. *) + (old () >>= function + | Error (`Conflict msg) -> + Log.debug (fun f -> f "old: conflict %s" msg); + Lwt.return None + | Ok o -> Lwt.return o) + >>= fun old -> + if equal_opt_keys old (Some k1) then Merge.ok k2 + else if equal_opt_keys old (Some k2) then Merge.ok k1 + else + let old () = + match old with + | None -> Merge.ok None + | Some old -> + get t old >>= fun vold -> + Merge.ok (Some (Some (S.Val.node vold))) + in + merge_node t ~old (Some (S.Val.node v1)) (Some (S.Val.node v2)) + >>=* fun node -> + empty_if_none t node >>= fun node -> + let parents = [ k1; k2 ] in + let commit = S.Val.v ~node ~parents ~info:(info ()) in + add t commit >>= fun key -> Merge.ok key + + let merge t ~info = Merge.(option (v S.Key.t (merge_commit info t))) + + module Key = Hash.Typed (S.Key) (S.Val) + module Val = S.Val +end + +module History (S : S.COMMIT_STORE) = struct + type commit = S.key + + type node = S.Node.key + + type 'a t = 'a S.t + + type v = S.Val.t + + let commit_t = S.Key.t + + let merge t ~info = + let f ~old c1 c2 = + let somify = Merge.map_promise (fun x -> Some x) in + let merge = S.merge t ~info in + Merge.f merge ~old:(somify old) (Some c1) (Some c2) >>=* function + | None -> Merge.conflict "History.merge" + | Some x -> Merge.ok x + in + Merge.v S.Key.t f + + let v t ~node ~parents ~info = + let commit = S.Val.v ~node ~parents ~info in + S.add t commit >|= fun hash -> (hash, commit) + + let pp_key = Type.pp S.Key.t + + let parents t c = + Log.debug (fun f -> f "parents %a" pp_key c); + S.find t c >|= function None -> [] | Some c -> S.Val.parents c + + module Graph = + Object_graph.Make (S.Node.Contents.Key) (S.Node.Metadata) (S.Node.Key) + (S.Key) + (struct + type t = unit + + let t = Type.unit + end) + + let edges t = + Log.debug (fun f -> f "edges"); + [ `Node (S.Val.node t) ] @ List.map (fun k -> `Commit k) (S.Val.parents t) + + let closure t ~min ~max = + Log.debug (fun f -> f "closure"); + let pred = function + | `Commit k -> ( + S.find t k >|= function Some r -> edges r | None -> [] ) + | _ -> Lwt.return_nil + in + let min = List.map (fun k -> `Commit k) min in + let max = List.map (fun k -> `Commit k) max in + Graph.closure ~pred ~min ~max () >|= fun g -> + List.fold_left + (fun acc -> function `Commit k -> k :: acc | _ -> acc) + [] (Graph.vertex g) + + module K = struct + type t = S.Key.t + + let compare = Type.compare S.Key.t + + let hash = S.Key.short_hash + + let equal = Type.equal S.Key.t + end + + module KSet = Set.Make (K) + module KHashtbl = Hashtbl.Make (K) + + let read_parents t commit = + S.find t commit >|= function + | None -> KSet.empty + | Some c -> KSet.of_list (S.Val.parents c) + + let equal_keys = Type.equal S.Key.t + + let str_key k = String.sub (Type.to_string S.Key.t k) 0 4 + + let pp_key = Fmt.of_to_string str_key + + let pp_keys ppf keys = + let keys = KSet.elements keys in + Fmt.pf ppf "[%a]" Fmt.(list ~sep:(unit " ") pp_key) keys + + let str_keys = Fmt.to_to_string pp_keys + + let lca_calls = ref 0 + + let rec unqueue todo seen = + if Queue.is_empty todo then None + else + let ((_, commit) as pop) = Queue.pop todo in + if KSet.mem commit seen then unqueue todo seen else Some pop + + (* Traverse the graph of commits using a breadth first search + strategy. Start by visiting the commits in [init] and stops + either when [check] returns [`Stop] or when all the ancestors of + [init] have been visited. *) + let traverse_bfs t ~f ~pp:_ ~check ~init ~return = + let todo = Queue.create () in + let add_todo d x = Queue.add (d, x) todo in + KSet.iter (add_todo 0) init; + let rec aux seen = + match check () with + | (`Too_many_lcas | `Max_depth_reached) as x -> Lwt.return (Error x) + | `Stop -> return () + | `Continue -> ( + match unqueue todo seen with + | None -> return () + | Some (depth, commit) -> + (* Log.debug "lca %d: %s.%d %a" + !lca_calls (pp_key commit) depth force (pp ()); *) + let seen = KSet.add commit seen in + read_parents t commit >>= fun parents -> + let () = f depth commit parents in + let parents = KSet.diff parents seen in + KSet.iter (add_todo (depth + 1)) parents; + aux seen ) + in + aux KSet.empty + + (* Initially the first node is marked as [Seen1] and the second as [Seen2]. + Marks are updated as the search progresses, and may change. *) + type mark = + | Seen1 (* reachable from the first commit *) + | Seen2 (* reachable from the second commit *) + | SeenBoth (* reachable from both, but below an LCA *) + | LCA + + (* reachable from both; candidate for the answer set *) + + let _pp_mark = function + | Seen1 -> "seen1" + | Seen2 -> "seen2" + | SeenBoth -> "seenBoth" + | LCA -> "LCA" + + (* Exploration state *) + type state = { + marks : mark KHashtbl.t; + (* marks of commits already explored *) + parents : KSet.t KHashtbl.t; + (* parents of commits already explored *) + layers : (int, KSet.t) Hashtbl.t; + (* layers of commit, sorted by depth *) + c1 : S.key; + (* initial state 1 *) + c2 : S.key; + (* initial state 2 *) + mutable depth : int; + (* the current exploration depth *) + mutable lcas : int; + (* number of commit marked with LCA *) + mutable complete : bool (* is the exploration complete? *) + } + + let pp_state t = + lazy + (let pp m = + KHashtbl.fold + (fun k v acc -> if v = m then str_key k :: acc else acc) + t.marks [] + |> String.concat " " + in + Fmt.strf "d: %d, seen1: %s, seen2: %s, seenboth: %s, lcas: %s (%d) %s" + t.depth (pp Seen1) (pp Seen2) (pp SeenBoth) (pp LCA) t.lcas + (String.concat " | " + (Hashtbl.fold + (fun d ks acc -> Fmt.strf "(%d: %s)" d (str_keys ks) :: acc) + t.layers []))) + + let get_mark_exn t elt = KHashtbl.find t.marks elt + + let get_mark t elt = try Some (get_mark_exn t elt) with Not_found -> None + + let set_mark t elt mark = KHashtbl.replace t.marks elt mark + + let get_layer t d = + try Hashtbl.find t.layers d with Not_found -> KSet.empty + + let add_to_layer t d k = + Hashtbl.replace t.layers d (KSet.add k (get_layer t d)) + + let add_parent t c p = KHashtbl.add t.parents c p + + let get_parent t c = + try KHashtbl.find t.parents c with Not_found -> KSet.empty + + let incr_lcas t = t.lcas <- t.lcas + 1 + + let decr_lcas t = t.lcas <- t.lcas - 1 + + let both_seen t k = + match get_mark t k with + | None | Some Seen1 | Some Seen2 -> false + | _ -> true + + let empty_state c1 c2 = + let t = + { marks = KHashtbl.create 10; + parents = KHashtbl.create 10; + layers = Hashtbl.create 10; + c1; + c2; + depth = 0; + lcas = 0; + complete = false + } + in + set_mark t c1 Seen1; + set_mark t c2 Seen2; + t + + (* update the parent mark and keep the number of lcas up-to-date. *) + let update_mark t mark commit = + let new_mark = + match (mark, get_mark t commit) with + | Seen1, Some Seen1 | Seen1, None -> Seen1 + | Seen2, Some Seen2 | Seen2, None -> Seen2 + | SeenBoth, Some LCA -> + decr_lcas t; + SeenBoth + | SeenBoth, _ -> SeenBoth + | Seen1, Some Seen2 | Seen2, Some Seen1 -> + incr_lcas t; + LCA + | _, Some LCA -> LCA + | _ -> SeenBoth + in + (* check for fast-forwards *) + let is_init () = equal_keys commit t.c1 || equal_keys commit t.c2 in + let is_shared () = new_mark = SeenBoth || new_mark = LCA in + if is_shared () && is_init () then ( + Log.debug (fun f -> f "fast-forward"); + t.complete <- true ); + set_mark t commit new_mark; + new_mark + + (* update the ancestors which have already been visisted. *) + let update_ancestors_marks t mark commit = + let todo = Queue.create () in + Queue.add commit todo; + let rec loop mark = + if Queue.is_empty todo then () + else + let a = Queue.pop todo in + let old_mark = get_mark t a in + let mark = update_mark t mark a in + let () = + match old_mark with + | Some (SeenBoth | LCA) -> () (* Can't be an LCA lower down *) + | Some old when old = mark -> () (* No change *) + | _ -> KSet.iter (fun x -> Queue.push x todo) (get_parent t a) + in + loop (if mark = LCA then SeenBoth else mark) + in + loop mark + + (* We are looking for LCAs, doing a breadth-first-search from the two starting commits. + This is called each time we visit a new commit. *) + let update_parents t depth commit parents = + add_parent t commit parents; + add_to_layer t depth commit; + if depth <> t.depth then ( + assert (depth = t.depth + 1); + (* before starting to explore a new layer, check if we really + have some work to do, ie. do we still have a commit seen only + by one node? *) + let layer = get_layer t t.depth in + let complete = KSet.for_all (both_seen t) layer in + if complete then t.complete <- true else t.depth <- depth ); + let mark = get_mark_exn t commit in + KSet.iter (update_ancestors_marks t mark) parents + + let lcas t = + KHashtbl.fold (fun k v acc -> if v = LCA then k :: acc else acc) t.marks [] + + let check ~max_depth ~n t = + if t.depth > max_depth then `Max_depth_reached + else if t.lcas > n then `Too_many_lcas + else if t.lcas = n || t.complete then `Stop + else `Continue + + let lcas t ?(max_depth = max_int) ?(n = max_int) c1 c2 = + incr lca_calls; + if max_depth < 0 then Lwt.return (Error `Max_depth_reached) + else if n <= 0 then Lwt.return (Error `Too_many_lcas) + else if equal_keys c1 c2 then Lwt.return (Ok [ c1 ]) + else + let init = KSet.of_list [ c1; c2 ] in + let s = empty_state c1 c2 in + let check () = check ~max_depth ~n s in + let pp () = pp_state s in + let return () = Lwt.return (Ok (lcas s)) in + let t0 = Sys.time () in + Lwt.finalize + (fun () -> + traverse_bfs t ~f:(update_parents s) ~pp ~check ~init ~return ) + (fun () -> + let t1 = Sys.time () -. t0 in + Log.debug (fun f -> + f "lcas %d: depth=%d time=%.4fs" !lca_calls s.depth t1 ); + Lwt.return_unit ) + + let rec three_way_merge t ~info ?max_depth ?n c1 c2 = + Log.debug (fun f -> f "3-way merge between %a and %a" pp_key c1 pp_key c2); + if equal_keys c1 c2 then Merge.ok c1 + else + lcas t ?max_depth ?n c1 c2 >>= fun lcas -> + let old () = + match lcas with + | Error `Too_many_lcas -> Merge.conflict "Too many lcas" + | Error `Max_depth_reached -> Merge.conflict "Max depth reached" + | Ok [] -> Merge.ok None (* no common ancestor *) + | Ok (old :: olds) -> + let rec aux acc = function + | [] -> Merge.ok (Some acc) + | old :: olds -> + three_way_merge t ~info acc old >>=* fun acc -> aux acc olds + in + aux old olds + in + let merge = + merge t ~info + |> Merge.with_conflict (fun msg -> + Fmt.strf "Recursive merging of common ancestors: %s" msg ) + |> Merge.f + in + merge ~old c1 c2 + + let lca_aux t ~info ?max_depth ?n c1 c2 = + if equal_keys c1 c2 then Merge.ok (Some c1) + else + lcas t ?max_depth ?n c1 c2 >>= function + | Error `Too_many_lcas -> Merge.conflict "Too many lcas" + | Error `Max_depth_reached -> Merge.conflict "Max depth reached" + | Ok [] -> Merge.ok None (* no common ancestor *) + | Ok [ x ] -> Merge.ok (Some x) + | Ok (c :: cs) -> + let rec aux acc = function + | [] -> Merge.ok (Some acc) + | c :: cs -> ( + three_way_merge t ~info ?max_depth ?n acc c >>= function + | Error (`Conflict _) -> Merge.ok None + | Ok acc -> aux acc cs ) + in + aux c cs + + let rec lca t ~info ?max_depth ?n = function + | [] -> Merge.conflict "History.lca: empty" + | [ c ] -> Merge.ok (Some c) + | c1 :: c2 :: cs -> ( + lca_aux t ~info ?max_depth ?n c1 c2 >>=* function + | None -> Merge.ok None + | Some c -> lca t ~info ?max_depth ?n (c :: cs) ) +end + +module V1 (C : S.COMMIT) = struct + module K = struct + let h = Type.string_of `Int64 + + let size_of ?headers x = + Type.size_of ?headers h (Type.to_bin_string C.hash_t x) + + let encode_bin ?headers e k = + Type.encode_bin ?headers h (Type.to_bin_string C.hash_t e) k + + let decode_bin ?headers buf off = + let n, v = Type.decode_bin ?headers h buf off in + ( n, + match Type.of_bin_string C.hash_t v with + | Ok v -> v + | Error (`Msg e) -> Fmt.failwith "decode_bin: %s" e ) + + let t = Type.like C.hash_t ~bin:(encode_bin, decode_bin, size_of) + end + + type hash = C.hash + + let hash_t = K.t + + type t = { parents : hash list; c : C.t } + + let import c = { c; parents = C.parents c } + + let export t = t.c + + let node t = C.node t.c + + let parents t = t.parents + + let info t = C.info t.c + + let v ~info ~node ~parents = { parents; c = C.v ~node ~parents ~info } + + let make = v + + let info_t : Info.t Type.t = + let open Type in + record "info" (fun date author message -> Info.v ~date ~author message) + |+ field "date" int64 (fun t -> Info.date t) + |+ field "author" (string_of `Int64) (fun t -> Info.author t) + |+ field "message" (string_of `Int64) (fun t -> Info.message t) + |> sealr + + let t : t Type.t = + let open Type in + record "commit" (fun node parents info -> make ~info ~node ~parents) + |+ field "node" K.t node + |+ field "parents" (list ~len:`Int64 K.t) parents + |+ field "info" info_t info |> sealr +end diff --git a/vendors/irmin/commit.mli b/vendors/irmin/commit.mli new file mode 100644 index 000000000000..ccc3c4fd636e --- /dev/null +++ b/vendors/irmin/commit.mli @@ -0,0 +1,49 @@ +(* + * 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. + *) + +(** Manage the database history. *) + +module Make (K : Type.S) : S.COMMIT with type hash = K.t + +module Store + (N : S.NODE_STORE) (C : sig + include S.CONTENT_ADDRESSABLE_STORE with type key = N.key + + module Key : S.HASH with type t = key + + module Val : S.COMMIT with type t = value and type hash = key + end) : + S.COMMIT_STORE + with type 'a t = 'a N.t * 'a C.t + and type key = C.key + and type value = C.value + and type Key.t = C.Key.t + and module Val = C.Val + +module History (C : S.COMMIT_STORE) : + S.COMMIT_HISTORY + with type 'a t = 'a C.t + and type v = C.Val.t + and type node = C.Node.key + and type commit = C.key + +module V1 (C : S.COMMIT) : sig + include S.COMMIT with type hash = C.hash + + val import : C.t -> t + + val export : t -> C.t +end diff --git a/vendors/irmin/conf.ml b/vendors/irmin/conf.ml new file mode 100644 index 000000000000..d8278fba6688 --- /dev/null +++ b/vendors/irmin/conf.ml @@ -0,0 +1,149 @@ +(* + * Copyright (c) 2017 Daniel C. Bünzli + * Copyright (c) 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. + *) + +type 'a parser = string -> ('a, [ `Msg of string ]) result + +type 'a printer = 'a Fmt.t + +type 'a converter = 'a parser * 'a printer + +let parser (p, _) = p + +let printer (_, p) = p + +let str = Printf.sprintf + +let quote s = str "`%s'" s + +module Err = struct + let alts = function + | [ a; b ] -> str "either %s or %s" a b + | alts -> str "one of: %s" (String.concat ", " alts) + + let invalid kind s exp = str "invalid %s %s, %s" kind (quote s) exp + + let invalid_val = invalid "value" +end + +let bool = + ( (fun s -> + try Ok (bool_of_string s) + with Invalid_argument _ -> + Error (`Msg (Err.invalid_val s (Err.alts [ "true"; "false" ]))) ), + Fmt.bool ) + +let parse_with t_of_str exp s = + try Ok (t_of_str s) with Failure _ -> Error (`Msg (Err.invalid_val s exp)) + +let int = (parse_with int_of_string "expected an integer", Fmt.int) + +let string = ((fun s -> Ok s), Fmt.string) + +let some (parse, print) = + let none = "" in + ( (fun s -> match parse s with Ok v -> Ok (Some v) | Error _ as e -> e), + fun ppf v -> + match v with None -> Fmt.string ppf none | Some v -> print ppf v ) + +let uri = + let parse s = Ok (Uri.of_string s) in + let print pp u = Fmt.string pp (Uri.to_string u) in + (parse, print) + +module Univ = struct + type t = exn + + let create (type s) () = + let module M = struct + exception E of s option + end in + ((fun x -> M.E (Some x)), function M.E x -> x | _ -> None) +end + +type 'a key = { + id : int; + to_univ : 'a -> Univ.t; + of_univ : Univ.t -> 'a option; + name : string; + doc : string option; + docv : string option; + docs : string option; + conv : 'a converter; + default : 'a +} + +let name t = t.name + +let doc t = t.doc + +let docv t = t.docv + +let docs t = t.docs + +let conv t = t.conv + +let default t = t.default + +let key ?docs ?docv ?doc name conv default = + let () = + String.iter + (function + | '-' | '_' | 'a' .. 'z' | '0' .. '9' -> () + | _ -> raise @@ Invalid_argument name ) + name + in + let to_univ, of_univ = Univ.create () in + let id = Oo.id (object end) in + { id; to_univ; of_univ; name; docs; docv; doc; conv; default } + +module Id = struct + type t = int + + let compare (x : int) (y : int) = compare x y +end + +module M = Map.Make (Id) + +type t = Univ.t M.t + +let empty = M.empty + +let singleton k v = M.singleton k.id (k.to_univ v) + +let is_empty = M.is_empty + +let mem d k = M.mem k.id d + +let add d k v = M.add k.id (k.to_univ v) d + +let union r s = M.fold M.add r s + +let rem d k = M.remove k.id d + +let find d k = try k.of_univ (M.find k.id d) with Not_found -> None + +let get d k = + try + match k.of_univ (M.find k.id d) with + | Some v -> v + | None -> raise Not_found + with Not_found -> k.default + +(* ~root *) +let root = + key ~docv:"ROOT" ~doc:"The location of the Git repository root." + ~docs:"COMMON OPTIONS" "root" (some string) None diff --git a/vendors/irmin/conf.mli b/vendors/irmin/conf.mli new file mode 100644 index 000000000000..c8449b2e7194 --- /dev/null +++ b/vendors/irmin/conf.mli @@ -0,0 +1,81 @@ +(* + * Copyright (c) 2017 Daniel C. Bünzli + * Copyright (c) 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. + *) + +type 'a parser = string -> ('a, [ `Msg of string ]) result + +type 'a printer = 'a Fmt.t + +type 'a converter = 'a parser * 'a printer + +val parser : 'a converter -> 'a parser + +val printer : 'a converter -> 'a printer + +val bool : bool converter + +val int : int converter + +val string : string converter + +val some : 'a converter -> 'a option converter + +val uri : Uri.t converter + +type 'a key + +val key : + ?docs:string -> + ?docv:string -> + ?doc:string -> + string -> + 'a converter -> + 'a -> + 'a key + +val name : 'a key -> string + +val docs : 'a key -> string option + +val docv : 'a key -> string option + +val doc : 'a key -> string option + +val conv : 'a key -> 'a converter + +val default : 'a key -> 'a + +val root : string option key + +type t + +val empty : t + +val singleton : 'a key -> 'a -> t + +val is_empty : t -> bool + +val mem : t -> 'a key -> bool + +val add : t -> 'a key -> 'a -> t + +val rem : t -> 'a key -> t + +val union : t -> t -> t + +val find : t -> 'a key -> 'a option + +val get : t -> 'a key -> 'a diff --git a/vendors/irmin/contents.ml b/vendors/irmin/contents.ml new file mode 100644 index 000000000000..1ed0be4b740a --- /dev/null +++ b/vendors/irmin/contents.ml @@ -0,0 +1,316 @@ +(* + * 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 + +let lexeme e x = ignore (Jsonm.encode e (`Lexeme x)) + +let rec encode_json e = function + | `Null -> lexeme e `Null + | `Bool b -> lexeme e (`Bool b) + | `String s -> lexeme e (`String s) + | `Float f -> lexeme e (`Float f) + | `A a -> + lexeme e `As; + List.iter (encode_json e) a; + lexeme e `Ae + | `O o -> + lexeme e `Os; + List.iter + (fun (k, v) -> + lexeme e (`Name k); + encode_json e v ) + o; + lexeme e `Oe + +let decode_json d = + let decode d = + match Jsonm.decode d with + | `Lexeme l -> l + | `Error e -> failwith (Fmt.strf "%a" Jsonm.pp_error e) + | _ -> failwith "invalid JSON encoding" + in + let rec unwrap v d = + match v with + | `Os -> obj [] d + | `As -> arr [] d + | (`Null | `Bool _ | `String _ | `Float _) as v -> v + | _ -> failwith "invalid JSON value" + and arr vs d = + match decode d with + | `Ae -> `A (List.rev vs) + | v -> + let v = unwrap v d in + arr (v :: vs) d + and obj ms d = + match decode d with + | `Oe -> `O (List.rev ms) + | `Name k -> + let v = unwrap (decode d) d in + obj ((k, v) :: ms) d + | _ -> failwith "invalid JSON object" + in + try Ok (unwrap (decode d) d) with Failure msg -> Error (`Msg msg) + +type json = + [ `Null + | `Bool of bool + | `String of string + | `Float of float + | `O of (string * json) list + | `A of json list ] + +module Json_value = struct + type t = json + + let pp fmt x = + let buffer = Buffer.create 32 in + let encoder = Jsonm.encoder (`Buffer buffer) in + encode_json encoder x; + ignore @@ Jsonm.encode encoder `End; + let s = Buffer.contents buffer in + Fmt.pf fmt "%s" s + + let of_string s = + let decoder = Jsonm.decoder (`String s) in + match decode_json decoder with Ok obj -> Ok obj | Error _ as err -> err + + let t = + let open Type in + mu (fun ty -> + variant "json" (fun null bool string float obj arr -> function + | `Null -> null + | `Bool b -> bool b + | `String s -> string s + | `Float f -> float f + | `O o -> obj o + | `A a -> arr a ) + |~ case0 "null" `Null + |~ case1 "bool" bool (fun x -> `Bool x) + |~ case1 "string" string (fun x -> `String x) + |~ case1 "float" float (fun x -> `Float x) + |~ case1 "object" (list (pair string ty)) (fun obj -> `O obj) + |~ case1 "array" (list ty) (fun arr -> `A arr) + |> sealv ) + + let rec equal a b = + match (a, b) with + | `Null, `Null -> true + | `Bool a, `Bool b -> Type.(equal bool) a b + | `String a, `String b -> String.equal a b + | `Float a, `Float b -> Type.(equal float) a b + | `A a, `A b -> ( + try List.for_all2 (fun a' b' -> equal a' b') a b + with Invalid_argument _ -> false ) + | `O a, `O b -> ( + let compare_fst (a, _) (b, _) = compare a b in + try + List.for_all2 + (fun (k, v) (k', v') -> k = k' && equal v v') + (List.sort compare_fst a) (List.sort compare_fst b) + with Invalid_argument _ -> false ) + | _, _ -> false + + let t = Type.like ~equal ~cli:(pp, of_string) t + + let rec merge_object ~old x y = + let open Merge.Infix in + let m = + Merge.(alist Type.string t (fun _key -> option (v t merge_value))) + in + Merge.(f m ~old x y) >>=* fun x -> Merge.ok (`O x) + + and merge_float ~old x y = + let open Merge.Infix in + Merge.(f float ~old x y) >>=* fun f -> Merge.ok (`Float f) + + and merge_string ~old x y = + let open Merge.Infix in + Merge.(f string ~old x y) >>=* fun s -> Merge.ok (`String s) + + and merge_bool ~old x y = + let open Merge.Infix in + Merge.(f bool ~old x y) >>=* fun b -> Merge.ok (`Bool b) + + and merge_array ~old x y = + let open Merge.Infix in + Merge.(f (Merge.idempotent (Type.list t)) ~old x y) >>=* fun x -> + Merge.ok (`A x) + + and merge_value ~old x y = + let open Merge.Infix in + old () >>=* fun old -> + match (old, x, y) with + | Some `Null, _, _ -> merge_value ~old:(fun () -> Merge.ok None) x y + | None, `Null, `Null -> Merge.ok `Null + | Some (`Float old), `Float a, `Float b -> + merge_float ~old:(fun () -> Merge.ok (Some old)) a b + | None, `Float a, `Float b -> + merge_float ~old:(fun () -> Merge.ok None) a b + | Some (`String old), `String a, `String b -> + merge_string ~old:(fun () -> Merge.ok (Some old)) a b + | None, `String a, `String b -> + merge_string ~old:(fun () -> Merge.ok None) a b + | Some (`Bool old), `Bool a, `Bool b -> + merge_bool ~old:(fun () -> Merge.ok (Some old)) a b + | None, `Bool a, `Bool b -> merge_bool ~old:(fun () -> Merge.ok None) a b + | Some (`A old), `A a, `A b -> + merge_array ~old:(fun () -> Merge.ok (Some old)) a b + | None, `A a, `A b -> merge_array ~old:(fun () -> Merge.ok None) a b + | Some (`O old), `O a, `O b -> + merge_object ~old:(fun () -> Merge.ok (Some old)) a b + | None, `O a, `O b -> merge_object ~old:(fun () -> Merge.ok None) a b + | _, _, _ -> Merge.conflict "Conflicting JSON datatypes" + + let merge_json = Merge.(v t merge_value) + + let merge = Merge.(option merge_json) +end + +module Json = struct + type t = (string * json) list + + let pp fmt x = + let buffer = Buffer.create 32 in + let encoder = Jsonm.encoder (`Buffer buffer) in + encode_json encoder (`O x); + ignore @@ Jsonm.encode encoder `End; + let s = Buffer.contents buffer in + Fmt.pf fmt "%s" s + + let of_string s = + let decoder = Jsonm.decoder (`String s) in + match decode_json decoder with + | Ok (`O obj) -> Ok obj + | Ok _ -> Error (`Msg "Irmin JSON values must be objects") + | Error _ as err -> err + + let equal a b = Json_value.equal (`O a) (`O b) + + let t = Type.(list (pair string Json_value.t)) + + let t = Type.like ~equal ~cli:(pp, of_string) t + + let merge = + Merge.(option (alist Type.string Json_value.t (fun _ -> Json_value.merge))) +end + +module Json_tree (Store : S.STORE with type contents = json) = struct + include Json_value + + let to_concrete_tree j : Store.Tree.concrete = + let rec obj j acc = + match j with + | [] -> `Tree acc + | (k, v) :: l -> ( + match Type.of_string Store.Key.step_t k with + | Ok key -> obj l ((key, node v []) :: acc) + | _ -> obj l acc ) + and node j acc = + match j with + | `O j -> obj j acc + | _ -> `Contents (j, Store.Metadata.default) + in + node j [] + + let of_concrete_tree c : json = + let step = Type.to_string Store.Key.step_t in + let rec tree t acc = + match t with + | [] -> `O acc + | (k, v) :: l -> tree l ((step k, contents v []) :: acc) + and contents t acc = + match t with `Contents (c, _) -> c | `Tree c -> tree c acc + in + contents c [] + + let set_tree (tree : Store.tree) key j : Store.tree Lwt.t = + let c = to_concrete_tree j in + let c = Store.Tree.of_concrete c in + Store.Tree.add_tree tree key c + + let get_tree (tree : Store.tree) key = + Store.Tree.get_tree tree key >>= fun t -> + Store.Tree.to_concrete t >|= fun c -> of_concrete_tree c + + let set t key j ~info = + set_tree Store.Tree.empty Store.Key.empty j >>= function + | tree -> Store.set_tree_exn ~info t key tree + + let get t key = + Store.get_tree t key >>= fun tree -> get_tree tree Store.Key.empty +end + +module String = struct + type t = string + + let t = Type.string + + let merge = Merge.idempotent Type.(option string) +end + +module type STORE = S.CONTENTS_STORE + +module Store (S : sig + include S.CONTENT_ADDRESSABLE_STORE + + module Key : S.HASH with type t = key + + module Val : S.CONTENTS with type t = value +end) = +struct + module Key = Hash.Typed (S.Key) (S.Val) + module Val = S.Val + + type 'a t = 'a S.t + + type key = S.key + + type value = S.value + + let find = S.find + + let add = S.add + + let unsafe_add = S.unsafe_add + + let mem = S.mem + + let read_opt t = function None -> Lwt.return_none | Some k -> find t k + + let add_opt t = function + | None -> Lwt.return_none + | Some v -> add t v >>= fun k -> Lwt.return (Some k) + + let merge t = + Merge.like_lwt Type.(option Key.t) Val.merge (read_opt t) (add_opt t) +end + +module V1 = struct + module String = struct + include String + + let t = Type.string_of `Int64 + + let size_of ?headers:_ = Type.size_of ~headers:true t + + let decode_bin ?headers:_ = Type.decode_bin ~headers:true t + + let encode_bin ?headers:_ = Type.encode_bin ~headers:true t + + let t = Type.like t ~bin:(encode_bin, decode_bin, size_of) + end +end diff --git a/vendors/irmin/contents.mli b/vendors/irmin/contents.mli new file mode 100644 index 000000000000..9c48b925487f --- /dev/null +++ b/vendors/irmin/contents.mli @@ -0,0 +1,63 @@ +(* + * 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. + *) + +(** Values. *) + +type json = + [ `Null + | `Bool of bool + | `String of string + | `Float of float + | `O of (string * json) list + | `A of json list ] + +module String : S.CONTENTS with type t = string + +module Json : S.CONTENTS with type t = (string * json) list + +module Json_value : S.CONTENTS with type t = json + +module Json_tree (Store : S.STORE with type contents = json) : sig + include S.CONTENTS with type t = json + + val to_concrete_tree : t -> Store.Tree.concrete + + val of_concrete_tree : Store.Tree.concrete -> t + + val get_tree : Store.tree -> Store.key -> json Lwt.t + + val set_tree : Store.tree -> Store.key -> json -> Store.tree Lwt.t + + val get : Store.t -> Store.key -> json Lwt.t + + val set : Store.t -> Store.key -> json -> info:Info.f -> unit Lwt.t +end + +module V1 : sig + module String : S.CONTENTS with type t = string +end + +module Store (C : sig + include S.CONTENT_ADDRESSABLE_STORE + + module Key : S.HASH with type t = key + + module Val : S.CONTENTS with type t = value +end) : + S.CONTENTS_STORE + with type 'a t = 'a C.t + and type key = C.key + and type value = C.value diff --git a/vendors/irmin/diff.ml b/vendors/irmin/diff.ml new file mode 100644 index 000000000000..78b373b058e7 --- /dev/null +++ b/vendors/irmin/diff.ml @@ -0,0 +1,27 @@ +(* + * 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. + *) + +type 'a t = [ `Updated of 'a * 'a | `Removed of 'a | `Added of 'a ] + +let t a = + let open Type in + variant "diff" (fun updated removed added -> function + | `Updated x -> updated x | `Removed x -> removed x | `Added x -> added x + ) + |~ case1 "updated" (pair a a) (fun x -> `Updated x) + |~ case1 "removed" a (fun x -> `Removed x) + |~ case1 "added" a (fun x -> `Added x) + |> sealv diff --git a/vendors/irmin/diff.mli b/vendors/irmin/diff.mli new file mode 100644 index 000000000000..06b66ea1f47f --- /dev/null +++ b/vendors/irmin/diff.mli @@ -0,0 +1,19 @@ +(* + * 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. + *) + +type 'a t = [ `Updated of 'a * 'a | `Removed of 'a | `Added of 'a ] + +val t : 'a Type.t -> 'a t Type.t diff --git a/vendors/irmin/dot.ml b/vendors/irmin/dot.ml new file mode 100644 index 000000000000..6fdb9eb176b3 --- /dev/null +++ b/vendors/irmin/dot.ml @@ -0,0 +1,219 @@ +(* + * 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 +open Printf +open Astring + +let src = Logs.Src.create "irmin.dot" ~doc:"Irmin dot graph output" + +module Log = (val Logs.src_log src : Logs.LOG) + +module type S = sig + type db + + val output_buffer : + db -> + ?html:bool -> + ?depth:int -> + ?full:bool -> + date:(int64 -> string) -> + Buffer.t -> + unit Lwt.t +end + +exception Utf8_failure + +let is_valid_utf8 str = + try + Uutf.String.fold_utf_8 + (fun _ _ -> function `Malformed _ -> raise Utf8_failure | _ -> ()) + () str; + true + with Utf8_failure -> false + +module Make (S : S.STORE) = struct + type db = S.t + + module Branch = S.Private.Branch + module Contents = S.Private.Contents + module Node = S.Private.Node + module Commit = S.Private.Commit + module Slice = S.Private.Slice + module Graph = + Object_graph.Make (Contents.Key) (Node.Metadata) (Node.Key) (Commit.Key) + (Branch.Key) + + let fprintf (t : db) ?depth ?(html = false) ?full ~date name = + Log.debug (fun f -> + f "fprintf depth=%s html=%b full=%s" + (match depth with None -> "" | Some d -> string_of_int d) + html + (match full with None -> "" | Some b -> string_of_bool b) ); + S.Repo.export ?full ?depth (S.repo t) >>= fun slice -> + let vertex = Hashtbl.create 102 in + let add_vertex v l = Hashtbl.add vertex v l in + let mem_vertex v = Hashtbl.mem vertex v in + let edges = ref [] in + let add_edge v1 l v2 = + if mem_vertex v1 && mem_vertex v2 then edges := (v1, l, v2) :: !edges + in + let string_of_key t k = + let s = Type.to_string t k in + if String.length s <= 8 then s else String.with_range s ~len:8 + in + let string_of_contents s = + let s = + if String.length s <= 10 then s else String.with_range s ~len:10 + in + let s = if is_valid_utf8 s then s else "" in + s + in + let label_of_node k _ = + let s = + ( if html then + sprintf "
%s
" + else fun x -> x ) + (string_of_key Node.Key.t k) + in + `Label s + in + let label_of_step l = + let l = Type.to_string S.Key.step_t l in + let s = + (if html then sprintf "
%s
" else fun x -> x) + (string_of_contents l) + in + `Label s + in + let label_of_commit k c = + let k = string_of_key Commit.Key.t k in + let o = Commit.Val.info c in + let s = + if html then + sprintf + "
\n\ + \
%s
\n\ + \
%s
\n\ + \
%s
\n\ + \ 
%s
\n\ + \
 
\n\ +
" + k (Info.author o) + (date (Info.date o)) + (String.Ascii.escape (Info.message o)) + else sprintf "%s" k + in + `Label s + in + let label_of_contents k v = + let k = string_of_key Contents.Key.t k in + let s = + if html then + sprintf + "
\n\ + \
%s
\n\ + \
 
\n\ +
" + k + else + let v = string_of_contents (Type.to_string Contents.Val.t v) in + sprintf "%s (%s)" k (String.Ascii.escape_string v) + in + `Label s + in + let label_of_tag t = + let s = + if html then + sprintf "
%s
" (Type.to_string Branch.Key.t t) + else Type.to_string Branch.Key.t t + in + `Label s + in + let contents = ref [] in + let nodes = ref [] in + let commits = ref [] in + Slice.iter slice (function + | `Contents c -> + contents := c :: !contents; + Lwt.return_unit + | `Node n -> + nodes := n :: !nodes; + Lwt.return_unit + | `Commit c -> + commits := c :: !commits; + Lwt.return_unit ) + >>= fun () -> + List.iter + (fun (k, c) -> + add_vertex (`Contents k) [ `Shape `Box; label_of_contents k c ] ) + !contents; + List.iter + (fun (k, t) -> + add_vertex (`Node k) [ `Shape `Box; `Style `Dotted; label_of_node k t ] + ) + !nodes; + List.iter + (fun (k, r) -> + add_vertex (`Commit k) + [ `Shape `Box; `Style `Bold; label_of_commit k r ] ) + !commits; + List.iter + (fun (k, t) -> + List.iter + (fun (l, v) -> + match v with + | `Contents (v, _meta) -> + add_edge (`Node k) + [ `Style `Dotted; label_of_step l ] + (`Contents v) + | `Node n -> + add_edge (`Node k) [ `Style `Solid; label_of_step l ] (`Node n) + ) + (Node.Val.list t) ) + !nodes; + List.iter + (fun (k, r) -> + List.iter + (fun c -> add_edge (`Commit k) [ `Style `Bold ] (`Commit c)) + (Commit.Val.parents r); + add_edge (`Commit k) [ `Style `Dashed ] (`Node (Commit.Val.node r)) ) + !commits; + let branch_t = S.Private.Repo.branch_t (S.repo t) in + Branch.list branch_t >>= fun bs -> + Lwt_list.iter_s + (fun r -> + Branch.find branch_t r >|= function + | None -> () + | Some k -> + add_vertex (`Branch r) + [ `Shape `Plaintext; label_of_tag r; `Style `Filled ]; + add_edge (`Branch r) [ `Style `Bold ] (`Commit k) ) + bs + >|= fun () -> + let map = function + | `Contents c -> `Contents (c, Node.Metadata.default) + | (`Commit _ | `Node _ | `Branch _) as k -> k + in + let vertex = Hashtbl.fold (fun k v acc -> (map k, v) :: acc) vertex [] in + let edges = List.map (fun (k, l, v) -> (map k, l, map v)) !edges in + fun ppf -> Graph.output ppf vertex edges name + + let output_buffer t ?html ?depth ?full ~date buf = + fprintf t ?depth ?full ?html ~date "graph" >|= fun fprintf -> + let ppf = Format.formatter_of_buffer buf in + fprintf ppf +end diff --git a/vendors/irmin/dot.mli b/vendors/irmin/dot.mli new file mode 100644 index 000000000000..88c2cf2ab632 --- /dev/null +++ b/vendors/irmin/dot.mli @@ -0,0 +1,32 @@ +(* + * 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. + *) + +(** Store dumps. *) + +module type S = sig + type db + + val output_buffer : + db -> + ?html:bool -> + ?depth:int -> + ?full:bool -> + date:(int64 -> string) -> + Buffer.t -> + unit Lwt.t +end + +module Make (S : S.STORE) : S with type db = S.t diff --git a/vendors/irmin/dune b/vendors/irmin/dune new file mode 100644 index 000000000000..b2bf4a0c8949 --- /dev/null +++ b/vendors/irmin/dune @@ -0,0 +1,4 @@ +(library + (name irmin) + (public_name irmin) + (libraries fmt uri jsonm lwt ocamlgraph logs astring base64 digestif logs.fmt)) diff --git a/vendors/irmin/hash.ml b/vendors/irmin/hash.ml new file mode 100644 index 000000000000..487203c77cc1 --- /dev/null +++ b/vendors/irmin/hash.ml @@ -0,0 +1,82 @@ +(* + * 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. + *) + +module Make (H : Digestif.S) = struct + type t = H.t + + external get_64 : string -> int -> int64 = "%caml_string_get64u" + + let short_hash c = Int64.to_int (get_64 (H.to_raw_string c) 0) + + let hash_size = H.digest_size + + let of_hex s = + match H.consistent_of_hex s with + | x -> Ok x + | exception Invalid_argument e -> Error (`Msg e) + + let pp_hex ppf x = Fmt.string ppf (H.to_hex x) + + let t = + Type.map ~cli:(pp_hex, of_hex) + Type.(string_of (`Fixed hash_size)) + H.of_raw_string H.to_raw_string + + let hash s = H.digesti_string s +end + +module SHA1 = Make (Digestif.SHA1) +module RMD160 = Make (Digestif.RMD160) +module SHA224 = Make (Digestif.SHA224) +module SHA256 = Make (Digestif.SHA256) +module SHA384 = Make (Digestif.SHA384) +module SHA512 = Make (Digestif.SHA512) +module BLAKE2B = Make (Digestif.BLAKE2B) +module BLAKE2S = Make (Digestif.BLAKE2S) + +module Typed (K : S.HASH) (V : Type.S) = struct + include K + + type value = V.t + + let hash v = K.hash (Type.pre_hash V.t v) +end + +module V1 (K : S.HASH) : S.HASH with type t = K.t = struct + type t = K.t + + let hash = K.hash + + let short_hash = K.short_hash + + let hash_size = K.hash_size + + let h = Type.string_of `Int64 + + let size_of ?headers x = Type.size_of ?headers h (Type.to_bin_string K.t x) + + let encode_bin ?headers e k = + Type.encode_bin ?headers h (Type.to_bin_string K.t e) k + + let decode_bin ?headers buf off = + let n, v = Type.decode_bin ?headers h buf off in + ( n, + match Type.of_bin_string K.t v with + | Ok v -> v + | Error (`Msg e) -> Fmt.failwith "decode_bin: %s" e ) + + let t = Type.like K.t ~bin:(encode_bin, decode_bin, size_of) +end diff --git a/vendors/irmin/hash.mli b/vendors/irmin/hash.mli new file mode 100644 index 000000000000..b8a9b9f82b65 --- /dev/null +++ b/vendors/irmin/hash.mli @@ -0,0 +1,40 @@ +(* + * 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. + *) + +(** Implementation of keys *) + +module Make (H : Digestif.S) : S.HASH with type t = H.t + +module SHA1 : S.HASH + +module RMD160 : S.HASH + +module SHA224 : S.HASH + +module SHA256 : S.HASH + +module SHA384 : S.HASH + +module SHA512 : S.HASH + +module BLAKE2B : S.HASH + +module BLAKE2S : S.HASH + +module Typed (K : S.HASH) (V : Type.S) : + S.TYPED_HASH with type t = K.t and type value = V.t + +module V1 (H : S.HASH) : S.HASH with type t = H.t diff --git a/vendors/irmin/info.ml b/vendors/irmin/info.ml new file mode 100644 index 000000000000..55a7a6ffc2ba --- /dev/null +++ b/vendors/irmin/info.ml @@ -0,0 +1,45 @@ +(* + * 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. + *) + +type t = { date : int64; author : string; message : string } + +let t = + let open Type in + record "info" (fun date author message -> { date; author; message }) + |+ field "date" int64 (fun t -> t.date) + |+ field "author" string (fun t -> t.author) + |+ field "message" string (fun t -> t.message) + |> sealr + +type f = unit -> t + +let create ~date ~author message = { date; message; author } + +let with_message t message = { t with message } + +let empty = { date = 0L; author = ""; message = "" } + +let v ~date ~author message = + if date = 0L && author = "" && message = "" then empty + else create ~date ~author message + +let date t = t.date + +let author t = t.author + +let message t = t.message + +let none () = empty diff --git a/vendors/irmin/info.mli b/vendors/irmin/info.mli new file mode 100644 index 000000000000..131e787fac95 --- /dev/null +++ b/vendors/irmin/info.mli @@ -0,0 +1,37 @@ +(* + * 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. + *) + +(** Provenance tracking. *) + +type t + +val t : t Type.t + +val v : date:int64 -> author:string -> string -> t + +val date : t -> int64 + +val author : t -> string + +val message : t -> string + +val with_message : t -> string -> t + +val empty : t + +type f = unit -> t + +val none : f diff --git a/vendors/irmin/irmin.ml b/vendors/irmin/irmin.ml new file mode 100644 index 000000000000..3d815a7c9620 --- /dev/null +++ b/vendors/irmin/irmin.ml @@ -0,0 +1,255 @@ +(* + * 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 +module Type = Type +module Diff = Diff +module Content_addressable = Store.Content_addressable + +module Contents = struct + include Contents + + module type S = S.CONTENTS + + module type STORE = S.CONTENTS_STORE +end + +module Merge = Merge + +module Branch = struct + include Branch + + module type S = S.BRANCH + + module type STORE = S.BRANCH_STORE +end + +module Info = Info +module Dot = Dot.Make + +module Hash = struct + include Hash + + module type S = S.HASH + + module type TYPED = S.TYPED_HASH +end + +module Path = struct + include Path + + module type S = S.PATH +end + +module Make_ext + (CA : S.CONTENT_ADDRESSABLE_STORE_MAKER) + (AW : S.ATOMIC_WRITE_STORE_MAKER) + (M : S.METADATA) + (C : Contents.S) + (P : Path.S) + (B : Branch.S) + (H : Hash.S) + (N : S.NODE + with type metadata = M.t + and type hash = H.t + and type step = P.step) + (CT : S.COMMIT with type hash = H.t) = +struct + module X = struct + module Hash = H + + module Contents = struct + module CA = struct + module Key = Hash + module Val = C + include CA (Key) (Val) + end + + include Contents.Store (CA) + end + + module Node = struct + module CA = struct + module Key = Hash + module Val = N + include CA (Key) (Val) + end + + include Node.Store (Contents) (P) (M) (CA) + end + + module Commit = struct + module CA = struct + module Key = Hash + module Val = CT + include CA (Key) (Val) + end + + include Commit.Store (Node) (CA) + end + + module Branch = struct + module Key = B + module Val = H + include AW (Key) (Val) + end + + module Slice = Slice.Make (Contents) (Node) (Commit) + module Sync = Sync.None (H) (B) + + module Repo = struct + type t = { + config : Conf.t; + contents : [ `Read ] Contents.t; + nodes : [ `Read ] Node.t; + commits : [ `Read ] Commit.t; + branch : Branch.t + } + + let contents_t t = t.contents + + let node_t t = t.nodes + + let commit_t t = t.commits + + let branch_t t = t.branch + + let batch t f = + Contents.CA.batch t.contents @@ fun c -> + Node.CA.batch (snd t.nodes) @@ fun n -> + Commit.CA.batch (snd t.commits) @@ fun ct -> + let contents_t = c in + let node_t = (contents_t, n) in + let commit_t = (node_t, ct) in + f contents_t node_t commit_t + + let v config = + Contents.CA.v config >>= fun contents -> + Node.CA.v config >>= fun nodes -> + Commit.CA.v config >>= fun commits -> + let nodes = (contents, nodes) in + let commits = (nodes, commits) in + Branch.v config >|= fun branch -> + { contents; nodes; commits; branch; config } + end + end + + include Store.Make (X) +end + +module Make + (CA : S.CONTENT_ADDRESSABLE_STORE_MAKER) + (AW : S.ATOMIC_WRITE_STORE_MAKER) + (M : S.METADATA) + (C : S.CONTENTS) + (P : S.PATH) + (B : S.BRANCH) + (H : S.HASH) = +struct + module N = Node.Make (H) (P) (M) + module CT = Commit.Make (H) + include Make_ext (CA) (AW) (M) (C) (P) (B) (H) (N) (CT) +end + +module Of_private = Store.Make + +module type CONTENT_ADDRESSABLE_STORE = S.CONTENT_ADDRESSABLE_STORE + +module type APPEND_ONLY_STORE = S.APPEND_ONLY_STORE + +module type ATOMIC_WRITE_STORE = S.ATOMIC_WRITE_STORE + +module type TREE = S.TREE + +module type S = S.STORE + +type config = Conf.t + +type 'a diff = 'a Diff.t + +module type CONTENT_ADDRESSABLE_STORE_MAKER = S.CONTENT_ADDRESSABLE_STORE_MAKER + +module type APPEND_ONLY_STORE_MAKER = S.APPEND_ONLY_STORE_MAKER + +module type ATOMIC_WRITE_STORE_MAKER = S.ATOMIC_WRITE_STORE_MAKER + +module type S_MAKER = S.MAKER + +module type KV = + S with type key = string list and type step = string and type branch = string + +module type KV_MAKER = functor (C : Contents.S) -> KV with type contents = C.t + +module Private = struct + module Conf = Conf + + module Node = struct + include Node + + module type S = S.NODE + + module type GRAPH = S.NODE_GRAPH + + module type STORE = S.NODE_STORE + end + + module Commit = struct + include Commit + + module type S = S.COMMIT + + module type STORE = S.COMMIT_STORE + + module type HISTORY = S.COMMIT_HISTORY + end + + module Slice = struct + include Slice + + module type S = S.SLICE + end + + module Sync = struct + include Sync + + module type S = S.SYNC + end + + module type S = S.PRIVATE + + module Watch = Watch + module Lock = Lock +end + +let version = Version.current + +module type SYNC = S.SYNC_STORE + +module Sync = Sync_ext.Make + +type remote = S.remote = .. + +let remote_store (type t) (module M : S with type t = t) (t : t) = + let module X : S.STORE with type t = t = M in + Sync_ext.remote_store (module X) t + +module Metadata = struct + module type S = S.METADATA + + module None = Node.No_metadata +end + +module Json_tree = Contents.Json_tree diff --git a/vendors/irmin/irmin.mli b/vendors/irmin/irmin.mli new file mode 100644 index 000000000000..74913f4c5901 --- /dev/null +++ b/vendors/irmin/irmin.mli @@ -0,0 +1,3693 @@ +(* + * 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. + *) + +(** Irmin public API. + + [Irmin] is a library to design and use persistent stores with + built-in snapshot, branching and reverting mechanisms. Irmin uses + concepts similar to {{:http://git-scm.com/}Git} but it exposes + them as a high level library instead of a complex command-line + frontend. It features a {e bidirectional} Git backend, where an + application can read and persist its state using the Git format, + fully-compatible with the usual Git tools and workflows. + + Irmin is designed to use a large variety of backends. It is + written in pure OCaml and does not depend on external C stubs; it + is thus very portable and aims to run everywhere, from Linux to + browser and MirageOS unikernels. + + Consult the {!basics} and {!examples} of use for a quick + start. See also the {{!Irmin_unix}documentation} for the unix + backends. + + {e Release %%VERSION%% - %%HOMEPAGE%% } +*) + +val version : string +(** The version of the library. *) + +(** {1 Preliminaries} *) + +(** Dynamic types for Irmin values. *) +module Type : sig + (** Yet-an-other type combinator library + + [Type] provides type combinators to define runtime + representation for OCaml types and {{!generics}generic + operations} to manipulate values with a runtime type + representation. + + The type combinators supports all the usual {{!primitives}type + primitives} but also compact definitions of {{!records}records} + and {{!variants}variants}. It also allows the definition of + run-time representations of {{!recursive}recursive types}. *) + + (** {1 Type Combinators} *) + + (** The type for runtime representation of values of type ['a]. *) + type 'a t + + (** The type of integer used to store buffers, list or array + lengths. *) + type len = [ `Int | `Int8 | `Int16 | `Int32 | `Int64 | `Fixed of int ] + + (** {1:primitives Primitives} *) + + val unit : unit t + (** [unit] is a representation of the unit type. *) + + val bool : bool t + (** [bool] is a representation of the boolean type. *) + + val char : char t + (** [char] is a representation of the character type. *) + + val int : int t + (** [int] is a representation of integers. Binary serialization uses + a varying-width representation. *) + + val int32 : int32 t + (** [int32] is a representation of the 32-bit integer type. *) + + val int64 : int64 t + (** [int64] is a representation of the 64-bit integer type. *) + + val float : float t + (** [float] is a representation of the [float] type. *) + + val string : string t + (** [string] is a representation of the [string] type. *) + + val bytes : bytes t + (** [bytes] is a representation of the [bytes] type. *) + + val string_of : len -> string t + (** Like {!string} but with a given fixed size. *) + + val bytes_of : len -> bytes t + (** Like {!bytes} but with a given fixed size. *) + + val list : ?len:len -> 'a t -> 'a list t + (** [list t] is a representation of lists of values of type [t]. *) + + val array : ?len:len -> 'a t -> 'a array t + (** [array t] is a representation of arrays of values of type [t]. *) + + val option : 'a t -> 'a option t + (** [option t] is a representation of values of type [t option]. *) + + val pair : 'a t -> 'b t -> ('a * 'b) t + (** [pair x y] is a representation of values of type [x * y]. *) + + val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t + (** [triple x y z] is a representation of values of type + [x * y * z]. *) + + val result : 'a t -> 'b t -> ('a, 'b) result t + (** [result a b] is a representation of values of type + [(a, b) result]. *) + + (** {1:records Records} *) + + (** The type for representing open records of type ['a] with a constructor + of type ['b]. ['c] represents the remaining fields to be described using + the {!(|+)} operator. An open record initially satisfies ['c = 'b] and + can be {{!sealr}sealed} once ['c = 'a]. *) + type ('a, 'b, 'c) open_record + + val record : string -> 'b -> ('a, 'b, 'b) open_record + (** [record n f] is an incomplete representation of the record called [n] of + type ['a] with constructor [f]. To complete the representation, add fields + with {!(|+)} and then seal the record with {!sealr}. *) + + (** The type for fields holding values of type ['b] and belonging to a + record of type ['a]. *) + type ('a, 'b) field + + val field : string -> 'a t -> ('b -> 'a) -> ('b, 'a) field + (** [field n t g] is the representation of the field [n] of type [t] + with getter [g]. + + For instance: + + {[ + type manuscript = { title : string option } + + let manuscript = field "title" (option string) (fun t -> t.title)]} + *) + + val ( |+ ) : + ('a, 'b, 'c -> 'd) open_record -> + ('a, 'c) field -> + ('a, 'b, 'd) open_record + (** [r |+ f] is the open record [r] augmented with the field [f]. *) + + val sealr : ('a, 'b, 'a) open_record -> 'a t + (** [sealr r] seals the open record [r]. *) + + (** Putting all together: + + {[ + type menu = { restaurant: string; items: (string * int32) list; } + + let t = + record "t" (fun restaurant items -> {restaurant; items}) + |+ field "restaurant" string (fun t -> t.restaurant) + |+ field "items" (list (pair string int32)) (fun t -> t.items) + |> sealr]} + *) + + (** {1:variants Variants} *) + + (** The type for representing open variants of type ['a] with pattern + matching of type ['b]. ['c] represents the remaining constructors to + be described using the {!(|~)} operator. An open variant initially + satisfies [c' = 'b] and can be {{!sealv}sealed} once ['c = 'a]. *) + type ('a, 'b, 'c) open_variant + + val variant : string -> 'b -> ('a, 'b, 'b) open_variant + (** [variant n p] is an incomplete representation of the variant type + called [n] of type ['a] using [p] to deconstruct values. To complete + the representation, add cases with {!(|~)} and then seal the variant + with {!sealv}. *) + + (** The type for representing variant cases of type ['a] with + patterns of type ['b]. *) + type ('a, 'b) case + + (** The type for representing patterns for a variant of type ['a]. *) + type 'a case_p + + val case0 : string -> 'a -> ('a, 'a case_p) case + (** [case0 n v] is a representation of a variant constructor [v] with no + arguments and name [n]. e.g. + + {[ + type t = Foo + + let foo = case0 "Foo" Foo]} + *) + + val case1 : string -> 'b t -> ('b -> 'a) -> ('a, 'b -> 'a case_p) case + (** [case1 n t c] is a representation of a variant constructor [c] with an + argument of type [t] and name [n]. e.g. + + {[ + type t = Foo of string + + let foo = case1 "Foo" string (fun s -> Foo s)]} + *) + + val ( |~ ) : + ('a, 'b, 'c -> 'd) open_variant -> + ('a, 'c) case -> + ('a, 'b, 'd) open_variant + (** [v |~ c] is the open variant [v] augmented with the case [c]. *) + + val sealv : ('a, 'b, 'a -> 'a case_p) open_variant -> 'a t + (** [sealv v] seals the open variant [v]. *) + + (** Putting all together: + {[ + type t = Foo | Bar of string + + let t = + variant "t" (fun foo bar -> function + | Foo -> foo + | Bar s -> bar s) + |~ case0 "Foo" Foo + |~ case1 "Bar" string (fun x -> Bar x) + |> sealv]} + *) + + val enum : string -> (string * 'a) list -> 'a t + (** [enum n cs] is a representation of the variant type called [n] + with singleton cases [cs]. e.g. + + {[ + type t = Foo | Bar | Toto + + let t = enum "t" ["Foo", Foo; "Bar", Bar; "Toto", Toto]]} + *) + + (** {1:recursive Recursive definitions} + + [Type] allows a limited description of recursive records and + variants. + + {b TODO}: describe the limitations, e.g. only regular recursion + and no use of the generics inside the [mu*] functions and the + usual caveats with recursive values (such as infinite loops on + most of the generics which don't check sharing). + + *) + + val mu : ('a t -> 'a t) -> 'a t + (** [mu f] is the representation [r] such that [r = mu r]. + + For instance: + + {[ + type x = { x: x option } + + let x = mu (fun x -> + record "x" (fun x -> { x }) + |+ field "x" x (fun x -> x.x) + |> sealr)]} + *) + + val mu2 : ('a t -> 'b t -> 'a t * 'b t) -> 'a t * 'b t + (** [mu2 f] is the representations [r] and [s] such that + [r, s = mu2 r s]. + + For instance: + + {[ + type r = { foo: int; bar: string list; z: z option } + and z = { x: int; r: r list } + + (* Build the representation of [r] knowing [z]'s. *) + let mkr z = + record "r" (fun foo bar z -> { foo; bar; z }) + |+ field "foo" int (fun t -> t.foo) + |+ field "bar" (list string) (fun t -> t.bar) + |+ field "z" (option z) (fun t -> t.z) + |> sealr + + (* And the representation of [z] knowing [r]'s. *) + let mkz r = + record "z" (fun x r -> { x; r }) + |+ field "x" int (fun t -> t.x) + |+ field "r" (list r) (fun t -> t.r) + |> sealr + + (* Tie the loop. *) + let r, z = mu2 (fun r z -> mkr z, mkz y)]} + *) + + (** {1:generics Generic Operations} + + Given a value ['a t], it is possible to define generic operations + on value of type ['a] such as pretty-printing, parsing and + unparsing. + *) + + val equal : 'a t -> 'a -> 'a -> bool + (** [equal t] is the equality function between values of type [t]. *) + + val compare : 'a t -> 'a -> 'a -> int + (** [compare t] compares values of type [t]. *) + + val short_hash : 'a t -> ?seed:int -> 'a -> int + (** [hash t x] is a short hash of [x] of type [t]. *) + + (** The type for pretty-printers. *) + type 'a pp = 'a Fmt.t + + (** The type for parsers. *) + type 'a of_string = string -> ('a, [ `Msg of string ]) result + + val pp : 'a t -> 'a pp + (** [pp t] is the pretty-printer for values of type [t]. *) + + val to_string : 'a t -> 'a -> string + (** [to_string t] is [Fmt.to_to_string (pp t)]. *) + + val of_string : 'a t -> 'a of_string + (** [of_string t] parses values of type [t]. *) + + (** {2 JSON converters} *) + + module Json : sig + (** Overlay on top of Jsonm to work with rewindable streams. *) + + (** The type for JSON decoder. *) + type decoder + + val decoder : ?encoding:[< Jsonm.encoding ] -> [< Jsonm.src ] -> decoder + (** Same as {!Jsonm.decoder}. *) + + val decode : + decoder -> + [> `Await | `End | `Error of Jsonm.error | `Lexeme of Jsonm.lexeme ] + (** Same as {!Jsonm.decode}. *) + + val rewind : decoder -> Jsonm.lexeme -> unit + (** [rewind d l] rewinds [l] on top of the current state of + [d]. This allows to put back lexemes already seen. *) + end + + (** The type for JSON encoders. *) + type 'a encode_json = Jsonm.encoder -> 'a -> unit + + (** The type for JSON decoders. *) + type 'a decode_json = Json.decoder -> ('a, [ `Msg of string ]) result + + val pp_json : ?minify:bool -> 'a t -> 'a Fmt.t + (** Similar to {!dump} but pretty-prints the JSON representation instead + of the OCaml one. See {!encode_json} for details about the encoding. + + For instance: + + {[ + type t = { foo: int option; bar: string list };; + + let t = + record "r" (fun foo bar -> { foo; bar }) + |+ field "foo" (option int) (fun t -> t.foo) + |+ field "bar" (list string) (fun t -> t.bar) + |> sealr + + let s = Fmt.strf "%a\n" (pp t) { foo = None; bar = ["foo"] } + (* s is "{ foo = None; bar = [\"foo\"]; }" *) + + let j = Fmt.strf "%a\n" (pp_json t) { foo = None; bar = ["foo"] } + (* j is "{ \"bar\":[\"foo\"] }" *)]} + + {b NOTE:} this will automatically convert JSON fragments to valid + JSON objects by adding an enclosing array if necessary. *) + + val encode_json : 'a t -> Jsonm.encoder -> 'a -> unit + (** [encode_json t e] encodes [t] into the + {{:http://erratique.ch/software/jsonm}jsonm} encoder [e]. The + encoding is a relatively straightforward translation of the OCaml + structure into JSON. The main highlights are: + + {ul + {- OCaml [ints] are translated into JSON floats.} + {- OCaml strings are translated into JSON strings. You must then + ensure that the OCaml strings contains only valid UTF-8 + characters.} + {- OCaml record fields of type ['a option] are automatically + unboxed in their JSON representation. If the value if [None], + the field is removed from the JSON object.} + {- variant cases built using {!case0} are represented as strings.} + {- variant cases built using {!case1} are represented as a record + with one field; the field name is the name of the variant.} + } + + {b NOTE:} this can be used to encode JSON fragments. It's the + responsibility of the caller to ensure that the encoded JSON + fragment fits properly into a well-formed JSON object. *) + + val decode_json : 'a t -> Jsonm.decoder -> ('a, [ `Msg of string ]) result + (** [decode_json t e] decodes values of type [t] from the + {{:http://erratique.ch/software/jsonm}jsonm} decoder [e]. *) + + val decode_json_lexemes : + 'a t -> Jsonm.lexeme list -> ('a, [ `Msg of string ]) result + (** [decode_json_lexemes] is similar to {!decode_json} but uses an + already decoded list of JSON lexemes instead of a decoder. *) + + val to_json_string : ?minify:bool -> 'a t -> 'a -> string + (** [to_json_string] is {!encode_json} with a string encoder. *) + + val of_json_string : 'a t -> string -> ('a, [ `Msg of string ]) result + (** [of_json_string] is {!decode_json} with a string decoder .*) + + (** {2 Binary Converters} *) + + type 'a bin_seq = 'a -> (string -> unit) -> unit + + (** The type for binary encoders. If [headers] is not set, do not + output extra length headers for buffers. *) + type 'a encode_bin = ?headers:bool -> 'a bin_seq + + (** The type for binary decoders. IF [headers] is not set, do not + read extra length header for buffers and consider the whole + buffer instead. *) + type 'a decode_bin = ?headers:bool -> string -> int -> int * 'a + + (** The type for size function related to binary encoder/decoders. *) + type 'a size_of = ?headers:bool -> 'a -> int option + + val pre_hash : 'a t -> 'a bin_seq + (** [pre_hash t x] is the string representation of [x], of type + [t], which will be used to compute the digest of the value. By + default it's [to_bin_string t x] but it can be overriden by {!v}, + {!like} and {!map} operators. *) + + val encode_bin : 'a t -> 'a encode_bin + (** [encode_bin t] is the binary encoder for values of type [t]. *) + + val decode_bin : 'a t -> 'a decode_bin + (** [decode_bin t] is the binary decoder for values of type [t]. *) + + val to_bin_string : 'a t -> 'a -> string + (** [to_bin_string t x] use {!encode_bin} to convert [x], of type + [t], to a string. + + {b NOTE:} When [t] is {!Type.string} or {!Type.bytes}, the + original buffer [x] is not prefixed by its size as {!encode_bin} + would do. If [t] is {!Type.string}, the result is [x] (without + copy). *) + + val of_bin_string : 'a t -> string -> ('a, [ `Msg of string ]) result + (** [of_bin_string t s] is [v] such that [s = to_bin_string t v]. + + {b NOTE:} When [t] is {!Type.string}, the result is [s] (without + copy). *) + + val size_of : 'a t -> 'a size_of + (** [size_of t x] is either the size of [encode_bin t x] or the + binary encoding of [x], if the backend is not able to pre-compute + serialisation lengths. *) + + (** {1 Customs converters} *) + + val v : + cli:'a pp * 'a of_string -> + json:'a encode_json * 'a decode_json -> + bin:'a encode_bin * 'a decode_bin * 'a size_of -> + equal:('a -> 'a -> bool) -> + compare:('a -> 'a -> int) -> + short_hash:(?seed:int -> 'a -> int) -> + pre_hash:'a bin_seq -> + 'a t + + val like : + ?cli:'a pp * 'a of_string -> + ?json:'a encode_json * 'a decode_json -> + ?bin:'a encode_bin * 'a decode_bin * 'a size_of -> + ?equal:('a -> 'a -> bool) -> + ?compare:('a -> 'a -> int) -> + ?short_hash:('a -> int) -> + ?pre_hash:'a bin_seq -> + 'a t -> + 'a t + + val map : + ?cli:'a pp * 'a of_string -> + ?json:'a encode_json * 'a decode_json -> + ?bin:'a encode_bin * 'a decode_bin * 'a size_of -> + ?equal:('a -> 'a -> bool) -> + ?compare:('a -> 'a -> int) -> + ?short_hash:('a -> int) -> + ?pre_hash:'a bin_seq -> + 'b t -> + ('b -> 'a) -> + ('a -> 'b) -> + 'a t + + type 'a ty = 'a t + + module type S = sig + type t + + val t : t ty + end +end + +(** Commit info are used to keep track of the origin of write + operations in the stores. [Info] models the metadata associated + with commit objects in Git. *) +module Info : sig + (** {1 Commit Info} *) + + (** The type for commit info. *) + type t + + val v : date:int64 -> author:string -> string -> t + (** Create a new commit info. *) + + val date : t -> int64 + (** [date t] is [t]'s commit date. + + The date provided by the user when calling the {{!Info.v}create} + function. Rounding [Unix.gettimeofday ()] (when available) is a + good value for such date. On more esoteric platforms, any + monotonic counter is a fine value as well. On the Git backend, + the date is translated into the commit {e Date} field and is + expected to be the number of POSIX seconds (thus not counting + leap seconds) since the Epoch. *) + + val author : t -> string + (** [author t] is [t]'s commit author. + + The author identifies the entity (human, unikernel, process, + thread, etc) performing an operation. For the Git backend, this + will be directly translated into the {e Author} field. *) + + val message : t -> string + (** [message t] is [t]'s commit message. *) + + val empty : t + (** The empty commit info. *) + + (** {1 Info Functions} *) + + (** Alias for functions which can build commit info. *) + type f = unit -> t + + val none : f + (** The empty info function. [none ()] is [empty] *) + + (** {1 Value Types} *) + + val t : t Type.t + (** [t] is the value type for {!t}. *) +end + +(** [Merge] provides functions to build custom 3-way merge operators + for various user-defined contents. *) +module Merge : sig + (** The type for merge errors. *) + type conflict = [ `Conflict of string ] + + val ok : 'a -> ('a, conflict) result Lwt.t + (** Return [Ok x]. *) + + val conflict : ('a, unit, string, ('b, conflict) result Lwt.t) format4 -> 'a + (** Return [Error (Conflict str)]. *) + + val bind : + ('a, 'b) result Lwt.t -> + ('a -> ('c, 'b) result Lwt.t) -> + ('c, 'b) result Lwt.t + (** [bind r f] is the merge result which behaves as of the + application of the function [f] to the return value of [r]. If + [r] fails, [bind r f] also fails, with the same conflict. *) + + val map : ('a -> 'c) -> ('a, 'b) result Lwt.t -> ('c, 'b) result Lwt.t + (** [map f m] maps the result of a merge. This is the same as + [bind m (fun x -> ok (f x))]. *) + + (** {1 Merge Combinators} *) + + (** An ['a] promise is a function which, when called, will + eventually return a value type of ['a]. A promise is an + optional, lazy and non-blocking value. *) + type 'a promise = unit -> ('a option, conflict) result Lwt.t + + val promise : 'a -> 'a promise + (** [promise a] is the promise containing [a]. *) + + val map_promise : ('a -> 'b) -> 'a promise -> 'b promise + (** [map_promise f a] is the promise containing [f] applied to what + is promised by [a]. *) + + val bind_promise : 'a promise -> ('a -> 'b promise) -> 'b promise + (** [bind_promise a f] is the promise returned by [f] applied to + what is promised by [a]. *) + + (** Signature of a merge function. [old] is the value of the + least-common ancestor. + + {v + /----> t1 ----\ + ----> old |--> result + \----> t2 ----/ + v} + *) + type 'a f = old:'a promise -> 'a -> 'a -> ('a, conflict) result Lwt.t + + (** The type for merge combinators. *) + type 'a t + + val v : 'a Type.t -> 'a f -> 'a t + (** [v dt f] create a merge combinator. *) + + val f : 'a t -> 'a f + (** [f m] is [m]'s merge function. *) + + val seq : 'a t list -> 'a t + (** Call the merge functions in sequence. Stop as soon as one is {e + not} returning a conflict. *) + + val like : 'a Type.t -> 'b t -> ('a -> 'b) -> ('b -> 'a) -> 'a t + (** Use the merge function defined in another domain. If the + converting functions raise any exception the merge is a + conflict. *) + + val like_lwt : + 'a Type.t -> 'b t -> ('a -> 'b Lwt.t) -> ('b -> 'a Lwt.t) -> 'a t + (** Same as {{!Merge.biject}biject} but with blocking domain + converting functions. *) + + (** {1 Basic Merges} *) + + val default : 'a Type.t -> 'a t + (** [default t] is the default merge function for values of type + [t]. This is a simple merge function which supports changes in + one branch at a time: + + {ul + {- if [t1=old] then the result of the merge is [OK t2];} + {- if [t2=old] then return [OK t1];} + {- otherwise the result is [Conflict].} + } + *) + + val idempotent : 'a Type.t -> 'a t + (** [idempotent t] is the default merge function for values of type + [t] using idempotent operations. It follows the same rules as + the {!default} merge function but also adds: + + {ul + {- if [t1=t2] then the result of the merge is [OK t1].} + } + *) + + val unit : unit t + (** [unit] is the default merge function for unit values. *) + + val bool : bool t + (** [bool] is the default merge function for booleans. *) + + val char : char t + (** [char] is the default merge function for characters. *) + + val int32 : int32 t + (** [int32] is the default merge function for 32-bits integers. *) + + val int64 : int64 t + (** [int64] the default merge function for 64-bit integers. *) + + val float : float t + (** [float] is the default merge function for floating point + numbers. *) + + val string : string t + (** The default string merge function. Do not do anything clever, just + compare the strings using the [default] merge function. *) + + val option : 'a t -> 'a option t + (** Lift a merge function to optional values of the same type. If all + the provided values are inhabited, then call the provided merge + function, otherwise use the same behavior as {!default}. *) + + val pair : 'a t -> 'b t -> ('a * 'b) t + (** Lift merge functions to pairs of elements. *) + + val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t + (** Lift merge functions to triples of elements. *) + + (** {1 Counters and Multisets} *) + + (** The type for counter values. It is expected that the only valid + operations on counters are {e increment} and {e decrement}. The + following merge functions ensure that the counter semantics are + preserved: {e i.e.} it ensures that the number of increments and + decrements is preserved. *) + type counter = int64 + + val counter : counter t + (** The merge function for mergeable counters. *) + + (** Multi-sets. *) + module MultiSet (K : sig + include Set.OrderedType + + val t : t Type.t + end) : sig + val merge : counter Map.Make(K).t t + end + + (** {1 Maps and Association Lists} *) + + (** We consider the only valid operations for maps and + association lists to be: + + {ul + {- Adding a new bindings to the map.} + {- Removing a binding from the map.} + {- Replacing an existing binding with a different value.} + {- {e Trying to add an already existing binding is a no-op}.} + } + + We thus assume that no operation on maps is modifying the {e + key} names. So the following merge functions ensures that {e + (i)} new bindings are preserved {e (ii)} removed bindings stay + removed and {e (iii)} modified bindings are merged using the + merge function of values. + + {b Note:} We only consider sets of bindings, instead of + multisets. Application developers should take care of concurrent + addition and removal of similar bindings themselves, by using the + appropriate {{!Merge.MSet}multi-sets}. *) + + (** Lift merge functions to sets. *) + module Set (E : sig + include Set.OrderedType + + val t : t Type.t + end) : sig + val merge : Set.Make(E).t t + end + + val alist : 'a Type.t -> 'b Type.t -> ('a -> 'b option t) -> ('a * 'b) list t + (** Lift the merge functions to association lists. *) + + (** Lift the merge functions to maps. *) + + module Map (K : sig + include Map.OrderedType + + val t : t Type.t + end) : sig + val merge : 'a Type.t -> (K.t -> 'a option t) -> 'a Map.Make(K).t t + end + + (** Infix operators for manipulating merge results and {!promise}s. + + [open Irmin.Merge.Infix] at the top of your file to use them. *) + module Infix : sig + (** {1 Merge Result Combinators} *) + + val ( >>=* ) : + ('a, conflict) result Lwt.t -> + ('a -> ('b, conflict) result Lwt.t) -> + ('b, conflict) result Lwt.t + (** [>>=*] is {!bind}. *) + + val ( >|=* ) : + ('a, conflict) result Lwt.t -> ('a -> 'b) -> ('b, conflict) result Lwt.t + (** [>|=*] is {!map}. *) + + (** {1 Promise Combinators} + + This is useful to manipulate lca results. *) + + val ( >>=? ) : 'a promise -> ('a -> 'b promise) -> 'b promise + (** [>>=?] is {!bind_promise}. *) + + val ( >|=? ) : 'a promise -> ('a -> 'b) -> 'b promise + (** [>|=?] is {!map_promise}. *) + end + (** {1 Value Types} *) + + val conflict_t : conflict Type.t + (** [conflict_t] is the value type for {!conflict}. *) + + val result_t : 'a Type.t -> ('a, conflict) result Type.t + (** [result_t] is the value type for merge results. *) +end + +(** Differences between values. *) +module Diff : sig + (** The type for representing differences betwen values. *) + type 'a t = [ `Updated of 'a * 'a | `Removed of 'a | `Added of 'a ] + + (** {1 Value Types} *) + + val t : 'a Type.t -> 'a t Type.t + (** [t typ] is the value type for differences between values of type [typ]. *) +end + +(** The type for representing differences betwen values. *) +type 'a diff = 'a Diff.t + +(** {1 Low-level Stores} *) + +(** An Irmin store is automatically built from a number of lower-level + stores, each implementing fewer operations, such as + {{!CONTENT_ADDRESSABLE_STORE}content-addressable} + and {{!ATOMIC_WRITE_STORE}atomic-write} stores. These low-level stores + are provided + by various backends. *) + +(** Content-addressable backend store. *) +module type CONTENT_ADDRESSABLE_STORE = sig + (** {1 Content-addressable stores} + + Content-addressable stores are store where it is possible to read + and add new values. Keys are derived from the values raw contents + and hence are deterministic. *) + + (** The type for content-addressable backend stores. The ['a] + phantom type carries information about the store mutability. *) + type 'a t + + (** The type for keys. *) + type key + + (** The type for raw values. *) + type value + + val mem : [> `Read ] t -> key -> bool Lwt.t + (** [mem t k] is true iff [k] is present in [t]. *) + + val find : [> `Read ] t -> key -> value option Lwt.t + (** [find t k] is [Some v] if [k] is associated to [v] in [t] and + [None] is [k] is not present in [t]. *) + + val add : [> `Write ] t -> value -> key Lwt.t + (** Write the contents of a value to the store. It's the + responsibility of the content-addressable store to generate a + consistent key. *) + + val unsafe_add : [> `Write ] t -> key -> value -> unit Lwt.t + (** Same as {!add} but allows to specify the key directly. The + backend might choose to discared that key and/or can be corrupt + if the key scheme is not consistent. *) +end + +(** Append-only backend store. *) +module type APPEND_ONLY_STORE = sig + (** {1 Append-only stores} + + Append-onlye stores are store where it is possible to read + and add new values. *) + + (** The type for append-only backend stores. The ['a] + phantom type carries information about the store mutability. *) + type 'a t + + (** The type for keys. *) + type key + + (** The type for raw values. *) + type value + + val mem : [> `Read ] t -> key -> bool Lwt.t + (** [mem t k] is true iff [k] is present in [t]. *) + + val find : [> `Read ] t -> key -> value option Lwt.t + (** [find t k] is [Some v] if [k] is associated to [v] in [t] and + [None] is [k] is not present in [t]. *) + + val add : [> `Write ] t -> key -> value -> unit Lwt.t + (** Write the contents of a value to the store. *) +end + +(** Atomic-write stores. *) +module type ATOMIC_WRITE_STORE = sig + (** {1 Atomic write stores} + + Atomic-write stores are stores where it is possible to read, + update and remove elements, with atomically guarantees. *) + + (** The type for atomic-write backend stores. *) + type t + + (** The type for keys. *) + type key + + (** The type for raw values. *) + type value + + val mem : t -> key -> bool Lwt.t + (** [mem t k] is true iff [k] is present in [t]. *) + + val find : t -> key -> value option Lwt.t + (** [find t k] is [Some v] if [k] is associated to [v] in [t] and + [None] is [k] is not present in [t]. *) + + val set : t -> key -> value -> unit Lwt.t + (** [set t k v] replaces the contents of [k] by [v] in [t]. If [k] + is not already defined in [t], create a fresh binding. Raise + [Invalid_argument] if [k] is the {{!Path.empty}empty path}. *) + + val test_and_set : + t -> key -> test:value option -> set:value option -> bool Lwt.t + (** [test_and_set t key ~test ~set] sets [key] to [set] only if + the current value of [key] is [test] and in that case returns + [true]. If the current value of [key] is different, it returns + [false]. [None] means that the value does not have to exist or + is removed. + + {b Note:} The operation is guaranteed to be atomic. *) + + val remove : t -> key -> unit Lwt.t + (** [remove t k] remove the key [k] in [t]. *) + + val list : t -> key list Lwt.t + (** [list t] it the list of keys in [t]. *) + + (** The type of watch handlers. *) + type watch + + val watch : + t -> + ?init:(key * value) list -> + (key -> value diff -> unit Lwt.t) -> + watch Lwt.t + (** [watch t ?init f] adds [f] to the list of [t]'s watch handlers + and returns the watch handler to be used with {!unwatch}. [init] + is the optional initial values. It is more efficient to use + {!watch_key} to watch only a single given key.*) + + val watch_key : + t -> key -> ?init:value -> (value diff -> unit Lwt.t) -> watch Lwt.t + (** [watch_key t k ?init f] adds [f] to the list of [t]'s watch + handlers for the key [k] and returns the watch handler to be + used with {!unwatch}. [init] is the optional initial value of + the key. *) + + val unwatch : t -> watch -> unit Lwt.t + (** [unwatch t w] removes [w] from [t]'s watch handlers. *) +end + +(** {1 User-Defined Contents} *) + +(** Store paths. + + An Irmin {{!Irmin.S}store} binds {{!Path.S.t}paths} to + user-defined {{!Contents.S}contents}. Paths are composed by basic + elements, that we call {{!Path.S.step}steps}. The following [Path] + module provides functions to manipulate steps and paths. *) +module Path : sig + (** {1 Path} *) + + (** Signature for path implementations.*) + module type S = sig + (** {1 Path} *) + + (** The type for path values. *) + type t + + (** Type type for path's steps. *) + type step + + val empty : t + (** The empty path. *) + + val v : step list -> t + (** Create a path from a list of steps. *) + + val is_empty : t -> bool + (** Check if the path is empty. *) + + val cons : step -> t -> t + (** Prepend a step to the path. *) + + val rcons : t -> step -> t + (** Append a step to the path. *) + + val decons : t -> (step * t) option + (** Deconstruct the first element of the path. Return [None] if + the path is empty. *) + + val rdecons : t -> (t * step) option + (** Deconstruct the last element of the path. Return [None] if the + path is empty. *) + + val map : t -> (step -> 'a) -> 'a list + (** [map t f] maps [f] over all steps of [t]. *) + + (** {1 Value Types} *) + + val t : t Type.t + (** [t] is the value type for {!t}. *) + + val step_t : step Type.t + (** [step_t] is the value type for {!step}. *) + end + + (** An implementation of paths as string lists. *) + module String_list : S with type step = string and type t = string list +end + +(** Hashing functions. + + [Hash] provides user-defined hash functions to digest serialized + contents. Some {{!backend}backends} might be parameterized by such + hash functions, others might work with a fixed one (for instance, + the Git format uses only {{!Hash.SHA1}SHA1}). + + A {{!Hash.SHA1}SHA1} implementation is available to pass to the + backends. *) +module Hash : sig + (** {1 Contents Hashing} *) + + (** Signature for hash values. *) + module type S = sig + (** Signature for digest hashes, inspired by Digestif. *) + + (** The type for digest hashes. *) + type t + + val hash : ((string -> unit) -> unit) -> t + (** Compute a deterministic store key from a sequence of strings. *) + + val short_hash : t -> int + (** [short_hash h] is a small hash of [h], to be used for instance as + the `hash` function of an OCaml [Hashtbl]. *) + + val hash_size : int + (** [hash_size] is the size of hash results, in bytes. *) + + (** {1 Value Types} *) + + val t : t Type.t + (** [t] is the value type for {!t}. *) + end + + (** Signature for typed hashes, where [hash] directly takes a value + as argument and incremental hashing is not possible. *) + module type TYPED = sig + type t + + type value + + val hash : value -> t + (** Compute a deterministic store key from a string. *) + + val short_hash : t -> int + (** [short_hash h] is a small hash of [h], to be used for instance as + the `hash` function of an OCaml [Hashtbl]. *) + + val hash_size : int + (** [hash_size] is the size of hash results, in bytes. *) + + (** {1 Value Types} *) + + val t : t Type.t + (** [t] is the value type for {!t}. *) + end + + (** Digestif hashes. *) + module Make (H : Digestif.S) : S with type t = H.t + + module SHA1 : S + + module RMD160 : S + + module SHA224 : S + + module SHA256 : S + + module SHA384 : S + + module SHA512 : S + + module BLAKE2B : S + + module BLAKE2S : S + + (** v1 serialisation *) + module V1 (H : S) : S with type t = H.t + + (** Typed hashes. *) + + module Typed (K : S) (E : Type.S) : + TYPED with type t = K.t and type value = E.t +end + +(** [Metadata] defines metadata that is attached to contents but stored in + nodes. The Git backend uses this to indicate the type of file (normal, + executable or symlink). *) +module Metadata : sig + module type S = sig + (** The type for metadata. *) + type t + + val t : t Type.t + (** [t] is the value type for {!t}. *) + + val merge : t Merge.t + (** [merge] is the merge function for metadata. *) + + val default : t + (** The default metadata to attach, for APIs that don't + care about metadata. *) + end + + (** A metadata definition for systems that don't use metadata. *) + module None : S with type t = unit +end + +(** [Contents] specifies how user-defined contents need to be {e + serializable} and {e mergeable}. + + The user needs to provide: + + {ul + {- a type [t] to be used as store contents.} + {- a value type for [t] (built using the {{!Irmin.Type}Irmin.Type} combinators).} + {- a 3-way [merge] function, to handle conflicts between multiple + versions of the same contents.} + } + + Default implementations for {{!Contents.String}idempotent string} + and {{!Contents.Json}JSON} contents are provided. *) +module Contents : sig + module type S = sig + (** {1 Signature for store contents} *) + + (** The type for user-defined contents. *) + type t + + val t : t Type.t + (** [t] is the value type for {!t}. *) + + val merge : t option Merge.t + (** Merge function. Evaluates to [`Conflict msg] if the values + cannot be merged properly. The arguments of the merge function + can take [None] to mean that the key does not exists for + either the least-common ancestor or one of the two merging + points. The merge function returns [None] when the key's value + should be deleted. *) + end + + (** Contents of type [string], with the {{!Irmin.Merge.default}default} + 3-way merge strategy: assume that update operations are idempotent and + conflict iff values are modified concurrently. *) + module String : S with type t = string + + type json = + [ `Null + | `Bool of bool + | `String of string + | `Float of float + | `O of (string * json) list + | `A of json list ] + + (** [Json] contents are associations from strings to [json] values + stored as JSON encoded strings. If the same JSON key has been + modified concurrently with different values then the [merge] + function conflicts. *) + module Json : S with type t = (string * json) list + + (** [Json_value] allows any kind of json value to be stored, not only objects. *) + module Json_value : S with type t = json + + module V1 : sig + (** Same as {!String} but use v1 serialisation format. *) + module String : S with type t = string + end + + (** Contents store. *) + module type STORE = sig + include CONTENT_ADDRESSABLE_STORE + + val merge : [ `Read | `Write ] t -> key option Merge.t + (** [merge t] lifts the merge functions defined on contents values + to contents key. The merge function will: {e (i)} read the + values associated with the given keys, {e (ii)} use the merge + function defined on values and {e (iii)} write the resulting + values into the store to get the resulting key. See + {!Contents.S.merge}. + + If any of these operations fail, return [`Conflict]. *) + + (** [Key] provides base functions for user-defined contents keys. *) + module Key : Hash.TYPED with type t = key and type value = value + + (** [Val] provides base functions for user-defined contents values. *) + module Val : S with type t = value + end + + (** [Store] creates a contents store. *) + module Store (S : sig + include CONTENT_ADDRESSABLE_STORE + + module Key : Hash.S with type t = key + + module Val : S with type t = value + end) : + STORE with type 'a t = 'a S.t and type key = S.key and type value = S.value +end + +(** User-defined branches. *) +module Branch : sig + (** {1 Branches} *) + + (** The signature for branches. Irmin branches are similar to Git + branches: they are used to associated user-defined names to head + commits. Branches have a default value: the + {{!Branch.S.master}master} branch. *) + module type S = sig + (** {1 Signature for Branches} *) + + (** The type for branches. *) + type t + + val t : t Type.t + (** [t] is the value type for {!t}. *) + + val master : t + (** The name of the master branch. *) + + val is_valid : t -> bool + (** Check if the branch is valid. *) + end + + (** [String] is an implementation of {{!Branch.S}S} where branches + are strings. The [master] branch is ["master"]. Valid branch + names contain only alpha-numeric characters, [-], [_], [.], and + [/]. *) + module String : S with type t = string + + (** [STORE] specifies the signature for branch stores. + + A {i branch store} is a mutable and reactive key / value store, + where keys are branch names created by users and values are keys + are head commmits. *) + module type STORE = sig + (** {1 Branch Store} *) + + include ATOMIC_WRITE_STORE + + (** Base functions on keys. *) + module Key : S with type t = key + + (** Base functions on values. *) + module Val : Hash.S with type t = value + end +end + +(** The type for remote stores. *) +type remote = .. + +(** The type for backend-specific configuration values. + + Every backend has different configuration options, which are kept + abstract to the user. *) +type config + +(** [Private] defines functions only useful for creating new + backends. If you are just using the library (and not developing a + new backend), you should not use this module. *) +module Private : sig + (** Backend configuration. + + A backend configuration is a set of {{!keys}keys} mapping to + typed values. Backends define their own keys. *) + module Conf : sig + (** {1 Configuration converters} + + A configuration converter transforms a string value to an OCaml + value and vice-versa. There are a few + {{!builtin_converters}built-in converters}. *) + + (** The type for configuration converter parsers. *) + type 'a parser = string -> ('a, [ `Msg of string ]) result + + (** The type for configuration converter printers. *) + type 'a printer = 'a Fmt.t + + (** The type for configuration converters. *) + type 'a converter = 'a parser * 'a printer + + val parser : 'a converter -> 'a parser + (** [parser c] is [c]'s parser. *) + + val printer : 'a converter -> 'a printer + (** [converter c] is [c]'s printer. *) + + (** {1:keys Keys} *) + + (** The type for configuration keys whose lookup value is ['a]. *) + type 'a key + + val key : + ?docs:string -> + ?docv:string -> + ?doc:string -> + string -> + 'a converter -> + 'a -> + 'a key + (** [key ~docs ~docv ~doc name conv default] is a configuration key named + [name] that maps to value [default] by default. [conv] is + used to convert key values provided by end users. + + [docs] is the title of a documentation section under which the + key is documented. [doc] is a short documentation string for the + key, this should be a single sentence or paragraph starting with + a capital letter and ending with a dot. [docv] is a + meta-variable for representing the values of the key + (e.g. ["BOOL"] for a boolean). + + @raise Invalid_argument if the key name is not made of a + sequence of ASCII lowercase letter, digit, dash or underscore. + + {b Warning.} No two keys should share the same [name] as this + may lead to difficulties in the UI. *) + + val name : 'a key -> string + (** The key name. *) + + val conv : 'a key -> 'a converter + (** [tc k] is [k]'s converter. *) + + val default : 'a key -> 'a + (** [default k] is [k]'s default value. *) + + val doc : 'a key -> string option + (** [doc k] is [k]'s documentation string (if any). *) + + val docv : 'a key -> string option + (** [docv k] is [k]'s value documentation meta-variable (if any). *) + + val docs : 'a key -> string option + (** [docs k] is [k]'s documentation section (if any). *) + + val root : string option key + (** Default [--root=ROOT] argument. *) + + (** {1:conf Configurations} *) + + (** The type for configurations. *) + type t = config + + val empty : t + (** [empty] is the empty configuration. *) + + val singleton : 'a key -> 'a -> t + (** [singleton k v] is the configuration where [k] maps to [v]. *) + + val is_empty : t -> bool + (** [is_empty c] is [true] iff [c] is empty. *) + + val mem : t -> 'a key -> bool + (** [mem c k] is [true] iff [k] has a mapping in [c]. *) + + val add : t -> 'a key -> 'a -> t + (** [add c k v] is [c] with [k] mapping to [v]. *) + + val rem : t -> 'a key -> t + (** [rem c k] is [c] with [k] unbound. *) + + val union : t -> t -> t + (** [union r s] is the union of the configurations [r] and [s]. *) + + val find : t -> 'a key -> 'a option + (** [find c k] is [k]'s mapping in [c], if any. *) + + val get : t -> 'a key -> 'a + (** [get c k] is [k]'s mapping in [c]. + + {b Raises.} [Not_found] if [k] is not bound in [d]. *) + + (** {1:builtin_converters Built-in value converters} *) + + val bool : bool converter + (** [bool] converts values with [bool_of_string]. *) + + val int : int converter + (** [int] converts values with [int_of_string]. *) + + val string : string converter + (** [string] converts values with the identity function. *) + + val uri : Uri.t converter + (** [uri] converts values with {!Uri.of_string}. *) + + val some : 'a converter -> 'a option converter + (** [string] converts values with the identity function. *) + end + + (** [Watch] provides helpers to register event notifications on + read-write stores. *) + module Watch : sig + (** {1 Watch Helpers} *) + + (** The signature for watch helpers. *) + module type S = sig + (** {1 Watch Helpers} *) + + (** The type for store keys. *) + type key + + (** The type for store values. *) + type value + + (** The type for watch handlers. *) + type watch + + (** The type for watch state. *) + type t + + val stats : t -> int * int + (** [stats t] is a tuple [(k,a)] represeting watch stats. [k] is + the number of single key watchers for the store [t] and [a] the + number of global watchers for [t]. *) + + val notify : t -> key -> value option -> unit Lwt.t + (** Notify all listeners in the given watch state that a key has + changed, with the new value associated to this key. [None] + means the key has been removed. *) + + val v : unit -> t + (** Create a watch state. *) + + val clear : t -> unit Lwt.t + (** Clear all register listeners in the given watch state. *) + + val watch_key : + t -> key -> ?init:value -> (value diff -> unit Lwt.t) -> watch Lwt.t + (** Watch a given key for changes. More efficient than {!watch}. *) + + val watch : + t -> + ?init:(key * value) list -> + (key -> value diff -> unit Lwt.t) -> + watch Lwt.t + (** Add a watch handler. To watch a specific key, use + {!watch_key} which is more efficient. *) + + val unwatch : t -> watch -> unit Lwt.t + (** Remove a watch handler. *) + + val listen_dir : + t -> + string -> + key:(string -> key option) -> + value:(key -> value option Lwt.t) -> + (unit -> unit Lwt.t) Lwt.t + (** Register a thread looking for changes in the given directory + and return a function to stop watching and free up + resources. *) + end + + val workers : unit -> int + (** [workers ()] is the number of background worker threads + managing event notification currently active. *) + + (** The type for watch hooks. *) + type hook = + int -> string -> (string -> unit Lwt.t) -> (unit -> unit Lwt.t) Lwt.t + + val none : hook + (** [none] is the hooks which asserts false. *) + + val set_listen_dir_hook : hook -> unit + (** Register a function which looks for file changes in a + directory and return a function to stop watching. It is + probably best to use {!Irmin_watcher.hook} there. By default, + it uses {!none}. *) + + (** [Make] builds an implementation of watch helpers. *) + module Make (K : Type.S) (V : Type.S) : + S with type key = K.t and type value = V.t + end + + module Lock : sig + (** {1 Process locking helpers} *) + + module type S = sig + (** The type for lock manager. *) + type t + + (** The type for key to be locked. *) + type key + + val v : unit -> t + (** Create a lock manager. *) + + val with_lock : t -> key -> (unit -> 'a Lwt.t) -> 'a Lwt.t + (** [with_lock t k f] executes [f ()] while holding the exclusive + lock associated to the key [k]. *) + + val stats : t -> int + end + + (** Create a lock manager implementation. *) + module Make (K : Type.S) : S with type key = K.t + end + + (** [Node] provides functions to describe the graph-like structured + values. + + The node blocks form a labeled directed acyclic graph, labeled + by {{!Path.S.step}steps}: a list of steps defines a + unique path from one node to an other. + + Each node can point to user-defined {{!Contents.S}contents} + values. *) + module Node : sig + module type S = sig + (** {1 Node values} *) + + (** The type for node values. *) + type t + + (** The type for node metadata. *) + type metadata + + (** The type for keys. *) + type hash + + (** The type for steps between nodes. *) + type step + + (** The type for either (node) keys or (contents) keys combined with + their metadata. *) + type value = [ `Node of hash | `Contents of hash * metadata ] + + val v : (step * value) list -> t + (** [create l] is a new node. *) + + val list : t -> (step * value) list + (** [list t] is the contents of [t]. *) + + val empty : t + (** [empty] is the empty node. *) + + val is_empty : t -> bool + (** [is_empty t] is true iff [t] is {!empty}. *) + + val find : t -> step -> value option + (** [find t s] is the value associated with [s] in [t]. + + A node can point to user-defined + {{!Node.S.contents}contents}. The edge between the node and + the contents is labeled by a {{!Node.S.step}step}. *) + + val add : t -> step -> value -> t + (** [add t s v] is the node where [find t v] is [Some s] but + is similar to [t] otherwise. *) + + val remove : t -> step -> t + (** [remove t s] is the node where [find t s] is [None] but is + similar to [t] otherwise. *) + + (** {1 Value types} *) + + val t : t Type.t + (** [t] is the value type for {!t}. *) + + val default : metadata + (** [default] is the default metadata value. *) + + val metadata_t : metadata Type.t + (** [metadata_t] is the value type for {!metadata}. *) + + val hash_t : hash Type.t + (** [hash_t] is the value type for {!hash}. *) + + val step_t : step Type.t + (** [step_t] is the value type for {!step}. *) + + val value_t : value Type.t + (** [value_t] is the value type for {!value}. *) + end + + (** [Make] provides a simple node implementation, parameterized by + the contents and notes keys [K], paths [P] and metadata [M]. *) + module Make + (K : Type.S) (P : sig + type step + + val step_t : step Type.t + end) + (M : Metadata.S) : + S with type hash = K.t and type step = P.step and type metadata = M.t + + (** v1 serialisation *) + module V1 (S : S) : sig + include + S + with type hash = S.hash + and type step = S.step + and type metadata = S.metadata + + val import : S.t -> t + + val export : t -> S.t + end + + (** [STORE] specifies the signature for node stores. *) + module type STORE = sig + include CONTENT_ADDRESSABLE_STORE + + (** [Path] provides base functions on node paths. *) + module Path : Path.S + + val merge : [ `Read | `Write ] t -> key option Merge.t + (** [merge] is the 3-way merge function for nodes keys. *) + + (** [Key] provides base functions for node keys. *) + module Key : Hash.TYPED with type t = key and type value = value + + (** [Metadata] provides base functions for node metadata. *) + module Metadata : Metadata.S + + (** [Val] provides base functions for node values. *) + module Val : + S + with type t = value + and type hash = key + and type metadata = Metadata.t + and type step = Path.step + + (** [Contents] is the underlying contents store. *) + module Contents : Contents.STORE with type key = Val.hash + end + + (** [Store] creates node stores. *) + module Store + (C : Contents.STORE) + (P : Path.S) + (M : Metadata.S) (S : sig + include CONTENT_ADDRESSABLE_STORE with type key = C.key + + module Key : Hash.S with type t = key + + module Val : + S + with type t = value + and type hash = key + and type metadata = M.t + and type step = P.step + end) : + STORE + with type 'a t = 'a C.t * 'a S.t + and type key = S.key + and type value = S.value + and module Path = P + and module Metadata = M + and type Key.t = S.Key.t + and module Val = S.Val + + (** [Graph] specifies the signature for node graphs. A node graph + is a deterministic DAG, labeled by steps. *) + module type GRAPH = sig + (** {1 Node Graphs} *) + + (** The type for store handles. *) + type 'a t + + (** The type for node metadata. *) + type metadata + + (** The type of user-defined contents. *) + type contents + + (** The type for node values. *) + type node + + (** The type of steps. A step is used to pass from one node to + another. *) + type step + + (** The type of store paths. A path is composed of + {{!step}steps}. *) + type path + + (** The type for store values. *) + type value = [ `Node of node | `Contents of contents * metadata ] + + val empty : [> `Write ] t -> node Lwt.t + (** The empty node. *) + + val v : [> `Write ] t -> (step * value) list -> node Lwt.t + (** [v t n] is a new node containing [n]. *) + + val list : [> `Read ] t -> node -> (step * value) list Lwt.t + (** [list t n] is the contents of the node [n]. *) + + val find : [> `Read ] t -> node -> path -> value option Lwt.t + (** [find t n p] is the contents of the path [p] starting form + [n]. *) + + val add : [ `Read | `Write ] t -> node -> path -> value -> node Lwt.t + (** [add t n p v] is the node [x] such that [find t x p] is + [Some v] and it behaves the same [n] for other + operations. *) + + val remove : [ `Read | `Write ] t -> node -> path -> node Lwt.t + (** [remove t n path] is the node [x] such that [find t x] is + [None] and it behhaves then same as [n] for other + operations. *) + + val closure : + [> `Read ] t -> min:node list -> max:node list -> node list Lwt.t + (** [closure t ~min ~max] is the transitive closure [c] of [t]'s + nodes such that: + + {ul + {- There is a path in [t] from any nodes in [min] to nodes + in [c]. If [min] is empty, that condition is always true.} + {- There is a path in [t] from any nodes in [c] to nodes in + [max]. If [max] is empty, that condition is always false.} + } + + {b Note:} Both [min] and [max] are subsets of [c].*) + + (** {1 Value Types} *) + + val metadata_t : metadata Type.t + (** [metadat_t] is the value type for {!metadata}. *) + + val contents_t : contents Type.t + (** [contents_t] is the value type for {!contents}. *) + + val node_t : node Type.t + (** [node_t] is the value type for {!node}. *) + + val step_t : step Type.t + (** [step_t] is the value type for {!step}. *) + + val path_t : path Type.t + (** [path_t] is the value type for {!path}. *) + + val value_t : value Type.t + (** [value_t] is the value type for {!value}. *) + end + + module Graph (S : STORE) : + GRAPH + with type 'a t = 'a S.t + and type contents = S.Contents.key + and type metadata = S.Val.metadata + and type node = S.key + and type path = S.Path.t + and type step = S.Path.step + end + + (** Commit values represent the store history. + + Every commit contains a list of predecessor commits, and the + collection of commits form an acyclic directed graph. + + Every commit also can contain an optional key, pointing to a + {{!Private.Commit.STORE}node} value. See the + {{!Private.Node.STORE}Node} signature for more details on node + values. *) + module Commit : sig + module type S = sig + (** {1 Commit values} *) + + (** The type for commit values. *) + type t + + (** Type for keys. *) + type hash + + val v : info:Info.t -> node:hash -> parents:hash list -> t + (** Create a commit. *) + + val node : t -> hash + (** The underlying node. *) + + val parents : t -> hash list + (** The commit parents. *) + + val info : t -> Info.t + (** The commit info. *) + + (** {1 Value Types} *) + + val t : t Type.t + (** [t] is the value type for {!t}. *) + + val hash_t : hash Type.t + (** [hash_t] is the value type for {!hash}. *) + end + + (** [Make] provides a simple implementation of commit values, + parameterized by the commit and node keys [K]. *) + module Make (K : Type.S) : S with type hash = K.t + + (** V1 serialisation. *) + module V1 (S : S) : sig + include S with type hash = S.hash + + val import : S.t -> t + + val export : t -> S.t + end + + (** [STORE] specifies the signature for commit stores. *) + module type STORE = sig + (** {1 Commit Store} *) + + include CONTENT_ADDRESSABLE_STORE + + val merge : [ `Read | `Write ] t -> info:Info.f -> key option Merge.t + (** [merge] is the 3-way merge function for commit keys. *) + + (** [Key] provides base functions for commit keys. *) + module Key : Hash.TYPED with type t = key and type value = value + + (** [Val] provides functions for commit values. *) + module Val : S with type t = value and type hash = key + + (** [Node] is the underlying node store. *) + module Node : Node.STORE with type key = Val.hash + end + + (** [Store] creates a new commit store. *) + module Store + (N : Node.STORE) (S : sig + include CONTENT_ADDRESSABLE_STORE with type key = N.key + + module Key : Hash.S with type t = key + + module Val : S with type t = value and type hash = key + end) : + STORE + with type 'a t = 'a N.t * 'a S.t + and type key = S.key + and type value = S.value + and type Key.t = S.Key.t + and module Val = S.Val + + (** [History] specifies the signature for commit history. The + history is represented as a partial-order of commits and basic + functions to search through that history are provided. + + Every commit can point to an entry point in a node graph, where + user-defined contents are stored. *) + module type HISTORY = sig + (** {1 Commit History} *) + + (** The type for store handles. *) + type 'a t + + (** The type for node values. *) + type node + + (** The type for commit values. *) + type commit + + (** The type for commit objects. *) + type v + + val v : + [> `Write ] t -> + node:node -> + parents:commit list -> + info:Info.t -> + (commit * v) Lwt.t + (** Create a new commit. *) + + val parents : [> `Read ] t -> commit -> commit list Lwt.t + (** Get the commit parents. + + Commits form a append-only, fully functional, partial-order + data-structure: every commit carries the list of its + immediate predecessors. *) + + val merge : [ `Read | `Write ] t -> info:Info.f -> commit Merge.t + (** [merge t] is the 3-way merge function for commit. *) + + val lcas : + [> `Read ] t -> + ?max_depth:int -> + ?n:int -> + commit -> + commit -> + (commit list, [ `Max_depth_reached | `Too_many_lcas ]) result Lwt.t + (** Find the lowest common ancestors + {{:http://en.wikipedia.org/wiki/Lowest_common_ancestor}lca} + between two commits. *) + + val lca : + [ `Read | `Write ] t -> + info:Info.f -> + ?max_depth:int -> + ?n:int -> + commit list -> + (commit option, Merge.conflict) result Lwt.t + (** Compute the lowest common ancestors ancestor of a list of + commits by recursively calling {!lcas} and merging the + results. + + If one of the merges results in a conflict, or if a call to + {!lcas} returns either [Error `Max_depth_reached] or + [Error `Too_many_lcas] then the function returns the same + error. *) + + val three_way_merge : + [ `Read | `Write ] t -> + info:Info.f -> + ?max_depth:int -> + ?n:int -> + commit -> + commit -> + (commit, Merge.conflict) result Lwt.t + (** Compute the {!lcas} of the two commit and 3-way merge the + result. *) + + val closure : + [> `Read ] t -> min:commit list -> max:commit list -> commit list Lwt.t + (** Same as {{!Private.Node.GRAPH.closure}GRAPH.closure} but for + the history graph. *) + + (** {1 Value Types} *) + + val commit_t : commit Type.t + (** [commit_t] is the value type for {!commit}. *) + end + + (** Build a commit history. *) + module History (S : STORE) : + HISTORY + with type 'a t = 'a S.t + and type node = S.Node.key + and type commit = S.key + end + + (** The signature for slices. *) + module Slice : sig + module type S = sig + (** {1 Slices} *) + + (** The type for slices. *) + type t + + (** The type for exported contents. *) + type contents + + (** The type for exported nodes. *) + type node + + (** The type for exported commits. *) + type commit + + (** The type for exported values. *) + type value = [ `Contents of contents | `Node of node | `Commit of commit ] + + val empty : unit -> t Lwt.t + (** Create a new empty slice. *) + + val add : t -> value -> unit Lwt.t + (** [add t v] adds [v] to [t]. *) + + val iter : t -> (value -> unit Lwt.t) -> unit Lwt.t + (** [iter t f] calls [f] on all values of [t]. *) + + (** {1 Value Types} *) + + val t : t Type.t + (** [t] is the value type for {!t}. *) + + val contents_t : contents Type.t + (** [content_t] is the value type for {!contents}. *) + + val node_t : node Type.t + (** [node_t] is the value type for {!node}. *) + + val commit_t : commit Type.t + (** [commit_t] is the value type for {!commit}. *) + + val value_t : value Type.t + (** [value_t] is the value type for {!value}. *) + end + + (** Build simple slices. *) + module Make (C : Contents.STORE) (N : Node.STORE) (H : Commit.STORE) : + S + with type contents = C.key * C.value + and type node = N.key * N.value + and type commit = H.key * H.value + end + + module Sync : sig + module type S = sig + (** {1 Remote synchronization} *) + + (** The type for store handles. *) + type t + + (** The type for store heads. *) + type commit + + (** The type for branch IDs. *) + type branch + + (** The type for sync endpoints. *) + type endpoint + + val fetch : + t -> + ?depth:int -> + endpoint -> + branch -> + (commit option, [ `Msg of string ]) result Lwt.t + (** [fetch t uri] fetches the contents of the remote store + located at [uri] into the local store [t]. Return the head + of the remote branch with the same name, which is now in the + local store. [No_head] means no such branch exists. *) + + val push : + t -> + ?depth:int -> + endpoint -> + branch -> + (unit, [ `Msg of string | `Detached_head ]) result Lwt.t + (** [push t uri] pushes the contents of the local store [t] into + the remote store located at [uri]. *) + end + + (** [None] is an implementation of {{!Private.Sync.S}S} which does + nothing. *) + module None (H : Type.S) (B : Type.S) : sig + include S with type commit = H.t and type branch = B.t + + val v : 'a -> t Lwt.t + (** Create a remote store handle. *) + end + end + + (** The complete collection of private implementations. *) + module type S = sig + (** {1 Private Implementations} *) + + (** Internal hashes. *) + module Hash : Hash.S + + (** Private content store. *) + module Contents : Contents.STORE with type key = Hash.t + + (** Private node store. *) + module Node : + Node.STORE with type key = Hash.t and type Val.hash = Contents.key + + (** Private commit store. *) + module Commit : + Commit.STORE with type key = Hash.t and type Val.hash = Node.key + + (** Private branch store. *) + module Branch : Branch.STORE with type value = Commit.key + + (** Private slices. *) + module Slice : + Slice.S + with type contents = Contents.key * Contents.value + and type node = Node.key * Node.value + and type commit = Commit.key * Commit.value + + (** Private repositories. *) + module Repo : sig + type t + + val v : config -> t Lwt.t + + val contents_t : t -> [ `Read ] Contents.t + + val node_t : t -> [ `Read ] Node.t + + val commit_t : t -> [ `Read ] Commit.t + + val branch_t : t -> Branch.t + + val batch : + t -> + ([ `Read | `Write ] Contents.t -> + [ `Read | `Write ] Node.t -> + [ `Read | `Write ] Commit.t -> + 'a Lwt.t) -> + 'a Lwt.t + end + + (** URI-based low-level sync. *) + module Sync : sig + include Sync.S with type commit = Commit.key and type branch = Branch.key + + val v : Repo.t -> t Lwt.t + end + end +end + +(** {1 High-level Stores} + + An Irmin store is a branch-consistent store where keys are lists + of steps. + + An example is a Git repository where keys are filenames, {e i.e.} + lists of ['/']-separated strings. More complex examples are + structured values, where steps might contain first-class field + accessors and array offsets. + + Irmin provides the following features: + + {ul + {- Support for fast clones, branches and merges, in a fashion very + similar to Git.} + {- Efficient staging areas for fast, transient, in-memory operations.} + {- Fast {{!Sync}synchronization} primitives between remote + stores, using native backend protocols (as the Git protocol) + when available.} + } +*) + +(** Irmin stores. *) +module type S = sig + (** {1 Irmin stores} + + Irmin stores are tree-like read-write stores with + extended capabilities. They allow an application (or a + collection of applications) to work with multiple local states, + which can be forked and merged programmatically, without having + to rely on a global state. In a way very similar to version + control systems, Irmin local states are called {i branches}. + + There are two kinds of store in Irmin: the ones based on + {{!persistent}persistent} named branches and the ones based + {{!temporary}temporary} detached heads. These exist relative to a + local, larger (and shared) store, and have some (shared) + contents. This is exactly the same as usual version control + systems, that the informed user can see as an implicit purely + functional data-structure. *) + + (** The type for Irmin repositories. *) + type repo + + (** The type for Irmin stores. *) + type t + + (** The type for {!key} steps. *) + type step + + (** The type for store keys. A key is a sequence of {!step}s. *) + type key + + (** The type for store metadata. *) + type metadata + + (** The type for store contents. *) + type contents + + (** The type for store nodes. *) + type node + + (** The type for store trees. *) + type tree = [ `Node of node | `Contents of contents * metadata ] + + (** The type for object hashes. *) + type hash + + (** Type for commit identifiers. Similar to Git's commit SHA1s. *) + type commit + + (** Type for persistent branch names. Branches usually share a + common global namespace and it's the user's responsibility to + avoid name clashes. *) + type branch + + (** Type for store slices. *) + type slice + + (** The type for errors associated with functions computing least + common ancestors *) + type lca_error = [ `Max_depth_reached | `Too_many_lcas ] + + (** The type for errors for {!fast_forward}. *) + type ff_error = [ `No_change | `Rejected | lca_error ] + + (** Repositories. *) + module Repo : sig + (** {1 Repositories} + + A repository contains a set of branches. *) + + (** The type of repository handles. *) + type t = repo + + val v : config -> t Lwt.t + (** [v config] connects to a repository in a backend-specific + manner. *) + + val heads : t -> commit list Lwt.t + (** [heads] is {!Head.list}. *) + + val branches : t -> branch list Lwt.t + (** [branches] is {!Branch.list}. *) + + val export : + ?full:bool -> + ?depth:int -> + ?min:commit list -> + ?max:commit list -> + t -> + slice Lwt.t + (** [export t ~depth ~min ~max] exports the store slice between + [min] and [max], using at most [depth] history depth (starting + from the max). + + If [max] is not specified, use the current [heads]. If [min] is + not specified, use an unbound past (but can still be limited by + [depth]). + + [depth] is used to limit the depth of the commit history. [None] + here means no limitation. + + If [full] is set (default is true), the full graph, including the + commits, nodes and contents, is exported, otherwise it is the + commit history graph only. *) + + val import : t -> slice -> (unit, [ `Msg of string ]) result Lwt.t + (** [import t s] imports the contents of the slice [s] in [t]. Does + not modify branches. *) + end + + val empty : repo -> t Lwt.t + (** [empty repo] is a temporary, empty store. Becomes a normal + temporary store after the first update. *) + + val master : repo -> t Lwt.t + (** [master repo] is a persistent store based on [r]'s master + branch. This operation is cheap, can be repeated multiple + times. *) + + val of_branch : repo -> branch -> t Lwt.t + (** [of_branch r name] is a persistent store based on the branch + [name]. Similar to [master], but use [name] instead + {!Branch.S.master}. *) + + val of_commit : commit -> t Lwt.t + (** [of_commit c] is a temporary store, based on the commit [c]. + + Temporary stores do not have stable names: instead they can be + addressed using the hash of the current commit. Temporary stores + are similar to Git's detached heads. In a temporary store, all + the operations are performed relative to the current head and + update operations can modify the current head: the current + stores's head will automatically become the new head obtained + after performing the update. *) + + val repo : t -> repo + (** [repo t] is the repository containing [t]. *) + + val tree : t -> tree Lwt.t + (** [tree t] is [t]'s current tree. Contents is not allowed at the + root of the tree. *) + + (** [Status] provides base functions for store statuses. *) + module Status : sig + (** The type for store status. *) + type t = [ `Empty | `Branch of branch | `Commit of commit ] + + val t : repo -> t Type.t + (** [t] is the value type for {!t}. *) + + val pp : t Fmt.t + (** [pp] is the pretty-printer for store status. *) + end + + val status : t -> Status.t + (** [status t] is [t]'s status. It can either be a branch, a commit + or empty. *) + + (** Managing the store's heads. *) + module Head : sig + val list : repo -> commit list Lwt.t + (** [list t] is the list of all the heads in local store. Similar + to [git rev-list --all]. *) + + val find : t -> commit option Lwt.t + (** [find t] is the current head of the store [t]. This works for + both persistent and temporary branches. In the case of a + persistent branch, this involves getting the the head + associated with the branch, so this may block. In the case of + a temporary store, it simply returns the current head. Returns + [None] if the store has no contents. Similar to + [git rev-parse HEAD]. *) + + val get : t -> commit Lwt.t + (** Same as {!find} but raise [Invalid_argument] if the store does + not have any contents. *) + + val set : t -> commit -> unit Lwt.t + (** [set t h] updates [t]'s contents with the contents of the + commit [h]. Can cause data loss as it discards the current + contents. Similar to [git reset --hard ]. *) + + val fast_forward : + t -> + ?max_depth:int -> + ?n:int -> + commit -> + (unit, [ `No_change | `Rejected | lca_error ]) result Lwt.t + (** [fast_forward t h] is similar to {!update} but the [t]'s head + is updated to [h] only if [h] is stricly in the future of + [t]'s current head. [max_depth] or [n] are used to limit the + search space of the lowest common ancestors (see {!lcas}). + + The result is: + {ul + {- [Ok ()] if the operation is succesfull;} + {- [Error `No_change] if [h] is already [t]'s head;} + {- [Error `Rejected] if [h] is not in the strict future of [t]'s head.} + {- [Error e] if the history exploration has been cut before + getting useful results. In that case. the operation can be + retried using different parameters of [n] and [max_depth] + to get better results.} + } + + *) + + val test_and_set : + t -> test:commit option -> set:commit option -> bool Lwt.t + (** Same as {!update_head} but check that the value is [test] before + updating to [set]. Use {!update} or {!merge} instead if + possible. *) + + val merge : + into:t -> + info:Info.f -> + ?max_depth:int -> + ?n:int -> + commit -> + (unit, Merge.conflict) result Lwt.t + (** [merge ~into:t ?max_head ?n commit] merges the contents of the + commit associated to [commit] into [t]. [max_depth] is the + maximal depth used for getting the lowest common ancestor. [n] + is the maximum number of lowest common ancestors. If present, + [max_depth] or [n] are used to limit the search space of the + lowest common ancestors (see {!lcas}). *) + end + + (** Object hashes. *) + module Hash : Hash.S with type t = hash + + (** [Commit] defines immutable objects to describe store updates. *) + module Commit : sig + (** The type for store commits. *) + type t = commit + + val t : repo -> t Type.t + (** [t] is the value type for {!t}. *) + + val pp_hash : t Fmt.t + (** [pp] is the pretty-printer for commit. Display only the + hash. *) + + val v : repo -> info:Info.t -> parents:hash list -> tree -> commit Lwt.t + (** [v r i ~parents:p t] is the commit [c] such that: + {ul + {- [info c = i]} + {- [parents c = p]} + {- [tree c = t]}} + *) + + val tree : commit -> tree + (** [tree c] is [c]'s root tree. *) + + val parents : commit -> hash list + (** [parents c] are [c]'s parents. *) + + val info : commit -> Info.t + (** [info c] is [c]'s info. *) + + (** {1 Import/Export} *) + + val hash : commit -> hash + (** [hash c] it [c]'s hash. *) + + val of_hash : repo -> hash -> commit option Lwt.t + (** [of_hash r h] is the the commit object in [r] having [h] as + hash, or [None] is no such commit object exists. *) + end + + (** [Contents] provides base functions for the store's contents. *) + module Contents : sig + include Contents.S with type t = contents + + (** {1 Import/Export} *) + + val hash : contents -> hash + (** [hash c] it [c]'s hash in the repository [r]. *) + + val of_hash : repo -> hash -> contents option Lwt.t + (** [of_hash r h] is the the contents object in [r] having [h] as + hash, or [None] is no such contents object exists. *) + end + + (** Managing store's trees. *) + + module Tree : sig + (** [Tree] provides immutable, in-memory partial mirror of the + store, with lazy reads and delayed writes. + + Trees are like staging area in Git: they are immutable + temporary non-persistent areas (they disappear if the host + crash), held in memory for efficiency, where reads are done + lazily and writes are done only when needed on commit: if you + modify a key twice, only the last change will be written to + the store when you commit. *) + + (** {1 Constructors} *) + + val empty : tree + (** [empty] is the empty tree. The empty tree does not have + associated backend configuration values, as they can perform + in-memory operation, independently of any given backend. *) + + val of_contents : ?metadata:metadata -> contents -> tree + (** [of_contents c] is the subtree built from the contents [c]. *) + + val of_node : node -> tree + (** [of_node n] is the subtree built from the node [n]. *) + + val kind : tree -> key -> [ `Contents | `Node ] option Lwt.t + (** [kind t k] is the type of [s] in [t]. It could either be a + tree node or some file contents. It is [None] if [k] is not + present in [t]. *) + + val list : tree -> key -> (step * [ `Contents | `Node ]) list Lwt.t + (** [list t key] is the list of files and sub-nodes stored under [k] + in [t]. *) + + (** {1 Diffs} *) + + val diff : tree -> tree -> (key * (contents * metadata) diff) list Lwt.t + (** [diff x y] is the difference of contents between [x] and [y]. *) + + (** {1 Manipulating Contents} *) + + val mem : tree -> key -> bool Lwt.t + (** [mem t k] is true iff [k] is associated to some contents in + [t]. *) + + val find_all : tree -> key -> (contents * metadata) option Lwt.t + (** [find_all t k] is [Some (b, m)] if [k] is associated to the + contents [b] and metadata [m] in [t] and [None] if [k] is not + present in [t]. *) + + val find : tree -> key -> contents option Lwt.t + (** [find] is similar to {!find_all} but it discards metadata. *) + + val get_all : tree -> key -> (contents * metadata) Lwt.t + (** Same as {!find_all} but raise [Invalid_arg] if [k] is not + present in [t]. *) + + val get : tree -> key -> contents Lwt.t + (** Same as {!get_all} but ignore the metadata. *) + + val add : tree -> key -> ?metadata:metadata -> contents -> tree Lwt.t + (** [add t k c] is the tree where the key [k] is bound to the + contents [c] but is similar to [t] for other bindings. *) + + val remove : tree -> key -> tree Lwt.t + (** [remove t k] is the tree where [k] bindings has been removed + but is similar to [t] for other bindings. *) + + (** {1 Manipulating Subtrees} *) + + val mem_tree : tree -> key -> bool Lwt.t + (** [mem_tree t k] is false iff [find_tree k = None]. *) + + val find_tree : tree -> key -> tree option Lwt.t + (** [find_tree t k] is [Some v] if [k] is associated to [v] in + [t]. It is [None] if [k] is not present in [t]. *) + + val get_tree : tree -> key -> tree Lwt.t + (** [get_tree t k] is [v] if [k] is associated to [v] in [t]. + Raise [Invalid_arg] if [k] is not present in [t].*) + + val add_tree : tree -> key -> tree -> tree Lwt.t + (** [add_tree t k v] is the tree where the key [k] is bound to the + tree [v] but is similar to [t] for other bindings *) + + val merge : tree Merge.t + (** [merge] is the 3-way merge function for trees. *) + + (** {1 Folds} *) + + (** The type for fold marks. *) + type marks + + val empty_marks : unit -> marks + (** [empty_marks ()] is an empty collection of marks. *) + + (** The type for {!fold}'s [force] parameter. [`True] forces the + fold to read the objects of the lazy nodes. [`False f] is + applying [f] on every lazy node instead. *) + type 'a force = [ `True | `False of key -> 'a -> 'a Lwt.t ] + + (** The type for {!fold}'s [uniq] parameters. [`False] folds over + all the nodes. [`True] does not recurse on nodes already + seen. [`Marks m] uses the collection of marks [m] to store the + cache of keys: the fold will modify [m]. This can be used for + incremental folds. *) + type uniq = [ `False | `True | `Marks of marks ] + + (** The type for {!fold}'s [pre] and [post] parameters. *) + type 'a node_fn = key -> step list -> 'a -> 'a Lwt.t + + val fold : + ?force:'a force -> + ?uniq:uniq -> + ?pre:'a node_fn -> + ?post:'a node_fn -> + (key -> contents -> 'a -> 'a Lwt.t) -> + tree -> + 'a -> + 'a Lwt.t + (** [fold f t acc] folds [f] over [t]'s leafs. + + For every node [n], ui [n] is a leaf node, call [f path n]. Otherwise: + + {ul + {- Call [pre path n]. By default [pre] is the identity;} + {- Recursively call [fold] on each children, in lexicographic order;} + {- Call [post path n]; By default [post] is the identity.}} + + See {!force} for details about the [force] parameters. By default + it is [`True]. + + See {!uniq} for details about the [uniq] parameters. By default + it is [`False]. + *) + + (** {1 Stats} *) + + (** The type for tree stats. *) + type stats = { + nodes : int; (** Number of node. *) + leafs : int; (** Number of leafs. *) + skips : int; (** Number of lazy nodes. *) + depth : int; (** Maximal depth. *) + width : int (** Maximal width. *) + } + + val pp_stats : stats Fmt.t + (** [pp_stats] is the pretty printer for tree statistics. *) + + val stats : ?force:bool -> tree -> stats Lwt.t + (** [stats ~force t] are [t]'s statistics. If [force] is true, + this will force the reading of lazy nodes. By default it is + [false]. *) + + (** {1 Concrete Trees} *) + + (** The type for concrete trees. *) + type concrete = + [ `Tree of (step * concrete) list | `Contents of contents * metadata ] + + val of_concrete : concrete -> tree + (** [of_concrete c] is the subtree equivalent to the concrete tree + [c]. *) + + val to_concrete : tree -> concrete Lwt.t + (** [to_concrete t] is the concrete tree equivalent to the subtree + [t]. *) + + (** {1 Caches} *) + + val clear : ?depth:int -> tree -> unit + (** [clear ?depth t] clears all the cache in the tree [t] for + subtrees with a depth higher than [depth]. If [depth] is not + set, all the subtrees are cleared. *) + + (** Global cache of key -> tree -- used for hash-consing and to + speed-up lookups. *) + module Cache : sig + val length : unit -> [ `Contents of int ] * [ `Nodes of int ] + + val clear : ?depth:int -> unit -> unit + (** [clear ?depth ()] clears the global cache. If [depth] is + set, only keep entries with depth greater than [depth] and + prune these so that their depth is [depth]. *) + + val dump : unit Fmt.t + end + + (** {1 Performance counters} *) + + type counters = { + mutable contents_hash : int; + mutable contents_find : int; + mutable contents_add : int; + mutable contents_cache_length : int; + mutable contents_cache_find : int; + mutable contents_cache_miss : int; + mutable node_hash : int; + mutable node_mem : int; + mutable node_add : int; + mutable node_find : int; + mutable node_cache_length : int; + mutable node_cache_find : int; + mutable node_cache_miss : int; + mutable node_val_v : int; + mutable node_val_find : int; + mutable node_val_list : int + } + + val counters : unit -> counters + + val dump_counters : unit Fmt.t + + val reset_counters : unit -> unit + + val inspect : tree -> [ `Contents | `Node of [ `Map | `Hash | `Value ] ] + + (** {1 Import/Export} *) + + val hash : tree -> hash + (** [hash r c] it [c]'s hash in the repository [r]. *) + + val of_hash : repo -> hash -> tree option Lwt.t + (** [of_hash r h] is the the tree object in [r] having [h] as + hash, or [None] is no such tree object exists. *) + + val shallow : repo -> hash -> tree + (** [shallow r h] is the shallow tree object with the hash [h]. No + check is performed to verify if [h] actually exists in [r]. *) + end + + (** {1 Reads} *) + + val kind : t -> key -> [ `Contents | `Node ] option Lwt.t + (** [kind] is {!Tree.kind} applied to [t]'s root tree. *) + + val list : t -> key -> (step * [ `Contents | `Node ]) list Lwt.t + (** [list t] is {!Tree.list} applied to [t]'s root tree. *) + + val mem : t -> key -> bool Lwt.t + (** [mem t] is {!Tree.mem} applied to [t]'s root tree. *) + + val mem_tree : t -> key -> bool Lwt.t + (** [mem_tree t] is {!Tree.mem_tree} applied to [t]'s root tree. *) + + val find_all : t -> key -> (contents * metadata) option Lwt.t + (** [find_all t] is {!Tree.find_all} applied to [t]'s root tree. *) + + val find : t -> key -> contents option Lwt.t + (** [find t] is {!Tree.find} applied to [t]'s root tree. *) + + val get_all : t -> key -> (contents * metadata) Lwt.t + (** [get_all t] is {!Tree.get_all} applied on [t]'s root tree. *) + + val get : t -> key -> contents Lwt.t + (** [get t] is {!Tree.get} applied to [t]'s root tree. *) + + val find_tree : t -> key -> tree option Lwt.t + (** [find_tree t] is {!Tree.find_tree} applied to [t]'s root + tree. *) + + val get_tree : t -> key -> tree Lwt.t + (** [get_tree t k] is {!Tree.get_tree} applied to [t]'s root + tree. *) + + val hash : t -> key -> hash option Lwt.t + (** [hash t k] *) + + (** {1 Udpates} *) + + (** The type for write errors. + + {ul + {- Merge conflict. } + {- Concurrent transactions are competing to get the current + operation committed and too many attemps have been tried + (livelock). } + {- A "test and set" operation has failed and the current value + is [v] instead of the one we were waiting for. }} + *) + type write_error = + [ Merge.conflict | `Too_many_retries of int | `Test_was of tree option ] + + val set : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + contents -> + (unit, write_error) result Lwt.t + (** [set t k ~info v] sets [k] to the value [v] in [t]. Discard any + previous results but ensure that no operation is lost in the + history. + + This function always uses {!Metadata.default} as metadata. + Use {!set_tree} with `[Contents (c, m)] for different ones. + + The result is [Error `Too_many_retries] if the concurrent + operations do not allow the operation to commit to the underlying + storage layer (livelock). *) + + val set_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + contents -> + unit Lwt.t + (** [set_exn] is like {!set} but raise [Failure _] instead + of using a result type. *) + + val set_tree : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + tree -> + (unit, write_error) result Lwt.t + (** [set_tree] is like {!set} but for trees. *) + + val set_tree_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + tree -> + unit Lwt.t + (** [set_tree] is like {!set_exn} but for trees. *) + + val remove : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + (unit, write_error) result Lwt.t + (** [remove t ~info k] remove any bindings to [k] in [t]. + + The result is [Error `Too_many_retries] if the concurrent + operations do not allow the operation to commit to the underlying + storage layer (livelock). *) + + val remove_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + unit Lwt.t + (** [remove_exn] is like {!remove} but raise [Failure _] instead of + a using result type. *) + + val test_and_set : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + test:contents option -> + set:contents option -> + (unit, write_error) result Lwt.t + (** [test_and_set ~test ~set] is like {!set} but it atomically + checks that the tree is [test] before modifying it to [set]. + + This function always uses {!Metadata.default} as metadata. + Use {!test_and_set_tree} with `[Contents (c, m)] for different ones. + + The result is [Error (`Test t)] if the current tree is [t] + instead of [test]. + + The result is [Error `Too_many_retries] if the concurrent + operations do not allow the operation to commit to the underlying + storage layer (livelock). *) + + val test_and_set_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + test:contents option -> + set:contents option -> + unit Lwt.t + (** [test_and_set_exn] is like {!test_and_set} but raise [Failure _] + instead of using a result type. *) + + val test_and_set_tree : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + test:tree option -> + set:tree option -> + (unit, write_error) result Lwt.t + (** [test_and_set_tree] is like {!test_and_set} but for trees. *) + + val test_and_set_tree_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + test:tree option -> + set:tree option -> + unit Lwt.t + (** [test_and_set_tree_exn] is like {!test_and_set_exn} but for + trees. *) + + val merge : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:contents option -> + t -> + key -> + contents option -> + (unit, write_error) result Lwt.t + (** [merge ~old] is like {!set} but merge the current tree + and the new tree using [old] as ancestor in case of conflicts. + + This function always uses {!Metadata.default} as metadata. + Use {!merge_tree} with `[Contents (c, m)] for different ones. + + The result is [Error (`Conflict c)] if the merge failed with the + conflict [c]. + + The result is [Error `Too_many_retries] if the concurrent + operations do not allow the operation to commit to the underlying + storage layer (livelock). *) + + val merge_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:contents option -> + t -> + key -> + contents option -> + unit Lwt.t + (** [merge_exn] is like {!merge} but raise [Failure _] instead of + using a result type. *) + + val merge_tree : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:tree option -> + t -> + key -> + tree option -> + (unit, write_error) result Lwt.t + (** [merge_tree] is like {!merge_tree} but for trees. *) + + val merge_tree_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:tree option -> + t -> + key -> + tree option -> + unit Lwt.t + (** [merge_tree] is like {!merge_tree} but for trees. *) + + val with_tree : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + ?strategy:[ `Set | `Test_and_set | `Merge ] -> + info:Info.f -> + t -> + key -> + (tree option -> tree option Lwt.t) -> + (unit, write_error) result Lwt.t + (** [with_tree t k ~info f] replaces {i atomically} the subtree [v] + under [k] in the store [t] by the contents of the tree [f v], + using the commit info [info ()]. + + If [v = f v] and [allow_empty] is unset (default) then, the + operation is a no-op. + + If [v != f v] and no other changes happen concurrently, [f v] + becomes the new subtree under [k]. If other changes happen + concurrently to that operations, the semantics depend on the + value of [strategy]: + + {ul + {- if [strategy = `Set], use {!set} and discard any concurrent + updates to [k]. } + {- if [strategy = `Test_and_set] (default), use {!test_and_set} + and ensure that no concurrent operations are updating [k]. } + {- if [strategy = `Merge], use {!merge} and ensure + that concurrent updates and merged with the values present + at the beginning of the transaction. }} + + {b Note:} Irmin transactions provides + {{:https://en.wikipedia.org/wiki/Snapshot_isolation}snapshot + isolation} guarantees: reads and writes are isolated in every + transaction, but only write conflicts are visible on commit. *) + + val with_tree_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + ?strategy:[ `Set | `Test_and_set | `Merge ] -> + info:Info.f -> + t -> + key -> + (tree option -> tree option Lwt.t) -> + unit Lwt.t + (** [with_tree_exn] is like {!with_tree} but raise [Failure _] + instead of using a return type. *) + + (** {1 Clones} *) + + val clone : src:t -> dst:branch -> t Lwt.t + (** [clone ~src ~dst] makes [dst] points to [Head.get src]. [dst] is + created if needed. Remove the current contents en [dst] if [src] + is {!empty}. *) + + (** {1 Watches} *) + + (** The type for store watches. *) + type watch + + val watch : t -> ?init:commit -> (commit diff -> unit Lwt.t) -> watch Lwt.t + (** [watch t f] calls [f] every time the contents of [t]'s head is + updated. + + {b Note:} even if [f] might skip some head updates, it will + never be called concurrently: all consecutive calls to [f] are + done in sequence, so we ensure that the previous one ended + before calling the next one. *) + + val watch_key : + t -> + key -> + ?init:commit -> + ((commit * tree) diff -> unit Lwt.t) -> + watch Lwt.t + (** [watch_key t key f] calls [f] every time the [key]'s value is + added, removed or updated. If the current branch is deleted, + no signal is sent to the watcher. *) + + val unwatch : watch -> unit Lwt.t + (** [unwatch w] disable [w]. Return once the [w] is fully + disabled. *) + + (** {1 Merges and Common Ancestors.} *) + + (** The type for merge functions. *) + type 'a merge = + info:Info.f -> + ?max_depth:int -> + ?n:int -> + 'a -> + (unit, Merge.conflict) result Lwt.t + + val merge_into : into:t -> t merge + (** [merge_into ~into i t] merges [t]'s current branch into [x]'s + current branch using the info [i]. After that operation, the two + stores are still independent. Similar to [git merge ]. *) + + val merge_with_branch : t -> branch merge + (** Same as {!merge} but with a branch ID. *) + + val merge_with_commit : t -> commit merge + (** Same as {!merge} but with a commit ID. *) + + val lcas : + ?max_depth:int -> ?n:int -> t -> t -> (commit list, lca_error) result Lwt.t + (** [lca ?max_depth ?n msg t1 t2] returns the collection of least + common ancestors between the heads of [t1] and [t2] branches. + + {ul + {- [max_depth] is the maximum depth of the exploration (default + is [max_int]). Return [Error `Max_depth_reached] if this depth + is exceeded.} + {- [n] is the maximum expected number of lcas. Stop the + exploration as soon as [n] lcas are found. Return + [Error `Too_many_lcas] if more [lcas] are found. } + } + *) + + val lcas_with_branch : + t -> + ?max_depth:int -> + ?n:int -> + branch -> + (commit list, lca_error) result Lwt.t + (** Same as {!lcas} but takes a branch ID as argument. *) + + val lcas_with_commit : + t -> + ?max_depth:int -> + ?n:int -> + commit -> + (commit list, lca_error) result Lwt.t + (** Same as {!lcas} but takes a commit ID as argument. *) + + (** {1 History} *) + + (** An history is a DAG of heads. *) + module History : Graph.Sig.P with type V.t = commit + + val history : + ?depth:int -> ?min:commit list -> ?max:commit list -> t -> History.t Lwt.t + (** [history ?depth ?min ?max t] is a view of the history of the + store [t], of depth at most [depth], starting from the [max] + (or from the [t]'s head if the list of heads is empty) and + stopping at [min] if specified. *) + + val last_modified : ?depth:int -> ?n:int -> t -> key -> commit list Lwt.t + (** [last_modified ?number c k] is the list of the last [number] commits + that modified [key], in ascending order of date. [depth] is the maximum + depth to be explored in the commit graph, if any. Default value for + [number] is 1. *) + + (** Manipulate branches. *) + module Branch : sig + (** {1 Branch Store} + + Manipulate relations between {{!branch}branches} and + {{!commit}commits}. *) + + val mem : repo -> branch -> bool Lwt.t + (** [mem r b] is true iff [b] is present in [r]. *) + + val find : repo -> branch -> commit option Lwt.t + (** [find r b] is [Some c] iff [c] is bound to [b] in [t]. It is + [None] if [b] is not present in [t]. *) + + val get : repo -> branch -> commit Lwt.t + (** [get t b] is similar to {!find} but raise [Invalid_argument] + if [b] is not present in [t]. *) + + val set : repo -> branch -> commit -> unit Lwt.t + (** [set t b c] bounds [c] to [b] in [t]. *) + + val remove : repo -> branch -> unit Lwt.t + (** [remove t b] removes [b] from [t]. *) + + val list : repo -> branch list Lwt.t + (** [list t] is the list of branches present in [t]. *) + + val watch : + repo -> + branch -> + ?init:commit -> + (commit diff -> unit Lwt.t) -> + watch Lwt.t + (** [watch t b f] calls [f] on every change in [b]. *) + + val watch_all : + repo -> + ?init:(branch * commit) list -> + (branch -> commit diff -> unit Lwt.t) -> + watch Lwt.t + (** [watch_all t f] calls [f] on every branch-related change in + [t], including creation/deletion events. *) + + (** Base functions for branches. *) + include Branch.S with type t = branch + end + + (** [Key] provides base functions for the stores's paths. *) + module Key : Path.S with type t = key and type step = step + + (** [Metadata] provides base functions for node metadata. *) + module Metadata : Metadata.S with type t = metadata + + (** {1 Value Types} *) + + val step_t : step Type.t + (** [step_t] is the value type for {!step}. *) + + val key_t : key Type.t + (** [key_t] is the value type for {!key}. *) + + val metadata_t : metadata Type.t + (** [metadata_t] is the value type for {!metadata}. *) + + val contents_t : contents Type.t + (** [contents_t] is the value type for {!contents}. *) + + val node_t : node Type.t + (** [node_t] is the value type for {!node}. *) + + val tree_t : tree Type.t + (** [tree_t] is the value type for {!tree}. *) + + val commit_t : repo -> commit Type.t + (** [commit_t r] is the value type for {!commit}. *) + + val branch_t : branch Type.t + (** [branch_t] is the value type for {!branch}. *) + + val slice_t : slice Type.t + (** [slice_t] is the value type for {!slice}. *) + + val kind_t : [ `Node | `Contents ] Type.t + (** [kind_t] is the value type for values returned by {!kind}. *) + + val lca_error_t : lca_error Type.t + (** [lca_error_t] is the value type for {!lca_error}. *) + + val ff_error_t : ff_error Type.t + (** [ff_error_t] is the value type for {!ff_error}. *) + + val write_error_t : write_error Type.t + (** [write_error_t] is the value type for {!write_error}. *) + + (** Private functions, which might be used by the backends. *) + module Private : sig + include + Private.S + with type Contents.value = contents + and module Node.Path = Key + and type Hash.t = Hash.t + and type Node.Metadata.t = metadata + and type Branch.key = branch + and type Slice.t = slice + and type Repo.t = repo + end + + type remote += + | E of Private.Sync.endpoint + (** Extend the [remote] type with [endpoint]. *) + + (** {2 Converters to private types} *) + + val to_private_node : node -> Private.Node.value option Lwt.t + (** [to_private_node n] is the private node objects built using [n]. + The operation can fetch the database to read an object as [n] + could be represented as a hash. The result is [None] iff that + hash doesn't exist in the database. *) + + val of_private_node : repo -> Private.Node.value -> node + (** [of_private_node r n] is the node build from the private node + object [n]. *) + + val to_private_commit : commit -> Private.Commit.value + (** [to_private_commit c] is the private commit object associated + with the commit [c]. *) + + val of_private_commit : repo -> Private.Commit.value -> commit + (** [of_private_commit r c] is the commit associated with the + private commit object [c]. *) + + val save_contents : [> `Write ] Private.Contents.t -> contents -> hash Lwt.t + (** Save a content into the database *) + + val save_tree : + ?clear:bool -> + repo -> + [> `Write ] Private.Contents.t -> + [ `Read | `Write ] Private.Node.t -> + tree -> + hash Lwt.t + (** Save a tree into the database. Does not do any reads. If + [clear] is set (it is by default), the tree cache will be + cleared after the save. *) +end + +(** [Json_tree] is used to project JSON values onto trees. Instead of the entire + object being stored under one key, it is split across several keys starting + at the specified root key. *) +module Json_tree (Store : S with type contents = Contents.json) : sig + include Contents.S with type t = Contents.json + + val to_concrete_tree : t -> Store.Tree.concrete + + val of_concrete_tree : Store.Tree.concrete -> t + + val get_tree : Store.tree -> Store.key -> t Lwt.t + (** Extract a [json] value from tree at the given key. *) + + val set_tree : Store.tree -> Store.key -> t -> Store.tree Lwt.t + (** Project a [json] value onto a tree at the given key. *) + + val get : Store.t -> Store.key -> t Lwt.t + (** Extract a [json] value from a store at the given key. *) + + val set : Store.t -> Store.key -> t -> info:Info.f -> unit Lwt.t + (** Project a [json] value onto a store at the given key. *) +end + +(** [S_MAKER] is the signature exposed by any backend providing {!S} + implementations. [M] is the implementation of user-defined + metadata, [C] is the one for user-defined contents, [B] is the + implementation for branches and [H] is the implementation for + object (blobs, trees, commits) hashes. It does not use any native + synchronization primitives. *) +module type S_MAKER = functor + (M : Metadata.S) + (C : Contents.S) + (P : Path.S) + (B : Branch.S) + (H : Hash.S) + -> S + with type key = P.t + and type step = P.step + and type metadata = M.t + and type contents = C.t + and type branch = B.t + and type hash = H.t + +(** [KV] is similar to {!S} but chooses sensible implementations for + path and branch. *) +module type KV = + S with type key = string list and type step = string and type branch = string + +(** [KV_MAKER] is like {!S_MAKER} but where everything except the + contents is replaced by sensible default implementations. *) +module type KV_MAKER = functor (C : Contents.S) -> KV with type contents = C.t + +(** {2 Synchronization} *) + +val remote_store : (module S with type t = 'a) -> 'a -> remote +(** [remote_store t] is the remote corresponding to the local store + [t]. Synchronization is done by importing and exporting store + {{!BC.slice}slices}, so this is usually much slower than native + synchronization using {!Store.remote} but it works for all + backends. *) + +(** [SYNC] provides functions to synchronize an Irmin store with local + and remote Irmin stores. *) +module type SYNC = sig + (** {1 Native Synchronization} *) + + (** Type type for store handles. *) + type db + + (** The type for store heads. *) + type commit + + (** The type for remote status. *) + type status = [ `Empty | `Head of commit ] + + val status_t : db -> status Type.t + (** [status_t db] is the value type for {!status} of remote [db]. *) + + val pp_status : status Fmt.t + (** [pp_status] pretty-prints return statuses. *) + + val fetch : + db -> ?depth:int -> remote -> (status, [ `Msg of string ]) result Lwt.t + (** [fetch t ?depth r] populate the local store [t] with objects for + the remote store [r], using [t]'s current branch. The [depth] + parameter limits the history depth. Return [`Empty] if either the + local or remote store do not have a valid head. *) + + val fetch_exn : db -> ?depth:int -> remote -> status Lwt.t + (** Same as {!fetch} but raise [Invalid_argument] if either the + local or remote store do not have a valid head. *) + + (** The type for pull errors. *) + type pull_error = [ `Msg of string | Merge.conflict ] + + val pp_pull_error : pull_error Fmt.t + (** [pp_push_error] pretty-prints pull errors. *) + + val pull : + db -> + ?depth:int -> + remote -> + [ `Merge of Info.f | `Set ] -> + (status, pull_error) result Lwt.t + (** [pull t ?depth r s] is similar to {{!Sync.fetch}fetch} but it + also updates [t]'s current branch. [s] is the update strategy: + + {ul + {- [`Merge] uses [Head.merge]. Can return a conflict.} + {- [`Set] uses [S.Head.set].} + } *) + + val pull_exn : + db -> ?depth:int -> remote -> [ `Merge of Info.f | `Set ] -> status Lwt.t + (** Same as {!pull} but raise [Invalid_arg] in case of conflict. *) + + (** The type for push errors. *) + type push_error = [ `Msg of string | `Detached_head ] + + val pp_push_error : push_error Fmt.t + (** [pp_push_error] pretty-prints push errors. *) + + val push : db -> ?depth:int -> remote -> (status, push_error) result Lwt.t + (** [push t ?depth r] populates the remote store [r] with objects + from the current store [t], using [t]'s current branch. If [b] + is [t]'s current branch, [push] also updates the head of [b] in + [r] to be the same as in [t]. + + {b Note:} {e Git} semantics is to update [b] only if the new + head if more recent. This is not the case in {e Irmin}. *) + + val push_exn : db -> ?depth:int -> remote -> status Lwt.t + (** Same as {!push} but raise [Invalid_argument] if an error + happens. *) +end + +(** The default [Sync] implementation. *) +module Sync (S : S) : SYNC with type db = S.t and type commit = S.commit + +(** {1:examples Examples} + + These examples are in the [examples] directory of the + distribution. + + {3 Syncing with a remote} + + A simple synchronization example, using the + {{!Irmin_unix.Git}Git} backend and the {!Sync} helpers. The + code clones a fresh repository if the repository does not exist + locally, otherwise it performs a fetch: in this case, only + the missing contents are downloaded. + +{[ +open Lwt.Infix + +module S = Irmin_unix.Git.FS.KV(Irmin.Contents.String) +module Sync = Irmin.Sync(S) +let config = Irmin_git.config "/tmp/test" + +let upstream = + if Array.length Sys.argv = 2 then (Uri.of_string (Store.remote Sys.argv.(1))) + else (Printf.eprintf "Usage: sync [uri]\n%!"; exit 1) + +let test () = + S.Repo.v config >>= S.master + >>= fun t -> Sync.pull_exn t upstream `Set + >>= fun () -> S.get t ["README.md"] + >|= fun r -> Printf.printf "%s\n%!" r + +let () = Lwt_main.run (test ()) +]} + + {3 Mergeable logs} + + We will demonstrate the use of custom merge operators by + defining mergeable debug log files. We first define a log entry + as a pair of a timestamp and a message, using the combinator + exposed by {!Irmin.Type}: + +{[ +module Entry : sig + include Irmin.Type.S + val v: string -> t + val timestamp: t -> int +end = struct + + type t = { timestamp: int; message : string; } + + let compare x y = compare x.timestamp y.timestamp + + let time = ref 0 + + let v message = + incr time; + { timestamp = !time; message } + + let timestamp t = t.timestamp + + let pp ppf { timestamp; message } = + Fmt.pf ppf "%04d: %s" timestamp message + + let of_string str = + match String.split_on_char '\t' str with + | [] -> Error (`Msg ("invalid entry: " ^ str)) + | ts :: msg_sects -> + let message = String.concat "\t" msg_sects in + try Ok { timestamp = int_of_string ts; message } + with Failure e -> Error (`Msg e) + + let t = + let open Irmin.Type in + record "entry" (fun t32 message -> { timestamp = Int32.to_int t32; message }) + |+ field "timestamp" int32 (fun t -> Int32.of_int t.timestamp) + |+ field "message" string (fun t -> t.message) + |> sealr + + let t = Irmin.Type.like ~cli:(pp, of_string) ~compare t + +end +]} + + A log file is a list of entries (one per line), ordered by + decreasing order of timestamps. The 3-way [merge] operator for log + files concatenates and sorts the new entries and prepend them + to the common ancestor's ones. + +{[ +(* A log file *) +module Log: sig + include Irmin.Contents.S + val add: t -> Entry.t -> t + val empty: t +end = struct + + type t = Entry.t list + + let empty = [] + + let pp ppf l = List.iter (Fmt.pf ppf "%a\n" Entry.pp ) (List.rev l) + + let of_string str = + let lines = String.cuts ~empty:false ~sep:"\n" str in + try + List.fold_left (fun acc l -> + match Entry.of_string l with + | Ok x -> x :: acc + | Error (`Msg e) -> failwith e + ) [] lines + |> fun l -> Ok l + with Failure e -> + Error (`Msg e) + + let t = Irmin.Type.(list Entry.t) + let t = Irmin.Type.like' ~cli:(pp, of_string) t + + let timestamp = function + | [] -> 0 + | e :: _ -> Entry.timestamp e + + let newer_than timestamp file = + let rec aux acc = function + | [] -> List.rev acc + | h:: _ when Entry.timestamp h <= timestamp -> List.rev acc + | h::t -> aux (h::acc) t + in + aux [] file + + let merge ~old t1 t2 = + let open Irmin.Merge.Infix in + old () >>=* fun old -> + let old = match old with None -> [] | Some o -> o in + let ts = timestamp old in + let t1 = newer_than ts t1 in + let t2 = newer_than ts t2 in + let t3 = List.sort Entry.compare (List.rev_append t1 t2) in + Irmin.Merge.ok (List.rev_append t3 old) + + let merge = Irmin.Merge.(option (v t merge)) + + let add t e = e :: t + +end ]} + + {b Note:} The serialisation primitives used in that example are + not very efficient in this case as they parse the file + every time. For real usage, you would write buffered versions of + [Log.pp] and [Log.of_string]. + + To persist the log file on disk, we need to choose a backend. We + show here how to use the on-disk [Git] backend on Unix. + +{[ + (* Build an Irmin store containing log files. *) + module S = Irmin_unix.Git.FS.KV(Log) + + (* Set-up the local configuration of the Git repository. *) + let config = Irmin_git.config ~bare:true "/tmp/irmin/test" + + (* Set-up the commit info function *) + let info fmt = Irmin_unix.info ~author:"logger" fmt +]} + + We can now define a toy example to use our mergeable log files. + +{[ + open Lwt.Infix + + (* Name of the log file. *) + let file = [ "local"; "debug" ] + + (* Read the entire log file. *) + let read_file t = + S.find t file >|= function + | None -> [] + | Some l -> l + + (* Persist a new entry in the log. *) + let log t fmt = + Fmt.kstrf (fun message -> + read_file t >>= fun logs -> + let logs = Log.add logs (Entry.v message) in + S.set t (info "Adding a new entry") file logs + ) fmt + + let () = + Lwt_main.run begin + S.Repo.v config >>= S.master + >>= fun t -> log t "Adding a new log entry" + >>= fun () -> Irmin.clone_force ~src:t ~dst:"x" + >>= fun x -> log x "Adding new stuff to x" + >>= fun () -> log x "Adding more stuff to x" + >>= fun () -> log x "More. Stuff. To x." + >>= fun () -> log t "I can add stuff on t also" + >>= fun () -> log t "Yes. On t!" + >>= fun () -> S.merge (info "Merging x into t") x ~into:t + >|= function Ok () -> () | Error _ -> failwith "merge conflict!" + end +]} + +*) + +(** {1 Helpers} *) + +(** [Dot] provides functions to export a store to the Graphviz `dot` + format. *) +module Dot (S : S) : sig + (** {1 Dot Export} *) + + val output_buffer : + S.t -> + ?html:bool -> + ?depth:int -> + ?full:bool -> + date:(int64 -> string) -> + Buffer.t -> + unit Lwt.t + (** [output_buffer t ?html ?depth ?full buf] outputs the Graphviz + representation of [t] in the buffer [buf]. + + [html] (default is false) enables HTML labels. + + [depth] is used to limit the depth of the commit history. [None] + here means no limitation. + + If [full] is set (default is not) the full graph, including the + commits, nodes and contents, is exported, otherwise it is the + commit history graph only. *) +end + +(** {1:backend Backends} + + API to create new Irmin backends. A backend is an implementation + exposing either a concrete implementation of {!S} or a functor + providing {!S} once applied. + + There are two ways to create a concrete {!Irmin.S} implementation: + + {ul + {- {!Make} creates a store where all the objects are stored in the + same store, using the same internal keys format and a custom binary + format based on {{:https://github.com/janestreet/bin_prot}bin_prot}, + with no native synchronization primitives: it is usually what is + needed to quickly create a new backend.} + {- {!Make_ext} creates a store with a {e deep} embedding of each + of the internal stores into separate store, with total control over + the binary format and using the native synchronization protocols + when available.} + } +*) + +(** [APPEND_ONLY_STORE_MAKER] is the signature exposed by + append-only store backends. [K] is the implementation of keys + and [V] is the implementation of values. *) +module type APPEND_ONLY_STORE_MAKER = functor (K : Type.S) (V : Type.S) -> sig + include APPEND_ONLY_STORE with type key = K.t and type value = V.t + + val batch : [ `Read ] t -> ([ `Read | `Write ] t -> 'a Lwt.t) -> 'a Lwt.t + (** [batch t f] applies the writes in [f] in a separate batch. The + exact guarantees depends on the backends. *) + + val v : config -> [ `Read ] t Lwt.t + (** [v config] is a function returning fresh store handles, with the + configuration [config], which is provided by the backend. *) +end + +(** [CONTENT_ADDRESSABLE_STOREMAKER] is the signature exposed by + content-addressable store backends. [K] is the implementation of keys + and [V] is the implementation of values. *) +module type CONTENT_ADDRESSABLE_STORE_MAKER = functor + (K : Hash.S) + (V : Type.S) + -> sig + include CONTENT_ADDRESSABLE_STORE with type key = K.t and type value = V.t + + val batch : [ `Read ] t -> ([ `Read | `Write ] t -> 'a Lwt.t) -> 'a Lwt.t + (** [batch t f] applies the writes in [f] in a separate batch. The + exact guarantees depends on the backends. *) + + val v : config -> [ `Read ] t Lwt.t + (** [v config] is a function returning fresh store handles, with the + configuration [config], which is provided by the backend. *) +end + +module Content_addressable + (S : APPEND_ONLY_STORE_MAKER) + (K : Hash.S) + (V : Type.S) : sig + include + CONTENT_ADDRESSABLE_STORE + with type 'a t = 'a S(K)(V).t + and type key = K.t + and type value = V.t + + val batch : [ `Read ] t -> ([ `Read | `Write ] t -> 'a Lwt.t) -> 'a Lwt.t + (** [batch t f] applies the writes in [f] in a separate batch. The + exact guarantees depends on the backends. *) + + val v : config -> [ `Read ] t Lwt.t + (** [v config] is a function returning fresh store handles, with the + configuration [config], which is provided by the backend. *) +end + +(** [ATOMIC_WRITE_STORE_MAKER] is the signature exposed by atomic-write + store backends. [K] is the implementation of keys and [V] is the + implementation of values.*) +module type ATOMIC_WRITE_STORE_MAKER = functor (K : Type.S) (V : Type.S) -> sig + include ATOMIC_WRITE_STORE with type key = K.t and type value = V.t + + val v : config -> t Lwt.t + (** [v config] is a function returning fresh store handles, with the + configuration [config], which is provided by the backend. *) +end + +(** Simple store creator. Use the same type of all of the internal + keys and store all the values in the same store. *) +module Make + (CA : CONTENT_ADDRESSABLE_STORE_MAKER) + (AW : ATOMIC_WRITE_STORE_MAKER) : S_MAKER + +module Make_ext + (CA : CONTENT_ADDRESSABLE_STORE_MAKER) + (AW : ATOMIC_WRITE_STORE_MAKER) + (Metadata : Metadata.S) + (Contents : Contents.S) + (Path : Path.S) + (Branch : Branch.S) + (Hash : Hash.S) + (Node : Private.Node.S + with type metadata = Metadata.t + and type hash = Hash.t + and type step = Path.step) + (Commit : Private.Commit.S with type hash = Hash.t) : + S + with type key = Path.t + and type contents = Contents.t + and type branch = Branch.t + and type hash = Hash.t + and type step = Path.step + and type metadata = Metadata.t + and type Key.step = Path.step + +(** Advanced store creator. *) +module Of_private (P : Private.S) : + S + with type key = P.Node.Path.t + and type contents = P.Contents.value + and type branch = P.Branch.key + and type hash = P.Hash.t + and type step = P.Node.Path.step + and type metadata = P.Node.Val.metadata + and type Key.step = P.Node.Path.step + and type repo = P.Repo.t + and type slice = P.Slice.t + and module Private = P diff --git a/vendors/irmin/irmin.opam b/vendors/irmin/irmin.opam new file mode 100644 index 000000000000..c75e65066c33 --- /dev/null +++ b/vendors/irmin/irmin.opam @@ -0,0 +1,38 @@ +opam-version: "2.0" +version: "2.0" +maintainer: "thomas@gazagnaire.org" +authors: ["Thomas Gazagnaire" "Thomas Leonard"] +license: "ISC" +homepage: "https://github.com/mirage/irmin" +bug-reports: "https://github.com/mirage/irmin/issues" +dev-repo: "git+https://github.com/mirage/irmin.git" +doc: "https://mirage.github.io/irmin/" + +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] +] + +depends: [ + "ocaml" {>= "4.03.0"} + "dune" {build & >= "1.1.0"} + "fmt" {>= "0.8.0"} + "uri" {>= "1.3.12"} + "jsonm" {>= "1.0.0"} + "lwt" {>= "2.4.7"} + "base64" {>= "2.0.0"} + "digestif" + "ocamlgraph" + "logs" {>= "0.5.0"} + "astring" +] +synopsis: """ +Irmin, a distributed database that follows the same design principles as Git +""" +description: """ +Irmin is a library for persistent stores with built-in snapshot, +branching and reverting mechanisms. It is designed to use a large +variety of backends. Irmin is written in pure OCaml and does not +depend on external C stubs; it aims to run everywhere, from Linux, +to browsers and Xen unikernels. +""" diff --git a/vendors/irmin/lock.ml b/vendors/irmin/lock.ml new file mode 100644 index 000000000000..5c6478a07979 --- /dev/null +++ b/vendors/irmin/lock.ml @@ -0,0 +1,72 @@ +(* + * 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. + *) + +let ( >>= ) = Lwt.bind + +module type S = sig + type key + + type t + + val v : unit -> t + + val with_lock : t -> key -> (unit -> 'a Lwt.t) -> 'a Lwt.t + + val stats : t -> int +end + +module Make (K : Type.S) = struct + module K = struct + type t = K.t + + let hash = Hashtbl.hash + + let equal = Type.equal K.t + end + + module KHashtbl = Hashtbl.Make (K) + + type key = K.t + + type t = { global : Lwt_mutex.t; locks : Lwt_mutex.t KHashtbl.t } + + let v () = { global = Lwt_mutex.create (); locks = KHashtbl.create 1024 } + + let stats t = KHashtbl.length t.locks + + let lock t key () = + let lock = + try KHashtbl.find t.locks key + with Not_found -> + let lock = Lwt_mutex.create () in + KHashtbl.add t.locks key lock; + lock + in + Lwt.return lock + + let unlock t key () = + let () = + if KHashtbl.mem t.locks key then + let lock = KHashtbl.find t.locks key in + if Lwt_mutex.is_empty lock then KHashtbl.remove t.locks key + in + Lwt.return_unit + + let with_lock t k fn = + Lwt_mutex.with_lock t.global (lock t k) >>= fun lock -> + Lwt_mutex.with_lock lock fn >>= fun r -> + Lwt_mutex.with_lock t.global (unlock t k) >>= fun () -> Lwt.return r +end diff --git a/vendors/irmin-lmdb/irmin_lmdb.mli b/vendors/irmin/lock.mli similarity index 76% rename from vendors/irmin-lmdb/irmin_lmdb.mli rename to vendors/irmin/lock.mli index 34a1a3cbdb4f..3c2ce73ff975 100644 --- a/vendors/irmin-lmdb/irmin_lmdb.mli +++ b/vendors/irmin/lock.mli @@ -1,6 +1,5 @@ (* * 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 @@ -15,9 +14,16 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -(** Quick-and-dirty LevelDB backend for Irmin. *) +module type S = sig + type key -val config: - ?config:Irmin.config -> ?mapsize:int64 -> ?readonly:bool -> string -> Irmin.config + type t -module Make : Irmin.S_MAKER + val v : unit -> t + + val with_lock : t -> key -> (unit -> 'a Lwt.t) -> 'a Lwt.t + + val stats : t -> int +end + +module Make (K : Type.S) : S with type key = K.t diff --git a/vendors/irmin/lru.ml b/vendors/irmin/lru.ml new file mode 100644 index 000000000000..8b137891791f --- /dev/null +++ b/vendors/irmin/lru.ml @@ -0,0 +1 @@ + diff --git a/vendors/irmin/merge.ml b/vendors/irmin/merge.ml new file mode 100644 index 000000000000..857053be7681 --- /dev/null +++ b/vendors/irmin/merge.ml @@ -0,0 +1,443 @@ +(* + * 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 +open Printf + +let src = Logs.Src.create "irmin.merge" ~doc:"Irmin merging" + +module Log = (val Logs.src_log src : Logs.LOG) + +type conflict = [ `Conflict of string ] + +type 'a promise = unit -> ('a option, conflict) result Lwt.t + +let promise t : 'a promise = fun () -> Lwt.return (Ok (Some t)) + +let memo fn = + let r = ref None in + fun () -> + match !r with + | Some x -> x + | None -> + fn () >>= fun x -> + r := Some (Lwt.return x); + Lwt.return x + +type 'a f = old:'a promise -> 'a -> 'a -> ('a, conflict) result Lwt.t + +type 'a t = 'a Type.t * 'a f + +let v t f = (t, f) + +let f (x : 'a t) = snd x + +let conflict fmt = + ksprintf + (fun msg -> + Log.debug (fun f -> f "conflict: %s" msg); + Lwt.return (Error (`Conflict msg)) ) + fmt + +let bind x f = x >>= function Error _ as x -> Lwt.return x | Ok x -> f x + +let map f x = x >|= function Error _ as x -> x | Ok x -> Ok (f x) + +let map_promise f t () = + t () >|= function + | Error _ as x -> x + | Ok None -> Ok None + | Ok (Some a) -> Ok (Some (f a)) + +let bind_promise t f () = + t () >>= function + | Error _ as x -> Lwt.return x + | Ok None -> Lwt.return @@ Ok None + | Ok (Some a) -> f a () + +let ok x = Lwt.return (Ok x) + +module Infix = struct + let ( >>=* ) = bind + + let ( >|=* ) x f = map f x + + let ( >>=? ) = bind_promise + + let ( >|=? ) x f = map_promise f x +end + +open Infix + +let default (type a) (t : a Type.t) : a t = + let pp = Type.pp t and ( = ) = Type.equal t in + ( t, + fun ~old t1 t2 -> + let open Infix in + Log.debug (fun f -> f "default %a | %a" pp t1 pp t2); + old () >>=* function + | None -> conflict "default: add/add and no common ancestor" + | Some old -> + Log.debug (fun f -> f "default old=%a" pp t1); + if old = t1 && t1 = t2 then ok t1 + else if old = t1 then ok t2 + else if old = t2 then ok t1 + else conflict "default" ) + +let idempotent dt = + let ( = ) = Type.equal dt in + let default = default dt in + let f ~old x y = if x = y then ok x else f default ~old x y in + v dt f + +let seq = function + | [] -> invalid_arg "nothing to merge" + | (t, _) :: _ as ts -> + ( t, + fun ~old v1 v2 -> + Lwt_list.fold_left_s + (fun acc (_, merge) -> + match acc with Ok x -> ok x | Error _ -> merge ~old v1 v2 ) + (Error (`Conflict "nothing to merge")) + ts ) + +let option (type a) ((a, t) : a t) : a option t = + let dt = Type.option a in + let pp = Type.pp dt in + ( dt, + fun ~old t1 t2 -> + Log.debug (fun f -> f "some %a | %a" pp t1 pp t2); + f (default Type.(option a)) ~old t1 t2 >>= function + | Ok x -> ok x + | Error _ -> ( + match (t1, t2) with + | None, None -> ok None + | Some v1, Some v2 -> + let open Infix in + let old () = + old () >>=* function + | None -> ok None + | Some o -> + Log.debug (fun f -> f "option old=%a" pp o); + ok o + in + t ~old v1 v2 >|=* fun x -> Some x + | Some x, None | None, Some x -> ( + let open Infix in + old () >>=* function + | None | Some None -> ok (Some x) + | Some (Some o) -> + let pp = Type.pp a and ( = ) = Type.equal a in + Log.debug (fun f -> f "option old=%a" pp o); + if x = o then ok (Some x) else conflict "option: add/del" ) ) + ) + +let pair (da, a) (db, b) = + let dt = Type.pair da db in + let pp = Type.pp dt in + ( dt, + fun ~old x y -> + Log.debug (fun f -> f "pair %a | %a" pp x pp y); + (snd (default dt)) ~old x y >>= function + | Ok x -> ok x + | Error _ -> + let (a1, b1), (a2, b2) = (x, y) in + let o1 = map_promise fst old in + let o2 = map_promise snd old in + a ~old:o1 a1 a2 >>=* fun a3 -> b ~old:o2 b1 b2 >|=* fun b3 -> (a3, b3) + ) + +let triple (da, a) (db, b) (dc, c) = + let dt = Type.triple da db dc in + let pp = Type.pp dt in + ( dt, + fun ~old x y -> + Log.debug (fun f -> f "triple %a | %a" pp x pp y); + (snd (default dt)) ~old x y >>= function + | Ok x -> ok x + | Error _ -> + let (a1, b1, c1), (a2, b2, c2) = (x, y) in + let o1 = map_promise (fun (x, _, _) -> x) old in + let o2 = map_promise (fun (_, x, _) -> x) old in + let o3 = map_promise (fun (_, _, x) -> x) old in + a ~old:o1 a1 a2 >>=* fun a3 -> + b ~old:o2 b1 b2 >>=* fun b3 -> + c ~old:o3 c1 c2 >|=* fun c3 -> (a3, b3, c3) ) + +exception C of string + +let merge_elt merge_v old key vs = + let v1, v2 = + match vs with + | `Left v -> (Some v, None) + | `Right v -> (None, Some v) + | `Both (v1, v2) -> (Some v1, Some v2) + in + let old () = old key in + merge_v key ~old v1 v2 >>= function + | Error (`Conflict msg) -> Lwt.fail (C msg) + | Ok x -> Lwt.return x + +(* 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 + +(* assume l1 and l2 are key-sorted *) +let alist_iter2_lwt compare_k f l1 l2 = + let open Lwt in + let l3 = ref [] in + alist_iter2 compare_k (fun left right -> l3 := f left right :: !l3) l1 l2; + Lwt_list.iter_p (fun b -> b >>= fun () -> return_unit) (List.rev !l3) + +(* DO NOT assume l1 and l2 are key-sorted *) +let alist_merge_lwt compare_k f l1 l2 = + let open Lwt in + let l3 = ref [] in + let sort l = List.sort (fun (x, _) (y, _) -> compare_k x y) l in + let l1 = sort l1 in + let l2 = sort l2 in + let f key data = + f key data >>= function + | None -> return_unit + | Some v -> + l3 := (key, v) :: !l3; + return_unit + in + alist_iter2_lwt compare_k f l1 l2 >>= fun () -> return !l3 + +let alist dx dy merge_v = + let dt = Type.(list (pair dx dy)) in + ( dt, + fun ~old x y -> + let pair = Type.pair dx dy in + let pp = Type.pp dt in + Log.debug (fun l -> l "alist %a | %a" pp x pp y); + let sort = List.sort @@ Type.compare pair in + let x = sort x in + let y = sort y in + let old k = + let open Infix in + old () >|=* function + | None -> Some None (* no parent = parent with empty value *) + | Some old -> + let old = try Some (List.assoc k old) with Not_found -> None in + Some old + in + let merge_v k = f (merge_v k) in + Lwt.catch + (fun () -> + alist_merge_lwt Type.(compare dx) (merge_elt merge_v old) x y >>= ok + ) + (function C msg -> conflict "%s" msg | e -> Lwt.fail e) ) + +module MultiSet (K : sig + include Set.OrderedType + + val t : t Type.t +end) = +struct + module M = Map.Make (K) + + let of_alist l = List.fold_left (fun map (k, v) -> M.add k v map) M.empty l + + let t = Type.map Type.(list (pair K.t int64)) of_alist M.bindings + + let merge ~old m1 m2 = + let get k m = try M.find k m with Not_found -> 0L in + let set k v m = match v with 0L -> M.remove k m | _ -> M.add k v m in + let add k v m = set k (Int64.add v @@ get k m) m in + let keys = ref M.empty in + old () >|=* fun old -> + let old = + match old with + | None -> M.empty (* no parent = parent with empty value *) + | Some o -> o + in + M.iter (fun k v -> keys := add k (Int64.neg v) !keys) old; + M.iter (fun k v -> keys := add k v !keys) m1; + M.iter (fun k v -> keys := add k v !keys) m2; + !keys + + let merge = (t, merge) +end + +module Set (K : sig + include Set.OrderedType + + val t : t Type.t +end) = +struct + module S = Set.Make (K) + + let of_list l = List.fold_left (fun set elt -> S.add elt set) S.empty l + + let t = Type.(map @@ list K.t) of_list S.elements + + let pp = Type.pp t + + let merge ~old x y = + Log.debug (fun l -> l "merge %a %a" pp x pp y); + old () >|=* fun old -> + let old = match old with None -> S.empty | Some o -> o in + let ( ++ ) = S.union and ( -- ) = S.diff in + let to_add = x -- old ++ (y -- old) in + let to_del = old -- x ++ (old -- y) in + old -- to_del ++ to_add + + let merge = (t, merge) +end + +module Map (K : sig + include Map.OrderedType + + val t : t Type.t +end) = +struct + module M = Map.Make (K) + + let of_alist l = List.fold_left (fun map (k, v) -> M.add k v map) M.empty l + + let t x = Type.map Type.(list @@ pair K.t x) of_alist M.bindings + + let iter2 f t1 t2 = alist_iter2 K.compare f (M.bindings t1) (M.bindings t2) + + 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 () -> Lwt.return_unit) (List.rev !m3) + + let merge_maps f m1 m2 = + let l3 = ref [] in + let f key data = + f key data >|= function None -> () | Some v -> l3 := (key, v) :: !l3 + in + iter2 f m1 m2 >>= fun () -> + let m3 = of_alist !l3 in + Lwt.return m3 + + let merge dv (merge_v : K.t -> 'a option t) = + let pp ppf m = Type.(pp (list (pair K.t dv))) ppf @@ M.bindings m in + let merge_v k = f (merge_v k) in + ( t dv, + fun ~old m1 m2 -> + Log.debug (fun f -> f "assoc %a | %a" pp m1 pp m2); + Lwt.catch + (fun () -> + let old key = + old () >>=* function + | None -> ok None + | Some old -> + Log.debug (fun f -> f "assoc old=%a" pp old); + let old = + try Some (M.find key old) with Not_found -> None + in + ok (Some old) + in + merge_maps (merge_elt merge_v old) m1 m2 >>= ok ) + (function C msg -> conflict "%s" msg | e -> Lwt.fail e) ) +end + +let like da t a_to_b b_to_a = + let pp = Type.pp da in + let merge ~old a1 a2 = + Log.debug (fun f -> f "biject %a | %a" pp a1 pp a2); + try + let b1 = a_to_b a1 in + let b2 = a_to_b a2 in + let old = memo (map_promise a_to_b old) in + (f t) ~old b1 b2 >|=* b_to_a + with Not_found -> conflict "biject" + in + seq [ default da; (da, merge) ] + +let like_lwt (type a b) da (t : b t) (a_to_b : a -> b Lwt.t) + (b_to_a : b -> a Lwt.t) : a t = + let pp = Type.pp da in + let merge ~old a1 a2 = + Log.debug (fun f -> f "biject' %a | %a" pp a1 pp a2); + try + a_to_b a1 >>= fun b1 -> + a_to_b a2 >>= fun b2 -> + let old = + memo (fun () -> + bind (old ()) @@ function + | None -> ok None + | Some a -> a_to_b a >|= fun b -> Ok (Some b) ) + in + bind ((f t) ~old b1 b2) @@ fun b3 -> b_to_a b3 >>= ok + with Not_found -> conflict "biject'" + in + seq [ default da; (da, merge) ] + +let unit = default Type.unit + +let bool = default Type.bool + +let char = default Type.char + +let int32 = default Type.int32 + +let int64 = default Type.int64 + +let float = default Type.float + +let string = default Type.string + +type counter = int64 + +let counter = + ( Type.int64, + fun ~old x y -> + old () >|=* fun old -> + let old = match old with None -> 0L | Some o -> o in + let ( + ) = Int64.add and ( - ) = Int64.sub in + x + y - old ) + +let with_conflict rewrite (d, f) = + let f ~old x y = + f ~old x y >>= function + | Error (`Conflict msg) -> conflict "%s" (rewrite msg) + | Ok x -> ok x + in + (d, f) + +let conflict_t = + Type.(map string) (fun x -> `Conflict x) (function `Conflict x -> x) + +let result_t ok = + let open Type in + variant "result" (fun ok error -> function + | Ok x -> ok x | Error x -> error x ) + |~ case1 "ok" ok (fun x -> Ok x) + |~ case1 "error" conflict_t (fun x -> Error x) + |> sealv diff --git a/vendors/irmin/merge.mli b/vendors/irmin/merge.mli new file mode 100644 index 000000000000..2e98985f4f67 --- /dev/null +++ b/vendors/irmin/merge.mli @@ -0,0 +1,127 @@ +(* + * 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. + *) + +(** Merge operators. *) + +type conflict = [ `Conflict of string ] + +type 'a promise = unit -> ('a option, conflict) result Lwt.t + +type 'a f = old:'a promise -> 'a -> 'a -> ('a, conflict) result Lwt.t + +type 'a t + +val v : 'a Type.t -> 'a f -> 'a t + +val f : 'a t -> 'a f + +val bind : + ('a, 'b) result Lwt.t -> + ('a -> ('c, 'b) result Lwt.t) -> + ('c, 'b) result Lwt.t + +val map : ('a -> 'c) -> ('a, 'b) result Lwt.t -> ('c, 'b) result Lwt.t + +val promise : 'a -> 'a promise + +val map_promise : ('a -> 'b) -> 'a promise -> 'b promise + +val bind_promise : 'a promise -> ('a -> 'b promise) -> 'b promise + +val seq : 'a t list -> 'a t + +val default : 'a Type.t -> 'a t + +val idempotent : 'a Type.t -> 'a t + +val unit : unit t + +val bool : bool t + +val char : char t + +val int32 : int32 t + +val int64 : int64 t + +val float : float t + +val string : string t + +type counter = int64 + +val counter : counter t + +val option : 'a t -> 'a option t + +val pair : 'a t -> 'b t -> ('a * 'b) t + +val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t + +module MultiSet (K : sig + include Set.OrderedType + + val t : t Type.t +end) : sig + val merge : counter Map.Make(K).t t +end + +module Set (E : sig + include Set.OrderedType + + val t : t Type.t +end) : sig + val merge : Set.Make(E).t t +end + +val alist : 'a Type.t -> 'b Type.t -> ('a -> 'b option t) -> ('a * 'b) list t + +module Map (K : sig + include Map.OrderedType + + val t : t Type.t +end) : sig + val merge : 'a Type.t -> (K.t -> 'a option t) -> 'a Map.Make(K).t t +end + +val like : 'a Type.t -> 'b t -> ('a -> 'b) -> ('b -> 'a) -> 'a t + +val like_lwt : + 'a Type.t -> 'b t -> ('a -> 'b Lwt.t) -> ('b -> 'a Lwt.t) -> 'a t + +val with_conflict : (string -> string) -> 'a t -> 'a t + +val ok : 'a -> ('a, conflict) result Lwt.t + +val conflict : ('a, unit, string, ('b, conflict) result Lwt.t) format4 -> 'a + +module Infix : sig + val ( >>=* ) : + ('a, conflict) result Lwt.t -> + ('a -> ('b, conflict) result Lwt.t) -> + ('b, conflict) result Lwt.t + + val ( >|=* ) : + ('a, conflict) result Lwt.t -> ('a -> 'b) -> ('b, conflict) result Lwt.t + + val ( >>=? ) : 'a promise -> ('a -> 'b promise) -> 'b promise + + val ( >|=? ) : 'a promise -> ('a -> 'b) -> 'b promise +end + +val conflict_t : conflict Type.t + +val result_t : 'a Type.t -> ('a, conflict) result Type.t diff --git a/vendors/irmin/node.ml b/vendors/irmin/node.ml new file mode 100644 index 000000000000..2469f7774515 --- /dev/null +++ b/vendors/irmin/node.ml @@ -0,0 +1,473 @@ +(* + * Copyright (c) 2013 Louis Gesbert + * 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 + +let src = Logs.Src.create "irmin.node" ~doc:"Irmin trees/nodes" + +module Log = (val Logs.src_log src : Logs.LOG) + +module No_metadata = struct + type t = unit + + let t = Type.unit + + let default = () + + let merge = Merge.v t (fun ~old:_ () () -> Merge.ok ()) +end + +module Make + (K : Type.S) (P : sig + type step + + val step_t : step Type.t + end) + (M : S.METADATA) = +struct + type hash = K.t + + type step = P.step + + type metadata = M.t + + type kind = [ `Node | `Contents of M.t ] + + type entry = { kind : kind; name : P.step; node : K.t } + + let kind_t = + let open Type in + variant "Tree.kind" (fun node contents contents_m -> function + | `Node -> node + | `Contents m -> + if Type.equal M.t m M.default then contents else contents_m m ) + |~ case0 "node" `Node + |~ case0 "contents" (`Contents M.default) + |~ case1 "contents" M.t (fun m -> `Contents m) + |> sealv + + let entry_t : entry Type.t = + let open Type in + record "Tree.entry" (fun kind name node -> { kind; name; node }) + |+ field "kind" kind_t (function { kind; _ } -> kind) + |+ field "name" P.step_t (fun { name; _ } -> name) + |+ field "node" K.t (fun { node; _ } -> node) + |> sealr + + let to_entry (k, v) = + match v with + | `Node h -> { name = k; kind = `Node; node = h } + | `Contents (h, m) -> { name = k; kind = `Contents m; node = h } + + let of_entry n = + ( n.name, + match n.kind with + | `Node -> `Node n.node + | `Contents m -> `Contents (n.node, m) ) + + module StepMap = Map.Make (struct + type t = P.step + + let compare (x : t) (y : t) = Type.compare P.step_t y x + end) + + type value = [ `Contents of hash * metadata | `Node of hash ] + + type t = entry StepMap.t + + let v l = + List.fold_left + (fun acc x -> StepMap.add (fst x) (to_entry x) acc) + StepMap.empty l + + let list t = List.rev_map (fun (_, e) -> of_entry e) (StepMap.bindings t) + + let find t s = + try + let _, v = of_entry (StepMap.find s t) in + Some v + with Not_found -> None + + let empty = StepMap.empty + + let is_empty e = list e = [] + + let add t k v = + let e = to_entry (k, v) in + StepMap.update k + (fun e' -> + if Type.equal (Type.option entry_t) (Some e) e' then e' else Some e ) + t + + let remove t k = StepMap.remove k t + + let step_t = P.step_t + + let hash_t = K.t + + let metadata_t = M.t + + let default = M.default + + let value_t = + let open Type in + variant "value" (fun n c x -> function + | `Node h -> n h + | `Contents (h, m) -> if Type.equal M.t m M.default then c h else x (h, m) + ) + |~ case1 "node" K.t (fun k -> `Node k) + |~ case1 "contents" K.t (fun h -> `Contents (h, M.default)) + |~ case1 "contents-x" (pair K.t M.t) (fun (h, m) -> `Contents (h, m)) + |> sealv + + let of_entries e = v (List.rev_map of_entry e) + + let entries e = List.rev_map (fun (_, e) -> e) (StepMap.bindings e) + + let t = Type.map Type.(list entry_t) of_entries entries +end + +module Store + (C : S.CONTENTS_STORE) + (P : S.PATH) + (M : S.METADATA) (S : sig + include S.CONTENT_ADDRESSABLE_STORE with type key = C.key + + module Key : S.HASH with type t = key + + module Val : + S.NODE + with type t = value + and type hash = key + and type metadata = M.t + and type step = P.step + end) = +struct + module Contents = C + module Key = Hash.Typed (S.Key) (S.Val) + module Path = P + module Metadata = M + + type 'a t = 'a C.t * 'a S.t + + type key = S.key + + type value = S.value + + let mem (_, t) = S.mem t + + let find (_, t) = S.find t + + let add (_, t) = S.add t + + let unsafe_add (_, t) = S.unsafe_add t + + let all_contents t = + let kvs = S.Val.list t in + List.fold_left + (fun acc -> function k, `Contents c -> (k, c) :: acc | _ -> acc) + [] kvs + + let all_succ t = + let kvs = S.Val.list t in + List.fold_left + (fun acc -> function k, `Node n -> (k, n) :: acc | _ -> acc) + [] kvs + + let contents_t = C.Key.t + + let metadata_t = M.t + + let step_t = Path.step_t + + (* [Merge.alist] expects us to return an option. [C.merge] does + that, but we need to consider the metadata too... *) + let merge_contents_meta c = + (* This gets us [C.t option, S.Val.Metadata.t]. We want [(C.t * + S.Val.Metadata.t) option]. *) + let explode = function + | None -> (None, M.default) + | Some (c, m) -> (Some c, m) + in + let implode = function None, _ -> None | Some c, m -> Some (c, m) in + Merge.like + Type.(option (pair contents_t metadata_t)) + (Merge.pair (C.merge c) M.merge) + explode implode + + let merge_contents_meta c = + Merge.alist step_t + Type.(pair contents_t metadata_t) + (fun _step -> merge_contents_meta c) + + let merge_parents merge_key = + Merge.alist step_t S.Key.t (fun _step -> merge_key) + + let merge_value (c, _) merge_key = + let explode t = (all_contents t, all_succ t) in + let implode (contents, succ) = + let xs = List.rev_map (fun (s, c) -> (s, `Contents c)) contents in + let ys = List.rev_map (fun (s, n) -> (s, `Node n)) succ in + S.Val.v (xs @ ys) + in + let merge = Merge.pair (merge_contents_meta c) (merge_parents merge_key) in + Merge.like S.Val.t merge explode implode + + let rec merge t = + let merge_key = + Merge.v (Type.option S.Key.t) (fun ~old x y -> + Merge.(f (merge t)) ~old x y ) + in + let merge = merge_value t merge_key in + let read = function + | None -> Lwt.return S.Val.empty + | Some k -> ( find t k >|= function None -> S.Val.empty | Some v -> v ) + in + let add v = + if S.Val.is_empty v then Lwt.return_none + else add t v >>= fun k -> Lwt.return (Some k) + in + Merge.like_lwt Type.(option S.Key.t) merge read add + + module Val = S.Val +end + +module Graph (S : S.NODE_STORE) = struct + module Path = S.Path + module Contents = S.Contents.Key + module Metadata = S.Metadata + + type step = Path.step + + type metadata = Metadata.t + + type contents = Contents.t + + type node = S.key + + type path = Path.t + + type 'a t = 'a S.t + + type value = [ `Contents of contents * metadata | `Node of node ] + + let empty t = S.add t S.Val.empty + + let list t n = + Log.debug (fun f -> f "steps"); + S.find t n >|= function None -> [] | Some n -> S.Val.list n + + module U = struct + type t = unit + + let t = Type.unit + end + + module Graph = Object_graph.Make (Contents) (Metadata) (S.Key) (U) (U) + + let edges t = + List.rev_map + (function _, `Node n -> `Node n | _, `Contents c -> `Contents c) + (S.Val.list t) + + let pp_key = Type.pp S.Key.t + + let pp_keys = Fmt.(Dump.list pp_key) + + let pp_path = Type.pp S.Path.t + + let closure t ~min ~max = + Log.debug (fun f -> f "closure min=%a max=%a" pp_keys min pp_keys max); + let pred = function + | `Node k -> ( S.find t k >|= function None -> [] | Some v -> edges v ) + | _ -> Lwt.return_nil + in + let min = List.rev_map (fun x -> `Node x) min in + let max = List.rev_map (fun x -> `Node x) max in + Graph.closure ~pred ~min ~max () >>= fun g -> + let keys = + List.fold_left + (fun acc -> function `Node x -> x :: acc | _ -> acc) + [] (Graph.vertex g) + in + Lwt.return keys + + let v t xs = S.add t (S.Val.v xs) + + let find_step t node step = + Log.debug (fun f -> f "contents %a" pp_key node); + S.find t node >|= function None -> None | Some n -> S.Val.find n step + + let find t node path = + Log.debug (fun f -> f "read_node_exn %a %a" pp_key node pp_path path); + let rec aux node path = + match Path.decons path with + | None -> Lwt.return (Some (`Node node)) + | Some (h, tl) -> ( + find_step t node h >>= function + | (None | Some (`Contents _)) as x -> Lwt.return x + | Some (`Node node) -> aux node tl ) + in + aux node path + + let err_empty_path () = invalid_arg "Irmin.node: empty path" + + let map_one t node f label = + Log.debug (fun f -> f "map_one %a" Type.(pp Path.step_t) label); + let old_key = S.Val.find node label in + ( match old_key with + | None | Some (`Contents _) -> Lwt.return S.Val.empty + | Some (`Node k) -> ( + S.find t k >|= function None -> S.Val.empty | Some v -> v ) ) + >>= fun old_node -> + f old_node >>= fun new_node -> + if Type.equal S.Val.t old_node new_node then Lwt.return node + else if S.Val.is_empty new_node then + let node = S.Val.remove node label in + if S.Val.is_empty node then Lwt.return S.Val.empty else Lwt.return node + else S.add t new_node >|= fun k -> S.Val.add node label (`Node k) + + let map t node path f = + Log.debug (fun f -> f "map %a %a" pp_key node pp_path path); + let rec aux node path = + match Path.decons path with + | None -> Lwt.return (f node) + | Some (h, tl) -> map_one t node (fun node -> aux node tl) h + in + (S.find t node >|= function None -> S.Val.empty | Some n -> n) + >>= fun node -> aux node path >>= S.add t + + let add t node path n = + Log.debug (fun f -> f "add %a %a" pp_key node pp_path path); + match Path.rdecons path with + | Some (path, file) -> map t node path (fun node -> S.Val.add node file n) + | None -> ( + match n with + | `Node n -> Lwt.return n + | `Contents _ -> failwith "TODO: Node.add" ) + + let rdecons_exn path = + match Path.rdecons path with + | Some (l, t) -> (l, t) + | None -> err_empty_path () + + let remove t node path = + let path, file = rdecons_exn path in + map t node path (fun node -> S.Val.remove node file) + + let path_t = Path.t + + let node_t = S.Key.t + + let metadata_t = Metadata.t + + let step_t = Path.step_t + + let contents_t = Contents.t + + let value_t = S.Val.value_t +end + +module V1 (N : S.NODE) = struct + module K = struct + let h = Type.string_of `Int64 + + let size_of ?headers x = + Type.size_of ?headers h (Type.to_bin_string N.hash_t x) + + let encode_bin ?headers e k = + Type.encode_bin ?headers h (Type.to_bin_string N.hash_t e) k + + let decode_bin ?headers buf off = + let n, v = Type.decode_bin ?headers h buf off in + ( n, + match Type.of_bin_string N.hash_t v with + | Ok v -> v + | Error (`Msg e) -> Fmt.failwith "decode_bin: %s" e ) + + let t = Type.like N.hash_t ~bin:(encode_bin, decode_bin, size_of) + end + + type step = N.step + + type hash = N.hash + + type metadata = N.metadata + + type value = N.value + + let hash_t = N.hash_t + + let metadata_t = N.metadata_t + + type t = { n : N.t; entries : (step * value) list } + + let import n = { n; entries = N.list n } + + let export t = t.n + + let v entries = + let n = N.v entries in + { n; entries } + + let list t = t.entries + + let empty = { n = N.empty; entries = [] } + + let is_empty t = t.entries = [] + + let default = N.default + + let find t k = N.find t.n k + + let add t k v = + let n = N.add t.n k v in + if t.n == n then t else { n; entries = N.list n } + + let remove t k = + let n = N.remove t.n k in + if t.n == n then t else { n; entries = N.list n } + + let step_t : step Type.t = + let to_string p = Type.to_bin_string N.step_t p in + let of_string s = + Type.of_bin_string N.step_t s |> function + | Ok x -> x + | Error (`Msg e) -> Fmt.failwith "Step.of_string: %s" e + in + Type.(map (string_of `Int64)) of_string to_string + + let value_t = + let open Type in + record "node" (fun contents metadata node -> + match (contents, metadata, node) with + | Some c, None, None -> `Contents (c, N.default) + | Some c, Some m, None -> `Contents (c, m) + | None, None, Some n -> `Node n + | _ -> failwith "invalid node" ) + |+ field "contents" (option K.t) (function + | `Contents (x, _) -> Some x + | _ -> None ) + |+ field "metadata" (option N.metadata_t) (function + | `Contents (_, x) when not (equal N.metadata_t N.default x) -> Some x + | _ -> None ) + |+ field "node" (option K.t) (function `Node n -> Some n | _ -> None) + |> sealr + + let t : t Type.t = + Type.map Type.(list ~len:`Int64 (pair step_t value_t)) v list +end diff --git a/vendors/irmin/node.mli b/vendors/irmin/node.mli new file mode 100644 index 000000000000..472effb73578 --- /dev/null +++ b/vendors/irmin/node.mli @@ -0,0 +1,75 @@ +(* + * Copyright (c) 2013 Louis Gesbert + * 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. + *) + +(** Nodes represent structured values serialized in the block + store. *) + +module No_metadata : S.METADATA with type t = unit + +module Make + (K : Type.S) (P : sig + type step + + val step_t : step Type.t + end) + (M : S.METADATA) : + S.NODE with type hash = K.t and type step = P.step and type metadata = M.t + +module Store + (C : S.CONTENTS_STORE) + (P : S.PATH) + (M : S.METADATA) (N : sig + include S.CONTENT_ADDRESSABLE_STORE with type key = C.key + + module Key : S.HASH with type t = key + + module Val : + S.NODE + with type t = value + and type hash = key + and type metadata = M.t + and type step = P.step + end) : + S.NODE_STORE + with type 'a t = 'a C.t * 'a N.t + and type key = N.key + and type value = N.value + and module Path = P + and module Metadata = M + and type Key.t = N.key + and module Val = N.Val + +module Graph (N : S.NODE_STORE) : + S.NODE_GRAPH + with type 'a t = 'a N.t + and type contents = N.Contents.key + and type metadata = N.Val.metadata + and type node = N.key + and type step = N.Path.step + and type path = N.Path.t + +module V1 (N : S.NODE) : sig + include + S.NODE + with type hash = N.hash + and type step = N.step + and type metadata = N.metadata + + val import : N.t -> t + + val export : t -> N.t +end diff --git a/vendors/irmin/object_graph.ml b/vendors/irmin/object_graph.ml new file mode 100644 index 000000000000..1ecf6acaed3d --- /dev/null +++ b/vendors/irmin/object_graph.ml @@ -0,0 +1,236 @@ +(* + * 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 + +let src = Logs.Src.create "irmin.graph" ~doc:"Irmin graph support" + +module Log = (val Logs.src_log src : Logs.LOG) + +let list_partition_map f t = + let rec aux fst snd = function + | [] -> (List.rev fst, List.rev snd) + | h :: t -> ( + match f h with + | `Fst x -> aux (x :: fst) snd t + | `Snd x -> aux fst (x :: snd) t ) + in + aux [] [] t + +module type S = sig + include Graph.Sig.I + + include Graph.Oper.S with type g := t + + module Topological : sig + val fold : (vertex -> 'a -> 'a) -> t -> 'a -> 'a + end + + val vertex : t -> vertex list + + val edges : t -> (vertex * vertex) list + + val closure : + ?depth:int -> + pred:(vertex -> vertex list Lwt.t) -> + min:vertex list -> + max:vertex list -> + unit -> + t Lwt.t + + val output : + Format.formatter -> + (vertex * Graph.Graphviz.DotAttributes.vertex list) list -> + (vertex * Graph.Graphviz.DotAttributes.edge list * vertex) list -> + string -> + unit + + val min : t -> vertex list + + val max : t -> vertex list + + type dump = vertex list * (vertex * vertex) list + + val export : t -> dump + + val import : dump -> t + + module Dump : Type.S with type t = dump +end + +module Make + (Contents : Type.S) + (Metadata : Type.S) + (Node : Type.S) + (Commit : Type.S) + (Branch : Type.S) = +struct + module X = struct + type t = + [ `Contents of Contents.t * Metadata.t + | `Node of Node.t + | `Commit of Commit.t + | `Branch of Branch.t ] + + let t = + let open Type in + variant "vertex" (fun contents node commit branch -> function + | `Contents x -> contents x + | `Node x -> node x + | `Commit x -> commit x + | `Branch x -> branch x ) + |~ case1 "contents" (pair Contents.t Metadata.t) (fun x -> `Contents x) + |~ case1 "node" Node.t (fun x -> `Node x) + |~ case1 "commit" Commit.t (fun x -> `Commit x) + |~ case1 "branch" Branch.t (fun x -> `Branch x) + |> sealv + + let equal = Type.equal t + + let compare = Type.compare t + + (* we are using cryptographic hashes here, so the first bytes + are good enough to be used as short hashes. *) + let hash (t : t) : int = + match t with + | `Contents (c, _) -> Type.short_hash Contents.t c + | `Node n -> Type.short_hash Node.t n + | `Commit c -> Type.short_hash Commit.t c + | `Branch b -> Type.short_hash Branch.t b + end + + module G = Graph.Imperative.Digraph.ConcreteBidirectional (X) + module GO = Graph.Oper.I (G) + module Topological = Graph.Topological.Make (G) + module Table = Hashtbl.Make (X) + include G + include GO + + type dump = vertex list * (vertex * vertex) list + + (* XXX: for the binary format, we can use offsets in the vertex list + to save space. *) + module Dump = struct + type t = X.t list * (X.t * X.t) list + + let t = Type.(pair (list X.t) (list (pair X.t X.t))) + end + + let vertex g = G.fold_vertex (fun k set -> k :: set) g [] + + let edges g = G.fold_edges (fun k1 k2 list -> (k1, k2) :: list) g [] + + let closure ?(depth = max_int) ~pred ~min ~max () = + Log.debug (fun f -> + f "closure depth=%d (%d elements)" depth (List.length max) ); + let g = G.create ~size:1024 () in + let marks = Table.create 1024 in + let mark key level = Table.add marks key level in + let has_mark key = Table.mem marks key in + List.iter (fun k -> mark k max_int) min; + List.iter (G.add_vertex g) max; + let todo = Queue.create () in + List.iter (fun k -> Queue.push (k, 0) todo) max; + let rec add () = + match Queue.pop todo with + | exception Queue.Empty -> return_unit + | key, level -> + if level >= depth then add () + else if has_mark key then add () + else ( + mark key level; + Log.debug (fun f -> f "ADD %a %d" Type.(pp X.t) key level); + if not (G.mem_vertex g key) then G.add_vertex g key; + pred key >>= fun keys -> + List.iter (fun k -> G.add_edge g k key) keys; + List.iter (fun k -> Queue.push (k, level + 1) todo) keys; + add () ) + in + add () >>= fun () -> Lwt.return g + + let min g = + G.fold_vertex + (fun v acc -> if G.in_degree g v = 0 then v :: acc else acc) + g [] + + let max g = + G.fold_vertex + (fun v acc -> if G.out_degree g v = 0 then v :: acc else acc) + g [] + + let vertex_attributes = ref (fun _ -> []) + + let edge_attributes = ref (fun _ -> []) + + let graph_name = ref None + + module Dot = Graph.Graphviz.Dot (struct + include G + + let edge_attributes k = !edge_attributes k + + let default_edge_attributes _ = [] + + let vertex_name k = + let str t v = Type.to_string t v in + match k with + | `Node n -> str Node.t n + | `Commit c -> str Commit.t c + | `Branch b -> str Branch.t b + | `Contents (c, _) -> str Contents.t c + + let vertex_attributes k = !vertex_attributes k + + let default_vertex_attributes _ = [] + + let get_subgraph _ = None + + let graph_attributes _ = + match !graph_name with None -> [] | Some n -> [ `Label n ] + end) + + let export t = (vertex t, edges t) + + let import (vs, es) = + let g = G.create ~size:(List.length vs) () in + List.iter (G.add_vertex g) vs; + List.iter (fun (v1, v2) -> G.add_edge g v1 v2) es; + g + + let output ppf vertex edges name = + Log.debug (fun f -> f "output %s" name); + let g = G.create ~size:(List.length vertex) () in + List.iter (fun (v, _) -> G.add_vertex g v) vertex; + List.iter (fun (v1, _, v2) -> G.add_edge g v1 v2) edges; + let eattrs (v1, v2) = + try + let l = List.filter (fun (x, _, y) -> x = v1 && y = v2) edges in + let l = List.fold_left (fun acc (_, l, _) -> l @ acc) [] l in + let labels, others = + list_partition_map (function `Label l -> `Fst l | x -> `Snd x) l + in + match labels with + | [] -> others + | [ l ] -> `Label l :: others + | _ -> `Label (String.concat "," labels) :: others + with Not_found -> [] + in + let vattrs v = try List.assoc v vertex with Not_found -> [] in + vertex_attributes := vattrs; + edge_attributes := eattrs; + graph_name := Some name; + Dot.fprint_graph ppf g +end diff --git a/vendors/irmin/object_graph.mli b/vendors/irmin/object_graph.mli new file mode 100644 index 000000000000..0108fea77e47 --- /dev/null +++ b/vendors/irmin/object_graph.mli @@ -0,0 +1,89 @@ +(* + * 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. + *) + +(** Graphs. *) + +module type S = sig + (** Directed graph *) + include Graph.Sig.I + + (** Basic operations. *) + include Graph.Oper.S with type g := t + + (** Topoogical traversal *) + module Topological : sig + val fold : (vertex -> 'a -> 'a) -> t -> 'a -> 'a + end + + val vertex : t -> vertex list + (** Get all the vertices. *) + + val edges : t -> (vertex * vertex) list + (** Get all the relations. *) + + val closure : + ?depth:int -> + pred:(vertex -> vertex list Lwt.t) -> + min:vertex list -> + max:vertex list -> + unit -> + t Lwt.t + (** [closure min max pred] creates the clansitive closure of [max] + using the precedence relation [pred]. The closure will not + contain any keys before the the one specified in [min]. *) + + val output : + Format.formatter -> + (vertex * Graph.Graphviz.DotAttributes.vertex list) list -> + (vertex * Graph.Graphviz.DotAttributes.edge list * vertex) list -> + string -> + unit + (** [output ppf vertex edges name] create aand dumps the graph + contents on [ppf]. The graph is defined by its [vertex] and + [edges]. [name] is the name of the output graph.*) + + val min : t -> vertex list + (** Compute the minimum vertex. *) + + val max : t -> vertex list + (** Compute the maximun vertex. *) + + (** Expose the graph internals. *) + type dump = vertex list * (vertex * vertex) list + + val export : t -> dump + (** Expose the graph as a pair of vertices and edges. *) + + val import : dump -> t + (** Import a graph. *) + + (** The base functions over graph internals. *) + module Dump : Type.S with type t = dump +end + +(** Build a graph. *) +module Make + (Contents : Type.S) + (Metadata : Type.S) + (Node : Type.S) + (Commit : Type.S) + (Branch : Type.S) : + S + with type V.t = + [ `Contents of Contents.t * Metadata.t + | `Node of Node.t + | `Commit of Commit.t + | `Branch of Branch.t ] diff --git a/vendors/irmin/path.ml b/vendors/irmin/path.ml new file mode 100644 index 000000000000..4841ccded6b5 --- /dev/null +++ b/vendors/irmin/path.ml @@ -0,0 +1,56 @@ +(* + * 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 Astring + +module String_list = struct + type step = string + + let step_t = Type.string + + type t = step list + + let empty = [] + + let is_empty l = l = [] + + let cons s t = s :: t + + let rcons t s = t @ [ s ] + + let decons = function [] -> None | h :: t -> Some (h, t) + + let rdecons l = + match List.rev l with [] -> None | h :: t -> Some (List.rev t, h) + + let map l f = List.map f l + + let v x = x + + let pp ppf t = + let len = List.fold_left (fun acc s -> 1 + acc + String.length s) 1 t in + let buf = Buffer.create len in + List.iter + (fun s -> + Buffer.add_char buf '/'; + Buffer.add_string buf s ) + t; + Fmt.string ppf (Buffer.contents buf) + + let of_string s = Ok (List.filter (( <> ) "") (String.cuts s ~sep:"/")) + + let t = Type.like ~cli:(pp, of_string) Type.(list step_t) +end diff --git a/vendors/irmin/path.mli b/vendors/irmin/path.mli new file mode 100644 index 000000000000..fcdf57b13bb3 --- /dev/null +++ b/vendors/irmin/path.mli @@ -0,0 +1,19 @@ +(* + * 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. + *) + +(** Tree path handling. *) + +module String_list : S.PATH with type step = string and type t = string list diff --git a/vendors/irmin/s.ml b/vendors/irmin/s.ml new file mode 100644 index 000000000000..5d138d252032 --- /dev/null +++ b/vendors/irmin/s.ml @@ -0,0 +1,1148 @@ +(* + * 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. + *) + +(** Irmin signatures *) + +module type PATH = sig + type t + + type step + + val empty : t + + val v : 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 + + val t : t Type.t + + val step_t : step Type.t +end + +module type HASH = sig + type t + + val hash : ((string -> unit) -> unit) -> t + + val short_hash : t -> int + + val hash_size : int + + val t : t Type.t +end + +module type TYPED_HASH = sig + type t + + type value + + val hash : value -> t + + val short_hash : t -> int + + val hash_size : int + + val t : t Type.t +end + +module type CONTENTS = sig + include Type.S + + val merge : t option Merge.t +end + +module type CONTENT_ADDRESSABLE_STORE = sig + type 'a t + + type key + + type value + + val mem : [> `Read ] t -> key -> bool Lwt.t + + val find : [> `Read ] t -> key -> value option Lwt.t + + val add : [> `Write ] t -> value -> key Lwt.t + + val unsafe_add : [> `Write ] t -> key -> value -> unit Lwt.t +end + +module type CONTENT_ADDRESSABLE_STORE_MAKER = functor + (K : HASH) + (V : Type.S) + -> sig + include CONTENT_ADDRESSABLE_STORE with type key = K.t and type value = V.t + + val batch : [ `Read ] t -> ([ `Read | `Write ] t -> 'a Lwt.t) -> 'a Lwt.t + + val v : Conf.t -> [ `Read ] t Lwt.t +end + +module type APPEND_ONLY_STORE = sig + type 'a t + + type key + + type value + + val mem : [> `Read ] t -> key -> bool Lwt.t + + val find : [> `Read ] t -> key -> value option Lwt.t + + val add : [> `Write ] t -> key -> value -> unit Lwt.t +end + +module type APPEND_ONLY_STORE_MAKER = functor (K : Type.S) (V : Type.S) -> sig + include APPEND_ONLY_STORE with type key = K.t and type value = V.t + + val batch : [ `Read ] t -> ([ `Read | `Write ] t -> 'a Lwt.t) -> 'a Lwt.t + + val v : Conf.t -> [ `Read ] t Lwt.t +end + +module type METADATA = sig + include Type.S + + val merge : t Merge.t + + val default : t +end + +module type CONTENTS_STORE = sig + include CONTENT_ADDRESSABLE_STORE + + val merge : [ `Read | `Write ] t -> key option Merge.t + + module Key : TYPED_HASH with type t = key and type value = value + + module Val : CONTENTS with type t = value +end + +module type NODE = sig + type t + + type metadata + + type hash + + type step + + type value = [ `Node of hash | `Contents of hash * metadata ] + + val v : (step * value) list -> t + + val list : t -> (step * value) list + + val empty : t + + val is_empty : t -> bool + + val find : t -> step -> value option + + val add : t -> step -> value -> t + + val remove : t -> step -> t + + val t : t Type.t + + val default : metadata + + val metadata_t : metadata Type.t + + val hash_t : hash Type.t + + val step_t : step Type.t + + val value_t : value Type.t +end + +module type NODE_GRAPH = sig + type 'a t + + type metadata + + type contents + + type node + + type step + + type path + + type value = [ `Node of node | `Contents of contents * metadata ] + + val empty : [> `Write ] t -> node Lwt.t + + val v : [> `Write ] t -> (step * value) list -> node Lwt.t + + val list : [> `Read ] t -> node -> (step * value) list Lwt.t + + val find : [> `Read ] t -> node -> path -> value option Lwt.t + + val add : [ `Read | `Write ] t -> node -> path -> value -> node Lwt.t + + val remove : [ `Read | `Write ] t -> node -> path -> node Lwt.t + + val closure : + [> `Read ] t -> min:node list -> max:node list -> node list Lwt.t + + val metadata_t : metadata Type.t + + val contents_t : contents Type.t + + val node_t : node Type.t + + val step_t : step Type.t + + val path_t : path Type.t + + val value_t : value Type.t +end + +module type NODE_STORE = sig + include CONTENT_ADDRESSABLE_STORE + + module Path : PATH + + val merge : [ `Read | `Write ] t -> key option Merge.t + + module Key : TYPED_HASH with type t = key and type value = value + + module Metadata : METADATA + + module Val : + NODE + with type t = value + and type hash = key + and type metadata = Metadata.t + and type step = Path.step + + module Contents : CONTENTS_STORE with type key = Val.hash +end + +type config = Conf.t + +type 'a diff = 'a Diff.t + +module type COMMIT = sig + type t + + type hash + + val v : info:Info.t -> node:hash -> parents:hash list -> t + + val node : t -> hash + + val parents : t -> hash list + + val info : t -> Info.t + + val t : t Type.t + + val hash_t : hash Type.t +end + +module type COMMIT_STORE = sig + include CONTENT_ADDRESSABLE_STORE + + val merge : [ `Read | `Write ] t -> info:Info.f -> key option Merge.t + + module Key : TYPED_HASH with type t = key and type value = value + + module Val : COMMIT with type t = value and type hash = key + + module Node : NODE_STORE with type key = Val.hash +end + +module type COMMIT_HISTORY = sig + type 'a t + + type node + + type commit + + type v + + val v : + [> `Write ] t -> + node:node -> + parents:commit list -> + info:Info.t -> + (commit * v) Lwt.t + + val parents : [> `Read ] t -> commit -> commit list Lwt.t + + val merge : [ `Read | `Write ] t -> info:Info.f -> commit Merge.t + + val lcas : + [> `Read ] t -> + ?max_depth:int -> + ?n:int -> + commit -> + commit -> + (commit list, [ `Max_depth_reached | `Too_many_lcas ]) result Lwt.t + + val lca : + [ `Read | `Write ] t -> + info:Info.f -> + ?max_depth:int -> + ?n:int -> + commit list -> + (commit option, Merge.conflict) result Lwt.t + + val three_way_merge : + [ `Read | `Write ] t -> + info:Info.f -> + ?max_depth:int -> + ?n:int -> + commit -> + commit -> + (commit, Merge.conflict) result Lwt.t + + val closure : + [> `Read ] t -> min:commit list -> max:commit list -> commit list Lwt.t + + val commit_t : commit Type.t +end + +module type SLICE = sig + type t + + type contents + + type node + + type commit + + type value = [ `Contents of contents | `Node of node | `Commit of commit ] + + val empty : unit -> t Lwt.t + + val add : t -> value -> unit Lwt.t + + val iter : t -> (value -> unit Lwt.t) -> unit Lwt.t + + val t : t Type.t + + val contents_t : contents Type.t + + val node_t : node Type.t + + val commit_t : commit Type.t + + val value_t : value Type.t +end + +module type BRANCH = sig + include Type.S + + val master : t + + val is_valid : t -> bool +end + +(** Read-write stores. *) +module type ATOMIC_WRITE_STORE = sig + type t + + type key + + type value + + val mem : t -> key -> bool Lwt.t + + val find : t -> key -> value option Lwt.t + + val set : t -> key -> value -> unit Lwt.t + + val test_and_set : + t -> key -> test:value option -> set:value option -> bool Lwt.t + + val remove : t -> key -> unit Lwt.t + + val list : t -> key list Lwt.t + + type watch + + val watch : + t -> + ?init:(key * value) list -> + (key -> value Diff.t -> unit Lwt.t) -> + watch Lwt.t + + val watch_key : + t -> key -> ?init:value -> (value Diff.t -> unit Lwt.t) -> watch Lwt.t + + val unwatch : t -> watch -> unit Lwt.t +end + +module type ATOMIC_WRITE_STORE_MAKER = functor (K : Type.S) (V : Type.S) -> sig + include ATOMIC_WRITE_STORE with type key = K.t and type value = V.t + + val v : Conf.t -> t Lwt.t +end + +module type BRANCH_STORE = sig + include ATOMIC_WRITE_STORE + + module Key : BRANCH with type t = key + + module Val : HASH with type t = value +end + +type remote = .. + +module type SYNC = sig + type t + + type commit + + type branch + + type endpoint + + val fetch : + t -> + ?depth:int -> + endpoint -> + branch -> + (commit option, [ `Msg of string ]) result Lwt.t + + val push : + t -> + ?depth:int -> + endpoint -> + branch -> + (unit, [ `Msg of string | `Detached_head ]) result Lwt.t +end + +module type PRIVATE = sig + module Hash : HASH + + module Contents : CONTENTS_STORE with type key = Hash.t + + module Node : + NODE_STORE with type key = Hash.t and type Val.hash = Contents.key + + module Commit : + COMMIT_STORE with type key = Hash.t and type Val.hash = Node.key + + module Branch : BRANCH_STORE with type value = Commit.key + + module Slice : + SLICE + with type contents = Contents.key * Contents.value + and type node = Node.key * Node.value + and type commit = Commit.key * Commit.value + + module Repo : sig + type t + + val v : Conf.t -> t Lwt.t + + val contents_t : t -> [ `Read ] Contents.t + + val node_t : t -> [ `Read ] Node.t + + val commit_t : t -> [ `Read ] Commit.t + + val branch_t : t -> Branch.t + + val batch : + t -> + ([ `Read | `Write ] Contents.t -> + [ `Read | `Write ] Node.t -> + [ `Read | `Write ] Commit.t -> + 'a Lwt.t) -> + 'a Lwt.t + end + + module Sync : sig + include SYNC with type commit = Commit.key and type branch = Branch.key + + val v : Repo.t -> t Lwt.t + end +end + +module type TREE = sig + type key + + type step + + type metadata + + type contents + + type node + + type tree = [ `Node of node | `Contents of contents * metadata ] + + val empty : tree + + val of_contents : ?metadata:metadata -> contents -> tree + + val of_node : node -> tree + + val kind : tree -> key -> [ `Contents | `Node ] option Lwt.t + + val list : tree -> key -> (step * [ `Contents | `Node ]) list Lwt.t + + val diff : tree -> tree -> (key * (contents * metadata) diff) list Lwt.t + + val mem : tree -> key -> bool Lwt.t + + val find_all : tree -> key -> (contents * metadata) option Lwt.t + + val find : tree -> key -> contents option Lwt.t + + val get_all : tree -> key -> (contents * metadata) Lwt.t + + val get : tree -> key -> contents Lwt.t + + val add : tree -> key -> ?metadata:metadata -> contents -> tree Lwt.t + + val remove : tree -> key -> tree Lwt.t + + val mem_tree : tree -> key -> bool Lwt.t + + val find_tree : tree -> key -> tree option Lwt.t + + val get_tree : tree -> key -> tree Lwt.t + + val add_tree : tree -> key -> tree -> tree Lwt.t + + val merge : tree Merge.t + + type marks + + val empty_marks : unit -> marks + + type 'a force = [ `True | `False of key -> 'a -> 'a Lwt.t ] + + type uniq = [ `False | `True | `Marks of marks ] + + type 'a node_fn = key -> step list -> 'a -> 'a Lwt.t + + val fold : + ?force:'a force -> + ?uniq:uniq -> + ?pre:'a node_fn -> + ?post:'a node_fn -> + (key -> contents -> 'a -> 'a Lwt.t) -> + tree -> + 'a -> + 'a Lwt.t + + type stats = { + nodes : int; + leafs : int; + skips : int; + depth : int; + width : int + } + + val pp_stats : stats Fmt.t + + val stats : ?force:bool -> tree -> stats Lwt.t + + type concrete = + [ `Tree of (step * concrete) list | `Contents of contents * metadata ] + + val of_concrete : concrete -> tree + + val to_concrete : tree -> concrete Lwt.t + + val clear : ?depth:int -> tree -> unit + + module Cache : sig + val length : unit -> [ `Contents of int ] * [ `Nodes of int ] + + val clear : ?depth:int -> unit -> unit + + val dump : unit Fmt.t + end + + type counters = { + mutable contents_hash : int; + mutable contents_find : int; + mutable contents_add : int; + mutable contents_cache_length : int; + mutable contents_cache_find : int; + mutable contents_cache_miss : int; + mutable node_hash : int; + mutable node_mem : int; + mutable node_add : int; + mutable node_find : int; + mutable node_cache_length : int; + mutable node_cache_find : int; + mutable node_cache_miss : int; + mutable node_val_v : int; + mutable node_val_find : int; + mutable node_val_list : int + } + + val counters : unit -> counters + + val dump_counters : unit Fmt.t + + val reset_counters : unit -> unit + + val inspect : tree -> [ `Contents | `Node of [ `Map | `Hash | `Value ] ] +end + +module type STORE = sig + type repo + + type t + + type step + + type key + + type metadata + + type contents + + type node + + type tree = [ `Node of node | `Contents of contents * metadata ] + + type hash + + type commit + + type branch + + type slice + + type lca_error = [ `Max_depth_reached | `Too_many_lcas ] + + type ff_error = [ `No_change | `Rejected | lca_error ] + + module Repo : sig + type t = repo + + val v : config -> t Lwt.t + + val heads : t -> commit list Lwt.t + + val branches : t -> branch list Lwt.t + + val export : + ?full:bool -> + ?depth:int -> + ?min:commit list -> + ?max:commit list -> + t -> + slice Lwt.t + + val import : t -> slice -> (unit, [ `Msg of string ]) result Lwt.t + end + + val empty : Repo.t -> t Lwt.t + + val master : Repo.t -> t Lwt.t + + val of_branch : Repo.t -> branch -> t Lwt.t + + val of_commit : commit -> t Lwt.t + + val repo : t -> Repo.t + + val tree : t -> tree Lwt.t + + module Status : sig + type t = [ `Empty | `Branch of branch | `Commit of commit ] + + val t : Repo.t -> t Type.t + + val pp : t Fmt.t + end + + val status : t -> Status.t + + module Head : sig + val list : Repo.t -> commit list Lwt.t + + val find : t -> commit option Lwt.t + + val get : t -> commit Lwt.t + + val set : t -> commit -> unit Lwt.t + + val fast_forward : + t -> ?max_depth:int -> ?n:int -> commit -> (unit, ff_error) result Lwt.t + + val test_and_set : + t -> test:commit option -> set:commit option -> bool Lwt.t + + val merge : + into:t -> + info:Info.f -> + ?max_depth:int -> + ?n:int -> + commit -> + (unit, Merge.conflict) result Lwt.t + end + + module Hash : HASH with type t = hash + + module Commit : sig + type t = commit + + val t : Repo.t -> t Type.t + + val pp_hash : t Fmt.t + + val v : Repo.t -> info:Info.t -> parents:hash list -> tree -> commit Lwt.t + + val tree : commit -> tree + + val parents : commit -> hash list + + val info : commit -> Info.t + + val hash : commit -> hash + + val of_hash : Repo.t -> hash -> commit option Lwt.t + end + + module Contents : sig + include CONTENTS with type t = contents + + val hash : contents -> hash + + val of_hash : Repo.t -> hash -> contents option Lwt.t + end + + module Tree : sig + include + TREE + with type step := step + and type key := key + and type metadata := metadata + and type contents := contents + and type node := node + and type tree := tree + + val hash : tree -> hash + + val of_hash : Repo.t -> hash -> tree option Lwt.t + + val shallow : Repo.t -> hash -> tree + end + + val kind : t -> key -> [ `Contents | `Node ] option Lwt.t + + val list : t -> key -> (step * [ `Contents | `Node ]) list Lwt.t + + val mem : t -> key -> bool Lwt.t + + val mem_tree : t -> key -> bool Lwt.t + + val find_all : t -> key -> (contents * metadata) option Lwt.t + + val find : t -> key -> contents option Lwt.t + + val get_all : t -> key -> (contents * metadata) Lwt.t + + val get : t -> key -> contents Lwt.t + + val find_tree : t -> key -> tree option Lwt.t + + val get_tree : t -> key -> tree Lwt.t + + val hash : t -> key -> hash option Lwt.t + + type write_error = + [ Merge.conflict | `Too_many_retries of int | `Test_was of tree option ] + + val set : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + contents -> + (unit, write_error) result Lwt.t + + val set_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + contents -> + unit Lwt.t + + val set_tree : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + tree -> + (unit, write_error) result Lwt.t + + val set_tree_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + tree -> + unit Lwt.t + + val remove : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + (unit, write_error) result Lwt.t + + val remove_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + unit Lwt.t + + val test_and_set : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + test:contents option -> + set:contents option -> + (unit, write_error) result Lwt.t + + val test_and_set_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + test:contents option -> + set:contents option -> + unit Lwt.t + + val test_and_set_tree : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + test:tree option -> + set:tree option -> + (unit, write_error) result Lwt.t + + val test_and_set_tree_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + key -> + test:tree option -> + set:tree option -> + unit Lwt.t + + val merge : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:contents option -> + t -> + key -> + contents option -> + (unit, write_error) result Lwt.t + + val merge_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:contents option -> + t -> + key -> + contents option -> + unit Lwt.t + + val merge_tree : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:tree option -> + t -> + key -> + tree option -> + (unit, write_error) result Lwt.t + + val merge_tree_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:tree option -> + t -> + key -> + tree option -> + unit Lwt.t + + val with_tree : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + ?strategy:[ `Set | `Test_and_set | `Merge ] -> + info:Info.f -> + t -> + key -> + (tree option -> tree option Lwt.t) -> + (unit, write_error) result Lwt.t + + val with_tree_exn : + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + ?strategy:[ `Set | `Test_and_set | `Merge ] -> + info:Info.f -> + t -> + key -> + (tree option -> tree option Lwt.t) -> + unit Lwt.t + + val clone : src:t -> dst:branch -> t Lwt.t + + type watch + + val watch : t -> ?init:commit -> (commit diff -> unit Lwt.t) -> watch Lwt.t + + val watch_key : + t -> + key -> + ?init:commit -> + ((commit * tree) diff -> unit Lwt.t) -> + watch Lwt.t + + val unwatch : watch -> unit Lwt.t + + type 'a merge = + info:Info.f -> + ?max_depth:int -> + ?n:int -> + 'a -> + (unit, Merge.conflict) result Lwt.t + + val merge_into : into:t -> t merge + + val merge_with_branch : t -> branch merge + + val merge_with_commit : t -> commit merge + + val lcas : + ?max_depth:int -> ?n:int -> t -> t -> (commit list, lca_error) result Lwt.t + + val lcas_with_branch : + t -> + ?max_depth:int -> + ?n:int -> + branch -> + (commit list, lca_error) result Lwt.t + + val lcas_with_commit : + t -> + ?max_depth:int -> + ?n:int -> + commit -> + (commit list, lca_error) result Lwt.t + + module History : Graph.Sig.P with type V.t = commit + + val history : + ?depth:int -> ?min:commit list -> ?max:commit list -> t -> History.t Lwt.t + + val last_modified : ?depth:int -> ?n:int -> t -> key -> commit list Lwt.t + + module Branch : sig + val mem : Repo.t -> branch -> bool Lwt.t + + val find : Repo.t -> branch -> commit option Lwt.t + + val get : Repo.t -> branch -> commit Lwt.t + + val set : Repo.t -> branch -> commit -> unit Lwt.t + + val remove : Repo.t -> branch -> unit Lwt.t + + val list : Repo.t -> branch list Lwt.t + + val watch : + Repo.t -> + branch -> + ?init:commit -> + (commit diff -> unit Lwt.t) -> + watch Lwt.t + + val watch_all : + Repo.t -> + ?init:(branch * commit) list -> + (branch -> commit diff -> unit Lwt.t) -> + watch Lwt.t + + include BRANCH with type t = branch + end + + module Key : PATH with type t = key and type step = step + + module Metadata : METADATA with type t = metadata + + val step_t : step Type.t + + val key_t : key Type.t + + val metadata_t : metadata Type.t + + val contents_t : contents Type.t + + val node_t : node Type.t + + val tree_t : tree Type.t + + val commit_t : Repo.t -> commit Type.t + + val branch_t : branch Type.t + + val slice_t : slice Type.t + + val kind_t : [ `Contents | `Node ] Type.t + + val lca_error_t : lca_error Type.t + + val ff_error_t : ff_error Type.t + + val write_error_t : write_error Type.t + + module Private : sig + include + PRIVATE + with type Contents.value = contents + and module Hash = Hash + and module Node.Path = Key + and type Node.Metadata.t = metadata + and type Branch.key = branch + and type Slice.t = slice + and type Repo.t = repo + end + + type remote += E of Private.Sync.endpoint + + val to_private_node : node -> Private.Node.value option Lwt.t + + val of_private_node : repo -> Private.Node.value -> node + + val to_private_commit : commit -> Private.Commit.value + + val of_private_commit : repo -> Private.Commit.value -> commit + + val save_contents : [> `Write ] Private.Contents.t -> contents -> hash Lwt.t + + val save_tree : + ?clear:bool -> + repo -> + [> `Write ] Private.Contents.t -> + [ `Read | `Write ] Private.Node.t -> + tree -> + hash Lwt.t +end + +module type MAKER = functor + (M : METADATA) + (C : CONTENTS) + (P : PATH) + (B : BRANCH) + (H : HASH) + -> STORE + with type key = P.t + and type step = P.step + and type metadata = M.t + and type contents = C.t + and type branch = B.t + and type hash = H.t + +type remote += Store : (module STORE with type t = 'a) * 'a -> remote + +module type SYNC_STORE = sig + type db + + type commit + + type push_error = [ `Msg of string | `Detached_head ] + + type pull_error = [ `Msg of string | Merge.conflict ] + + type status = [ `Empty | `Head of commit ] + + val status_t : db -> status Type.t + + val pp_status : status Fmt.t + + val fetch : + db -> ?depth:int -> remote -> (status, [ `Msg of string ]) result Lwt.t + + val fetch_exn : db -> ?depth:int -> remote -> status Lwt.t + + val pp_pull_error : pull_error Fmt.t + + val pull : + db -> + ?depth:int -> + remote -> + [ `Merge of Info.f | `Set ] -> + (status, pull_error) result Lwt.t + + val pull_exn : + db -> ?depth:int -> remote -> [ `Merge of Info.f | `Set ] -> status Lwt.t + + val pp_push_error : push_error Fmt.t + + val push : db -> ?depth:int -> remote -> (status, push_error) result Lwt.t + + val push_exn : db -> ?depth:int -> remote -> status Lwt.t +end diff --git a/vendors/irmin/slice.ml b/vendors/irmin/slice.ml new file mode 100644 index 000000000000..1d553bed1b27 --- /dev/null +++ b/vendors/irmin/slice.ml @@ -0,0 +1,83 @@ +(* + * 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. + *) + +module Make + (Contents : S.CONTENTS_STORE) + (Node : S.NODE_STORE) + (Commit : S.COMMIT_STORE) = +struct + type contents = Contents.key * Contents.value + + type node = Node.key * Node.value + + type commit = Commit.key * Commit.value + + type value = [ `Contents of contents | `Node of node | `Commit of commit ] + + type t = { + mutable contents : (Contents.key * Contents.value) list; + mutable nodes : (Node.key * Node.value) list; + mutable commits : (Commit.key * Commit.value) list + } + + let t = + let open Type in + record "slice" (fun contents nodes commits -> { contents; nodes; commits }) + |+ field "contents" + (list (pair Contents.Key.t Contents.Val.t)) + (fun t -> t.contents) + |+ field "nodes" (list (pair Node.Key.t Node.Val.t)) (fun t -> t.nodes) + |+ field "commits" + (list (pair Commit.Key.t Commit.Val.t)) + (fun t -> t.commits) + |> sealr + + let empty () = Lwt.return { contents = []; nodes = []; commits = [] } + + let add t = function + | `Contents c -> + t.contents <- c :: t.contents; + Lwt.return_unit + | `Node n -> + t.nodes <- n :: t.nodes; + Lwt.return_unit + | `Commit c -> + t.commits <- c :: t.commits; + Lwt.return_unit + + let iter t f = + Lwt.choose + [ Lwt_list.iter_p (fun c -> f (`Contents c)) t.contents; + Lwt_list.iter_p (fun n -> f (`Node n)) t.nodes; + Lwt_list.iter_p (fun c -> f (`Commit c)) t.commits + ] + + let contents_t = Type.pair Contents.Key.t Contents.Val.t + + let node_t = Type.pair Node.Key.t Node.Val.t + + let commit_t = Type.pair Commit.Key.t Commit.Val.t + + let value_t = + let open Type in + variant "slice" (fun contents node commit -> function + | `Contents x -> contents x | `Node x -> node x | `Commit x -> commit x + ) + |~ case1 "contents" contents_t (fun x -> `Contents x) + |~ case1 "node" node_t (fun x -> `Node x) + |~ case1 "commit" commit_t (fun x -> `Commit x) + |> sealv +end diff --git a/vendors/irmin/slice.mli b/vendors/irmin/slice.mli new file mode 100644 index 000000000000..7c91911a21e4 --- /dev/null +++ b/vendors/irmin/slice.mli @@ -0,0 +1,21 @@ +(* + * 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. + *) + +module Make (C : S.CONTENTS_STORE) (N : S.NODE_STORE) (H : S.COMMIT_STORE) : + S.SLICE + with type contents = C.key * C.value + and type node = N.key * N.value + and type commit = H.key * H.value diff --git a/vendors/irmin/store.ml b/vendors/irmin/store.ml new file mode 100644 index 000000000000..a476f81c41fc --- /dev/null +++ b/vendors/irmin/store.ml @@ -0,0 +1,1131 @@ +(* + * 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 +open Merge.Infix + +let src = Logs.Src.create "irmin" ~doc:"Irmin branch-consistent store" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Content_addressable + (AO : S.APPEND_ONLY_STORE_MAKER) + (K : S.HASH) + (V : Type.S) = +struct + include AO (K) (V) + open Lwt.Infix + module H = Hash.Typed (K) (V) + + let hash = H.hash + + let pp_key = Type.pp K.t + + let find t k = + find t k >>= function + | None -> Lwt.return None + | Some v as r -> + let k' = hash v in + if Type.equal K.t k k' then Lwt.return r + else + Fmt.kstrf Lwt.fail_invalid_arg + "corrupted value: got %a, expecting %a" pp_key k' pp_key k + + let unsafe_add t k v = add t k v + + let add t v = + let k = hash v in + add t k v >|= fun () -> k +end + +module Make (P : S.PRIVATE) = struct + module Branch_store = P.Branch + + type branch = Branch_store.key + + module Hash = P.Hash + + type hash = Hash.t + + type lca_error = [ `Max_depth_reached | `Too_many_lcas ] + + type ff_error = [ `No_change | `Rejected | lca_error ] + + module Key = P.Node.Path + + type key = Key.t + + module Metadata = P.Node.Metadata + module H = Commit.History (P.Commit) + + type S.remote += E of P.Sync.endpoint + + module Contents = struct + include P.Contents.Val + + let of_hash r h = P.Contents.find (P.Repo.contents_t r) h + + let hash c = P.Contents.Key.hash c + end + + module Tree = struct + include Tree.Make (P) + + let of_hash r h = + import r h >|= function Some t -> Some (`Node t) | None -> None + + let shallow r h = `Node (import_no_check r h) + + let hash : tree -> hash = + fun tr -> match hash tr with `Node h -> h | `Contents (h, _) -> h + end + + let save_contents b c = P.Contents.add b c + + let save_tree ?(clear = true) r x y (tr : Tree.tree) = + match tr with + | `Contents (c, _) -> save_contents x c + | `Node n -> Tree.export ~clear r x y n + + type node = Tree.node + + type contents = Contents.t + + type metadata = Metadata.t + + type tree = Tree.tree + + type repo = P.Repo.t + + module Commit = struct + type t = { r : repo; h : Hash.t; v : P.Commit.value } + + let t r = + let open Type in + record "commit" (fun h v -> { r; h; v }) + |+ field "hash" Hash.t (fun t -> t.h) + |+ field "value" P.Commit.Val.t (fun t -> t.v) + |> sealr + + let v r ~info ~parents tree = + P.Repo.batch r @@ fun contents_t node_t commit_t -> + ( match tree with + | `Node n -> Tree.export r contents_t node_t n + | `Contents _ -> Lwt.fail_invalid_arg "cannot add contents at the root" + ) + >>= fun node -> + let v = P.Commit.Val.v ~info ~node ~parents in + P.Commit.add commit_t v >|= fun h -> { r; h; v } + + let node t = P.Commit.Val.node t.v + + let tree t = Tree.import_no_check t.r (node t) |> fun n -> `Node n + + let equal x y = Type.equal Hash.t x.h y.h + + let hash t = t.h + + let info t = P.Commit.Val.info t.v + + let parents t = P.Commit.Val.parents t.v + + let pp_hash ppf t = Type.pp Hash.t ppf t.h + + let of_hash r h = + P.Commit.find (P.Repo.commit_t r) h >|= function + | None -> None + | Some v -> Some { r; h; v } + + let to_private_commit t = t.v + + let of_private_commit r v = + let h = P.Commit.Key.hash v in + { r; h; v } + + let equal_opt x y = + match (x, y) with + | None, None -> true + | Some x, Some y -> equal x y + | _ -> false + end + + type commit = Commit.t + + let to_private_node = Tree.to_private_node + + let of_private_node = Tree.of_private_node + + let to_private_commit = Commit.to_private_commit + + let of_private_commit = Commit.of_private_commit + + type head_ref = [ `Branch of branch | `Head of commit option ref ] + + module OCamlGraph = Graph + module Graph = Node.Graph (P.Node) + module KGraph = + Object_graph.Make (P.Contents.Key) (P.Node.Metadata) (P.Node.Key) + (P.Commit.Key) + (Branch_store.Key) + + type slice = P.Slice.t + + type watch = unit -> unit Lwt.t + + let unwatch w = w () + + module Repo = struct + type t = repo + + let v = P.Repo.v + + let graph_t t = P.Repo.node_t t + + let history_t t = P.Repo.commit_t t + + let branch_t t = P.Repo.branch_t t + + let commit_t t = P.Repo.commit_t t + + let node_t t = P.Repo.node_t t + + let contents_t t = P.Repo.contents_t t + + let branches t = P.Branch.list (branch_t t) + + let heads repo = + let t = branch_t repo in + Branch_store.list t >>= fun bs -> + Lwt_list.fold_left_s + (fun acc r -> + Branch_store.find t r >>= function + | None -> Lwt.return acc + | Some h -> ( + Commit.of_hash repo h >|= function + | None -> acc + | Some h -> h :: acc ) ) + [] bs + + let export ?(full = true) ?depth ?(min = []) ?(max = []) t = + Log.debug (fun f -> + f "export depth=%s full=%b min=%d max=%d" + (match depth with None -> "" | Some d -> string_of_int d) + full (List.length min) (List.length max) ); + (match max with [] -> heads t | m -> Lwt.return m) >>= fun max -> + P.Slice.empty () >>= fun slice -> + let max = List.map (fun x -> `Commit x.Commit.h) max in + let min = List.map (fun x -> `Commit x.Commit.h) min in + let pred = function + | `Commit k -> + H.parents (history_t t) k >|= fun parents -> + List.map (fun x -> `Commit x) parents + | _ -> Lwt.return_nil + in + KGraph.closure ?depth ~pred ~min ~max () >>= fun g -> + let keys = + List.fold_left + (fun acc -> function `Commit c -> c :: acc | _ -> acc) + [] (KGraph.vertex g) + in + let root_nodes = ref [] in + Lwt_list.iter_p + (fun k -> + P.Commit.find (commit_t t) k >>= function + | None -> Lwt.return_unit + | Some c -> + root_nodes := P.Commit.Val.node c :: !root_nodes; + P.Slice.add slice (`Commit (k, c)) ) + keys + >>= fun () -> + if not full then Lwt.return slice + else + (* XXX: we can compute a [min] if needed *) + Graph.closure (graph_t t) ~min:[] ~max:!root_nodes >>= fun nodes -> + let module KSet = Set.Make (struct + type t = P.Contents.key + + let compare = Type.compare P.Contents.Key.t + end) in + let contents = ref KSet.empty in + Lwt_list.iter_p + (fun k -> + P.Node.find (node_t t) k >>= function + | None -> Lwt.return_unit + | Some v -> + List.iter + (function + | _, `Contents (c, _) -> contents := KSet.add c !contents + | _ -> () ) + (P.Node.Val.list v); + P.Slice.add slice (`Node (k, v)) ) + nodes + >>= fun () -> + Lwt_list.iter_p + (fun k -> + P.Contents.find (contents_t t) k >>= function + | None -> Lwt.return_unit + | Some m -> P.Slice.add slice (`Contents (k, m)) ) + (KSet.elements !contents) + >|= fun () -> slice + + exception Import_error of string + + let import_error fmt = Fmt.kstrf (fun x -> Lwt.fail (Import_error x)) fmt + + let import t s = + let aux name add dk (k, v) = + add v >>= fun k' -> + if not (Type.equal dk k k') then + import_error "%s import error: expected %a, got %a" name + Type.(pp dk) + k + Type.(pp dk) + k' + else Lwt.return_unit + in + let contents = ref [] in + let nodes = ref [] in + let commits = ref [] in + P.Slice.iter s (function + | `Contents c -> + contents := c :: !contents; + Lwt.return_unit + | `Node n -> + nodes := n :: !nodes; + Lwt.return_unit + | `Commit c -> + commits := c :: !commits; + Lwt.return_unit ) + >>= fun () -> + P.Repo.batch t @@ fun contents_t node_t commit_t -> + Lwt.catch + (fun () -> + Lwt_list.iter_p + (aux "Contents" (P.Contents.add contents_t) P.Contents.Key.t) + !contents + >>= fun () -> + Lwt_list.iter_p (aux "Node" (P.Node.add node_t) P.Node.Key.t) !nodes + >>= fun () -> + Lwt_list.iter_p + (aux "Commit" (P.Commit.add commit_t) P.Commit.Key.t) + !commits + >|= fun () -> Ok () ) + (function + | Import_error e -> Lwt.return (Error (`Msg e)) + | e -> Fmt.kstrf Lwt.fail_invalid_arg "impot error: %a" Fmt.exn e ) + end + + type t = { + repo : Repo.t; + head_ref : head_ref; + mutable tree : (commit * tree) option; + (* cache for the store tree *) + lock : Lwt_mutex.t + } + + type step = Key.step + + let repo t = t.repo + + let branch_t t = Repo.branch_t t.repo + + let commit_t t = Repo.commit_t t.repo + + let history_t t = commit_t t + + let status t = + match t.head_ref with + | `Branch b -> `Branch b + | `Head h -> ( match !h with None -> `Empty | Some c -> `Commit c ) + + let head_ref t = + match t.head_ref with + | `Branch t -> `Branch t + | `Head h -> ( match !h with None -> `Empty | Some h -> `Head h ) + + let branch t = + match head_ref t with + | `Branch t -> Lwt.return (Some t) + | `Empty | `Head _ -> Lwt.return_none + + let err_no_head s = Fmt.kstrf Lwt.fail_invalid_arg "Irmin.%s: no head" s + + let retry_merge name fn = + let rec aux i = + fn () >>= function + | Error _ as c -> Lwt.return c + | Ok true -> Merge.ok () + | Ok false -> + Log.debug (fun f -> f "Irmin.%s: conflict, retrying (%d)." name i); + aux (i + 1) + in + aux 1 + + let of_ref repo head_ref = + let lock = Lwt_mutex.create () in + Lwt.return { lock; head_ref; repo; tree = None } + + let pp_branch = Type.pp Branch_store.Key.t + + let err_invalid_branch t = + let err = Fmt.strf "%a is not a valid branch name." pp_branch t in + Lwt.fail (Invalid_argument err) + + let of_branch repo id = + if Branch_store.Key.is_valid id then of_ref repo (`Branch id) + else err_invalid_branch id + + let master repo = of_branch repo Branch_store.Key.master + + let empty repo = of_ref repo (`Head (ref None)) + + let of_commit c = of_ref c.Commit.r (`Head (ref (Some c))) + + let pp_key = Type.pp Key.t + + let skip_key key = + Log.debug (fun l -> l "[watch-key] key %a has not changed" pp_key key); + Lwt.return () + + let changed_key key = + Log.debug (fun l -> l "[watch-key] key %a has changed" pp_key key) + + let with_tree ~key x f = + x >>= function + | None -> skip_key key + | Some x -> + changed_key key; + f x + + let lift_tree_diff ~key tree fn = function + | `Removed x -> with_tree ~key (tree x) @@ fun v -> fn @@ `Removed (x, v) + | `Added x -> with_tree ~key (tree x) @@ fun v -> fn @@ `Added (x, v) + | `Updated (x, y) -> ( + assert (not (Commit.equal x y)); + tree x >>= fun vx -> + tree y >>= fun vy -> + match (vx, vy) with + | None, None -> skip_key key + | None, Some vy -> + changed_key key; + fn @@ `Added (y, vy) + | Some vx, None -> + changed_key key; + fn @@ `Removed (x, vx) + | Some vx, Some vy -> + if Tree.equal vx vy then skip_key key + else ( + changed_key key; + fn @@ `Updated ((x, vx), (y, vy)) ) ) + + let head t = + let h = + match head_ref t with + | `Head key -> Lwt.return (Some key) + | `Empty -> Lwt.return_none + | `Branch name -> ( + Branch_store.find (branch_t t) name >>= function + | None -> Lwt.return_none + | Some h -> Commit.of_hash t.repo h ) + in + h >|= fun h -> + Log.debug (fun f -> f "Head.find -> %a" Fmt.(option Commit.pp_hash) h); + h + + let tree_and_head t = + head t >|= function + | None -> None + | Some h -> ( + match t.tree with + | Some (o, t) when Commit.equal o h -> Some (o, t) + | _ -> + t.tree <- None; + (* the tree cache needs to be invalidated *) + let n = Tree.import_no_check (repo t) (Commit.node h) in + let tree = `Node n in + t.tree <- Some (h, tree); + Some (h, tree) ) + + let tree t = + tree_and_head t >|= function + | None -> Tree.empty + | Some (_, tree) -> (tree :> tree) + + let lift_head_diff repo fn = function + | `Removed x -> ( + Commit.of_hash repo x >>= function + | None -> Lwt.return_unit + | Some x -> fn (`Removed x) ) + | `Updated (x, y) -> ( + Commit.of_hash repo x >>= fun x -> + Commit.of_hash repo y >>= fun y -> + match (x, y) with + | None, None -> Lwt.return_unit + | Some x, None -> fn (`Removed x) + | None, Some y -> fn (`Added y) + | Some x, Some y -> fn (`Updated (x, y)) ) + | `Added x -> ( + Commit.of_hash repo x >>= function + | None -> Lwt.return_unit + | Some x -> fn (`Added x) ) + + let watch t ?init fn = + branch t >>= function + | None -> failwith "watch a detached head: TODO" + | Some name0 -> + let init = + match init with + | None -> None + | Some head0 -> Some [ (name0, head0.Commit.h) ] + in + Branch_store.watch (branch_t t) ?init (fun name head -> + if Type.equal Branch_store.Key.t name0 name then + lift_head_diff t.repo fn head + else Lwt.return_unit ) + >|= fun id () -> Branch_store.unwatch (branch_t t) id + + let pp_key = Type.pp Key.t + + let watch_key t key ?init fn = + Log.info (fun f -> f "watch-key %a" pp_key key); + let tree c = Tree.find_tree (Commit.tree c) key in + watch t ?init (lift_tree_diff ~key tree fn) + + module Head = struct + let list = Repo.heads + + let find = head + + let get t = + find t >>= function None -> err_no_head "head" | Some k -> Lwt.return k + + let set t c = + match t.head_ref with + | `Head h -> + h := Some c; + Lwt.return_unit + | `Branch name -> Branch_store.set (branch_t t) name c.Commit.h + + let test_and_set_unsafe t ~test ~set = + match t.head_ref with + | `Head head -> + (* [head] is protected by [t.lock]. *) + if Commit.equal_opt !head test then ( + head := set; + Lwt.return true ) + else Lwt.return false + | `Branch name -> + let h = function None -> None | Some c -> Some c.Commit.h in + Branch_store.test_and_set (branch_t t) name ~test:(h test) + ~set:(h set) + + let test_and_set t ~test ~set = + Lwt_mutex.with_lock t.lock (fun () -> test_and_set_unsafe t ~test ~set) + + type ff_error = [ `Rejected | `No_change | lca_error ] + + let fast_forward t ?max_depth ?n new_head = + let return x = if x then Ok () else Error (`Rejected :> ff_error) in + find t >>= function + | None -> test_and_set t ~test:None ~set:(Some new_head) >|= return + | Some old_head -> ( + Log.debug (fun f -> + f "fast-forward-head old=%a new=%a" Commit.pp_hash old_head + Commit.pp_hash new_head ); + if Commit.equal new_head old_head then + (* we only update if there is a change *) + Lwt.return (Error `No_change) + else + H.lcas (history_t t) ?max_depth ?n new_head.Commit.h + old_head.Commit.h + >>= function + | Ok [ x ] when Type.equal Hash.t x old_head.Commit.h -> + (* we only update if new_head > old_head *) + test_and_set t ~test:(Some old_head) ~set:(Some new_head) + >|= return + | Ok _ -> Lwt.return (Error `Rejected) + | Error e -> Lwt.return (Error (e :> ff_error)) ) + + (* Merge two commits: + - Search for common ancestors + - Perform recursive 3-way merges *) + let three_way_merge t ?max_depth ?n ~info c1 c2 = + P.Repo.batch (repo t) @@ fun _ _ commit_t -> + H.three_way_merge commit_t ?max_depth ?n ~info c1.Commit.h c2.Commit.h + + (* FIXME: we might want to keep the new commit in case of conflict, + and use it as a base for the next merge. *) + let merge ~into:t ~info ?max_depth ?n c1 = + Log.debug (fun f -> f "merge_head"); + let aux () = + head t >>= fun head -> + match head with + | None -> test_and_set_unsafe t ~test:head ~set:(Some c1) >>= Merge.ok + | Some c2 -> + three_way_merge t ~info ?max_depth ?n c1 c2 >>=* fun c3 -> + Commit.of_hash t.repo c3 >>= fun c3 -> + test_and_set_unsafe t ~test:head ~set:c3 >>= Merge.ok + in + Lwt_mutex.with_lock t.lock (fun () -> retry_merge "merge_head" aux) + end + + (* Retry an operation until the optimistic lock is happy. Ensure + that the operation is done at least once. *) + let retry ~retries fn = + let done_once = ref false in + let rec aux i = + if !done_once && i > retries then + Lwt.return (Error (`Too_many_retries retries)) + else + fn () >>= function + | Ok true -> Lwt.return (Ok ()) + | Error e -> Lwt.return (Error e) + | Ok false -> + done_once := true; + aux (i + 1) + in + aux 0 + + let root_tree = function `Node _ as n -> n | `Contents _ -> assert false + + let add_commit t old_head ((c, _) as tree) = + match t.head_ref with + | `Head head -> + Lwt_mutex.with_lock t.lock (fun () -> + if not (Commit.equal_opt old_head !head) then Lwt.return false + else ( + (* [head] is protected by [t.lock] *) + head := Some c; + t.tree <- Some tree; + Lwt.return true ) ) + | `Branch name -> + (* concurrent handlers and/or process can modify the + branch. Need to check that we are still working on the same + head. *) + let test = + match old_head with None -> None | Some c -> Some (Commit.hash c) + in + let set = Some (Commit.hash c) in + Branch_store.test_and_set (branch_t t) name ~test ~set >|= fun r -> + if r then t.tree <- Some tree; + r + + type write_error = + [ Merge.conflict | `Too_many_retries of int | `Test_was of tree option ] + + let pp_write_error ppf = function + | `Conflict e -> Fmt.pf ppf "Got a conflict: %s" e + | `Too_many_retries i -> + Fmt.pf ppf + "Failure after %d attempts to retry the operation: Too many attempts." + i + | `Test_was t -> + Fmt.pf ppf "Test-and-set failed: got %a when reading the store" + Type.(pp (option Tree.tree_t)) + t + + let write_error e : ('a, write_error) result Lwt.t = Lwt.return (Error e) + + let err_test v = write_error (`Test_was v) + + type snapshot = { + head : commit option; + root : tree; + tree : tree option; + (* the subtree used by the transaction *) + parents : commit list + } + + let snapshot t key = + tree_and_head t >>= function + | None -> + Lwt.return + { head = None; root = Tree.empty; tree = None; parents = [] } + | Some (c, root) -> + let root = (root :> tree) in + Tree.find_tree root key >|= fun tree -> + { head = Some c; root; tree; parents = [ c ] } + + let same_tree x y = + match (x, y) with + | None, None -> true + | None, _ | _, None -> false + | Some x, Some y -> Tree.equal x y + + (* Update the store with a new commit. Ensure the no commit becomes orphan + in the process. *) + let update ?(allow_empty = false) ~info ?parents t key merge_tree f = + snapshot t key >>= fun s -> + (* this might take a very long time *) + f s.tree >>= fun new_tree -> + (* if no change and [allow_empty = true] then, do nothing *) + if same_tree s.tree new_tree && (not allow_empty) && s.head <> None then + Lwt.return (Ok true) + else + merge_tree s.root key ~current_tree:s.tree ~new_tree >>= function + | Error _ as e -> Lwt.return e + | Ok root -> + let info = info () in + let parents = match parents with None -> s.parents | Some p -> p in + let parents = List.map Commit.hash parents in + Commit.v (repo t) ~info ~parents root >>= fun c -> + add_commit t s.head (c, root_tree root) >|= fun r -> Ok r + + let ok x = Ok x + + let fail name = function + | Ok x -> Lwt.return x + | Error e -> Fmt.kstrf Lwt.fail_with "%s: %a" name pp_write_error e + + let set_tree_once root key ~current_tree:_ ~new_tree = + match new_tree with + | None -> Tree.remove root key >|= ok + | Some tree -> Tree.add_tree root key tree >|= ok + + let set_tree ?(retries = 13) ?allow_empty ?parents ~info t k v = + Log.debug (fun l -> l "set %a" pp_key k); + retry ~retries @@ fun () -> + update t k ?allow_empty ?parents ~info set_tree_once @@ fun _tree -> + Lwt.return (Some v) + + let set_tree_exn ?retries ?allow_empty ?parents ~info t k v = + set_tree ?retries ?allow_empty ?parents ~info t k v >>= fail "set_exn" + + let remove ?(retries = 13) ?allow_empty ?parents ~info t k = + Log.debug (fun l -> l "debug %a" pp_key k); + retry ~retries @@ fun () -> + update t k ?allow_empty ?parents ~info set_tree_once @@ fun _tree -> + Lwt.return None + + let remove_exn ?retries ?allow_empty ?parents ~info t k = + remove ?retries ?allow_empty ?parents ~info t k >>= fail "remove_exn" + + let set ?retries ?allow_empty ?parents ~info t k v = + let v = `Contents (v, Metadata.default) in + set_tree t k ?retries ?allow_empty ?parents ~info v + + let set_exn ?retries ?allow_empty ?parents ~info t k v = + set t k ?retries ?allow_empty ?parents ~info v >>= fail "set_exn" + + let test_and_set_tree_once ~test root key ~current_tree ~new_tree = + match (test, current_tree) with + | None, None -> set_tree_once root key ~new_tree ~current_tree + | None, _ | _, None -> err_test current_tree + | Some test, Some v -> + if Tree.equal test v then + set_tree_once root key ~new_tree ~current_tree + else err_test current_tree + + let test_and_set_tree ?(retries = 13) ?allow_empty ?parents ~info t k ~test + ~set = + Log.debug (fun l -> l "test-and-set %a" pp_key k); + retry ~retries @@ fun () -> + update t k ?allow_empty ?parents ~info (test_and_set_tree_once ~test) + @@ fun _tree -> Lwt.return set + + let test_and_set_tree_exn ?retries ?allow_empty ?parents ~info t k ~test ~set + = + test_and_set_tree ?retries ?allow_empty ?parents ~info t k ~test ~set + >>= fail "test_and_set_tree_exn" + + let test_and_set ?retries ?allow_empty ?parents ~info t k ~test ~set = + let test = + match test with + | None -> None + | Some t -> Some (`Contents (t, Metadata.default)) + in + let set = + match set with + | None -> None + | Some s -> Some (`Contents (s, Metadata.default)) + in + test_and_set_tree ?retries ?allow_empty ?parents ~info t k ~test ~set + + let test_and_set_exn ?retries ?allow_empty ?parents ~info t k ~test ~set = + test_and_set ?retries ?allow_empty ?parents ~info t k ~test ~set + >>= fail "test_and_set_exn" + + let merge_once ~old root key ~current_tree ~new_tree = + let old = Merge.promise old in + Merge.f (Merge.option Tree.merge) ~old current_tree new_tree >>= function + | Ok tr -> set_tree_once root key ~new_tree:tr ~current_tree + | Error e -> write_error (e :> write_error) + + let merge_tree ?(retries = 13) ?allow_empty ?parents ~info ~old t k tree = + Log.debug (fun l -> l "merge %a" pp_key k); + retry ~retries @@ fun () -> + update t k ?allow_empty ?parents ~info (merge_once ~old) @@ fun _tree -> + Lwt.return tree + + let merge_tree_exn ?retries ?allow_empty ?parents ~info ~old t k tree = + merge_tree ?retries ?allow_empty ?parents ~info ~old t k tree + >>= fail "merge_tree_exn" + + let merge ?retries ?allow_empty ?parents ~info ~old t k v = + let old = + match old with + | None -> None + | Some v -> Some (`Contents (v, Metadata.default)) + in + let v = + match v with + | None -> None + | Some v -> Some (`Contents (v, Metadata.default)) + in + merge_tree ?retries ?allow_empty ?parents ~info ~old t k v + + let merge_exn ?retries ?allow_empty ?parents ~info ~old t k v = + merge ?retries ?allow_empty ?parents ~info ~old t k v >>= fail "merge_exn" + + let mem t k = tree t >>= fun tree -> Tree.mem tree k + + let mem_tree t k = tree t >>= fun tree -> Tree.mem_tree tree k + + let find_all t k = tree t >>= fun tree -> Tree.find_all tree k + + let find t k = tree t >>= fun tree -> Tree.find tree k + + let get t k = tree t >>= fun tree -> Tree.get tree k + + let find_tree t k = tree t >>= fun tree -> Tree.find_tree tree k + + let get_tree t k = tree t >>= fun tree -> Tree.get_tree tree k + + let hash t k = + find_tree t k >|= function + | None -> None + | Some tree -> Some (Tree.hash tree) + + let get_all t k = tree t >>= fun tree -> Tree.get_all tree k + + let list t k = tree t >>= fun tree -> Tree.list tree k + + let kind t k = tree t >>= fun tree -> Tree.kind tree k + + let with_tree ?(retries = 13) ?allow_empty ?parents + ?(strategy = `Test_and_set) ~info t key f = + let done_once = ref false in + let rec aux n old_tree = + Log.debug (fun l -> l "with_tree %a (%d/%d)" pp_key key n retries); + if !done_once && n > retries then write_error (`Too_many_retries retries) + else + f old_tree >>= fun new_tree -> + match (strategy, new_tree) with + | `Set, Some tree -> + set_tree t key ~retries ?allow_empty ?parents tree ~info + | `Set, None -> remove t key ~retries ?allow_empty ~info ?parents + | `Test_and_set, _ -> ( + test_and_set_tree t key ~retries ?allow_empty ?parents ~info + ~test:old_tree ~set:new_tree + >>= function + | Error (`Test_was tr) when retries > 0 && n <= retries -> + done_once := true; + aux (n + 1) tr + | e -> Lwt.return e ) + | `Merge, _ -> ( + merge_tree ~old:old_tree ~retries ?allow_empty ?parents ~info t key + new_tree + >>= function + | Ok _ as x -> Lwt.return x + | Error (`Conflict _) when retries > 0 && n <= retries -> + done_once := true; + (* use the store's current tree as the new 'old store' *) + (tree_and_head t >>= function + | None -> Lwt.return None + | Some (_, tr) -> Tree.find_tree (tr :> tree) key) + >>= fun old_tree -> aux (n + 1) old_tree + | Error e -> write_error e ) + in + find_tree t key >>= fun old_tree -> aux 0 old_tree + + let with_tree_exn ?retries ?allow_empty ?parents ?strategy ~info f t key = + with_tree ?retries ?allow_empty ?strategy ?parents ~info f t key + >>= fail "with_tree_exn" + + let clone ~src ~dst = + (Head.find src >>= function + | None -> Branch_store.remove (branch_t src) dst + | Some h -> Branch_store.set (branch_t src) dst h.Commit.h) + >>= fun () -> of_branch (repo src) dst + + let return_lcas r = function + | Error _ as e -> Lwt.return e + | Ok commits -> + Lwt_list.filter_map_p (Commit.of_hash r) commits >|= fun x -> Ok x + + let lcas ?max_depth ?n t1 t2 = + Head.get t1 >>= fun h1 -> + Head.get t2 >>= fun h2 -> + H.lcas (history_t t1) ?max_depth ?n h1.Commit.h h2.Commit.h + >>= return_lcas t1.repo + + let lcas_with_commit t ?max_depth ?n c = + Head.get t >>= fun h -> + H.lcas (history_t t) ?max_depth ?n h.Commit.h c.Commit.h + >>= return_lcas t.repo + + let lcas_with_branch t ?max_depth ?n b = + Head.get t >>= fun h -> + Head.get { t with head_ref = `Branch b } >>= fun head -> + H.lcas (history_t t) ?max_depth ?n h.Commit.h head.Commit.h + >>= return_lcas t.repo + + module Private = P + + type 'a merge = + info:Info.f -> + ?max_depth:int -> + ?n:int -> + 'a -> + (unit, Merge.conflict) result Lwt.t + + let merge_with_branch t ~info ?max_depth ?n other = + Log.debug (fun f -> f "merge_with_branch %a" pp_branch other); + Branch_store.find (branch_t t) other >>= function + | None -> + Fmt.kstrf Lwt.fail_invalid_arg + "merge_with_branch: %a is not a valid branch ID" pp_branch other + | Some c -> ( + Commit.of_hash t.repo c >>= function + | None -> Lwt.fail_invalid_arg "invalid commit" + | Some c -> Head.merge ~into:t ~info ?max_depth ?n c ) + + let merge_with_commit t ~info ?max_depth ?n other = + Head.merge ~into:t ~info ?max_depth ?n other + + let merge_into ~into ~info ?max_depth ?n t = + Log.debug (fun l -> l "merge"); + match head_ref t with + | `Branch name -> merge_with_branch into ~info ?max_depth ?n name + | `Head h -> merge_with_commit into ~info ?max_depth ?n h + | `Empty -> Merge.ok () + + module History = OCamlGraph.Persistent.Digraph.ConcreteBidirectional (struct + type t = commit + + let hash h = P.Commit.Key.short_hash h.Commit.h + + let compare x y = Type.compare P.Commit.Key.t x.Commit.h y.Commit.h + + let equal x y = Type.equal P.Commit.Key.t x.Commit.h y.Commit.h + end) + + module Gmap = struct + module Src = + Object_graph.Make (P.Contents.Key) (P.Node.Metadata) (P.Node.Key) + (P.Commit.Key) + (Branch_store.Key) + + module Dst = struct + include History + + let empty () = empty + end + + let filter_map f g = + let t = Dst.empty () in + Src.fold_edges + (fun x y t -> + t >>= fun t -> + f x >>= fun x -> + f y >|= fun y -> + match (x, y) with + | Some x, Some y -> + let t = Dst.add_vertex t x in + let t = Dst.add_vertex t y in + Dst.add_edge t x y + | _ -> t ) + g (Lwt.return t) + end + + let history ?depth ?(min = []) ?(max = []) t = + Log.debug (fun f -> f "history"); + let pred = function + | `Commit k -> + H.parents (history_t t) k + >>= Lwt_list.filter_map_p (Commit.of_hash t.repo) + >|= fun parents -> List.map (fun x -> `Commit x.Commit.h) parents + | _ -> Lwt.return_nil + in + (Head.find t >>= function + | Some h -> Lwt.return [ h ] + | None -> Lwt.return max) + >>= fun max -> + let max = List.map (fun k -> `Commit k.Commit.h) max in + let min = List.map (fun k -> `Commit k.Commit.h) min in + Gmap.Src.closure ?depth ~min ~max ~pred () >>= fun g -> + Gmap.filter_map + (function `Commit k -> Commit.of_hash t.repo k | _ -> Lwt.return_none) + g + + let pp_option = Type.pp (Type.option Type.int) + + module Heap = Bheap.Make (struct + type t = commit * int + + let compare c1 c2 = + Int64.compare + (Info.date (Commit.info (fst c1))) + (Info.date (Commit.info (fst c2))) + end) + + let last_modified ?depth ?(n = 1) t key = + Log.debug (fun l -> + l "last_modified depth=%a number=%d key=%a" pp_option depth n pp_key + key ); + Head.get t >>= fun commit -> + let heap = Heap.create 5 in + let () = Heap.add heap (commit, 0) in + let rec search acc = + if Heap.is_empty heap || List.length acc = n then Lwt.return acc + else + let current, current_depth = Heap.pop_maximum heap in + let parents = Commit.parents current in + of_commit current >>= fun store -> + find store key >>= fun current_value -> + if List.length parents = 0 then + if current_value <> None then Lwt.return (current :: acc) + else Lwt.return acc + else + let max_depth = + match depth with + | Some depth -> current_depth >= depth + | None -> false + in + Lwt_list.for_all_p + (fun hash -> + Commit.of_hash (repo store) hash >>= function + | Some commit -> ( + let () = + if not max_depth then + Heap.add heap (commit, current_depth + 1) + in + of_commit commit >>= fun store -> + find store key >|= fun e -> + match (e, current_value) with + | Some x, Some y -> not (Type.equal Contents.t x y) + | Some _, None -> true + | _, _ -> false ) + | None -> Lwt.return_false ) + parents + >>= fun found -> + if found then search (current :: acc) else search acc + in + search [] + + module Branch = struct + include P.Branch.Key + + let mem t = P.Branch.mem (P.Repo.branch_t t) + + let find t br = + P.Branch.find (Repo.branch_t t) br >>= function + | None -> Lwt.return_none + | Some h -> Commit.of_hash t h + + let set t br h = P.Branch.set (P.Repo.branch_t t) br (Commit.hash h) + + let remove t = P.Branch.remove (P.Repo.branch_t t) + + let list = Repo.branches + + let watch t k ?init f = + let init = match init with None -> None | Some h -> Some h.Commit.h in + P.Branch.watch_key (Repo.branch_t t) k ?init (lift_head_diff t f) + >|= fun w () -> Branch_store.unwatch (Repo.branch_t t) w + + let watch_all t ?init f = + let init = + match init with + | None -> None + | Some i -> Some (List.map (fun (k, v) -> (k, v.Commit.h)) i) + in + let f k v = lift_head_diff t (f k) v in + P.Branch.watch (Repo.branch_t t) ?init f >|= fun w () -> + Branch_store.unwatch (Repo.branch_t t) w + + let err_not_found k = + Fmt.kstrf invalid_arg "Branch.get: %a not found" pp_branch k + + let get t k = + find t k >>= function None -> err_not_found k | Some v -> Lwt.return v + end + + module Status = struct + type t = [ `Empty | `Branch of branch | `Commit of commit ] + + let t r = + let open Type in + variant "status" (fun empty branch commit -> function + | `Empty -> empty | `Branch b -> branch b | `Commit c -> commit c ) + |~ case0 "empty" `Empty + |~ case1 "branch" Branch.t (fun b -> `Branch b) + |~ case1 "commit" (Commit.t r) (fun c -> `Commit c) + |> sealv + + let pp ppf = function + | `Empty -> Fmt.string ppf "empty" + | `Branch b -> Type.pp Branch.t ppf b + | `Commit c -> Type.pp Hash.t ppf (Commit.hash c) + end + + let slice_t = P.Slice.t + + let tree_t = Tree.tree_t + + let contents_t = Contents.t + + let metadata_t = Metadata.t + + let key_t = Key.t + + let step_t = Key.step_t + + let node_t = Tree.node_t + + let commit_t = Commit.t + + let branch_t = Branch.t + + let kind_t = Type.enum "kind" [ ("contents", `Contents); ("node", `Node) ] + + let lca_error_t = + Type.enum "lca-error" + [ ("max-depth-reached", `Max_depth_reached); + ("too-many-lcas", `Too_many_lcas) + ] + + let ff_error_t = + Type.enum "ff-error" + [ ("max-depth-reached", `Max_depth_reached); + ("too-many-lcas", `Too_many_lcas); + ("no-change", `No_change); + ("rejected", `Rejected) + ] + + let write_error_t = + let open Type in + variant "write-error" (fun c m e -> function + | `Conflict x -> c x | `Too_many_retries x -> m x | `Test_was x -> e x ) + |~ case1 "conflict" string (fun x -> `Conflict x) + |~ case1 "too-many-retries" int (fun x -> `Too_many_retries x) + |~ case1 "test-got" (option tree_t) (fun x -> `Test_was x) + |> sealv + + let write_error_t = + let of_string _ = assert false in + Type.like ~cli:(pp_write_error, of_string) write_error_t +end diff --git a/vendors/irmin/store.mli b/vendors/irmin/store.mli new file mode 100644 index 000000000000..9c421eb44d8b --- /dev/null +++ b/vendors/irmin/store.mli @@ -0,0 +1,46 @@ +(* + * 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. + *) + +(** Branch-consistent stores: read-write store with support fork/merge + operations. *) + +module Make (P : S.PRIVATE) : + S.STORE + with type key = P.Node.Path.t + and type contents = P.Contents.value + and type branch = P.Branch.key + and type hash = P.Hash.t + and type slice = P.Slice.t + and type step = P.Node.Path.step + and type metadata = P.Node.Val.metadata + and module Key = P.Node.Path + and type repo = P.Repo.t + and module Private = P + +module Content_addressable + (X : S.APPEND_ONLY_STORE_MAKER) + (K : S.HASH) + (V : Type.S) : sig + include + S.CONTENT_ADDRESSABLE_STORE + with type 'a t = 'a X(K)(V).t + and type key = K.t + and type value = V.t + + val batch : [ `Read ] t -> ([ `Read | `Write ] t -> 'a Lwt.t) -> 'a Lwt.t + + val v : Conf.t -> [ `Read ] t Lwt.t +end diff --git a/vendors/irmin/sync.ml b/vendors/irmin/sync.ml new file mode 100644 index 000000000000..7ea3f779bb53 --- /dev/null +++ b/vendors/irmin/sync.ml @@ -0,0 +1,33 @@ +(* + * 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. + *) + +module None (H : Type.S) (R : Type.S) = struct + type t = unit + + let v _ = Lwt.return () + + type endpoint = unit + + type commit = H.t + + type branch = R.t + + let fetch () ?depth:_ _ _br = + Lwt.return_error (`Msg "fetch operation is not available") + + let push () ?depth:_ _ _br = + Lwt.return_error (`Msg "push operation is not available") +end diff --git a/vendors/irmin/sync.mli b/vendors/irmin/sync.mli new file mode 100644 index 000000000000..a569c2598dfb --- /dev/null +++ b/vendors/irmin/sync.mli @@ -0,0 +1,23 @@ +(* + * 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. + *) + +(** Store Synchronisation signatures. *) + +module None (H : Type.S) (R : Type.S) : sig + include S.SYNC with type commit = H.t and type branch = R.t + + val v : 'a -> t Lwt.t +end diff --git a/vendors/irmin/sync_ext.ml b/vendors/irmin/sync_ext.ml new file mode 100644 index 000000000000..1b73c3715b5f --- /dev/null +++ b/vendors/irmin/sync_ext.ml @@ -0,0 +1,198 @@ +(* + * 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 +open S + +let invalid_argf fmt = Fmt.kstrf Lwt.fail_invalid_arg fmt + +let src = Logs.Src.create "irmin.sync" ~doc:"Irmin remote sync" + +module Log = (val Logs.src_log src : Logs.LOG) + +let remote_store m x = S.Store (m, x) + +module Make (S : S.STORE) = struct + module B = S.Private.Sync + + type db = S.t + + type commit = S.commit + + let conv dx dy x = + let str = Type.to_bin_string dx x in + Type.of_bin_string dy str + + let convert_slice (type r s) (module RP : PRIVATE with type Slice.t = r) + (module SP : PRIVATE with type Slice.t = s) r = + SP.Slice.empty () >>= fun s -> + RP.Slice.iter r (function + | `Contents (k, v) -> ( + let k = conv RP.Contents.Key.t SP.Contents.Key.t k in + let v = conv RP.Contents.Val.t SP.Contents.Val.t v in + match (k, v) with + | Ok k, Ok v -> SP.Slice.add s (`Contents (k, v)) + | _ -> Lwt.return_unit ) + | `Node (k, v) -> ( + let k = conv RP.Node.Key.t SP.Node.Key.t k in + let v = conv RP.Node.Val.t SP.Node.Val.t v in + match (k, v) with + | Ok k, Ok v -> SP.Slice.add s (`Node (k, v)) + | _ -> Lwt.return_unit ) + | `Commit (k, v) -> ( + let k = conv RP.Commit.Key.t SP.Commit.Key.t k in + let v = conv RP.Commit.Val.t SP.Commit.Val.t v in + match (k, v) with + | Ok k, Ok v -> SP.Slice.add s (`Commit (k, v)) + | _ -> Lwt.return_unit ) ) + >>= fun () -> Lwt.return s + + let convs src dst l = + List.fold_left + (fun acc x -> match conv src dst x with Ok x -> x :: acc | _ -> acc) + [] l + + let pp_branch = Type.pp S.Branch.t + + let pp_hash = Type.pp S.Hash.t + + type status = [ `Empty | `Head of commit ] + + let pp_status ppf = function + | `Empty -> Fmt.string ppf "empty" + | `Head c -> Type.pp S.Hash.t ppf (S.Commit.hash c) + + let status_t t = + let open Type in + variant "status" (fun empty head -> function + | `Empty -> empty | `Head c -> head c ) + |~ case0 "empty" `Empty + |~ case1 "head" S.(commit_t @@ repo t) (fun c -> `Head c) + |> sealv + + let fetch t ?depth remote = + match remote with + | Store ((module R), r) -> ( + Log.debug (fun f -> f "fetch store"); + let s_repo = S.repo t in + let r_repo = R.repo r in + S.Repo.heads s_repo >>= fun min -> + let min = convs S.(commit_t s_repo) R.(commit_t r_repo) min in + R.Head.find r >>= function + | None -> Lwt.return_ok `Empty + | Some h -> ( + R.Repo.export (R.repo r) ?depth ~min ~max:[ h ] >>= fun r_slice -> + convert_slice (module R.Private) (module S.Private) r_slice + >>= fun s_slice -> + S.Repo.import s_repo s_slice >|= function + | Error e -> Error e + | Ok () -> ( + match conv R.(commit_t r_repo) S.(commit_t s_repo) h with + | Ok h -> Ok (`Head h) + | Error e -> Error e ) ) ) + | S.E e -> ( + match S.status t with + | `Empty | `Commit _ -> Lwt.return_ok `Empty + | `Branch br -> ( + Log.debug (fun l -> l "Fetching branch %a" pp_branch br); + B.v (S.repo t) >>= fun g -> + B.fetch g ?depth e br >>= function + | Error _ as e -> Lwt.return e + | Ok (Some c) -> ( + Log.debug (fun l -> l "Fetched %a" pp_hash c); + S.Commit.of_hash (S.repo t) c >|= function + | None -> Ok `Empty + | Some x -> Ok (`Head x) ) + | Ok None -> ( + S.Head.find t >>= function + | Some h -> Lwt.return_ok (`Head h) + | None -> Lwt.return_ok `Empty ) ) ) + | _ -> Lwt.return_error (`Msg "fetch operation is not available") + + let fetch_exn t ?depth remote = + fetch t ?depth remote >>= function + | Ok h -> Lwt.return h + | Error (`Msg e) -> invalid_argf "Sync.fetch_exn: %s" e + + type pull_error = [ `Msg of string | Merge.conflict ] + + let pp_pull_error ppf = function + | `Msg s -> Fmt.string ppf s + | `Conflict c -> Fmt.pf ppf "conflict: %s" c + + let pull t ?depth remote kind : (status, pull_error) result Lwt.t = + fetch t ?depth remote >>= function + | Error e -> Lwt.return_error (e :> pull_error) + | Ok (`Head k) -> ( + match kind with + | `Set -> S.Head.set t k >|= fun () -> Ok (`Head k) + | `Merge info -> ( + S.Head.merge ~into:t ~info k >>= function + | Ok () -> Lwt.return_ok (`Head k) + | Error e -> Lwt.return_error (e :> pull_error) ) ) + | Ok `Empty -> Lwt.return_ok `Empty + + let pull_exn t ?depth remote kind = + pull t ?depth remote kind >>= function + | Ok x -> Lwt.return x + | Error e -> invalid_argf "Sync.pull_exn: %a" pp_pull_error e + + type push_error = [ `Msg of string | `Detached_head ] + + let pp_push_error ppf = function + | `Msg s -> Fmt.string ppf s + | `Detached_head -> Fmt.string ppf "cannot push to a non-persistent store" + + let push t ?depth remote = + Log.debug (fun f -> f "push"); + match remote with + | Store ((module R), r) -> ( + S.Head.find t >>= function + | None -> Lwt.return_ok `Empty + | Some h -> ( + Log.debug (fun f -> f "push store"); + R.Repo.heads (R.repo r) >>= fun min -> + let r_repo = R.repo r in + let s_repo = S.repo t in + let min = convs R.(commit_t r_repo) S.(commit_t s_repo) min in + S.Repo.export (S.repo t) ?depth ~min >>= fun s_slice -> + convert_slice (module S.Private) (module R.Private) s_slice + >>= fun r_slice -> + R.Repo.import (R.repo r) r_slice >>= function + | Error e -> Lwt.return (Error (e :> push_error)) + | Ok () -> ( + match conv S.(commit_t s_repo) R.(commit_t r_repo) h with + | Error e -> Lwt.return (Error (e :> push_error)) + | Ok h -> + R.Head.set r h >>= fun () -> + S.Head.get t >|= fun head -> Ok (`Head head) ) ) ) + | S.E e -> ( + match S.status t with + | `Empty -> Lwt.return_ok `Empty + | `Commit _ -> Lwt.return (Error `Detached_head) + | `Branch br -> ( + S.of_branch (S.repo t) br >>= S.Head.get >>= fun head -> + B.v (S.repo t) >>= fun g -> + B.push g ?depth e br >>= function + | Ok () -> Lwt.return_ok (`Head head) + | Error err -> Lwt.return_error (err :> push_error) ) ) + | _ -> Lwt.return_error (`Msg "push operation is not available") + + let push_exn t ?depth remote = + push t ?depth remote >>= function + | Ok x -> Lwt.return x + | Error e -> invalid_argf "Sync.push_exn: %a" pp_push_error e +end diff --git a/vendors/irmin/sync_ext.mli b/vendors/irmin/sync_ext.mli new file mode 100644 index 000000000000..a293792ca698 --- /dev/null +++ b/vendors/irmin/sync_ext.mli @@ -0,0 +1,22 @@ +(* + * 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. + *) + +(** Store Synchronisation. *) + +val remote_store : (module S.STORE with type t = 'a) -> 'a -> S.remote + +module Make (X : S.STORE) : + S.SYNC_STORE with type db = X.t and type commit = X.commit diff --git a/vendors/irmin/tree.ml b/vendors/irmin/tree.ml new file mode 100644 index 000000000000..35299e81955e --- /dev/null +++ b/vendors/irmin/tree.ml @@ -0,0 +1,1780 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * Copyright (c) 2017 Grégoire Henry + * + * 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 + +let src = Logs.Src.create "irmin.tree" ~doc:"Persistent lazy trees for Irmin" + +module Log = (val Logs.src_log src : Logs.LOG) + +(* 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 [@tailcall]) t1 t2 + | x -> + if x < 0 then ( + f k1 (`Left v1); + (aux [@tailcall]) t1 l2 ) + else ( + f k2 (`Right v2); + (aux [@tailcall]) l1 t2 ) ) + in + aux l1 l2 + +(* assume l1 and l2 are key-sorted *) +let alist_iter2_lwt compare_k f l1 l2 = + let l3 = ref [] in + alist_iter2 compare_k (fun left right -> l3 := f left right :: !l3) l1 l2; + Lwt_list.iter_s (fun b -> b >>= fun () -> Lwt.return_unit) (List.rev !l3) + +module Cache (K : Type.S) : sig + type 'a t + + type key = K.t + + val create : is_empty:('a -> bool) -> int -> 'a t + + val find : 'a t -> key -> 'a + + val add : 'a t -> key -> 'a -> unit + + val iter : (key -> 'a -> unit) -> 'a t -> unit + + val length : 'a t -> int +end = struct + module M = Ephemeron.K1.Make (struct + type t = K.t + + let equal (x : t) (y : t) = Type.equal K.t x y + + let hash (x : t) = Type.short_hash K.t x + end) + + type 'a t = { is_empty : 'a -> bool; m : 'a M.t } + + type key = K.t + + let create ~is_empty x = { is_empty; m = M.create x } + + let length t = + M.fold (fun _ v acc -> if t.is_empty v then acc else acc + 1) t.m 0 + + let add t k v = M.add t.m k v + + let find t k = M.find t.m k + + let iter f t = M.iter f t.m +end + +module Make (P : S.PRIVATE) = struct + type counters = { + mutable contents_hash : int; + mutable contents_find : int; + mutable contents_add : int; + mutable contents_cache_length : int; + mutable contents_cache_find : int; + mutable contents_cache_miss : int; + mutable node_hash : int; + mutable node_mem : int; + mutable node_add : int; + mutable node_find : int; + mutable node_cache_length : int; + mutable node_cache_find : int; + mutable node_cache_miss : int; + mutable node_val_v : int; + mutable node_val_find : int; + mutable node_val_list : int + } + + let counters_t = + let open Type in + record "counters" + (fun contents_hash + contents_find + contents_add + contents_cache_length + contents_cache_find + contents_cache_miss + node_hash + node_mem + node_add + node_find + node_cache_length + node_cache_find + node_cache_miss + node_val_v + node_val_find + node_val_list + -> + { contents_hash; + contents_find; + contents_add; + contents_cache_length; + contents_cache_find; + contents_cache_miss; + node_hash; + node_mem; + node_add; + node_find; + node_cache_length; + node_cache_find; + node_cache_miss; + node_val_v; + node_val_find; + node_val_list + } ) + |+ field "contents_hash" int (fun x -> x.contents_hash) + |+ field "contents_find" int (fun x -> x.contents_find) + |+ field "contents_add" int (fun x -> x.contents_add) + |+ field "contents_cache_length" int (fun x -> x.contents_cache_length) + |+ field "contents_cache_find" int (fun x -> x.contents_cache_find) + |+ field "contents_cache_miss" int (fun x -> x.contents_cache_miss) + |+ field "node_hash" int (fun x -> x.node_hash) + |+ field "node_mem" int (fun x -> x.node_mem) + |+ field "node_add" int (fun x -> x.node_add) + |+ field "node_find" int (fun x -> x.node_find) + |+ field "node_cache_length" int (fun x -> x.node_cache_length) + |+ field "node_cache_find" int (fun x -> x.node_cache_find) + |+ field "node_cache_miss" int (fun x -> x.node_cache_miss) + |+ field "node_val_v" int (fun x -> x.node_val_v) + |+ field "node_val_find" int (fun x -> x.node_val_find) + |+ field "node_val_list" int (fun x -> x.node_val_list) + |> sealr + + let dump_counters ppf t = Type.pp_json ~minify:false counters_t ppf t + + let fresh_counters () = + { contents_hash = 0; + contents_add = 0; + contents_find = 0; + contents_cache_length = 0; + contents_cache_find = 0; + contents_cache_miss = 0; + node_hash = 0; + node_mem = 0; + node_add = 0; + node_find = 0; + node_cache_length = 0; + node_cache_find = 0; + node_cache_miss = 0; + node_val_v = 0; + node_val_find = 0; + node_val_list = 0 + } + + let reset_counters t = + t.contents_hash <- 0; + t.contents_add <- 0; + t.contents_find <- 0; + t.contents_cache_length <- 0; + t.contents_cache_find <- 0; + t.contents_cache_miss <- 0; + t.node_hash <- 0; + t.node_mem <- 0; + t.node_add <- 0; + t.node_find <- 0; + t.node_cache_length <- 0; + t.node_cache_find <- 0; + t.node_cache_miss <- 0; + t.node_val_v <- 0; + t.node_val_find <- 0; + t.node_val_list <- 0 + + let cnt = fresh_counters () + + module Path = P.Node.Path + + module StepMap = struct + module X = struct + type t = Path.step + + let t = Path.step_t + + let compare = Type.compare Path.step_t + end + + include Map.Make (X) + include Merge.Map (X) + end + + module Metadata = P.Node.Metadata + + type key = Path.t + + type hash = P.Hash.t + + type step = Path.step + + type contents = P.Contents.value + + type repo = P.Repo.t + + let pp_hash = Type.pp P.Hash.t + + let pp_path = Type.pp Path.t + + module Hashes = Hashtbl.Make (struct + type t = hash + + let hash = P.Hash.short_hash + + let equal = Type.equal P.Hash.t + end) + + module Contents = struct + type v = Hash of repo * hash | Value of contents + + type info = { + mutable hash : hash option; + mutable value : contents option; + mutable color : [ `White | `Black ] + } + + type t = { mutable v : v; mutable info : info } + + module Hashes = Cache (P.Hash) + module Values = Cache (P.Contents.Val) + + let info_is_empty i = i.hash = None && i.value = None + + let values = Values.create ~is_empty:info_is_empty 1000 + + let hashes = Hashes.create ~is_empty:info_is_empty 1000 + + let iter_info f = + Values.iter (fun _ i -> f i) values; + Hashes.iter (fun _ i -> f i) hashes + + let mark color i = i.color <- color + + let v = + let open Type in + variant "Node.Contents.v" (fun hash value -> function + | Hash (_, x) -> hash x | Value v -> value v ) + |~ case1 "hash" P.Hash.t (fun _ -> assert false) + |~ case1 "value" P.Contents.Val.t (fun v -> Value v) + |> sealv + + let clear_info i = + if not (info_is_empty i) then ( + i.value <- None; + i.hash <- None ) + + let clear t = clear_info t.info + + let merge_info ~into:x y = + let () = + match (x.hash, y.hash) with + | None, None | Some _, None -> () + | Some _, Some _ -> () + | None, Some _ -> x.hash <- y.hash + in + let () = + match (x.value, y.value) with + | None, None | Some _, None -> () + | Some _, Some _ -> () + | None, _ -> x.value <- y.value + in + () + + let of_v v = + let hash, value = + match v with Hash (_, k) -> (Some k, None) | Value v -> (None, Some v) + in + (* hashcons the info *) + let info = + match (hash, value) with + | Some _, Some _ -> assert false + | None, None -> { hash; value; color = `White } + | None, Some v -> ( + cnt.contents_cache_find <- cnt.contents_cache_find + 1; + match Values.find values v with + | exception Not_found -> + cnt.contents_cache_miss <- cnt.contents_cache_miss + 1; + let i = { hash; value; color = `White } in + Values.add values v i; + i + | i -> i ) + | Some k, None -> ( + cnt.contents_cache_find <- cnt.contents_cache_find + 1; + match Hashes.find hashes k with + | exception Not_found -> + cnt.contents_cache_miss <- cnt.contents_cache_miss + 1; + let i = { hash; value; color = `White } in + Hashes.add hashes k i; + i + | i -> i ) + in + (* hashcons for the contents (= leaf nodes) *) + let v = + match (v, info.value, info.hash) with + | Value _, Some v, _ -> Value v + | Hash (r, _), _, Some h -> Hash (r, h) + | _ -> v + in + let t = { v; info } in + t + + let export ?clear:c repo t k = + let hash = t.info.hash in + if c = Some true then clear t; + match (t.v, hash) with + | Hash (_, k), _ -> t.v <- Hash (repo, k) + | Value _, None -> t.v <- Hash (repo, k) + | Value _, Some k -> t.v <- Hash (repo, k) + + let t = Type.map v of_v (fun t -> t.v) + + let of_value c = of_v (Value c) + + let of_hash repo k = of_v (Hash (repo, k)) + + let hash t = + match (t.v, t.info.hash) with + | Hash (_, k), None -> + let h = Some k in + t.info.hash <- h; + h + | _, h -> h + + let value t = + match (t.v, t.info.value) with + | Value v, None -> + let v = Some v in + t.info.value <- v; + v + | _, v -> v + + let hashcons t = + match (t.v, t.info.hash, t.info.value) with + | Hash (r, h), Some h', _ -> if h != h' then t.v <- Hash (r, h') + | Value v, _, Some v' -> if v != v' then t.v <- Value v' + | _ -> () + + let hash_of_value c v = + cnt.contents_hash <- cnt.contents_hash + 1; + let k = P.Contents.Key.hash v in + c.info.hash <- Some k; + let () = + cnt.contents_cache_find <- cnt.contents_cache_find + 1; + match Hashes.find hashes k with + | i -> + let old = c.info in + c.info <- i; + merge_info ~into:i old; + hashcons c + | exception Not_found -> + cnt.contents_cache_miss <- cnt.contents_cache_miss + 1; + Hashes.add hashes k c.info + in + match c.info.hash with Some k -> k | None -> k + + let to_hash c = + match hash c with + | Some k -> k + | None -> ( + match value c with None -> assert false | Some v -> hash_of_value c v ) + + let value_of_hash t repo k = + cnt.contents_find <- cnt.contents_find + 1; + P.Contents.find (P.Repo.contents_t repo) k >|= function + | None -> None + | Some v as vo -> + t.info.value <- vo; + let () = + cnt.contents_cache_find <- cnt.contents_cache_find + 1; + match Values.find values v with + | i -> + let old = t.info in + t.info <- i; + merge_info ~into:i old; + hashcons t + | exception Not_found -> + cnt.contents_cache_miss <- cnt.contents_cache_miss + 1; + Values.add values v t.info + in + t.info.value + + let to_value t = + match value t with + | Some v -> Lwt.return (Some v) + | None -> ( + match t.v with + | Value v -> Lwt.return (Some v) + | Hash (repo, k) -> value_of_hash t repo k ) + + let equal (x : t) (y : t) = + x == y + || + match (x.v, y.v) with + | Hash (_, x), Hash (_, y) -> Type.equal P.Hash.t x y + | Value x, Value y -> Type.equal P.Contents.Val.t x y + | _ -> Type.equal P.Hash.t (to_hash x) (to_hash y) + + let merge : t Merge.t = + let f ~old x y = + let old = + Merge.bind_promise old (fun old () -> + to_value old >|= fun c -> Ok (Some c) ) + in + to_value x >>= fun x -> + to_value y >>= fun y -> + Merge.(f P.Contents.Val.merge) ~old x y >|= function + | Ok (Some c) -> Ok (of_value c) + | Ok None -> Error (`Conflict "empty contents") + | Error _ as e -> e + in + Merge.v t f + + let fold ~force ~path f t acc = + let aux = function None -> Lwt.return acc | Some c -> f path c acc in + match force with + | `True -> to_value t >>= aux + | `False skip -> ( + match t.info.value with + | None -> skip path acc + | Some c -> aux (Some c) ) + end + + module Node = struct + type value = P.Node.Val.t + + type elt = [ `Node of t | `Contents of Contents.t * Metadata.t ] + + and map = elt StepMap.t + + and info = { + mutable value : value option; + mutable map : map option; + mutable hash : hash option; + mutable color : [ `White | `Black ]; + mutable findv_cache : map option + } + + and v = + | Map of map + | Hash of repo * hash + | Value of repo * value * map option + + and t = { mutable v : v; mutable info : info } + + let elt_t t : elt Type.t = + let open Type in + variant "Node.value" (fun node contents contents_m -> function + | `Node x -> node x + | `Contents (c, m) -> + if Type.equal Metadata.t m Metadata.default then contents c + else contents_m (c, m) ) + |~ case1 "Node" t (fun x -> `Node x) + |~ case1 "Contents" Contents.t (fun x -> `Contents (x, Metadata.default)) + |~ case1 "Contents-x" (pair Contents.t Metadata.t) (fun x -> `Contents x) + |> sealv + + let map_t (elt : elt Type.t) : map Type.t = + let open Type in + let to_map x = + List.fold_left (fun acc (k, v) -> StepMap.add k v acc) StepMap.empty x + in + let of_map m = StepMap.fold (fun k v acc -> (k, v) :: acc) m [] in + map (list (pair Path.step_t elt)) to_map of_map + + let v_t (m : map Type.t) : v Type.t = + let open Type in + variant "Node.node" (fun map hash value -> function + | Map m -> map m + | Hash (_, y) -> hash y + | Value (_, v, m) -> value (v, m) ) + |~ case1 "map" m (fun m -> Map m) + |~ case1 "hash" P.Hash.t (fun _ -> assert false) + |~ case1 "value" (pair P.Node.Val.t (option m)) (fun _ -> assert false) + |> sealv + + let rec merge_elt : type a. into:elt -> elt -> (unit -> a) -> a = + fun ~into:x y k -> + match (x, y) with + | `Contents (x, _), `Contents (y, _) -> + Contents.merge_info ~into:x.Contents.info y.Contents.info; + k () + | `Node x, `Node y -> (merge_info [@tailcall]) ~into:x.info y.info k + | _ -> k () + + and merge_map : type a. into:map -> map -> (unit -> a) -> a = + fun ~into:x y k -> + List.iter2 + (fun (_, x) (_, y) -> (merge_elt [@tailcall]) ~into:x y (fun () -> ())) + (StepMap.bindings x) (StepMap.bindings y); + k () + + and merge_info : type a. into:info -> info -> (unit -> a) -> a = + fun ~into:x y k -> + let () = + match (x.hash, y.hash) with + | None, None | Some _, None -> () + | Some _, Some _ -> () + | None, Some _ -> x.hash <- y.hash + in + let () = + match (x.value, y.value) with + | None, None | Some _, None -> () + | Some _, Some _ -> () + | None, _ -> x.value <- y.value + in + let () = + match (x.findv_cache, y.findv_cache) with + | None, None | Some _, None -> () + | None, Some _ -> x.findv_cache <- y.findv_cache + | Some a, Some b -> + let m = + StepMap.union + (fun _ a b -> + (merge_elt [@tailcall]) ~into:a b (fun () -> Some a) ) + a b + in + if m != a then x.findv_cache <- Some m + in + match (x.map, y.map) with + | None, None | Some _, None -> k () + | None, Some _ -> + x.map <- y.map; + k () + | Some x, Some y -> (merge_map [@tailcall]) ~into:x y k + + let info_is_empty i = + i.map = None && i.value = None && i.findv_cache = None && i.hash = None + + let depth i = + let rec map depth m k = + StepMap.fold + (fun _ v acc -> + match v with + | `Contents _ -> k (max acc (depth + 1)) + | `Node t -> + (aux [@tailcall]) (depth + 1) t (fun d -> k (max acc d)) ) + m depth + and aux depth t k = + match (t.v, t.info.map) with + | (Hash _ | Value _), None -> k 0 + | Map m, _ | _, Some m -> (map [@tailcall]) depth m k + in + match i.map with + | None -> 0 + | Some m -> (map [@tailcall]) 0 m (fun x -> x) + + let width i = match i.map with None -> 0 | Some m -> StepMap.cardinal m + + let dump_info ppf i = + let value = + match i.value with + | None -> "" + | Some v -> Type.to_string P.Node.Val.t v + in + let map = match i.map with None -> "" | Some _ -> "" in + let hash = match i.hash with None -> "" | Some _ -> "" in + let empty = if info_is_empty i then "*" else "" in + Fmt.pf ppf "[width=%d, depth=%d, value=%s, map=%s, hash=%s]%s" (width i) + (depth i) value map hash empty + + module Cache = Cache (P.Hash) + + let cache = Cache.create ~is_empty:info_is_empty 100 + + let iter_info f = Cache.iter (fun _ i -> f i) cache + + let mark c t = t.color <- c + + let hashcons t = + match (t.v, t.info.hash, t.info.map, t.info.value) with + | Hash (r, h), Some h', _, _ -> if h != h' then t.v <- Hash (r, h') + | Map v, _, Some v', _ -> + if v != v' then merge_map ~into:v' v (fun () -> t.v <- Map v') + | Value (r, v, None), _, _, Some v' -> + if v != v' then t.v <- Value (r, v', None) + | _ -> () + + let of_v v = + let hash, map, value = + match v with + | Map m -> (None, Some m, None) + | Hash (_, k) -> (Some k, None, None) + | Value (_, v, None) -> (None, None, Some v) + | Value _ -> (None, None, None) + in + let color = `White in + let findv_cache = None in + (* hashcons info *) + let info = + match hash with + | None -> { hash; map; value; color; findv_cache } + | Some k -> ( + cnt.node_cache_find <- cnt.node_cache_find + 1; + match Cache.find cache k with + | exception Not_found -> + cnt.node_cache_miss <- cnt.node_cache_miss + 1; + let i = { hash; map; value; color; findv_cache } in + Cache.add cache k i; + i + | i -> i ) + in + (* hashcons v *) + let t = { v; info } in + hashcons t; + t + + let t node = Type.map node of_v (fun t -> t.v) + + let _, t = + Type.mu2 (fun _ y -> + let elt = elt_t y in + let v = v_t (map_t elt) in + let t = t v in + (v, t) ) + + let elt_t = elt_t t + + let rec clear_map ~max_depth depth m = + List.iter + (fun (_, v) -> + match v with + | `Contents (c, _) -> + Contents.mark `Black c.Contents.info; + if depth + 1 > max_depth then Contents.clear c + | `Node t -> (clear [@tailcall]) ~max_depth (depth + 1) t ) + m + + and clear_info ~max_depth ?v depth i = + if i.color = `White then ( + let added = + match v with + | Some (Value (_, _, Some m)) -> StepMap.bindings m + | _ -> [] + in + let map = + match (v, i.map) with + | Some (Map m), _ | _, Some m -> StepMap.bindings m + | _ -> [] + in + let findv = + match i.findv_cache with Some m -> StepMap.bindings m | None -> [] + in + if depth >= max_depth && not (info_is_empty i) then ( + i.color <- `Black; + i.value <- None; + i.map <- None; + i.hash <- None; + i.findv_cache <- None ); + (clear_map [@tailcall]) ~max_depth depth (map @ added @ findv) ) + + and clear ~max_depth depth t = clear_info ~v:t.v ~max_depth depth t.info + + let clear_info ?depth:d i = + let max_depth = match d with None -> 0 | Some max_depth -> max_depth in + clear_info ~max_depth 0 i + + let clear ?depth:d n = + let max_depth = match d with None -> 0 | Some max_depth -> max_depth in + clear ~max_depth 0 n + + (* export t to the given repo and clear the cache *) + let export ?clear:c repo t k = + let hash = t.info.hash in + if c = Some true then clear t; + match t.v with + | Hash (_, k) -> t.v <- Hash (repo, k) + | Value (_, v, None) when P.Node.Val.is_empty v -> () + | Map m when StepMap.is_empty m -> + t.v <- Value (repo, P.Node.Val.empty, None) + | _ -> ( + match hash with + | None -> t.v <- Hash (repo, k) + | Some k -> t.v <- Hash (repo, k) ) + + let dump = Type.pp_json ~minify:false t + + let of_map m = of_v (Map m) + + let of_hash repo k = of_v (Hash (repo, k)) + + let of_value ?added repo v = of_v (Value (repo, v, added)) + + let empty = function + | { v = Hash (repo, _) | Value (repo, _, _); _ } -> + of_value repo P.Node.Val.empty + | _ -> of_map StepMap.empty + + let map_of_value repo (n : value) : map = + cnt.node_val_list <- cnt.node_val_list + 1; + let entries = P.Node.Val.list n in + let aux = function + | `Node h -> `Node (of_hash repo h) + | `Contents (c, m) -> `Contents (Contents.of_hash repo c, m) + in + List.fold_left + (fun acc (k, v) -> StepMap.add k (aux v) acc) + StepMap.empty entries + + let hash t = + match (t.v, t.info.hash) with + | Hash (_, h), None -> + let h = Some h in + t.info.hash <- h; + h + | _, h -> h + + let map t = + match (t.v, t.info.map) with + | Map m, None -> + let m = Some m in + t.info.map <- m; + m + | _, m -> m + + let value t = + match (t.v, t.info.value) with + | Value (_, v, None), None -> + let v = Some v in + t.info.value <- v; + v + | _, v -> v + + let hash_of_value t v = + cnt.node_hash <- cnt.node_hash + 1; + let k = P.Node.Key.hash v in + t.info.hash <- Some k; + let () = + cnt.node_cache_find <- cnt.node_cache_find + 1; + match Cache.find cache k with + | i -> + let old = t.info in + t.info <- i; + merge_info ~into:i old (fun () -> hashcons t) + | exception Not_found -> + cnt.node_cache_miss <- cnt.node_cache_miss + 1; + Cache.add cache k t.info + in + match t.info.hash with Some k -> k | None -> k + + let to_hash ~value_of_adds ~value_of_map t = + match hash t with + | Some h -> h + | None -> ( + let of_value v = hash_of_value t v in + match value t with + | Some v -> of_value v + | None -> ( + match t.v with + | Hash (_, h) -> h + | Value (_, v, None) -> of_value v + | Value (_, v, Some a) -> of_value (value_of_adds t v a) + | Map m -> of_value (value_of_map t m) ) ) + + let rec value_of_map t ~value_of_adds map = + if StepMap.is_empty map then ( + t.info.value <- Some P.Node.Val.empty; + P.Node.Val.empty ) + else + let alist = StepMap.bindings map in + let rec aux acc = function + | [] -> + let alist = List.rev acc in + cnt.node_val_v <- cnt.node_val_v + 1; + P.Node.Val.v alist + | (step, v) :: rest -> ( + match v with + | `Contents (c, m) -> + let v = `Contents (Contents.to_hash c, m) in + (aux [@tailcall]) ((step, v) :: acc) rest + | `Node n -> + let n = + to_hash ~value_of_adds + ~value_of_map:(value_of_map ~value_of_adds) + n + in + let v = `Node n in + (aux [@tailcall]) ((step, v) :: acc) rest ) + in + let v = aux [] alist in + t.info.value <- Some v; + v + + let value_of_elt ~value_of_adds e = + match e with + | `Contents (c, m) -> `Contents (Contents.to_hash c, m) + | `Node n -> + let h = + to_hash + ~value_of_map:(value_of_map ~value_of_adds) + ~value_of_adds n + in + `Node h + + let rec value_of_adds t v added = + let added = StepMap.bindings added in + let v = + List.fold_left + (fun v (k, e) -> + let e = value_of_elt ~value_of_adds e in + P.Node.Val.add v k e ) + v added + in + t.info.value <- Some v; + v + + let value_of_map = value_of_map ~value_of_adds + + let to_hash = to_hash ~value_of_adds ~value_of_map + + let value_of_hash t repo k = + match t.info.value with + | Some _ as v -> Lwt.return v + | None -> ( + cnt.node_find <- cnt.node_find + 1; + P.Node.find (P.Repo.node_t repo) k >|= function + | None -> None + | Some _ as v -> + t.info.value <- v; + v ) + + let to_value t = + match value t with + | Some v -> Lwt.return (Some v) + | None -> ( + match t.v with + | Value (_, v, None) -> Lwt.return (Some v) + | Value (_, v, Some m) -> + let v = value_of_adds t v m in + Lwt.return (Some v) + | Map m -> Lwt.return (Some (value_of_map t m)) + | Hash (repo, h) -> value_of_hash t repo h ) + + let to_map t = + match map t with + | Some m -> Lwt.return (Some m) + | None -> ( + let of_value repo v added = + let m = map_of_value repo v in + let m = + match added with + | None -> m + | Some added -> StepMap.union (fun _ _ a -> Some a) m added + in + t.info.map <- Some m; + Some m + in + match t.v with + | Map m -> Lwt.return (Some m) + | Value (repo, v, m) -> Lwt.return (of_value repo v m) + | Hash (repo, k) -> ( + value_of_hash t repo k >|= function + | None -> None + | Some v -> of_value repo v None ) ) + + let hash_equal x y = x == y || Type.equal P.Hash.t x y + + let contents_equal ((c1, m1) as x1) ((c2, m2) as x2) = + x1 == x2 || (Contents.equal c1 c2 && Type.equal Metadata.t m1 m2) + + let rec elt_equal (x : elt) (y : elt) = + x == y + || + match (x, y) with + | `Contents x, `Contents y -> contents_equal x y + | `Node x, `Node y -> equal x y + | _ -> false + + and map_equal (x : map) (y : map) = StepMap.equal elt_equal x y + + and equal (x : t) (y : t) = + x == y + || + match (x.v, y.v) with + | Hash (_, x), Hash (_, y) -> hash_equal x y + | Value (_, x, None), Value (_, y, None) -> Type.equal P.Node.Val.t x y + | Map x, Map y -> map_equal x y + | Value (_, x, Some a), Value (_, y, Some b) -> + Type.equal P.Node.Val.t x y && map_equal a b + | _ -> ( + match (value x, value y) with + | Some x, Some y -> Type.equal P.Node.Val.t x y + | _ -> ( + match (map x, map y) with + | Some x, Some y -> map_equal x y + | _ -> hash_equal (to_hash x) (to_hash y) ) ) + + let is_empty t = + match map t with + | Some m -> Lwt.return (StepMap.is_empty m) + | None -> ( + to_value t >|= function + | None -> false + | Some n -> P.Node.Val.is_empty n ) + + let list t = + let trim l = + List.rev_map + (fun (s, v) -> + (s, match v with `Contents _ -> `Contents | `Node _ -> `Node) ) + l + |> List.rev + in + match map t with + | Some m -> Lwt.return (trim (StepMap.bindings m)) + | None -> ( + to_value t >|= function + | None -> [] + | Some v -> + cnt.node_val_list <- cnt.node_val_list + 1; + trim (P.Node.Val.list v) ) + + let listv t = + to_map t >|= function None -> [] | Some m -> StepMap.bindings m + + let add_to_findv_cache t step v = + match t.info.findv_cache with + | None -> t.info.findv_cache <- Some (StepMap.singleton step v) + | Some m -> t.info.findv_cache <- Some (StepMap.add step v m) + + let findv t step = + let of_map m = + match StepMap.find step m with + | exception Not_found -> Lwt.return None + | `Node n -> Lwt.return (Some (`Node n)) + | `Contents (c, m) -> ( + Contents.to_value c >|= function + | None -> None + | Some c -> Some (`Contents (c, m)) ) + in + let of_value repo v = + match P.Node.Val.find v step with + | None -> Lwt.return None + | Some (`Contents (c, m)) -> ( + let c = Contents.of_hash repo c in + let (v : elt) = `Contents (c, m) in + add_to_findv_cache t step v; + Contents.to_value c >|= function + | None -> None + | Some c -> Some (`Contents (c, m)) ) + | Some (`Node n) -> + let n = of_hash repo n in + let v = `Node n in + add_to_findv_cache t step v; + Lwt.return (Some v) + in + let of_t () = + match t.v with + | Map m -> of_map m + | Value (repo, v, None) -> of_value repo v + | Value (repo, v, Some m) -> ( + of_map m >>= function + | Some _ as v -> Lwt.return v + | None -> of_value repo v ) + | Hash (repo, h) -> ( + match value t with + | Some v -> of_value repo v + | None -> ( + value_of_hash t repo h >>= function + | None -> Lwt.return None + | Some v -> of_value repo v ) ) + in + match map t with + | Some m -> of_map m + | None -> ( + match t.info.findv_cache with + | None -> of_t () + | Some m -> ( + of_map m >>= function + | None -> of_t () + | Some _ as r -> Lwt.return r ) ) + + let dummy_marks = Hashes.create 0 + + type marks = unit Hashes.t + + let empty_marks () = Hashes.create 39 + + let fold ~force ~uniq ~pre ~post ~path f t acc = + let marks = + match uniq with + | `False -> dummy_marks + | `True -> empty_marks () + | `Marks n -> n + in + let rec aux ~path acc t k = + match force with + | `True -> to_map t >>= fun m -> (map [@tailcall]) ~path acc m k + | `False skip -> ( + match t.info.map with + | Some n -> (map [@tailcall]) ~path acc (Some n) k + | _ -> skip path acc ) + and aux_uniq ~path acc t k = + if uniq = `False then (aux [@tailcall]) ~path acc t k + else + let h = to_hash t in + if Hashes.mem marks h then k acc + else ( + Hashes.add marks h (); + (aux [@tailcall]) ~path acc t k ) + and step ~path acc (s, v) k = + let path = Path.rcons path s in + match v with + | `Contents c -> Contents.fold ~force ~path f (fst c) acc >>= k + | `Node n -> (aux_uniq [@tailcall]) ~path acc n k + and steps ~path acc s k = + match s with + | [] -> k acc + | h :: t -> + (step [@tailcall]) ~path acc h @@ fun acc -> + (steps [@tailcall]) ~path acc t k + and map ~path acc m k = + match m with + | None -> k acc + | Some m -> + let bindings = StepMap.bindings m in + let s = List.rev_map fst bindings in + pre path s acc >>= fun acc -> + (steps [@tailcall]) ~path acc bindings @@ fun acc -> + post path s acc >>= k + in + aux_uniq ~path acc t Lwt.return + + let remove t step = + to_map t >|= function + | None -> t + | Some n -> + if not (StepMap.mem step n) then t + else of_map (StepMap.remove step n) + + let add t step v = + let v = + match v with + | `Node _ as n -> n + | `Contents (c, m) -> `Contents (Contents.of_value c, m) + in + let of_map m = + let m' = StepMap.add step v m in + if m == m' then t else of_map m' + in + let of_value repo n added = + let added' = StepMap.add step v added in + if added == added' then t else of_value repo n ~added:added' + in + match t.v with + | Map m -> Lwt.return (of_map m) + | Value (repo, n, None) -> Lwt.return (of_value repo n StepMap.empty) + | Value (repo, n, Some m) -> Lwt.return (of_value repo n m) + | Hash (repo, h) -> ( + match (value t, map t) with + | Some v, _ -> Lwt.return (of_value repo v StepMap.empty) + | _, Some m -> Lwt.return (of_map m) + | None, None -> + (value_of_hash t repo h >|= function + | Some v -> v + | None -> P.Node.Val.empty) + >|= fun v -> of_value repo v StepMap.empty ) + + let rec merge : type a. (t Merge.t -> a) -> a = + fun k -> + let f ~old x y = + let old = + Merge.bind_promise old (fun old () -> + to_map old >|= fun m -> Ok (Some m) ) + in + to_map x >>= fun x -> + to_map y >>= fun y -> + let m = + StepMap.merge elt_t (fun _step -> + (merge_elt [@tailcall]) Merge.option ) + in + Merge.(f @@ option m) ~old x y >|= function + | Ok (Some map) -> Ok (of_map map) + | Ok None -> Error (`Conflict "empty map") + | Error _ as e -> e + in + k (Merge.v t f) + + and merge_elt : type a. (elt Merge.t -> a) -> a = + fun k -> + let open Merge.Infix in + let f : elt Merge.f = + fun ~old x y -> + match (x, y) with + | `Contents (x, cx), `Contents (y, cy) -> + let mold = + Merge.bind_promise old (fun old () -> + match old with + | `Contents (_, m) -> Lwt.return (Ok (Some m)) + | `Node _ -> Lwt.return (Ok None) ) + in + Merge.(f Metadata.merge) ~old:mold cx cy >>=* fun m -> + let old = + Merge.bind_promise old (fun old () -> + match old with + | `Contents (c, _) -> Lwt.return (Ok (Some c)) + | `Node _ -> Lwt.return (Ok None) ) + in + Merge.(f Contents.merge) ~old x y >>=* fun c -> + Merge.ok (`Contents (c, m)) + | `Node x, `Node y -> + (merge [@tailcall]) (fun m -> + let old = + Merge.bind_promise old (fun old () -> + match old with + | `Contents _ -> Lwt.return (Ok None) + | `Node n -> Lwt.return (Ok (Some n)) ) + in + Merge.(f m ~old x y) >>=* fun n -> Merge.ok (`Node n) ) + | _ -> Merge.conflict "add/add values" + in + k (Merge.seq [ Merge.default elt_t; Merge.v elt_t f ]) + + let merge_elt = merge_elt (fun x -> x) + end + + type node = Node.t + + type metadata = Metadata.t + + type tree = [ `Node of node | `Contents of contents * metadata ] + + let of_private_node repo n = Node.of_value repo n + + let to_private_node = Node.to_value + + let node_t = Node.t + + let tree_t = + let open Type in + variant "tree" (fun node contents -> function + | `Node n -> node n | `Contents c -> contents c ) + |~ case1 "node" Node.t (fun n -> `Node n) + |~ case1 "contents" (pair P.Contents.Val.t Metadata.t) (fun c -> + `Contents c ) + |> sealv + + let dump ppf = function + | `Node n -> Fmt.pf ppf "node: %a" Node.dump n + | `Contents (c, _) -> + Fmt.pf ppf "contents: %a" (Type.pp P.Contents.Val.t) c + + let contents_equal ((c1, m1) as x1) ((c2, m2) as x2) = + x1 == x2 + || (c1 == c2 && m1 == m2) + || (Type.equal P.Contents.Val.t c1 c2 && Type.equal Metadata.t m1 m2) + + let equal (x : tree) (y : tree) = + x == y + || + match (x, y) with + | `Node x, `Node y -> Node.equal x y + | `Contents x, `Contents y -> contents_equal x y + | `Node _, `Contents _ | `Contents _, `Node _ -> false + + let is_empty = function + | `Node n -> Node.is_empty n + | `Contents _ -> Lwt.return false + + let of_node n = `Node n + + let of_contents ?(metadata = Metadata.default) c = `Contents (c, metadata) + + let clear ?depth = function + | `Node n -> Node.clear ?depth n + | `Contents _ -> () + + let sub t path = + let rec aux node path = + match Path.decons path with + | None -> Lwt.return (Some node) + | Some (h, p) -> ( + Node.findv node h >>= function + | None | Some (`Contents _) -> Lwt.return_none + | Some (`Node n) -> (aux [@tailcall]) n p ) + in + match t with + | `Node n -> (aux [@tailcall]) n path + | `Contents _ -> Lwt.return_none + + let find_tree (t : tree) path = + Log.debug (fun l -> l "Tree.find_tree %a" pp_path path); + match (t, Path.rdecons path) with + | v, None -> Lwt.return (Some v) + | _, Some (path, file) -> ( + sub t path >>= function + | None -> Lwt.return None + | Some n -> Node.findv n file ) + + type marks = Node.marks + + let empty_marks = Node.empty_marks + + type 'a force = [ `True | `False of key -> 'a -> 'a Lwt.t ] + + type uniq = [ `False | `True | `Marks of marks ] + + type 'a node_fn = key -> step list -> 'a -> 'a Lwt.t + + let id _ _ acc = Lwt.return acc + + let fold ?(force = `True) ?(uniq = `False) ?(pre = id) ?(post = id) f + (t : tree) acc = + match t with + | `Contents v -> f Path.empty (fst v) acc + | `Node n -> Node.fold ~force ~uniq ~pre ~post ~path:Path.empty f n acc + + type stats = { + nodes : int; + leafs : int; + skips : int; + depth : int; + width : int + } + + let empty_stats = { nodes = 0; leafs = 0; skips = 0; depth = 0; width = 0 } + + let pp_stats ppf { nodes; leafs; skips; depth; width } = + Fmt.pf ppf "{@[nodes=%d; leafs=%d; skips=%d; depth=%d; width=%d]}" nodes + leafs skips depth width + + let incr_nodes s = { s with nodes = s.nodes + 1 } + + let incr_leafs s = { s with leafs = s.leafs + 1 } + + let incr_skips s = { s with skips = s.skips + 1 } + + let set_depth p s = + let n_depth = List.length (Path.map p (fun _ -> ())) in + let depth = max n_depth s.depth in + { s with depth } + + let set_width childs s = + let width = max s.width (List.length childs) in + { s with width } + + let err_not_found n k = + Fmt.kstrf invalid_arg "Irmin.Tree.%s: %a not found" n pp_path k + + let get_tree (t : tree) path = + find_tree t path >|= function + | None -> err_not_found "get_tree" path + | Some v -> v + + let find_all t k = + find_tree t k >|= function + | None | Some (`Node _) -> None + | Some (`Contents c) -> Some c + + let find t k = + find_all t k >|= function None -> None | Some (c, _) -> Some c + + let get_all t k = + find_all t k >>= function + | None -> err_not_found "get" k + | Some v -> Lwt.return v + + let get t k = get_all t k >|= fun (c, _) -> c + + let mem t k = find t k >|= function None -> false | _ -> true + + let mem_tree t k = find_tree t k >|= function None -> false | _ -> true + + let kind t path = + Log.debug (fun l -> l "Tree.kind %a" pp_path path); + match (t, Path.rdecons path) with + | `Contents _, None -> Lwt.return (Some `Contents) + | _, None -> Lwt.return None + | _, Some (dir, file) -> ( + sub t dir >>= function + | None -> Lwt.return None + | Some m -> ( + Node.findv m file >>= function + | None -> Lwt.return None + | Some (`Contents _) -> Lwt.return (Some `Contents) + | Some (`Node _) -> Lwt.return (Some `Node) ) ) + + let list t path = + Log.debug (fun l -> l "Tree.list %a" pp_path path); + sub t path >>= function None -> Lwt.return [] | Some n -> Node.list n + + let may_remove t k = + Node.findv t k >>= function + | None -> Lwt.return_none + | Some _ -> Node.remove t k >>= fun t -> Lwt.return (Some t) + + let empty = `Node (Node.of_map StepMap.empty) + + let empty_node = function + | `Node n -> Node.empty n + | `Contents _ -> Node.of_map StepMap.empty + + let remove t k = + Log.debug (fun l -> l "Tree.remove %a" pp_path k); + let empty = empty_node t in + match Path.rdecons k with + | None -> + is_empty t >>= fun is_empty -> + if is_empty then Lwt.return t else Lwt.return (`Node empty) + | Some (path, file) -> ( + let rec aux view path k = + let some n = k (Some n) in + match Path.decons path with + | None -> may_remove view file >>= k + | Some (h, p) -> ( + Node.findv view h >>= function + | None | Some (`Contents _) -> k None + | Some (`Node child) -> + (aux [@tailcall]) child p (function + | None -> k None + | Some child' -> ( + (* remove empty dirs *) + Node.is_empty child' + >>= function + | true -> may_remove view h >>= k + | false -> Node.add view h (`Node child') >>= some ) ) + ) + in + let n = match t with `Node n -> n | _ -> empty in + (aux [@tailcall]) n path @@ function + | None -> Lwt.return t + | Some n -> Lwt.return (`Node n) ) + + let add_tree t k v = + Log.debug (fun l -> l "Tree.add_tree %a" pp_path k); + let empty = empty_node t in + match Path.rdecons k with + | None -> Lwt.return v + | Some (path, file) -> ( + let rec aux n path k = + let some n = k (Some n) in + match Path.decons path with + | None -> ( + Node.findv n file >>= function + | None -> Node.add n file v >>= some + | Some old -> + if equal old v then k None else Node.add n file v >>= some ) + | Some (h, p) -> ( + Node.findv n h >>= function + | None | Some (`Contents _) -> + (aux [@tailcall]) empty p (function + | None -> k None + | Some child' -> Node.add n h (`Node child') >>= some ) + | Some (`Node child) -> + (aux [@tailcall]) child p (function + | None -> k None + | Some child' -> Node.add n h (`Node child') >>= some ) ) + in + let n = match t with `Node n -> n | _ -> empty in + (aux [@tailcall]) n path @@ function + | None -> Lwt.return t + | Some node -> Lwt.return (`Node node) ) + + let add t k ?(metadata = Metadata.default) c = + Log.debug (fun l -> l "Tree.add %a" pp_path k); + let empty = empty_node t in + match Path.rdecons k with + | None -> ( + match t with + | `Contents c' when contents_equal c' (c, metadata) -> Lwt.return t + | _ -> Lwt.return (`Contents (c, metadata)) ) + | Some (path, file) -> ( + let rec aux n path k = + let some n = k (Some n) in + match Path.decons path with + | None -> ( + Node.findv n file >>= function + | Some (`Node _) | None -> + Node.add n file (`Contents (c, metadata)) >>= some + | Some (`Contents _ as old) -> + if equal old (`Contents (c, metadata)) then k None + else Node.add n file (`Contents (c, metadata)) >>= some ) + | Some (h, p) -> ( + Node.findv n h >>= function + | None | Some (`Contents _) -> + (aux [@tailcall]) empty p (function + | None -> assert false + | Some child -> Node.add n h (`Node child) >>= some ) + | Some (`Node child) -> + (aux [@tailcall]) child p (function + | None -> k None + | Some child' -> Node.add n h (`Node child') >>= some ) ) + in + let n = match t with `Node n -> n | _ -> empty in + (aux [@tailcall]) n path @@ function + | None -> Lwt.return t + | Some n -> Lwt.return (`Node n) ) + + let import repo k = + cnt.node_mem <- cnt.node_mem + 1; + P.Node.mem (P.Repo.node_t repo) k >|= function + | true -> Some (Node.of_hash repo k) + | false -> None + + let import_no_check repo k = Node.of_hash repo k + + let export ?clear repo contents_t node_t n = + let seen = Hashes.create 127 in + let add_node n v () = + cnt.node_add <- cnt.node_add + 1; + P.Node.add node_t v >|= fun k -> + let k' = Node.to_hash n in + assert (Type.equal P.Hash.t k k'); + Node.export ?clear repo n k + in + let add_contents c x () = + cnt.contents_add <- cnt.contents_add + 1; + P.Contents.add contents_t x >|= fun k -> + let k' = Contents.to_hash c in + assert (Type.equal P.Hash.t k k'); + Contents.export ?clear repo c k + in + let add_node_map n x () = add_node n (Node.value_of_map n x) () in + let todo = Stack.create () in + let rec add_to_todo : type a. _ -> (unit -> a Lwt.t) -> a Lwt.t = + fun n k -> + let h = Node.to_hash n in + if Hashes.mem seen h then k () + else ( + Hashes.add seen h (); + match n.Node.v with + | Node.Hash _ -> + Node.export ?clear repo n h; + k () + | Node.Value (_, x, None) -> + Stack.push (add_node n x) todo; + k () + | Map _ | Value (_, _, Some _) -> ( + cnt.node_mem <- cnt.node_mem + 1; + P.Node.mem node_t h >>= function + | true -> + Node.export ?clear repo n h; + k () + | false -> ( + match n.v with + | Hash _ | Value (_, _, None) -> + (* might happen if the node has already been added + (while the thread was block on P.Node.mem *) + k () + | Map children | Value (_, _, Some children) -> + (* 1. convert partial values to total values *) + ( match n.v with + | Value (_, _, Some _) -> ( + Node.to_value n >|= function + | None -> () + | Some v -> n.v <- Value (repo, v, None) ) + | _ -> Lwt.return () ) + >>= fun () -> + (* 2. push the current node job on the stack. *) + let () = + match (n.v, Node.value n) with + | _, Some v -> Stack.push (add_node n v) todo + | Map x, None -> Stack.push (add_node_map n x) todo + | _ -> assert false + in + let contents = ref [] in + let nodes = ref [] in + StepMap.iter + (fun _ -> function + | `Contents c -> contents := c :: !contents + | `Node n -> nodes := n :: !nodes ) + children; + (* 2. push the contents job on the stack. *) + List.iter + (fun (c, _) -> + let h = Contents.to_hash c in + if Hashes.mem seen h then () + else ( + Hashes.add seen h (); + match c.Contents.v with + | Contents.Hash _ -> () + | Contents.Value x -> + Stack.push (add_contents c x) todo ) ) + !contents; + (* 3. push the children jobs on the stack. *) + List.iter + (fun n -> + Stack.push + (fun () -> (add_to_todo [@tailcall]) n Lwt.return) + todo ) + !nodes; + k () ) ) ) + 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 + (add_to_todo [@tailcall]) n @@ fun () -> + loop () >|= fun () -> + let x = Node.to_hash n in + Log.debug (fun l -> l "Tree.export -> %a" pp_hash x); + x + + let merge : tree Merge.t = + let f ~old (x : tree) y = + let to_node x = + match x with + | `Node _ as x -> x + | `Contents (c, m) -> `Contents (Contents.of_value c, m) + in + let x = to_node x in + let y = to_node y in + let old = + Merge.bind_promise old (fun old -> Merge.promise (to_node old)) + in + Merge.(f Node.merge_elt) ~old x y >>= function + | Ok (`Contents (c, m)) -> ( + Contents.to_value c >>= function + | None -> Merge.conflict "conflict: contents" + | Some c -> Merge.ok (`Contents (c, m)) ) + | Ok (`Node _ as n) -> Merge.ok n + | Error _ as e -> Lwt.return e + in + Merge.v tree_t f + + let entries path tree = + let rec aux acc = function + | [] -> Lwt.return acc + | (path, h) :: todo -> + Node.listv h >>= fun childs -> + let acc, todo = + List.fold_left + (fun (acc, todo) (k, v) -> + let path = Path.rcons path k in + match v with + | `Node v -> (acc, (path, v) :: todo) + | `Contents c -> ((path, c) :: acc, todo) ) + (acc, todo) childs + in + (aux [@tailcall]) acc todo + in + (aux [@tailcall]) [] [ (path, tree) ] + + let diff_node (x : node) (y : node) = + let bindings n = + Node.to_map n >|= function None -> [] | Some m -> StepMap.bindings m + in + let removed acc (k, (c, m)) = + Contents.to_value c >|= function + | None -> acc + | Some c -> (k, `Removed (c, m)) :: acc + in + let added acc (k, (c, m)) = + Contents.to_value c >|= function + | None -> acc + | Some c -> (k, `Added (c, m)) :: acc + in + let rec aux acc = function + | [] -> Lwt.return acc + | (path, x, y) :: todo -> + if Node.equal x y then (aux [@tailcall]) acc todo + else + bindings x >>= fun x -> + bindings y >>= fun y -> + let acc = ref acc in + let todo = ref todo in + alist_iter2_lwt + Type.(compare @@ Path.step_t) + (fun key v -> + let path = Path.rcons path key in + match v with + (* Left *) + | `Left (`Contents x) -> + removed !acc (path, x) >|= fun x -> acc := x + | `Left (`Node x) -> + entries path x >>= fun xs -> + Lwt_list.fold_left_s removed !acc xs >|= fun xs -> + acc := xs + (* Right *) + | `Right (`Contents y) -> + added !acc (path, y) >|= fun y -> acc := y + | `Right (`Node y) -> + entries path y >>= fun ys -> + Lwt_list.fold_left_s added !acc ys >|= fun ys -> acc := ys + (* Both *) + | `Both (`Node x, `Node y) -> + todo := (path, x, y) :: !todo; + Lwt.return_unit + | `Both (`Contents x, `Node y) -> + entries path y >>= fun ys -> + removed !acc (path, x) >>= fun x -> + Lwt_list.fold_left_s added x ys >|= fun ys -> acc := ys + | `Both (`Node x, `Contents y) -> + entries path x >>= fun xs -> + added !acc (path, y) >>= fun y -> + Lwt_list.fold_left_s removed y xs >|= fun ys -> acc := ys + | `Both (`Contents x, `Contents y) -> ( + if Node.contents_equal x y then Lwt.return_unit + else + Contents.to_value (fst x) >>= fun cx -> + Contents.to_value (fst y) >|= fun cy -> + match (cx, cy) with + | None, None -> () + | Some cx, None -> + let x = (cx, snd x) in + acc := (path, `Removed x) :: !acc + | None, Some cy -> + let y = (cy, snd y) in + acc := (path, `Added y) :: !acc + | Some cx, Some cy -> + let x = (cx, snd x) in + let y = (cy, snd y) in + acc := (path, `Updated (x, y)) :: !acc ) ) + x y + >>= fun () -> (aux [@tailcall]) !acc !todo + in + (aux [@tailcall]) [] [ (Path.empty, x, y) ] + + let diff (x : tree) (y : tree) = + match (x, y) with + | `Contents x, `Contents y -> + if contents_equal x y then Lwt.return [] + else Lwt.return [ (Path.empty, `Updated (y, x)) ] + | `Node x, `Node y -> diff_node x y + | `Contents x, `Node y -> + let empty = Node.empty y in + diff_node empty y >|= fun diff -> (Path.empty, `Removed x) :: diff + | `Node x, `Contents y -> + let empty = Node.empty x in + diff_node x empty >|= fun diff -> (Path.empty, `Added y) :: diff + + type concrete = + [ `Tree of (step * concrete) list | `Contents of contents * metadata ] + + let of_concrete c = + let rec concrete k = function + | `Contents _ as v -> k v + | `Tree childs -> tree StepMap.empty (fun n -> k (`Node n)) childs + and contents k (c, m) = k (`Contents (Contents.of_value c, m)) + and tree map k = function + | [] -> k (Node.of_map map) + | (s, n) :: t -> + (concrete [@tailcall]) + (function + | `Contents c -> + (contents [@tailcall]) + (fun v -> (tree [@tailcall]) (StepMap.add s v map) k t) + c + | `Node _ as v -> (tree [@tailcall]) (StepMap.add s v map) k t ) + n + in + (concrete [@tailcall]) (fun x -> x) c + + let to_concrete t = + let rec tree k = function + | `Contents _ as v -> k v + | `Node n -> ( + Node.to_map n >>= function + | None -> k (`Tree []) + | Some n -> + (node [@tailcall]) [] (fun n -> k (`Tree n)) (StepMap.bindings n) + ) + and contents k (c, m) = + Contents.to_value c >>= function + | None -> k None + | Some c -> k @@ Some (`Contents (c, m)) + and node childs k = function + | [] -> k childs + | (s, n) :: t -> ( + match n with + | `Node _ as n -> + (tree [@tailcall]) (fun tree -> node ((s, tree) :: childs) k t) n + | `Contents c -> + (contents [@tailcall]) + (function + | None -> (node [@tailcall]) childs k t + | Some c -> (node [@tailcall]) ((s, c) :: childs) k t ) + c ) + in + tree (fun x -> Lwt.return x) t + + let hash (t : tree) = + Log.debug (fun l -> l "Tree.hash"); + match t with + | `Node n -> `Node (Node.to_hash n) + | `Contents (c, m) -> + cnt.contents_hash <- cnt.contents_hash + 1; + `Contents (P.Contents.Key.hash c, m) + + module Cache = struct + let length () = + ( `Contents Contents.(Hashes.length hashes), + `Nodes Node.(Cache.length cache) ) + + let clear ?depth () = + Log.info (fun l -> l "Tree.Cache.clear %a" Fmt.(option int) depth); + match depth with + | None -> + Contents.iter_info Contents.clear_info; + Node.iter_info (fun i -> Node.clear_info i) + | Some depth -> + Contents.iter_info (Contents.mark `White); + Node.iter_info (Node.mark `White); + Node.iter_info (fun i -> Node.clear_info ~depth i); + Contents.iter_info (fun i -> + if i.Contents.color = `White then Contents.clear_info i ) + + let dump ppf () = + let ppo t ppf = function + | None -> Fmt.pf ppf "" + | Some y -> Type.pp t ppf y + in + Contents.Hashes.iter + (fun k v -> + Fmt.pf ppf "C|%a: %a@." pp_hash k (ppo P.Contents.Val.t) + v.Contents.value ) + Contents.hashes; + Node.Cache.iter + (fun k v -> Fmt.pf ppf "N|%a: %a@." pp_hash k Node.dump_info v) + Node.cache + end + + let stats ?(force = false) (t : tree) = + let force = + if force then `True + else `False (fun k s -> set_depth k s |> incr_skips |> Lwt.return) + in + let f k _ s = set_depth k s |> incr_leafs |> Lwt.return in + let pre k childs s = + if childs = [] then Lwt.return s + else set_depth k s |> set_width childs |> incr_nodes |> Lwt.return + in + let post _ _ acc = Lwt.return acc in + fold ~force ~pre ~post f t empty_stats + + let counters () = cnt + + let dump_counters ppf () = + let `Contents c, `Nodes n = Cache.length () in + cnt.contents_cache_length <- c; + cnt.node_cache_length <- n; + dump_counters ppf cnt + + let reset_counters () = reset_counters cnt + + let inspect = function + | `Contents _ -> `Contents + | `Node n -> + `Node + ( match n.Node.v with + | Map _ -> `Map + | Value _ -> `Value + | Hash _ -> `Hash ) +end diff --git a/vendors/irmin/tree.mli b/vendors/irmin/tree.mli new file mode 100644 index 000000000000..b2aeab12acdd --- /dev/null +++ b/vendors/irmin/tree.mli @@ -0,0 +1,51 @@ +(* + * Copyright (c) 2013-2017 Thomas Gazagnaire + * Copyright (c) 2017 Grégoire Henry + * + * 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 Make (P : S.PRIVATE) : sig + include + S.TREE + with type key = P.Node.Path.t + and type step = P.Node.Path.step + and type metadata = P.Node.Val.metadata + and type contents = P.Contents.value + + val import : P.Repo.t -> P.Node.key -> node option Lwt.t + + val import_no_check : P.Repo.t -> P.Node.key -> node + + val export : + ?clear:bool -> + P.Repo.t -> + [> `Write ] P.Contents.t -> + [ `Read | `Write ] P.Node.t -> + node -> + P.Node.key Lwt.t + + val dump : tree Fmt.t + + val equal : tree -> tree -> bool + + val node_t : node Type.t + + val tree_t : tree Type.t + + val hash : tree -> [ `Contents of P.Hash.t * metadata | `Node of P.Hash.t ] + + val of_private_node : P.Repo.t -> P.Node.value -> node + + val to_private_node : node -> P.Node.value option Lwt.t +end diff --git a/vendors/irmin/type.ml b/vendors/irmin/type.ml new file mode 100644 index 000000000000..b766d088a122 --- /dev/null +++ b/vendors/irmin/type.ml @@ -0,0 +1,1659 @@ +(* + * Copyright (c) 2016-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. + *) + +type (_, _) eq = Refl : ('a, 'a) eq + +module Witness : sig + type 'a t + + val make : unit -> 'a t + + val eq : 'a t -> 'b t -> ('a, 'b) eq option +end = struct + type _ equality = .. + + module type Inst = sig + type t + + type _ equality += Eq : t equality + end + + type 'a t = (module Inst with type t = 'a) + + let make : type a. unit -> a t = + fun () -> + let module Inst = struct + type t = a + + type _ equality += Eq : t equality + end in + (module Inst) + + let eq : type a b. a t -> b t -> (a, b) eq option = + fun (module A) (module B) -> match A.Eq with B.Eq -> Some Refl | _ -> None +end + +module Json = struct + type decoder = { mutable lexemes : Jsonm.lexeme list; d : Jsonm.decoder } + + let decoder ?encoding src = { lexemes = []; d = Jsonm.decoder ?encoding src } + + let decoder_of_lexemes lexemes = { lexemes; d = Jsonm.decoder (`String "") } + + let rewind e l = e.lexemes <- l :: e.lexemes + + let decode e = + match e.lexemes with + | h :: t -> + e.lexemes <- t; + `Lexeme h + | [] -> Jsonm.decode e.d +end + +type len = [ `Int | `Int8 | `Int16 | `Int32 | `Int64 | `Fixed of int ] + +type 'a pp = 'a Fmt.t + +type 'a of_string = string -> ('a, [ `Msg of string ]) result + +type 'a to_string = 'a -> string + +type 'a encode_json = Jsonm.encoder -> 'a -> unit + +type 'a decode_json = Json.decoder -> ('a, [ `Msg of string ]) result + +type 'a bin_seq = 'a -> (string -> unit) -> unit + +type 'a encode_bin = ?headers:bool -> 'a bin_seq + +type 'a decode_bin = ?headers:bool -> string -> int -> int * 'a + +type 'a size_of = ?headers:bool -> 'a -> int option + +type 'a compare = 'a -> 'a -> int + +type 'a equal = 'a -> 'a -> bool + +type 'a short_hash = ?seed:int -> 'a -> int + +type 'a t = + | Self : 'a self -> 'a t + | Custom : 'a custom -> 'a t + | Map : ('a, 'b) map -> 'b t + | Prim : 'a prim -> 'a t + | List : 'a len_v -> 'a list t + | Array : 'a len_v -> 'a array t + | Tuple : 'a tuple -> 'a t + | Option : 'a t -> 'a option t + | Record : 'a record -> 'a t + | Variant : 'a variant -> 'a t + +and 'a len_v = { len : len; v : 'a t } + +and 'a custom = { + cwit : [ `Type of 'a t | `Witness of 'a Witness.t ]; + pp : 'a pp; + of_string : 'a of_string; + encode_json : 'a encode_json; + decode_json : 'a decode_json; + encode_bin : 'a encode_bin; + decode_bin : 'a decode_bin; + short_hash : 'a short_hash; + pre_hash : 'a bin_seq; + size_of : 'a size_of; + compare : 'a compare; + equal : 'a equal +} + +and ('a, 'b) map = { + x : 'a t; + f : 'a -> 'b; + g : 'b -> 'a; + mwit : 'b Witness.t +} + +and 'a self = { mutable self : 'a t } + +and 'a prim = + | Unit : unit prim + | Bool : bool prim + | Char : char prim + | Int : int prim + | Int32 : int32 prim + | Int64 : int64 prim + | Float : float prim + | String : len -> string prim + | Bytes : len -> bytes prim + +and 'a tuple = + | Pair : 'a t * 'b t -> ('a * 'b) tuple + | Triple : 'a t * 'b t * 'c t -> ('a * 'b * 'c) tuple + +and 'a record = { + rwit : 'a Witness.t; + rname : string; + rfields : 'a fields_and_constr +} + +and 'a fields_and_constr = + | Fields : ('a, 'b) fields * 'b -> 'a fields_and_constr + +and ('a, 'b) fields = + | F0 : ('a, 'a) fields + | F1 : ('a, 'b) field * ('a, 'c) fields -> ('a, 'b -> 'c) fields + +and ('a, 'b) field = { fname : string; ftype : 'b t; fget : 'a -> 'b } + +and 'a variant = { + vwit : 'a Witness.t; + vname : string; + vcases : 'a a_case array; + vget : 'a -> 'a case_v +} + +and 'a a_case = C0 : 'a case0 -> 'a a_case | C1 : ('a, 'b) case1 -> 'a a_case + +and 'a case_v = + | CV0 : 'a case0 -> 'a case_v + | CV1 : ('a, 'b) case1 * 'b -> 'a case_v + +and 'a case0 = { ctag0 : int; cname0 : string; c0 : 'a } + +and ('a, 'b) case1 = { + ctag1 : int; + cname1 : string; + ctype1 : 'b t; + c1 : 'b -> 'a +} + +type _ a_field = Field : ('a, 'b) field -> 'a a_field + +let rec pp_ty : type a. a t Fmt.t = + fun ppf -> function + | Self s -> Fmt.pf ppf "@[Self (%a@)]" pp_ty s.self + | Custom c -> Fmt.pf ppf "@[Custom (%a)@]" pp_custom c + | Map m -> Fmt.pf ppf "@[Map (%a)]" pp_ty m.x + | Prim p -> Fmt.pf ppf "@[Prim %a@]" pp_prim p + | List l -> Fmt.pf ppf "@[List%a (%a)@]" pp_len l.len pp_ty l.v + | Array a -> Fmt.pf ppf "@[Array%a (%a)@]" pp_len a.len pp_ty a.v + | Tuple (Pair (a, b)) -> Fmt.pf ppf "@[Pair (%a, %a)@]" pp_ty a pp_ty b + | Tuple (Triple (a, b, c)) -> + Fmt.pf ppf "@[Triple (%a, %a, %a)@]" pp_ty a pp_ty b pp_ty c + | Option t -> Fmt.pf ppf "@[Option (%a)@]" pp_ty t + | Record _ -> Fmt.pf ppf "@[Record@]" + | Variant _ -> Fmt.pf ppf "@[Variant@]" + +and pp_custom : type a. a custom Fmt.t = + fun ppf c -> + match c.cwit with `Type t -> pp_ty ppf t | `Witness _ -> Fmt.string ppf "-" + +and pp_prim : type a. a prim Fmt.t = + fun ppf -> function + | Unit -> Fmt.string ppf "Unit" + | Bool -> Fmt.string ppf "Bool" + | Char -> Fmt.string ppf "Char" + | Int -> Fmt.string ppf "Int" + | Int32 -> Fmt.string ppf "Int32" + | Int64 -> Fmt.string ppf "Int64" + | Float -> Fmt.string ppf "Float" + | String n -> Fmt.pf ppf "String%a" pp_len n + | Bytes n -> Fmt.pf ppf "Bytes%a" pp_len n + +and pp_len : len Fmt.t = + fun ppf -> function + | `Int8 -> Fmt.string ppf ":8" + | `Int64 -> Fmt.string ppf ":64" + | `Int16 -> Fmt.string ppf ":16" + | `Fixed n -> Fmt.pf ppf ":<%d>" n + | `Int -> () + | `Int32 -> Fmt.pf ppf ":32" + +module Refl = struct + let prim : type a b. a prim -> b prim -> (a, b) eq option = + fun a b -> + match (a, b) with + | Unit, Unit -> Some Refl + | Bool, Bool -> Some Refl + | Char, Char -> Some Refl + | Int, Int -> Some Refl + | Int32, Int32 -> Some Refl + | Int64, Int64 -> Some Refl + | Float, Float -> Some Refl + | String _, String _ -> Some Refl + | Bytes _, Bytes _ -> Some Refl + | _ -> None + + let rec t : type a b. a t -> b t -> (a, b) eq option = + fun a b -> + match (a, b) with + | Self a, _ -> t a.self b + | _, Self b -> t a b.self + | Map a, Map b -> Witness.eq a.mwit b.mwit + | Custom a, Custom b -> custom a b + | Prim a, Prim b -> prim a b + | Array a, Array b -> ( + match t a.v b.v with Some Refl -> Some Refl | None -> None ) + | List a, List b -> ( + match t a.v b.v with Some Refl -> Some Refl | None -> None ) + | Tuple a, Tuple b -> tuple a b + | Option a, Option b -> ( + match t a b with Some Refl -> Some Refl | None -> None ) + | Record a, Record b -> Witness.eq a.rwit b.rwit + | Variant a, Variant b -> Witness.eq a.vwit b.vwit + | _ -> None + + and custom : type a b. a custom -> b custom -> (a, b) eq option = + fun a b -> + match (a.cwit, b.cwit) with + | `Witness a, `Witness b -> Witness.eq a b + | `Type a, `Type b -> t a b + | _ -> None + + and tuple : type a b. a tuple -> b tuple -> (a, b) eq option = + fun a b -> + match (a, b) with + | Pair (a0, a1), Pair (b0, b1) -> ( + match (t a0 b0, t a1 b1) with + | Some Refl, Some Refl -> Some Refl + | _ -> None ) + | Triple (a0, a1, a2), Triple (b0, b1, b2) -> ( + match (t a0 b0, t a1 b1, t a2 b2) with + | Some Refl, Some Refl, Some Refl -> Some Refl + | _ -> None ) + | _ -> None +end + +let unit = Prim Unit + +let bool = Prim Bool + +let char = Prim Char + +let int = Prim Int + +let int32 = Prim Int32 + +let int64 = Prim Int64 + +let float = Prim Float + +let string = Prim (String `Int) + +let bytes = Prim (Bytes `Int) + +let string_of n = Prim (String n) + +let bytes_of n = Prim (Bytes n) + +let list ?(len = `Int) v = List { v; len } + +let array ?(len = `Int) v = Array { v; len } + +let pair a b = Tuple (Pair (a, b)) + +let triple a b c = Tuple (Triple (a, b, c)) + +let option a = Option a + +let v ~cli ~json ~bin ~equal ~compare ~short_hash ~pre_hash = + let pp, of_string = cli in + let encode_json, decode_json = json in + let encode_bin, decode_bin, size_of = bin in + Custom + { cwit = `Witness (Witness.make ()); + pp; + of_string; + pre_hash; + encode_json; + decode_json; + encode_bin; + decode_bin; + size_of; + compare; + equal; + short_hash + } + +(* fix points *) + +let mu : type a. (a t -> a t) -> a t = + fun f -> + let rec fake_x = { self = Self fake_x } in + let real_x = f (Self fake_x) in + fake_x.self <- real_x; + real_x + +let mu2 : type a b. (a t -> b t -> a t * b t) -> a t * b t = + fun f -> + let rec fake_x = { self = Self fake_x } in + let rec fake_y = { self = Self fake_y } in + let real_x, real_y = f (Self fake_x) (Self fake_y) in + fake_x.self <- real_x; + fake_y.self <- real_y; + (real_x, real_y) + +(* records *) + +type ('a, 'b, 'c) open_record = + ('a, 'c) fields -> string * 'b * ('a, 'b) fields + +let field fname ftype fget = { fname; ftype; fget } + +let record : string -> 'b -> ('a, 'b, 'b) open_record = fun n c fs -> (n, c, fs) + +let app : type a b c d. + (a, b, c -> d) open_record -> (a, c) field -> (a, b, d) open_record = + fun r f fs -> + let n, c, fs = r (F1 (f, fs)) in + (n, c, fs) + +let sealr : type a b. (a, b, a) open_record -> a t = + fun r -> + let rname, c, fs = r F0 in + let rwit = Witness.make () in + Record { rwit; rname; rfields = Fields (fs, c) } + +let ( |+ ) = app + +(* variants *) + +type 'a case_p = 'a case_v + +type ('a, 'b) case = int -> 'a a_case * 'b + +let case0 cname0 c0 ctag0 = + let c = { ctag0; cname0; c0 } in + (C0 c, CV0 c) + +let case1 cname1 ctype1 c1 ctag1 = + let c = { ctag1; cname1; ctype1; c1 } in + (C1 c, fun v -> CV1 (c, v)) + +type ('a, 'b, 'c) open_variant = 'a a_case list -> string * 'c * 'a a_case list + +let variant n c vs = (n, c, vs) + +let app v c cs = + let n, fc, cs = v cs in + let c, f = c (List.length cs) in + (n, fc f, c :: cs) + +let sealv v = + let vname, vget, vcases = v [] in + let vwit = Witness.make () in + let vcases = Array.of_list (List.rev vcases) in + Variant { vwit; vname; vcases; vget } + +let ( |~ ) = app + +let enum vname l = + let vwit = Witness.make () in + let _, vcases, mk = + List.fold_left + (fun (ctag0, cases, mk) (n, v) -> + let c = { ctag0; cname0 = n; c0 = v } in + (ctag0 + 1, C0 c :: cases, (v, CV0 c) :: mk) ) + (0, [], []) l + in + let vcases = Array.of_list (List.rev vcases) in + Variant { vwit; vname; vcases; vget = (fun x -> List.assq x mk) } + +let rec fields_aux : type a b. (a, b) fields -> a a_field list = function + | F0 -> [] + | F1 (h, t) -> Field h :: fields_aux t + +let fields r = match r.rfields with Fields (f, _) -> fields_aux f + +let result a b = + variant "result" (fun ok error -> function + | Ok x -> ok x | Error x -> error x ) + |~ case1 "ok" a (fun a -> Ok a) + |~ case1 "error" b (fun b -> Error b) + |> sealv + +module Equal = struct + let unit _ _ = true + + let bool (x : bool) (y : bool) = x = y + + let char (x : char) (y : char) = x = y + + let int (x : int) (y : int) = x = y + + let int32 (x : int32) (y : int32) = x = y + + let int64 (x : int64) (y : int64) = x = y + + let string x y = x == y || String.equal x y + + let bytes x y = x == y || Bytes.equal x y + + (* NOTE: equality is ill-defined on float *) + let float (x : float) (y : float) = x = y + + let list e x y = + x == y || (List.length x = List.length y && List.for_all2 e x y) + + let array e x y = + x == y + || Array.length x = Array.length y + && + let rec aux = function + | -1 -> true + | i -> e x.(i) y.(i) && aux (i - 1) + in + aux (Array.length x - 1) + + let pair ex ey ((x1, y1) as a) ((x2, y2) as b) = + a == b || (ex x1 x2 && ey y1 y2) + + let triple ex ey ez ((x1, y1, z1) as a) ((x2, y2, z2) as b) = + a == b || (ex x1 x2 && ey y1 y2 && ez z1 z2) + + let option e x y = + x == y + || + match (x, y) with + | None, None -> true + | Some x, Some y -> e x y + | _ -> false + + let rec t : type a. a t -> a equal = + fun ty a b -> + match ty with + | Self s -> t s.self a b + | Custom c -> c.equal a b + | Map m -> map m a b + | Prim p -> prim p a b + | List l -> list (t l.v) a b + | Array x -> array (t x.v) a b + | Tuple t -> tuple t a b + | Option x -> option (t x) a b + | Record r -> record r a b + | Variant v -> variant v a b + + and tuple : type a. a tuple -> a equal = function + | Pair (a, b) -> pair (t a) (t b) + | Triple (a, b, c) -> triple (t a) (t b) (t c) + + and map : type a b. (a, b) map -> b equal = + fun { x; g; _ } u v -> t x (g u) (g v) + + and prim : type a. a prim -> a equal = function + | Unit -> unit + | Bool -> bool + | Char -> char + | Int -> int + | Int32 -> int32 + | Int64 -> int64 + | Float -> float + | String _ -> string + | Bytes _ -> bytes + + and record : type a. a record -> a equal = + fun r x y -> List.for_all (function Field f -> field f x y) (fields r) + + and field : type a b. (a, b) field -> a equal = + fun f x y -> t f.ftype (f.fget x) (f.fget y) + + and variant : type a. a variant -> a equal = + fun v x y -> case_v (v.vget x) (v.vget y) + + and case_v : type a. a case_v equal = + fun x y -> + match (x, y) with + | CV0 x, CV0 y -> int x.ctag0 y.ctag0 + | CV1 (x, vx), CV1 (y, vy) -> + int x.ctag1 y.ctag1 && eq (x.ctype1, vx) (y.ctype1, vy) + | _ -> false + + and eq : type a b. a t * a -> b t * b -> bool = + fun (tx, x) (ty, y) -> + match Refl.t tx ty with Some Refl -> t tx x y | None -> assert false + + (* this should never happen *) +end + +let equal = Equal.t + +module Compare = struct + let unit (_ : unit) (_ : unit) = 0 + + let bool (x : bool) (y : bool) = compare x y + + let char = Char.compare + + let int (x : int) (y : int) = compare x y + + let int32 = Int32.compare + + let int64 = Int64.compare + + let float (x : float) (y : float) = compare x y + + let string x y = if x == y then 0 else String.compare x y + + let bytes x y = if x == y then 0 else Bytes.compare x y + + let list c x y = + if x == y then 0 + else + let rec aux x y = + match (x, y) with + | [], [] -> 0 + | [], _ -> -1 + | _, [] -> 1 + | xx :: x, yy :: y -> ( match c xx yy with 0 -> aux x y | i -> i ) + in + aux x y + + let array c x y = + if x == y then 0 + else + let lenx = Array.length x in + let leny = Array.length y in + if lenx > leny then 1 + else if lenx < leny then -1 + else + let rec aux i = + match c x.(i) y.(i) with + | 0 when i + 1 = lenx -> 0 + | 0 -> aux (i + 1) + | i -> i + in + aux 0 + + let pair cx cy ((x1, y1) as a) ((x2, y2) as b) = + if a == b then 0 else match cx x1 x2 with 0 -> cy y1 y2 | i -> i + + let triple cx cy cz ((x1, y1, z1) as a) ((x2, y2, z2) as b) = + if a == b then 0 + else match cx x1 x2 with 0 -> pair cy cz (y1, z1) (y2, z2) | i -> i + + let option c x y = + if x == y then 0 + else + match (x, y) with + | None, None -> 0 + | Some _, None -> 1 + | None, Some _ -> -1 + | Some x, Some y -> c x y + + let rec t : type a. a t -> a compare = + fun ty a b -> + match ty with + | Self s -> t s.self a b + | Custom c -> c.compare a b + | Map m -> map m a b + | Prim p -> prim p a b + | List l -> list (t l.v) a b + | Array x -> array (t x.v) a b + | Tuple t -> tuple t a b + | Option x -> option (t x) a b + | Record r -> record r a b + | Variant v -> variant v a b + + and tuple : type a. a tuple -> a compare = function + | Pair (x, y) -> pair (t x) (t y) + | Triple (x, y, z) -> triple (t x) (t y) (t z) + + and map : type a b. (a, b) map -> b compare = + fun { x; g; _ } u v -> t x (g u) (g v) + + and prim : type a. a prim -> a compare = function + | Unit -> unit + | Bool -> bool + | Char -> char + | Int -> int + | Int32 -> int32 + | Int64 -> int64 + | Float -> float + | String _ -> string + | Bytes _ -> bytes + + and record : type a. a record -> a compare = + fun r x y -> + let rec aux = function + | [] -> 0 + | Field f :: t -> ( match field f x y with 0 -> aux t | i -> i ) + in + aux (fields r) + + and field : type a b. (a, b) field -> a compare = + fun f x y -> t f.ftype (f.fget x) (f.fget y) + + and variant : type a. a variant -> a compare = + fun v x y -> case_v (v.vget x) (v.vget y) + + and case_v : type a. a case_v compare = + fun x y -> + match (x, y) with + | CV0 x, CV0 y -> int x.ctag0 y.ctag0 + | CV0 x, CV1 (y, _) -> int x.ctag0 y.ctag1 + | CV1 (x, _), CV0 y -> int x.ctag1 y.ctag0 + | CV1 (x, vx), CV1 (y, vy) -> ( + match int x.ctag1 y.ctag1 with + | 0 -> compare (x.ctype1, vx) (y.ctype1, vy) + | i -> i ) + + and compare : type a b. a t * a -> b t * b -> int = + fun (tx, x) (ty, y) -> + match Refl.t tx ty with Some Refl -> t tx x y | None -> assert false + + (* this should never happen *) +end + +let compare = Compare.t + +exception Not_utf8 + +let is_valid_utf8 str = + try + Uutf.String.fold_utf_8 + (fun _ _ -> function `Malformed _ -> raise Not_utf8 | _ -> ()) + () str; + true + with Not_utf8 -> false + +module Encode_json = struct + let lexeme e l = ignore (Jsonm.encode e (`Lexeme l)) + + let unit e () = lexeme e `Null + + let base64 e s = + let x = Base64.encode_exn s in + lexeme e `Os; + lexeme e (`Name "base64"); + lexeme e (`String x); + lexeme e `Oe + + let string e s = if is_valid_utf8 s then lexeme e (`String s) else base64 e s + + let bytes e b = + let s = Bytes.unsafe_to_string b in + string e s + + let char e c = + let s = String.make 1 c in + string e s + + let float e f = lexeme e (`Float f) + + let int e i = float e (float_of_int i) + + let int32 e i = float e (Int32.to_float i) + + let int64 e i = float e (Int64.to_float i) + + let bool e = function false -> float e 0. | _ -> float e 1. + + let list l e x = + lexeme e `As; + List.iter (l e) x; + lexeme e `Ae + + let array l e x = + lexeme e `As; + Array.iter (l e) x; + lexeme e `Ae + + let pair a b e (x, y) = + lexeme e `As; + a e x; + b e y; + lexeme e `Ae + + let triple a b c e (x, y, z) = + lexeme e `As; + a e x; + b e y; + c e z; + lexeme e `Ae + + let option o e = function None -> lexeme e `Null | Some x -> o e x + + let rec t : type a. a t -> a encode_json = + fun ty e -> + match ty with + | Self s -> t s.self e + | Custom c -> c.encode_json e + | Map b -> map b e + | Prim t -> prim t e + | List l -> list (t l.v) e + | Array a -> array (t a.v) e + | Tuple t -> tuple t e + | Option x -> option (t x) e + | Record r -> record r e + | Variant v -> variant v e + + and tuple : type a. a tuple -> a encode_json = function + | Pair (x, y) -> pair (t x) (t y) + | Triple (x, y, z) -> triple (t x) (t y) (t z) + + and map : type a b. (a, b) map -> b encode_json = + fun { x; g; _ } e u -> t x e (g u) + + and prim : type a. a prim -> a encode_json = function + | Unit -> unit + | Bool -> bool + | Char -> char + | Int -> int + | Int32 -> int32 + | Int64 -> int64 + | Float -> float + | String _ -> string + | Bytes _ -> bytes + + and record : type a. a record -> a encode_json = + fun r e x -> + let fields = fields r in + lexeme e `Os; + List.iter + (fun (Field f) -> + match (f.ftype, f.fget x) with + | Option _, None -> () + | Option o, Some x -> + lexeme e (`Name f.fname); + t o e x + | List _, [] -> () + | tx, x -> + lexeme e (`Name f.fname); + t tx e x ) + fields; + lexeme e `Oe + + and variant : type a. a variant -> a encode_json = + fun v e x -> case_v e (v.vget x) + + and case_v : type a. a case_v encode_json = + fun e c -> + match c with + | CV0 c -> string e c.cname0 + | CV1 (c, v) -> + lexeme e `Os; + lexeme e (`Name c.cname1); + t c.ctype1 e v; + lexeme e `Oe +end + +let encode_json = Encode_json.t + +let pp_json ?minify t ppf x = + let buf = Buffer.create 42 in + let e = Jsonm.encoder ?minify (`Buffer buf) in + encode_json t e x; + ignore (Jsonm.encode e `End); + Fmt.string ppf (Buffer.contents buf) + +let pp t = + let rec aux : type a. a t -> a pp = + fun t ppf x -> + match t with + | Self s -> aux s.self ppf x + | Custom c -> c.pp ppf x + | Map m -> map m ppf x + | Prim p -> prim p ppf x + | _ -> pp_json t ppf x + and map : type a b. (a, b) map -> b pp = fun l ppf x -> aux l.x ppf (l.g x) + and prim : type a. a prim -> a pp = + fun t ppf x -> + match t with + | Unit -> () + | Bool -> Fmt.bool ppf x + | Char -> Fmt.char ppf x + | Int -> Fmt.int ppf x + | Int32 -> Fmt.int32 ppf x + | Int64 -> Fmt.int64 ppf x + | Float -> Fmt.float ppf x + | String _ -> Fmt.string ppf x + | Bytes _ -> Fmt.string ppf (Bytes.unsafe_to_string x) + in + aux t + +let to_json_string ?minify t x = Fmt.to_to_string (pp_json ?minify t) x + +module Decode_json = struct + let lexeme e = + match Json.decode e with + | `Lexeme e -> Ok e + | `Error e -> Error (`Msg (Fmt.to_to_string Jsonm.pp_error e)) + | `End | `Await -> assert false + + let ( >>= ) l f = match l with Error _ as e -> e | Ok l -> f l + + let ( >|= ) l f = match l with Ok l -> Ok (f l) | Error _ as e -> e + + let join = function Error _ as e -> e | Ok x -> x + + let error e got expected = + let _, (l, c) = Jsonm.decoded_range e.Json.d in + Error + (`Msg + (Fmt.strf + "line %d, character %d:\n\ + Found lexeme %a, but lexeme %s was expected" + l c Jsonm.pp_lexeme got expected)) + + let expect_lexeme e expected = + lexeme e >>= fun got -> + if expected = got then Ok () + else error e got (Fmt.to_to_string Jsonm.pp_lexeme expected) + + (* read all lexemes until the end of the next well-formed value *) + let value e = + let lexemes = ref [] in + let objs = ref 0 in + let arrs = ref 0 in + let rec aux () = + lexeme e >>= fun l -> + lexemes := l :: !lexemes; + let () = + match l with + | `Os -> incr objs + | `As -> incr arrs + | `Oe -> decr objs + | `Ae -> decr arrs + | `Name _ | `Null | `Bool _ | `String _ | `Float _ -> () + in + if !objs > 0 || !arrs > 0 then aux () else Ok () + in + aux () >|= fun () -> List.rev !lexemes + + let unit e = expect_lexeme e `Null + + let get_base64_value e = + match lexeme e with + | Ok (`Name "base64") -> ( + match lexeme e with + | Ok (`String b) -> ( + match expect_lexeme e `Oe with + | Ok () -> Ok (Base64.decode_exn b) + | Error e -> Error e ) + | Ok l -> error e l "Bad base64 encoded character" + | Error e -> Error e ) + | Ok l -> error e l "Invalid base64 object" + | Error e -> Error e + + let string e = + lexeme e >>= function + | `String s -> Ok s + | `Os -> get_base64_value e + | l -> error e l "`String" + + let bytes e = + lexeme e >>= function + | `String s -> Ok (Bytes.unsafe_of_string s) + | `Os -> ( + match get_base64_value e with + | Ok s -> Ok (Bytes.unsafe_of_string s) + | Error e -> Error e ) + | l -> error e l "`String" + + let float e = + lexeme e >>= function `Float f -> Ok f | l -> error e l "`Float" + + let char e = + lexeme e >>= function + | `String s when String.length s = 1 -> Ok s.[0] + | `Os -> ( + match get_base64_value e with Ok s -> Ok s.[0] | Error x -> Error x ) + | l -> error e l "`String[0]" + + let int32 e = float e >|= Int32.of_float + + let int64 e = float e >|= Int64.of_float + + let int e = float e >|= int_of_float + + let bool e = int e >|= function 0 -> false | _ -> true + + let list l e = + expect_lexeme e `As >>= fun () -> + let rec aux acc = + lexeme e >>= function + | `Ae -> Ok (List.rev acc) + | lex -> + Json.rewind e lex; + l e >>= fun v -> aux (v :: acc) + in + aux [] + + let array l e = list l e >|= Array.of_list + + let pair a b e = + expect_lexeme e `As >>= fun () -> + a e >>= fun x -> b e >>= fun y -> expect_lexeme e `Ae >|= fun () -> (x, y) + + let triple a b c e = + expect_lexeme e `As >>= fun () -> + a e >>= fun x -> + b e >>= fun y -> + c e >>= fun z -> expect_lexeme e `Ae >|= fun () -> (x, y, z) + + let option o e = + lexeme e >>= function + | `Null -> Ok None + | lex -> + Json.rewind e lex; + o e >|= fun v -> Some v + + let rec t : type a. a t -> a decode_json = + fun ty d -> + match ty with + | Self s -> t s.self d + | Custom c -> c.decode_json d + | Map b -> map b d + | Prim t -> prim t d + | List l -> list (t l.v) d + | Array a -> array (t a.v) d + | Tuple t -> tuple t d + | Option x -> option (t x) d + | Record r -> record r d + | Variant v -> variant v d + + and tuple : type a. a tuple -> a decode_json = function + | Pair (x, y) -> pair (t x) (t y) + | Triple (x, y, z) -> triple (t x) (t y) (t z) + + and map : type a b. (a, b) map -> b decode_json = + fun { x; f; _ } e -> t x e >|= f + + and prim : type a. a prim -> a decode_json = function + | Unit -> unit + | Bool -> bool + | Char -> char + | Int -> int + | Int32 -> int32 + | Int64 -> int64 + | Float -> float + | String _ -> string + | Bytes _ -> bytes + + and record : type a. a record -> a decode_json = + fun r e -> + expect_lexeme e `Os >>= fun () -> + let rec soup acc = + lexeme e >>= function + | `Name n -> value e >>= fun s -> soup ((n, s) :: acc) + | `Oe -> Ok acc + | l -> error e l "`Record-contents" + in + soup [] >>= fun soup -> + let rec aux : type a b. + (a, b) fields -> b -> (a, [ `Msg of string ]) result = + fun f c -> + match f with + | F0 -> Ok c + | F1 (h, f) -> ( + let v = + try + let s = List.assoc h.fname soup in + let e = Json.decoder_of_lexemes s in + t h.ftype e + with Not_found -> ( + match h.ftype with + | Option _ -> Ok None + | List _ -> Ok [] + | _ -> + Error + (`Msg (Fmt.strf "missing value for %s.%s" r.rname h.fname)) ) + in + match v with Ok v -> aux f (c v) | Error _ as e -> e ) + in + let (Fields (f, c)) = r.rfields in + aux f c + + and variant : type a. a variant -> a decode_json = + fun v e -> + lexeme e >>= function + | `String s -> case0 s v e + | `Os -> case1 v e + | l -> error e l "(`String | `Os)" + + and case0 : type a. string -> a variant -> a decode_json = + fun s v _e -> + let rec aux i = + match v.vcases.(i) with + | C0 c when String.compare c.cname0 s = 0 -> Ok c.c0 + | _ -> + if i < Array.length v.vcases then aux (i + 1) + else Error (`Msg "variant") + in + aux 0 + + and case1 : type a. a variant -> a decode_json = + fun v e -> + lexeme e >>= function + | `Name s -> + let rec aux i = + match v.vcases.(i) with + | C1 c when String.compare c.cname1 s = 0 -> t c.ctype1 e >|= c.c1 + | _ -> + if i < Array.length v.vcases then aux (i + 1) + else Error (`Msg "variant") + in + aux 0 >>= fun c -> expect_lexeme e `Oe >|= fun () -> c + | l -> error e l "`Name" +end + +let decode_json x d = Decode_json.(t x @@ { Json.d; lexemes = [] }) + +let decode_json_lexemes x ls = Decode_json.(t x @@ Json.decoder_of_lexemes ls) + +let of_json_string x s = Decode_json.(t x @@ Json.decoder (`String s)) + +module Size_of = struct + let ( >>= ) x f = match x with Some x -> f x | None -> None + + let ( >|= ) x f = match x with Some x -> Some (f x) | None -> None + + let int n = + let rec aux len n = + if n >= 0 && n < 128 then len else aux (len + 1) (n lsr 7) + in + aux 1 n + + let len n = function + | `Int -> int n + | `Int8 -> 1 + | `Int16 -> 2 + | `Int32 -> 4 + | `Int64 -> 8 + | `Fixed _ -> 0 + + let unit () = 0 + + let char (_ : char) = 1 + + let int32 (_ : int32) = 4 + + let int64 (_ : int64) = 8 + + let bool (_ : bool) = 1 + + let float (_ : float) = 8 (* NOTE: we consider 'double' here *) + + let string ?(headers = true) n s = + let s = String.length s in + if not headers then s else len s n + s + + let bytes ?(headers = true) n s = + let s = Bytes.length s in + if not headers then s else len s n + s + + let list l n x = + let init = len (List.length x) n in + List.fold_left + (fun acc x -> acc >>= fun acc -> l x >|= fun l -> acc + l) + (Some init) x + + let array l n x = + let init = len (Array.length x) n in + Array.fold_left + (fun acc x -> acc >>= fun acc -> l x >|= fun l -> acc + l) + (Some init) x + + let pair a b (x, y) = a x >>= fun a -> b y >|= fun b -> a + b + + let triple a b c (x, y, z) = + a x >>= fun a -> b y >>= fun b -> c z >|= fun c -> a + b + c + + let option o = function + | None -> Some (char '\000') + | Some x -> o x >|= fun o -> char '\000' + o + + let rec t : type a. a t -> a size_of = + fun ty ?headers e -> + match ty with + | Self s -> t ?headers s.self e + | Custom c -> c.size_of ?headers e + | Map b -> map ?headers b e + | Prim t -> prim ?headers t e + | List l -> list (t l.v) l.len e + | Array a -> array (t a.v) a.len e + | Tuple t -> tuple ?headers t e + | Option x -> option (t x) e + | Record r -> record ?headers r e + | Variant v -> variant ?headers v e + + and tuple : type a. a tuple -> a size_of = + fun ty ?headers:_ -> + match ty with + | Pair (x, y) -> pair (t x) (t y) + | Triple (x, y, z) -> triple (t x) (t y) (t z) + + and map : type a b. (a, b) map -> b size_of = + fun { x; g; _ } ?headers u -> t ?headers x (g u) + + and prim : type a. a prim -> a size_of = + fun p ?headers x -> + match p with + | Unit -> Some (unit x) + | Bool -> Some (bool x) + | Char -> Some (char x) + | Int -> Some (int x) + | Int32 -> Some (int32 x) + | Int64 -> Some (int64 x) + | Float -> Some (float x) + | String n -> Some (string ?headers n x) + | Bytes n -> Some (bytes ?headers n x) + + and record : type a. a record -> a size_of = + fun r ?headers:_ x -> + let fields = fields r in + List.fold_left + (fun acc (Field f) -> acc >>= fun acc -> field f x >|= fun f -> acc + f) + (Some 0) fields + + and field : type a b. (a, b) field -> a size_of = + fun f ?headers:_ x -> t f.ftype (f.fget x) + + and variant : type a. a variant -> a size_of = + fun v ?headers:_ x -> + match v.vget x with + | CV0 v -> Some (int v.ctag0) + | CV1 (x, vx) -> t x.ctype1 vx >|= fun v -> int x.ctag1 + v +end + +let size_of = Size_of.t + +module B = struct + external get_16 : string -> int -> int = "%caml_string_get16" + + external get_32 : string -> int -> int32 = "%caml_string_get32" + + external get_64 : string -> int -> int64 = "%caml_string_get64" + + external set_16 : Bytes.t -> int -> int -> unit = "%caml_string_set16u" + + external set_32 : Bytes.t -> int -> int32 -> unit = "%caml_string_set32u" + + external set_64 : Bytes.t -> int -> int64 -> unit = "%caml_string_set64u" + + external swap16 : int -> int = "%bswap16" + + external swap32 : int32 -> int32 = "%bswap_int32" + + external swap64 : int64 -> int64 = "%bswap_int64" + + let get_uint16 s off = + if not Sys.big_endian then swap16 (get_16 s off) else get_16 s off + + let get_uint32 s off = + if not Sys.big_endian then swap32 (get_32 s off) else get_32 s off + + let get_uint64 s off = + if not Sys.big_endian then swap64 (get_64 s off) else get_64 s off + + let set_uint16 s off v = + if not Sys.big_endian then set_16 s off (swap16 v) else set_16 s off v + + let set_uint32 s off v = + if not Sys.big_endian then set_32 s off (swap32 v) else set_32 s off v + + let set_uint64 s off v = + if not Sys.big_endian then set_64 s off (swap64 v) else set_64 s off v +end + +module Encode_bin = struct + let unit () _k = () + + let add_bytes b k = k (Bytes.to_string b) + + let add_string s k = k s + + let char c = add_bytes (Bytes.make 1 c) + + let int8 i = char (Char.chr i) + + let int16 i = + let b = Bytes.create 2 in + B.set_uint16 b 0 i; + add_bytes b + + let int32 i = + let b = Bytes.create 4 in + B.set_uint32 b 0 i; + add_bytes b + + let int64 i = + let b = Bytes.create 8 in + B.set_uint64 b 0 i; + add_bytes b + + let float f = int64 (Int64.bits_of_float f) + + let bool b = char (if b then '\255' else '\000') + + let int i k = + let rec aux n = + if n >= 0 && n < 128 then int8 n k + else + let out = 128 + (n land 127) in + int8 out k; + aux (n lsr 7) + in + aux i + + let len n i = + match n with + | `Int -> int i + | `Int8 -> int8 i + | `Int16 -> int16 i + | `Int32 -> int32 (Int32.of_int i) + | `Int64 -> int64 (Int64.of_int i) + | `Fixed _ -> unit () + + let string ?(headers = true) n s k = + if not headers then add_string s k + else + let i = String.length s in + len n i k; + add_string s k + + let bytes ?(headers = true) n s k = + if not headers then add_bytes s k + else + let i = Bytes.length s in + len n i k; + add_bytes s k + + let list l n x k = + len n (List.length x) k; + List.iter (fun e -> l e k) x + + let array l n x k = + len n (Array.length x) k; + Array.iter (fun e -> l e k) x + + let pair a b (x, y) k = + a x k; + b y k + + let triple a b c (x, y, z) k = + a x k; + b y k; + c z k + + let option o v k = + match v with + | None -> char '\000' k + | Some x -> + char '\255' k; + o x k + + let rec t : type a. a t -> a encode_bin = + fun ty ?headers e k -> + match ty with + | Self s -> t ?headers s.self e k + | Custom c -> c.encode_bin ?headers e k + | Map b -> map ?headers b e k + | Prim t -> prim ?headers t e k + | List l -> list (t l.v) l.len e k + | Array a -> array (t a.v) a.len e k + | Tuple t -> tuple ?headers t e k + | Option x -> option (t x) e k + | Record r -> record ?headers r e k + | Variant v -> variant ?headers v e k + + and tuple : type a. a tuple -> a encode_bin = + fun ty ?headers:_ -> + match ty with + | Pair (x, y) -> pair (t x) (t y) + | Triple (x, y, z) -> triple (t x) (t y) (t z) + + and map : type a b. (a, b) map -> b encode_bin = + fun { x; g; _ } ?headers u k -> t ?headers x (g u) k + + and prim : type a. a prim -> a encode_bin = + fun ty ?headers -> + match ty with + | Unit -> unit + | Bool -> bool + | Char -> char + | Int -> int + | Int32 -> int32 + | Int64 -> int64 + | Float -> float + | String n -> string ?headers n + | Bytes n -> bytes ?headers n + + and record : type a. a record -> a encode_bin = + fun r ?headers:_ x k -> + let fields = fields r in + List.iter (fun (Field f) -> t f.ftype (f.fget x) k) fields + + and variant : type a. a variant -> a encode_bin = + fun v ?headers:_ x k -> case_v (v.vget x) k + + and case_v : type a. a case_v encode_bin = + fun ?headers:_ c k -> + match c with + | CV0 c -> int c.ctag0 k + | CV1 (c, v) -> + int c.ctag1 k; + t c.ctype1 v k +end + +let encode_bin = Encode_bin.t + +let to_bin size_of encode_bin x = + let seq = encode_bin ?headers:(Some false) x in + let len = + match size_of ?headers:(Some false) x with None -> 1024 | Some n -> n + in + let buf = Buffer.create len in + seq (Buffer.add_string buf); + Buffer.contents buf + +let to_bin_string t x = + let rec aux : type a. a t -> a -> string = + fun t x -> + match t with + | Self s -> aux s.self x + | Map m -> aux m.x (m.g x) + | Prim (String _) -> x + | Prim (Bytes _) -> Bytes.to_string x + | Custom c -> to_bin c.size_of c.encode_bin x + | _ -> to_bin (size_of t) (encode_bin t) x + in + aux t x + +let pre_hash t x = + let rec aux : type a. a t -> a bin_seq = + fun t v k -> + match t with + | Self s -> aux s.self v k + | Map m -> aux m.x (m.g v) k + | Custom c -> c.pre_hash v k + | _ -> encode_bin ?headers:(Some false) t v k + in + aux t x + +module Decode_bin = struct + let ( >|= ) (ofs, x) f = (ofs, f x) + + let ( >>= ) (ofs, x) f = f (ofs, x) + + let ok ofs x = (ofs, x) + + type 'a res = int * 'a + + let unit _ ofs = ok ofs () + + let char buf ofs = ok (ofs + 1) buf.[ofs] + + let int8 buf ofs = char buf ofs >|= Char.code + + let int16 buf ofs = ok (ofs + 2) (B.get_uint16 buf ofs) + + let int32 buf ofs = ok (ofs + 4) (B.get_uint32 buf ofs) + + let int64 buf ofs = ok (ofs + 8) (B.get_uint64 buf ofs) + + let bool buf ofs = char buf ofs >|= function '\000' -> false | _ -> true + + let float buf ofs = int64 buf ofs >|= Int64.float_of_bits + + let int buf ofs = + let rec aux n p ofs = + int8 buf ofs >>= fun (ofs, i) -> + let n = n + ((i land 127) lsl (p * 7)) in + if i >= 0 && i < 128 then (ofs, n) else aux n (p + 1) ofs + in + aux 0 0 ofs + + let len buf ofs = function + | `Int -> int buf ofs + | `Int8 -> int8 buf ofs + | `Int16 -> int16 buf ofs + | `Int32 -> int32 buf ofs >|= Int32.to_int + | `Int64 -> int64 buf ofs >|= Int64.to_int + | `Fixed n -> ok ofs n + + let has_fixed_size = function `Fixed _ -> true | _ -> false + + let string ?(headers = true) n buf ofs = + if (not headers) && not (has_fixed_size n) then ok (String.length buf) buf + else + len buf ofs n >>= fun (ofs, len) -> + let str = Bytes.create len in + String.blit buf ofs str 0 len; + ok (ofs + len) (Bytes.unsafe_to_string str) + + let bytes ?(headers = true) n buf ofs = + if (not headers) && not (has_fixed_size n) then + ok (String.length buf) (Bytes.of_string buf) + else + len buf ofs n >>= fun (ofs, len) -> + let str = Bytes.create len in + String.blit buf ofs str 0 len; + ok (ofs + len) str + + let list l n buf ofs = + len buf ofs n >>= fun (ofs, len) -> + let rec aux acc ofs = function + | 0 -> ok ofs (List.rev acc) + | n -> l buf ofs >>= fun (ofs, x) -> aux (x :: acc) ofs (n - 1) + in + aux [] ofs len + + let array l len buf ofs = list l len buf ofs >|= Array.of_list + + let pair a b buf ofs = + a buf ofs >>= fun (ofs, a) -> b buf ofs >|= fun b -> (a, b) + + let triple a b c buf ofs = + a buf ofs >>= fun (ofs, a) -> + b buf ofs >>= fun (ofs, b) -> c buf ofs >|= fun c -> (a, b, c) + + let option : type a. a decode_bin -> a option decode_bin = + fun o ?headers:_ buf ofs -> + char buf ofs >>= function + | ofs, '\000' -> ok ofs None + | ofs, _ -> o buf ofs >|= fun x -> Some x + + let rec t : type a. a t -> a decode_bin = + fun ty ?headers buf ofs -> + match ty with + | Self s -> t ?headers s.self buf ofs + | Custom c -> c.decode_bin ?headers buf ofs + | Map b -> map ?headers b buf ofs + | Prim t -> prim ?headers t buf ofs + | List l -> list (t l.v) l.len buf ofs + | Array a -> array (t a.v) a.len buf ofs + | Tuple t -> tuple ?headers t buf ofs + | Option x -> option ?headers (t x) buf ofs + | Record r -> record ?headers r buf ofs + | Variant v -> variant ?headers v buf ofs + + and tuple : type a. a tuple -> a decode_bin = + fun ty ?headers:_ -> + match ty with + | Pair (x, y) -> pair (t x) (t y) + | Triple (x, y, z) -> triple (t x) (t y) (t z) + + and map : type a b. (a, b) map -> b decode_bin = + fun { x; f; _ } ?headers buf ofs -> t ?headers x buf ofs >|= f + + and prim : type a. a prim -> a decode_bin = + fun ty ?headers -> + match ty with + | Unit -> unit + | Bool -> bool + | Char -> char + | Int -> int + | Int32 -> int32 + | Int64 -> int64 + | Float -> float + | String n -> string ?headers n + | Bytes n -> bytes ?headers n + + and record : type a. a record -> a decode_bin = + fun r ?headers:_ buf ofs -> + match r.rfields with + | Fields (fs, c) -> + let rec aux : type b. int -> b -> (a, b) fields -> a res = + fun ofs f -> function + | F0 -> ok ofs f + | F1 (h, t) -> field h buf ofs >>= fun (ofs, x) -> aux ofs (f x) t + in + aux ofs c fs + + and field : type a b. (a, b) field -> b decode_bin = fun f -> t f.ftype + + and variant : type a. a variant -> a decode_bin = + fun v ?headers:_ buf ofs -> + int buf ofs >>= fun (ofs, i) -> case v.vcases.(i) buf ofs + + and case : type a. a a_case -> a decode_bin = + fun c ?headers:_ buf ofs -> + match c with C0 c -> ok ofs c.c0 | C1 c -> t c.ctype1 buf ofs >|= c.c1 +end + +let map_result f = function Ok x -> Ok (f x) | Error _ as e -> e + +let decode_bin = Decode_bin.t + +let of_bin decode_bin x = + let last, v = decode_bin ?headers:(Some false) x 0 in + assert (last = String.length x); + Ok v + +let of_bin_string t x = + let rec aux : type a. a t -> string -> (a, [ `Msg of string ]) result = + fun t x -> + match t with + | Self s -> aux s.self x + | Map l -> aux l.x x |> map_result l.f + | Prim (String _) -> Ok x + | Prim (Bytes _) -> Ok (Bytes.of_string x) + | Custom c -> of_bin c.decode_bin x + | _ -> of_bin (decode_bin t) x + in + try aux t x with Invalid_argument e -> Error (`Msg e) + +let to_string t = Fmt.to_to_string (pp t) + +let of_string t = + let v f x = try Ok (f x) with Invalid_argument e -> Error (`Msg e) in + let rec aux : type a a. a t -> a of_string = + fun t x -> + match t with + | Self s -> aux s.self x + | Custom c -> c.of_string x + | Map m -> aux m.x x |> map_result m.f + | Prim p -> prim p x + | _ -> of_json_string t x + and prim : type a. a prim -> a of_string = + fun t x -> + match t with + | Unit -> Ok () + | Bool -> v bool_of_string x + | Char -> v (fun x -> x.[1]) x + | Int -> v int_of_string x + | Int32 -> v Int32.of_string x + | Int64 -> v Int64.of_string x + | Float -> v float_of_string x + | String _ -> Ok x + | Bytes _ -> Ok (Bytes.unsafe_of_string x) + in + aux t + +type 'a ty = 'a t + +let ( %% ) (h1 : int) (h2 : int) : int = Hashtbl.hash (h1, h2) + +let short_hash t ?seed x = + match t with + | Custom c -> c.short_hash ?seed x + | _ -> + let hash = + match seed with + | None -> Hashtbl.hash + | Some s -> Hashtbl.seeded_hash s + in + let h = ref 0 in + pre_hash t x (fun s -> h := hash s %% !h); + !h + +let like ?cli ?json ?bin ?equal ?compare ?short_hash:h ?pre_hash:p t = + let encode_json, decode_json = + match json with + | Some (x, y) -> (x, y) + | None -> ( + let rec is_prim : type a. a t -> bool = function + | Self s -> is_prim s.self + | Map m -> is_prim m.x + | Prim _ -> true + | _ -> false + in + match (t, cli) with + | ty, Some (pp, of_string) when is_prim ty -> + let ty = string in + ( (fun ppf u -> Encode_json.t ty ppf (Fmt.to_to_string pp u)), + fun buf -> Decode_json.(t ty buf >|= of_string |> join) ) + | _ -> (Encode_json.t t, Decode_json.t t) ) + in + let pp, of_string = + match cli with Some (x, y) -> (x, y) | None -> (pp t, of_string t) + in + let encode_bin, decode_bin, size_of = + match bin with + | Some (x, y, z) -> (x, y, z) + | None -> (encode_bin t, decode_bin t, size_of t) + in + let equal = + match equal with + | Some x -> x + | None -> ( + match compare with Some f -> fun x y -> f x y = 0 | None -> Equal.t t ) + in + let compare = match compare with Some x -> x | None -> Compare.t t in + let short_hash ?seed = + match h with Some x -> x | None -> short_hash ?seed t + in + let pre_hash = + match p with Some x -> x | None -> encode_bin ?headers:(Some false) + in + Custom + { cwit = `Type t; + pp; + of_string; + encode_json; + decode_json; + encode_bin; + decode_bin; + size_of; + compare; + equal; + short_hash; + pre_hash + } + +let map ?cli ?json ?bin ?equal ?compare ?short_hash ?pre_hash x f g = + match (cli, json, bin, equal, compare, short_hash, pre_hash) with + | None, None, None, None, None, None, None -> + Map { x; f; g; mwit = Witness.make () } + | _ -> + let x = Map { x; f; g; mwit = Witness.make () } in + like ?cli ?json ?bin ?equal ?compare ?short_hash ?pre_hash x + +module type S = sig + type t + + val t : t ty +end diff --git a/vendors/irmin/type.mli b/vendors/irmin/type.mli new file mode 100644 index 000000000000..2b102932a60e --- /dev/null +++ b/vendors/irmin/type.mli @@ -0,0 +1,212 @@ +(* + * Copyright (c) 2016-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. + *) + +type len = [ `Int | `Int8 | `Int16 | `Int32 | `Int64 | `Fixed of int ] + +type 'a t + +val unit : unit t + +val bool : bool t + +val char : char t + +val int : int t + +val int32 : int32 t + +val int64 : int64 t + +val float : float t + +val string : string t + +val bytes : bytes t + +val list : ?len:len -> 'a t -> 'a list t + +val array : ?len:len -> 'a t -> 'a array t + +val option : 'a t -> 'a option t + +val pair : 'a t -> 'b t -> ('a * 'b) t + +val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t + +val result : 'a t -> 'b t -> ('a, 'b) result t + +val string_of : len -> string t + +val bytes_of : len -> bytes t + +type ('a, 'b) field + +type ('a, 'b, 'c) open_record + +val field : string -> 'a t -> ('b -> 'a) -> ('b, 'a) field + +val sealr : ('a, 'b, 'a) open_record -> 'a t + +val ( |+ ) : + ('a, 'b, 'c -> 'd) open_record -> ('a, 'c) field -> ('a, 'b, 'd) open_record + +val record : string -> 'b -> ('a, 'b, 'b) open_record + +type ('a, 'b) case + +type 'a case_p + +type ('a, 'b, 'c) open_variant + +val case0 : string -> 'a -> ('a, 'a case_p) case + +val case1 : string -> 'b t -> ('b -> 'a) -> ('a, 'b -> 'a case_p) case + +val sealv : ('a, 'b, 'a -> 'a case_p) open_variant -> 'a t + +val variant : string -> 'b -> ('a, 'b, 'b) open_variant + +val ( |~ ) : + ('a, 'b, 'c -> 'd) open_variant -> ('a, 'c) case -> ('a, 'b, 'd) open_variant + +val enum : string -> (string * 'a) list -> 'a t + +val mu : ('a t -> 'a t) -> 'a t + +val mu2 : ('a t -> 'b t -> 'a t * 'b t) -> 'a t * 'b t + +(* generics *) + +val equal : 'a t -> 'a -> 'a -> bool + +val compare : 'a t -> 'a -> 'a -> int + +val short_hash : 'a t -> ?seed:int -> 'a -> int + +(* CLI *) + +type 'a pp = 'a Fmt.t + +type 'a to_string = 'a -> string + +type 'a of_string = string -> ('a, [ `Msg of string ]) result + +val pp : 'a t -> 'a Fmt.t + +val of_string : 'a t -> 'a of_string + +(* JSON (wire) *) + +module Json : sig + type decoder + + val decoder : ?encoding:[< Jsonm.encoding ] -> [< Jsonm.src ] -> decoder + + val decode : + decoder -> + [> `Await | `End | `Error of Jsonm.error | `Lexeme of Jsonm.lexeme ] + + val rewind : decoder -> Jsonm.lexeme -> unit +end + +type 'a encode_json = Jsonm.encoder -> 'a -> unit + +type 'a decode_json = Json.decoder -> ('a, [ `Msg of string ]) result + +(* Raw (disk) *) + +type 'a bin_seq = 'a -> (string -> unit) -> unit + +type 'a encode_bin = ?headers:bool -> 'a bin_seq + +type 'a decode_bin = ?headers:bool -> string -> int -> int * 'a + +type 'a size_of = ?headers:bool -> 'a -> int option + +val size_of : 'a t -> 'a size_of + +(* like *) + +val v : + cli:'a pp * 'a of_string -> + json:'a encode_json * 'a decode_json -> + bin:'a encode_bin * 'a decode_bin * 'a size_of -> + equal:('a -> 'a -> bool) -> + compare:('a -> 'a -> int) -> + short_hash:(?seed:int -> 'a -> int) -> + pre_hash:'a bin_seq -> + 'a t + +val like : + ?cli:'a pp * 'a of_string -> + ?json:'a encode_json * 'a decode_json -> + ?bin:'a encode_bin * 'a decode_bin * 'a size_of -> + ?equal:('a -> 'a -> bool) -> + ?compare:('a -> 'a -> int) -> + ?short_hash:('a -> int) -> + ?pre_hash:'a bin_seq -> + 'a t -> + 'a t + +val map : + ?cli:'b pp * 'b of_string -> + ?json:'b encode_json * 'b decode_json -> + ?bin:'b encode_bin * 'b decode_bin * 'b size_of -> + ?equal:('b -> 'b -> bool) -> + ?compare:('b -> 'b -> int) -> + ?short_hash:('b -> int) -> + ?pre_hash:'b bin_seq -> + 'a t -> + ('a -> 'b) -> + ('b -> 'a) -> + 'b t + +(* convenient functions. *) + +val to_string : 'a t -> 'a -> string + +val pp_json : ?minify:bool -> 'a t -> 'a Fmt.t + +val pre_hash : 'a t -> 'a bin_seq + +val encode_json : 'a t -> Jsonm.encoder -> 'a -> unit + +val decode_json : 'a t -> Jsonm.decoder -> ('a, [ `Msg of string ]) result + +val decode_json_lexemes : + 'a t -> Jsonm.lexeme list -> ('a, [ `Msg of string ]) result + +val to_json_string : ?minify:bool -> 'a t -> 'a to_string + +val of_json_string : 'a t -> 'a of_string + +val encode_bin : 'a t -> 'a encode_bin + +val to_bin_string : 'a t -> 'a to_string + +val decode_bin : 'a t -> 'a decode_bin + +val of_bin_string : 'a t -> 'a of_string + +type 'a ty = 'a t + +val pp_ty : 'a t Fmt.t + +module type S = sig + type t + + val t : t ty +end diff --git a/vendors/irmin/version.ml b/vendors/irmin/version.ml new file mode 100644 index 000000000000..3274b52a91db --- /dev/null +++ b/vendors/irmin/version.ml @@ -0,0 +1 @@ +let current = "%%VERSION%%" diff --git a/vendors/irmin/watch.ml b/vendors/irmin/watch.ml new file mode 100644 index 000000000000..cd188da31d6b --- /dev/null +++ b/vendors/irmin/watch.ml @@ -0,0 +1,341 @@ +(* + * Copyright (c) 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 + +let src = Logs.Src.create "irmin.watch" ~doc:"Irmin watch notifications" + +module Log = (val Logs.src_log src : Logs.LOG) + +module type S = sig + type key + + type value + + type watch + + type t + + val stats : t -> int * int + + val notify : t -> key -> value option -> unit Lwt.t + + val v : unit -> t + + val clear : t -> unit Lwt.t + + val watch_key : + t -> key -> ?init:value -> (value Diff.t -> unit Lwt.t) -> watch Lwt.t + + val watch : + t -> + ?init:(key * value) list -> + (key -> value Diff.t -> unit Lwt.t) -> + watch Lwt.t + + val unwatch : t -> watch -> unit Lwt.t + + val listen_dir : + t -> + string -> + key:(string -> key option) -> + value:(key -> value option Lwt.t) -> + (unit -> unit Lwt.t) Lwt.t +end + +let none _ _ = + Printf.eprintf "Listen hook not set!\n%!"; + assert false + +let listen_dir_hook = ref none + +type hook = + int -> string -> (string -> unit Lwt.t) -> (unit -> unit Lwt.t) Lwt.t + +let set_listen_dir_hook (h : hook) = listen_dir_hook := h + +let id () = + let c = ref 0 in + fun () -> + incr c; + !c + +let global = id () + +let workers_r = ref 0 + +let workers () = !workers_r + +let scheduler () = + let p = ref None in + let niet () = () in + let c = ref niet in + let push elt = + match !p with + | Some p -> p elt + | None -> + let stream, push = Lwt_stream.create () in + incr workers_r; + Lwt.async (fun () -> + (* FIXME: we would like to skip some updates if more recent ones + are at the back of the queue. *) + Lwt_stream.iter_s (fun f -> f ()) stream ); + p := Some push; + (c := fun () -> push None); + push elt + in + let clean () = + !c (); + decr workers_r; + c := niet; + p := None + in + let enqueue v = push (Some v) in + (clean, enqueue) + +module Make (K : sig + type t + + val t : t Type.t +end) (V : sig + type t + + val t : t Type.t +end) = +struct + type key = K.t + + type value = V.t + + type watch = int + + module KMap = Map.Make (struct + type t = K.t + + let compare = Type.compare K.t + end) + + module IMap = Map.Make (struct + type t = int + + let compare (x : int) (y : int) = compare x y + end) + + type key_handler = value Diff.t -> unit Lwt.t + + type all_handler = key -> value Diff.t -> unit Lwt.t + + let pp_value = Type.pp V.t + + let equal_opt_values = Type.(equal (option V.t)) + + let equal_keys = Type.equal K.t + + type t = { + id : int; + (* unique watch manager id. *) + lock : Lwt_mutex.t; + (* protect [keys] and [glb]. *) + mutable next : int; + (* next id, to identify watch handlers. *) + mutable keys : (key * value option * key_handler) IMap.t; + (* key handlers. *) + mutable glob : (value KMap.t * all_handler) IMap.t; + (* global handlers. *) + enqueue : (unit -> unit Lwt.t) -> unit; + (* enqueue notifications. *) + clean : unit -> unit; + (* destroy the notification thread. *) + mutable listeners : int; + (* number of listeners. *) + mutable stop_listening : unit -> unit Lwt.t + (* clean-up listen resources. *) + } + + let stats t = (IMap.cardinal t.keys, IMap.cardinal t.glob) + + let to_string t = + let k, a = stats t in + Printf.sprintf "[%d: %dk/%dg|%d]" t.id k a t.listeners + + let next t = + let id = t.next in + t.next <- id + 1; + id + + let is_empty t = IMap.is_empty t.keys && IMap.is_empty t.glob + + let clear_unsafe t = + t.keys <- IMap.empty; + t.glob <- IMap.empty; + t.next <- 0 + + let clear t = + Lwt_mutex.with_lock t.lock (fun () -> + clear_unsafe t; + Lwt.return_unit ) + + let v () = + let lock = Lwt_mutex.create () in + let clean, enqueue = scheduler () in + { lock; + clean; + enqueue; + id = global (); + next = 0; + keys = IMap.empty; + glob = IMap.empty; + listeners = 0; + stop_listening = (fun () -> Lwt.return_unit) + } + + let unwatch_unsafe t id = + Log.debug (fun f -> f "unwatch %s: id=%d" (to_string t) id); + let glob = IMap.remove id t.glob in + let keys = IMap.remove id t.keys in + t.glob <- glob; + t.keys <- keys + + let unwatch t id = + Lwt_mutex.with_lock t.lock (fun () -> + unwatch_unsafe t id; + if is_empty t then t.clean (); + Lwt.return_unit ) + + let mk old value = + match (old, value) with + | None, None -> assert false + | Some v, None -> `Removed v + | None, Some v -> `Added v + | Some x, Some y -> `Updated (x, y) + + let protect f () = + Lwt.catch f (fun e -> + Log.err (fun l -> + l "watch callback got: %a\n%s" Fmt.exn e + (Printexc.get_backtrace ()) ); + Lwt.return_unit ) + + let notify_all_unsafe t key value = + let todo = ref [] in + let glob = + IMap.fold + (fun id ((init, f) as arg) acc -> + let fire old_value = + Log.debug (fun f -> + f "notify-all[%d.%d]: firing! (v=%a)" t.id id + Fmt.(Dump.option pp_value) + old_value ); + todo := protect (fun () -> f key (mk old_value value)) :: !todo; + let init = + match value with + | None -> KMap.remove key init + | Some v -> KMap.add key v init + in + IMap.add id (init, f) acc + in + let old_value = + try Some (KMap.find key init) with Not_found -> None + in + if equal_opt_values old_value value then ( + Log.debug (fun f -> + f "notify-all[%d:%d]: same value, skipping." t.id id ); + IMap.add id arg acc ) + else fire old_value ) + t.glob IMap.empty + in + t.glob <- glob; + match !todo with + | [] -> () + | ts -> t.enqueue (fun () -> Lwt_list.iter_p (fun x -> x ()) ts) + + let notify_key_unsafe t key value = + let todo = ref [] in + let keys = + IMap.fold + (fun id ((k, old_value, f) as arg) acc -> + if not (equal_keys key k) then IMap.add id arg acc + else if equal_opt_values value old_value then ( + Log.debug (fun f -> + f "notify-key[%d.%d]: same value, skipping." t.id id ); + IMap.add id arg acc ) + else ( + Log.debug (fun f -> f "notify-key[%d:%d] firing!" t.id id); + todo := protect (fun () -> f (mk old_value value)) :: !todo; + IMap.add id (k, value, f) acc ) ) + t.keys IMap.empty + in + t.keys <- keys; + match !todo with + | [] -> () + | ts -> t.enqueue (fun () -> Lwt_list.iter_p (fun x -> x ()) ts) + + let notify t key value = + Lwt_mutex.with_lock t.lock (fun () -> + if is_empty t then Lwt.return_unit + else ( + notify_all_unsafe t key value; + notify_key_unsafe t key value; + Lwt.return_unit ) ) + + let watch_key_unsafe t key ?init f = + let id = next t in + Log.debug (fun f -> f "watch-key %s: id=%d" (to_string t) id); + t.keys <- IMap.add id (key, init, f) t.keys; + id + + let watch_key t key ?init f = + Lwt_mutex.with_lock t.lock (fun () -> + let id = watch_key_unsafe t ?init key f in + Lwt.return id ) + + let kmap_of_alist l = + List.fold_left (fun map (k, v) -> KMap.add k v map) KMap.empty l + + let watch_unsafe t ?(init = []) f = + let id = next t in + Log.debug (fun f -> f "watch %s: id=%d" (to_string t) id); + t.glob <- IMap.add id (kmap_of_alist init, f) t.glob; + id + + let watch t ?init f = + Lwt_mutex.with_lock t.lock (fun () -> + let id = watch_unsafe t ?init f in + Lwt.return id ) + + let listen_dir t dir ~key ~value = + let init () = + if t.listeners = 0 then ( + Log.debug (fun f -> f "%s: start listening to %s" (to_string t) dir); + !listen_dir_hook t.id dir (fun file -> + match key file with + | None -> Lwt.return_unit + | Some key -> value key >>= notify t key ) + >|= fun f -> t.stop_listening <- f ) + else ( + Log.debug (fun f -> f "%s: already listening on %s" (to_string t) dir); + Lwt.return_unit ) + in + init () >|= fun () -> + t.listeners <- t.listeners + 1; + function + | () -> + if t.listeners > 0 then t.listeners <- t.listeners - 1; + if t.listeners <> 0 then Lwt.return_unit + else ( + Log.debug (fun f -> f "%s: stop listening to %s" (to_string t) dir); + t.stop_listening () ) +end diff --git a/vendors/irmin/watch.mli b/vendors/irmin/watch.mli new file mode 100644 index 000000000000..0fbd3a081218 --- /dev/null +++ b/vendors/irmin/watch.mli @@ -0,0 +1,72 @@ +(* + * Copyright (c) 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. + *) + +(** Watches *) + +module type S = sig + type key + + type value + + type watch + + type t + + val stats : t -> int * int + + val notify : t -> key -> value option -> unit Lwt.t + + val v : unit -> t + + val clear : t -> unit Lwt.t + + val watch_key : + t -> key -> ?init:value -> (value Diff.t -> unit Lwt.t) -> watch Lwt.t + + val watch : + t -> + ?init:(key * value) list -> + (key -> value Diff.t -> unit Lwt.t) -> + watch Lwt.t + + val unwatch : t -> watch -> unit Lwt.t + + val listen_dir : + t -> + string -> + key:(string -> key option) -> + value:(key -> value option Lwt.t) -> + (unit -> unit Lwt.t) Lwt.t +end + +module Make (K : sig + type t + + val t : t Type.t +end) (V : sig + type t + + val t : t Type.t +end) : S with type key = K.t and type value = V.t + +type hook = + int -> string -> (string -> unit Lwt.t) -> (unit -> unit Lwt.t) Lwt.t + +val set_listen_dir_hook : hook -> unit + +val none : hook + +val workers : unit -> int -- GitLab From d57f4c3c2893d095adc44f5ee5999fb5970268b1 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Thu, 11 Jul 2019 11:43:26 +0200 Subject: [PATCH 02/17] storage: use irminv2 --- src/lib_shell/prevalidation.ml | 2 +- src/lib_shell/test/test_locator.ml | 3 +- src/lib_storage/context.ml | 706 ++++++++---------- src/lib_storage/context.mli | 4 +- src/lib_storage/context_dump.ml | 62 +- src/lib_storage/context_dump.mli | 23 +- src/lib_storage/dune | 4 +- src/lib_storage/tezos-storage.opam | 3 +- .../lib_delegate/client_baking_forge.ml | 2 +- 9 files changed, 347 insertions(+), 462 deletions(-) diff --git a/src/lib_shell/prevalidation.ml b/src/lib_shell/prevalidation.ml index 3bb91a9aef97..d6ea4ac6fda9 100644 --- a/src/lib_shell/prevalidation.ml +++ b/src/lib_shell/prevalidation.ml @@ -321,5 +321,5 @@ let preapply ~predecessor ~timestamp ~protocol_data operations = let context = Shell_context.unwrap_disk_context context in return (context, message) end >>=? fun (context, message) -> - Context.hash ?message ~time:timestamp context >>= fun context -> + let context = Context.hash ?message ~time:timestamp context in return ({ shell_header with context }, validation_result_list) diff --git a/src/lib_shell/test/test_locator.ml b/src/lib_shell/test/test_locator.ml index 534b5648e1e0..70b2ff511045 100644 --- a/src/lib_shell/test/test_locator.ml +++ b/src/lib_shell/test/test_locator.ml @@ -107,8 +107,7 @@ let make_empty_chain (chain:State.Chain.t) n : Block_hash.t Lwt.t = State.Block.context genesis >>= fun empty_context -> let header = State.Block.header genesis in let timestamp = State.Block.timestamp genesis in - Context.hash ~time:timestamp empty_context - >>= fun empty_context_hash -> + let empty_context_hash = Context.hash ~time:timestamp empty_context in Context.commit ~time:header.shell.timestamp empty_context >>= fun context -> let header = { header with shell = { header.shell with context } } in diff --git a/src/lib_storage/context.ml b/src/lib_storage/context.ml index cfdbc0ecd7c2..82a6aae926d3 100644 --- a/src/lib_storage/context.ml +++ b/src/lib_storage/context.ml @@ -25,320 +25,229 @@ (** Tezos - Versioned (key x value) store (over Irmin) *) -module IrminPath = Irmin.Path.String_list - -module MBytesContent = struct - type t = MBytes.t - let t = - Irmin.Type.(like cstruct) - (fun x -> Cstruct.to_bigarray x) - (fun x -> Cstruct.of_bigarray x) - let merge = Irmin.Merge.default Irmin.Type.(option t) - let pp ppf b = Format.pp_print_string ppf (MBytes.to_string b) - 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 Path = Irmin.Path.String_list +module Metadata = Irmin.Metadata.None -module IrminBlake2B : Irmin.Hash.S with type t = Context_hash.t = struct +exception TODO of string - type t = Context_hash.t +let todo fmt = Fmt.kstrf (fun s -> raise (TODO s)) fmt - let digest_size = Context_hash.size +module Hash : sig + include Irmin.Hash.S + val to_context_hash: t -> Context_hash.t + val of_context_hash: Context_hash.t -> t +end = struct + module H = Context_hash - let to_raw t = Cstruct.of_bigarray (Context_hash.to_bytes t) - let of_raw t = - match Context_hash.of_bytes_opt (Cstruct.to_bigarray t) with - | Some t -> t - | None -> - let str = Cstruct.to_string t in - Format.kasprintf invalid_arg "%s (%d)" str (String.length str) + type t = string - let t = Irmin.Type.like Irmin.Type.cstruct of_raw to_raw + let to_context_hash s = H.of_string_exn s - let digest t x = - Context_hash.hash_bytes - [Cstruct.to_bigarray (Irmin.Type.encode_cstruct t x)] + let of_context_hash h = H.to_string h - let pp = Context_hash.pp + let pp ppf t = H.pp ppf (H.of_string_exn t) let of_string x = - match Context_hash.of_b58check_exn x with - | exception (Invalid_argument s) -> Error (`Msg s) - | h -> Ok h + match H.of_b58check x with + | Ok _ -> Ok x + | Error _ -> todo "Hash.of_string" - let has_kind = function - | `SHA1 -> true - | _ -> false + let short_hash h = H.hash (to_context_hash h) - let to_raw_int c = - Int64.to_int @@ MBytes.get_int64 (Context_hash.to_bytes c) 0 + let t : t Irmin.Type.t = + Irmin.Type.like + ~cli:(pp, of_string) Irmin.Type.(string_of (`Fixed H.size)) + ~short_hash + let hash_size = H.size + + let hash f = + let init = ref [] in + f (fun x -> init := x :: !init); + let h = H.hash_string (List.rev !init) in + H.to_string h end -module GitStore = - Irmin_lmdb.Make - (Metadata) - (MBytesContent) - (Irmin.Path.String_list) - (Irmin.Branch.String) - (IrminBlake2B) +module Node = struct + module M = Irmin.Private.Node.Make (Hash) (Path) (Metadata) -type index = { - path: string ; - repo: GitStore.Repo.t ; - patch_context: context -> context Lwt.t ; -} + module V1 = struct + module Hash = Irmin.Hash.V1 (Hash) -and context = { - index: index ; - parents: GitStore.Commit.t list ; - tree: GitStore.tree ; -} -type t = context + type kind = [`Node | `Contents of Metadata.t] -(*-- Version Access and Update -----------------------------------------------*) + type entry = {key: string Lazy.t; kind: kind; name: M.step; node: Hash.t} -let current_protocol_key = ["protocol"] -let current_test_chain_key = ["test_chain"] -let current_data_key = ["data"] + let compare_entries a b = compare (Lazy.force a.key) (Lazy.force b.key) -let exists index key = - GitStore.Commit.of_hash index.repo key >>= function - | None -> Lwt.return_false - | Some _ -> Lwt.return_true + (* Irmin 1.4 uses int64 to store string lengths *) + let step_t = + let pre_hash = Irmin.Type.(pre_hash (string_of `Int64)) in + Irmin.Type.like M.step_t ~pre_hash -let checkout index key = - GitStore.Commit.of_hash index.repo key >>= function - | None -> Lwt.return_none - | Some commit -> - GitStore.Commit.tree commit >>= fun tree -> - let ctxt = { index ; tree ; parents = [commit] } in - Lwt.return_some ctxt + let metadata_t = + let some = "\255\000\000\000\000\000\000\000" in + let none = "\000\000\000\000\000\000\000\000" in + Irmin.Type.(map (string_of (`Fixed 8))) + (fun s -> + match s.[0] with + | '\255' -> None + | '\000' -> Some () + | _ -> assert false ) + (function Some _ -> some | None -> none) -let checkout_exn index key = - checkout index key >>= function - | None -> Lwt.fail Not_found - | Some p -> Lwt.return p + (* Irmin 1.4 uses int64 to store list lengths *) + let entry_t : entry Irmin.Type.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 + let key = + match kind with + | `Node -> lazy (name ^ "/") + | `Contents _ -> lazy name + in + {key; kind; name; node} ) + |+ field "kind" metadata_t (function + | {kind= `Node; _} -> None + | {kind= `Contents m; _} -> Some m ) + |+ field "name" step_t (fun {name; _} -> name) + |+ field "node" Hash.t (fun {node; _} -> node) + |> sealr -let raw_commit ~time ?(message = "") context = - let info = - Irmin.Info.v ~date:(Time.Protocol.to_seconds time) ~author:"Tezos" message in - GitStore.Commit.v - context.index.repo ~info ~parents:context.parents context.tree + let entries_t : entry list Irmin.Type.t = + Irmin.Type.(list ~len:`Int64 entry_t) -module P = GitStore.Private + let import_entry (s, v) = + match v with + | `Node h -> {key= lazy (s ^ "/"); name= s; kind= `Node; node= h} + | `Contents (h, m) -> {key= lazy s; name= s; kind= `Contents m; node= h} -(* --- FIXME(samoht): I am so sorry --- *) -module Hack = struct + let import t = List.map import_entry (M.list t) - module StepMap = struct - module X = struct - type t = GitStore.step - let t = GitStore.step_t - let compare = Irmin.Type.compare t - end - include Map.Make(X) + (* store the entries before hashing to be compatible with Tezos v1 *) + let pre_hash entries = + let entries = List.fast_sort compare_entries entries in + Irmin.Type.pre_hash entries_t entries end - module Contents = struct - - type key = P.Contents.key - type contents = P.Contents.value + include M - type t = - | Key of key - | Contents of contents - | Both of key * contents + let pre_hash_v1 x = V1.pre_hash (V1.import x) - let t = - let open Irmin.Type in - variant "Node.Contents" (fun key contents both -> function - | Key x -> key x - | Contents x -> contents x - | Both (x, y) -> both (x, y)) - |~ case1 "Key" P.Contents.Key.t (fun x -> Key x) - |~ case1 "Contents" P.Contents.Val.t (fun x -> Contents x) - |~ case1 "Both" (pair P.Contents.Key.t P.Contents.Val.t) - (fun (x, y) -> Both (x, y)) - |> sealv - - let hash = function - | Key k | Both (k, _) -> k - | Contents c -> P.Contents.Key.digest P.Contents.Val.t c + let t = Irmin.Type.(like t ~pre_hash:pre_hash_v1) +end - end +module Commit = struct + module M = Irmin.Private.Commit.Make (Hash) + module V1 = Irmin.Private.Commit.V1 (M) + include M - type key = P.Node.key + let pre_hash_v1 t = Irmin.Type.pre_hash V1.t (V1.import t) - type value = [ `Node of node | `Contents of Contents.t * Metadata.t ] + let t = Irmin.Type.like t ~pre_hash:pre_hash_v1 +end - and map = value StepMap.t +module Contents = struct + type t = string - and node = - | Map of map - | Key of key - | Both of key * map + let pre_hash_v1 x = + let ty = Irmin.Type.(pair (string_of `Int64) unit) in + Irmin.Type.(pre_hash ty) (x, ()) - let value t = - let open Irmin.Type in - variant "Node.value" (fun node contents -> function - | `Node x -> node x - | `Contents x -> contents x) - |~ case1 "Node" t (fun x -> `Node x) - |~ case1 "Contents" (pair Contents.t Metadata.t) (fun x -> `Contents x) - |> sealv + let t = Irmin.Type.(like ~pre_hash:pre_hash_v1 string) - let map value = - let open Irmin.Type in - let to_map x = - List.fold_left (fun acc (k, v) -> StepMap.add k v acc) StepMap.empty x - in - let of_map m = StepMap.fold (fun k v acc -> (k, v) :: acc) m [] in - like (list (pair GitStore.step_t value)) to_map of_map - - let node map = - let open Irmin.Type in - variant "Node.node" (fun map key both -> function - | Map x -> map x - | Key y -> key y - | Both (y,z) -> both (y, z)) - |~ case1 "Map" map (fun x -> Map x) - |~ case1 "Key" P.Node.Key.t (fun x -> Key x) - |~ case1 "Both" (pair P.Node.Key.t map) (fun (x, y) -> Both (x, y)) - |> sealv - - let node_t = Irmin.Type.mu (fun n -> - let value = value n in - node (map value) - ) + let merge = Irmin.Merge.(idempotent (Irmin.Type.option t)) +end - (* Mimick irmin-lmdb ordering *) - module Sort_key = struct - - exception Result of int - - let compare (x, vx) (y, vy) = match vx, vy with - | `Contents _, `Contents _ -> String.compare x y - | _ -> - let lenx = String.length x in - let leny = String.length y in - let i = ref 0 in - try - while !i < lenx && !i < leny do - match - Char.compare - (String.unsafe_get x !i) (String.unsafe_get y !i) - with - | 0 -> incr i - | i -> raise (Result i) - done; - let get len k v i = - if i < len then String.unsafe_get k i - else if i = len then match v with - | `Node _ -> '/' - | `Contents _ -> '\000' - else '\000' - in - match Char.compare (get lenx x vx !i) (get leny y vy !i) with - | 0 -> Char.compare (get lenx x vx (!i + 1)) (get leny y vy (!i + 1)) - | i -> i - with Result i -> - i +module Conf = struct + let entries = 32 + let stable_hash = 256 +end - end +module Store = + Irmin_pack.Make_ext (Conf)(Irmin.Metadata.None) (Contents) + (Irmin.Path.String_list) + (Irmin.Branch.String) + (Hash) + (Node) + (Commit) - let sort_entries = List.fast_sort Sort_key.compare +module P = Store.Private - module Entry = struct - type kind = [ `Node | `Contents of Metadata.t ] - type entry = { kind : kind; name : string; node : IrminBlake2B.t; } +type index = { + path: string ; + repo: Store.Repo.t ; + patch_context: context -> context Lwt.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 Metadata.t) (function - | { kind = `Node ; _ } -> None - | { kind = `Contents m ; _ } -> Some m) - |+ field "name" string (fun { name ; _ } -> name) - |+ field "node" IrminBlake2B.t (fun { node ; _ } -> node) - |> sealr +and context = { + index: index ; + parents: Store.Commit.t list ; + tree: Store.tree ; +} +type t = context - let of_entry e = e.name, match e.kind with - | `Node -> `Node e.node - | `Contents m -> `Contents (e.node, m) +(*-- Version Access and Update -----------------------------------------------*) - let to_entry (name, value) = match value with - | `Node node -> { name; kind = `Node; node } - | `Contents (node, m) -> { name; kind = `Contents m; node } +let current_protocol_key = ["protocol"] +let current_test_chain_key = ["test_chain"] +let current_data_key = ["data"] - let t = Irmin.Type.like entry_t of_entry to_entry - end +let exists index key = + Store.Commit.of_hash index.repo (Hash.of_context_hash key) + >|= function None -> false | Some _ -> true - let rec export_map map = - let alist = - StepMap.fold (fun step v acc -> - (step, hash_value v) :: acc - ) map [] - in - let l = sort_entries alist in - P.Node.Val.v l - - and hash_value = function - | `Contents (c, m) -> `Contents (Contents.hash c, m) - | `Node n -> `Node (hash_node n) - - and hash_node = function - | Both (k, _) | Key k -> k - | Map m -> - let v = export_map m in - let entries = P.Node.Val.list v in - (* This needs to match what is done in the backend... *) - let v = Irmin.Type.encode_cstruct (Irmin.Type.list Entry.t) entries in - IrminBlake2B.digest Irmin.Type.cstruct v - - let cast: GitStore.node -> node = fun n -> - let buf = Irmin.Type.encode_cstruct GitStore.node_t n in - match Irmin.Type.decode_cstruct node_t buf with - | Error (`Msg e) -> Fmt.failwith "invalid cast\n%s" e - | Ok x -> x +let checkout index key = + Store.Commit.of_hash index.repo (Hash.of_context_hash key) + >>= function + | None -> Lwt.return_none + | Some commit -> + let tree = Store.Commit.tree commit in + let ctxt = {index; tree; parents= [commit]} in + Lwt.return_some ctxt -end +let checkout_exn index key = + checkout index key + >>= function None -> Lwt.fail Not_found | Some p -> Lwt.return p + +(* unshalow possible 1-st level objects from previous partial + checkouts ; might be better to pass directly the list of shallow + objects. *) +let unshallow context = + Store.Tree.list context.tree [] >>= fun childs -> + P.Repo.batch context.index.repo (fun x y _ -> + Lwt_list.iter_s (fun (s, k) -> match k with + | `Contents -> Lwt.return () + | `Node -> + Store.Tree.get_tree context.tree [s] >>= fun tree -> + Store.save_tree ~clear:true context.index.repo x y tree >|= fun _ -> + () + ) childs) -let tree_hash: GitStore.tree -> GitStore.Tree.hash = function - | `Contents (c, m) -> `Contents (P.Contents.Key.digest P.Contents.Val.t c, m) - | `Node n -> `Node (Hack.hash_node (Hack.cast n)) +let raw_commit ~time ?(message = "") context = + let info = + Irmin.Info.v ~date:(Time.Protocol.to_seconds time) ~author:"Tezos" message + in + let parents = List.map Store.Commit.hash context.parents in + unshallow context >>= fun () -> + Store.Commit.v context.index.repo ~info ~parents context.tree >|= fun h -> + Store.Tree.clear context.tree; + h let hash ~time ?(message = "") context = let info = Irmin.Info.v ~date:(Time.Protocol.to_seconds time) ~author:"Tezos" message in - let parents = List.map (fun c -> GitStore.Commit.hash c) context.parents in - let node = match tree_hash context.tree with - | `Contents _ -> assert false - | `Node node -> node - in + let parents = List.map (fun c -> Store.Commit.hash c) context.parents in + let node = Store.Tree.hash context.tree in let commit = P.Commit.Val.v ~parents ~node ~info in - let x = P.Commit.Key.digest P.Commit.Val.t commit in - (* FIXME: this doesn't have to be lwt *) - Lwt.return x + let x = P.Commit.Key.hash commit in + Hash.to_context_hash x let commit ~time ?message context = - raw_commit ~time ?message context >>= fun commit -> - let h = GitStore.Commit.hash commit in - Lwt.return h + raw_commit ~time ?message context >|= fun commit -> + Hash.to_context_hash (Store.Commit.hash commit) (*-- Generic Store Primitives ------------------------------------------------*) @@ -348,40 +257,42 @@ type key = string list type value = MBytes.t let mem ctxt key = - GitStore.Tree.mem ctxt.tree (data_key key) >>= fun v -> + Store.Tree.mem ctxt.tree (data_key key) >>= fun v -> Lwt.return v let dir_mem ctxt key = - GitStore.Tree.mem_tree ctxt.tree (data_key key) >>= fun v -> + Store.Tree.mem_tree ctxt.tree (data_key key) >>= fun v -> Lwt.return v let raw_get ctxt key = - GitStore.Tree.find ctxt.tree key + Store.Tree.find ctxt.tree key >|= Option.map ~f:MBytes.of_string + let get t key = raw_get t (data_key key) let raw_set ctxt key data = - GitStore.Tree.add ctxt.tree key data >>= fun tree -> + Store.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 set t key data = raw_set t (data_key key) (MBytes.to_string data) let raw_del ctxt key = - GitStore.Tree.remove ctxt.tree key >>= fun tree -> + Store.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 = - GitStore.Tree.remove ctxt.tree (data_key key) >>= fun tree -> + Store.Tree.remove ctxt.tree (data_key key) >>= fun tree -> Lwt.return { ctxt with tree } let copy ctxt ~from ~to_ = - GitStore.Tree.find_tree ctxt.tree (data_key from) >>= function + Store.Tree.find_tree ctxt.tree (data_key from) >>= function | None -> Lwt.return_none | Some sub_tree -> - GitStore.Tree.add_tree ctxt.tree (data_key to_) sub_tree >>= fun tree -> + Store.Tree.add_tree ctxt.tree (data_key to_) sub_tree >>= fun tree -> Lwt.return_some { ctxt with tree } let fold ctxt key ~init ~f = - GitStore.Tree.list ctxt.tree (data_key key) >>= fun keys -> + Store.Tree.list ctxt.tree (data_key key) >>= fun keys -> Lwt_list.fold_left_s begin fun acc (name, kind) -> let key = @@ -399,7 +310,8 @@ let get_protocol v = | None -> assert false | Some data -> Lwt.return (Protocol_hash.of_bytes_exn data) let set_protocol v key = - raw_set v current_protocol_key (Protocol_hash.to_bytes key) + let key = MBytes.to_string (Protocol_hash.to_bytes key) in + raw_set v current_protocol_key key let get_test_chain v = raw_get v current_test_chain_key >>= function @@ -410,8 +322,9 @@ let get_test_chain v = | Some r -> Lwt.return r let set_test_chain v id = - raw_set v current_test_chain_key - (Data_encoding.Binary.to_bytes_exn Test_chain_status.encoding id) + let id = Data_encoding.Binary.to_bytes_exn Test_chain_status.encoding id in + raw_set v current_test_chain_key (MBytes.to_string id) + let del_test_chain v = raw_del v current_test_chain_key let fork_test_chain v ~protocol ~expiration = @@ -419,30 +332,28 @@ let fork_test_chain v ~protocol ~expiration = (*-- Initialisation ----------------------------------------------------------*) -let init ?patch_context ?mapsize ?readonly root = - GitStore.Repo.v - (Irmin_lmdb.config ?mapsize ?readonly root) >>= fun repo -> - Lwt.return { - path = root ; - repo ; - patch_context = - match patch_context with - | None -> (fun ctxt -> Lwt.return ctxt) - | Some patch_context -> patch_context - } +let init ?patch_context ?mapsize:_ ?readonly root = + Store.Repo.v (Irmin_pack.config ?readonly root) + >>= fun repo -> + Lwt.return + { path= root + ; repo + ; patch_context= + ( match patch_context with + | None -> fun ctxt -> Lwt.return ctxt + | Some patch_context -> patch_context ) } let get_branch chain_id = Format.asprintf "%a" Chain_id.pp chain_id - let commit_genesis index ~chain_id ~time ~protocol = - let tree = GitStore.Tree.empty in + let tree = Store.Tree.empty in let ctxt = { index ; tree ; parents = [] } in index.patch_context ctxt >>= fun ctxt -> set_protocol ctxt protocol >>= fun ctxt -> set_test_chain ctxt Not_running >>= fun ctxt -> raw_commit ~time ~message:"Genesis" ctxt >>= fun commit -> - GitStore.Branch.set index.repo (get_branch chain_id) commit >>= fun () -> - Lwt.return (GitStore.Commit.hash commit) + Store.Branch.set index.repo (get_branch chain_id) commit >|= fun () -> + Hash.to_context_hash (Store.Commit.hash commit) let compute_testchain_chain_id genesis = let genesis_hash = Block_hash.hash_bytes [Block_hash.to_bytes genesis] in @@ -462,7 +373,7 @@ let commit_test_chain_genesis ctxt (forked_header : Block_header.t) = predecessor = Block_hash.zero ; validation_passes = 0 ; operations_hash = Operation_list_list_hash.empty ; - context = GitStore.Commit.hash commit ; + context = Hash.to_context_hash (Store.Commit.hash commit) ; } in let forked_block = Block_header.hash forked_header in let genesis_hash = compute_testchain_genesis forked_block in @@ -471,27 +382,25 @@ let commit_test_chain_genesis ctxt (forked_header : Block_header.t) = { shell = { faked_shell_header with predecessor = genesis_hash } ; protocol_data = MBytes.create 0 } in let branch = get_branch chain_id in - GitStore.Branch.set ctxt.index.repo branch commit >>= fun () -> + Store.Branch.set ctxt.index.repo branch commit >>= fun () -> Lwt.return genesis_header let clear_test_chain index chain_id = (* TODO remove commits... ??? *) let branch = get_branch chain_id in - GitStore.Branch.remove index.repo branch + Store.Branch.remove index.repo branch let set_head index chain_id commit = let branch = get_branch chain_id in - GitStore.Commit.of_hash index.repo commit >>= function + Store.Commit.of_hash index.repo (Hash.of_context_hash commit) >>= function | None -> assert false - | Some commit -> - GitStore.Branch.set index.repo branch commit + | Some commit -> Store.Branch.set index.repo branch commit let set_master index commit = - GitStore.Commit.of_hash index.repo commit >>= function + Store.Commit.of_hash index.repo (Hash.of_context_hash commit) >>= function | None -> assert false - | Some commit -> - GitStore.Branch.set index.repo GitStore.Branch.master commit + | Some commit -> Store.Branch.set index.repo Store.Branch.master commit (* Context dumping *) @@ -620,15 +529,20 @@ end module Dumpable_context = struct type nonrec index = index type nonrec context = context - type tree = GitStore.tree - type hash = GitStore.Tree.hash + type tree = Store.tree + type hash = [`Blob of Store.hash | `Node of Store.hash] type step = string type key = step list type commit_info = Irmin.Info.t - let hash_export = function - | `Contents ( h, () ) -> `Blob, Context_hash.to_bytes h - | `Node h -> `Node, Context_hash.to_bytes h + type batch = + | Batch of Store.repo + * [`Read | `Write] P.Contents.t + * [`Read | `Write] P.Node.t + + let batch index f = + P.Repo.batch index.repo (fun x y _ -> f (Batch (index.repo, x, y))) + let hash_import ty mb = Context_hash.of_bytes mb >>? fun h -> match ty with @@ -673,83 +587,93 @@ module Dumpable_context = struct let open Data_encoding in let kind_encoding = string_enum [("node", `Node) ; ("blob", `Blob) ] in conv - begin fun hash -> hash_export hash end begin function - | (`Node, h) -> `Node (Context_hash.of_bytes_exn h) - | (`Blob, h) -> `Contents (Context_hash.of_bytes_exn h, ()) + | `Blob h -> `Blob, (Context_hash.to_bytes (Hash.to_context_hash h)) + | `Node h -> `Node, (Context_hash.to_bytes (Hash.to_context_hash h)) + end + begin function + | `Blob, h -> `Blob (Hash.of_context_hash (Context_hash.of_bytes_exn h)) + | `Node, h -> `Node (Hash.of_context_hash (Context_hash.of_bytes_exn h)) end (obj2 (req "kind" kind_encoding) (req "value" bytes)) let context_parents ctxt = match ctxt with | { parents = [commit]; _ } -> - (* XXX(samoht): fixed in irmin v2 *) - let key = GitStore.Commit.hash commit in - GitStore.Private.Commit.find - (GitStore.Private.Repo.commit_t ctxt.index.repo) key - >|= fun v -> - let commit = match v with None -> assert false | Some v -> v in - let parents = GitStore.Private.Commit.Val.parents commit in + let parents = Store.Commit.parents commit in + let parents = List.map Hash.to_context_hash parents in List.sort Context_hash.compare parents | _ -> assert false let context_info = function - | { parents = [c]; _ } -> GitStore.Commit.info c + | { parents = [c]; _ } -> Store.Commit.info c | _ -> assert false let context_info_export i = Irmin.Info.( date i, author i, message i ) - let context_info_import ( date, author, message) = Irmin.Info.v ~date ~author message + let context_info_import ( date, author, message) = + Irmin.Info.v ~date ~author message let get_context idx bh = checkout idx bh.Block_header.shell.context + let set_context ~info ~parents ctxt bh = let parents = List.sort Context_hash.compare parents in - GitStore.Tree.hash ctxt.index.repo ctxt.tree >>= function - | `Node node -> - let v = GitStore.Private.Commit.Val.v ~info ~node ~parents in - GitStore.Private.Commit.add (GitStore.Private.Repo.commit_t ctxt.index.repo) v - >>= fun ctxt_h -> - if Context_hash.equal bh.Block_header.shell.context ctxt_h - then Lwt.return_some bh - else Lwt.return_none - | `Contents _ -> assert false + let parents = List.map Hash.of_context_hash parents in + Store.Commit.v ctxt.index.repo ~info ~parents ctxt.tree >>= fun c -> + let h = Store.Commit.hash c in + if Context_hash.equal bh.Block_header.shell.context (Hash.to_context_hash h) + then Lwt.return_some bh + else Lwt.return_none let context_tree ctxt = ctxt.tree - let tree_hash ctxt = function - | `Node _ as node -> GitStore.Tree.hash ctxt.index.repo node - | contents -> Lwt.return (tree_hash contents) - let sub_tree tree key = GitStore.Tree.find_tree tree key - let tree_list tree = GitStore.Tree.list tree [] - let tree_content tree = GitStore.Tree.find tree [] - - let make_context index = { index ; tree = GitStore.Tree.empty ; parents = [] ; } + + let tree_hash = function + | `Node _ as tree -> `Node (Store.Tree.hash tree) + | `Contents (b, _) -> `Blob (Store.Contents.hash b) + + let sub_tree tree key = Store.Tree.find_tree tree key + let tree_list tree = Store.Tree.list tree [] + let tree_content tree = Store.Tree.find tree [] + + let make_context index = { index ; tree = Store.Tree.empty ; parents = [] ; } let update_context context tree = { context with tree ; } - let add_hash index tree key hash = - GitStore.Tree.of_hash index.repo hash >>= function + let add_blob_hash (Batch (repo, _, _)) tree key hash = + Store.Contents.of_hash repo hash >>= function | None -> Lwt.return_none - | Some sub_tree -> - GitStore.Tree.add_tree tree key sub_tree >>= - Lwt.return_some + | Some v -> Store.Tree.add tree key v >>= Lwt.return_some - let add_mbytes index bytes = - let tree = GitStore.Tree.of_contents bytes in - GitStore.Tree.hash index.repo tree >|= fun _ -> - tree + let add_node_hash (Batch (repo, _, _)) tree key hash = + Store.Tree.of_hash repo hash >>= function + | None -> Lwt.return_none + | Some t -> Store.Tree.add_tree tree key (t :> tree) >>= Lwt.return_some - let add_dir index l = + let add_mbytes (Batch (_, t, _)) bytes = + (* Save the contents in the store *) + Store.save_contents t bytes >|= fun _ -> + Store.Tree.of_contents bytes + + let add_dir batch l = let rec fold_list sub_tree = function | [] -> Lwt.return_some sub_tree - | ( step, hash ) :: tl -> - begin - add_hash index sub_tree [step]hash >>= function - | None -> Lwt.return_none - | Some sub_tree -> fold_list sub_tree tl - end + | (step, hash) :: tl -> ( + match hash with + | `Blob hash -> ( + add_blob_hash batch sub_tree [step] hash >>= function + | None -> Lwt.return_none + | Some sub_tree -> fold_list sub_tree tl + ) + | `Node hash -> ( + add_node_hash batch sub_tree [step] hash >>= function + | None -> Lwt.return_none + | Some sub_tree -> fold_list sub_tree tl + ) ) in - fold_list GitStore.Tree.empty l >>= function + fold_list Store.Tree.empty l >>= function | None -> Lwt.return_none | Some tree -> - GitStore.Tree.hash index.repo tree >>= fun _ -> - Lwt.return_some tree + let Batch (repo, x, y) = batch in + (* Save the node in the store ... *) + Store.save_tree ~clear:true repo x y tree >|= fun _ -> + Some tree module Commit_hash = Context_hash module Block_header = Block_header @@ -760,10 +684,9 @@ end (* Protocol data *) -let data_node_hash index context = - GitStore.Tree.get_tree context.tree current_data_key >>= fun dt -> - GitStore.Tree.hash index.repo dt >>= fun dt_hash -> - match dt_hash with `Node x -> Lwt.return x | _ -> assert false +let data_node_hash context = + Store.Tree.get_tree context.tree current_data_key >|= fun tree -> + Hash.to_context_hash (Store.Tree.hash tree) let get_transition_block_headers pruned_blocks = let rec aux hs x bs = match bs with @@ -793,10 +716,10 @@ let get_protocol_data_from_header index block_header = author ; message ; } in - Dumpable_context.context_parents context >>= fun parents -> + let parents = Dumpable_context.context_parents context in get_protocol context >>= fun protocol_hash -> get_test_chain context >>= fun test_chain_status -> - data_node_hash index context >>= fun data_key -> + data_node_hash context >>= fun data_key -> Lwt.return (level , { Protocol_data.parents ; protocol_hash ; @@ -805,40 +728,6 @@ let get_protocol_data_from_header index block_header = info ; }) -(* Mock some GitStore types, so we can build our own Merkle tree. *) - -module Mock : sig - - val node : GitStore.Repo.t -> P.Node.key -> GitStore.node - - val commit : GitStore.repo -> Hack.key -> P.Commit.value -> GitStore.commit - -end = struct - - [@@@ocaml.warning "-37"] - - type commit = { r: GitStore.Repo.t ; h: Context_hash.t; v: P.Commit.value } - - type empty - - type u = - | Map : empty -> u - | Key : GitStore.Repo.t * P.Node.key -> u - | Both: empty * empty * empty -> u - - and node = {mutable v : u} - - let node repo key = - let t : u = Key (repo, key) in - let node : node = {v = t} in - (Obj.magic node : GitStore.node) - - let commit r h v = - let c : commit = {r ; h ; v} in - (Obj.magic c : GitStore.commit) - -end - let validate_context_hash_consistency_and_commit ~data_hash ~expected_context_hash @@ -850,31 +739,36 @@ let validate_context_hash_consistency_and_commit ~parents ~index = + let data_hash = Hash.of_context_hash data_hash in + let parents = List.map Hash.of_context_hash parents in let protocol_value = Protocol_hash.to_bytes protocol_hash in let test_chain_value = Data_encoding.Binary.to_bytes_exn Test_chain_status.encoding test_chain in - let tree = GitStore.Tree.empty in - GitStore.Tree.add tree current_protocol_key protocol_value >>= fun tree -> - GitStore.Tree.add tree current_test_chain_key test_chain_value >>= fun tree -> - let info = Irmin.Info.v ~date:(Time.Protocol.to_seconds timestamp) ~author message in - let o_tree = Hack.cast (match tree with `Node n -> n | _ -> assert false) in - let map = match o_tree with Map m -> m | _ -> assert false in - let data_tree = Hack.Key data_hash in - let new_map = Hack.Map (Hack.StepMap.add "data" (`Node data_tree) map) in - let node = Hack.hash_node new_map in + let tree = Store.Tree.empty in + Store.Tree.add tree current_protocol_key (MBytes.to_string protocol_value) + >>= fun tree -> + Store.Tree.add tree current_test_chain_key (MBytes.to_string test_chain_value) + >>= fun tree -> + let info = + Irmin.Info.v ~date:(Time.Protocol.to_seconds timestamp) ~author message + in + let data_tree = Store.Tree.shallow index.repo data_hash in + Store.Tree.add_tree tree ["data"] data_tree >>= fun node -> + let node = Store.Tree.hash node in let commit = P.Commit.Val.v ~parents ~node ~info in - let computed_context_hash = P.Commit.Key.digest P.Commit.Val.t commit in + let computed_context_hash = Hash.to_context_hash (P.Commit.Key.hash commit) in if Context_hash.equal expected_context_hash computed_context_hash then - let mock_parents = List.map (fun h -> Mock.commit index.repo h commit) parents in - let ctxt = {index ; tree = GitStore.Tree.empty ; parents = mock_parents} in + let ctxt = + let parent = Store.of_private_commit index.repo commit in + {index ; tree = Store.Tree.empty ; parents = [parent]} + in set_test_chain ctxt test_chain >>= fun ctxt -> set_protocol ctxt protocol_hash >>= fun ctxt -> - let data_t = `Node (Mock.node index.repo data_hash) in - GitStore.Tree.add_tree ctxt.tree current_data_key data_t >>= fun new_tree -> - GitStore.Commit.v ctxt.index.repo ~info ~parents:ctxt.parents new_tree - >>= fun commit -> - let ctxt_h = GitStore.Commit.hash commit in - Lwt.return (Context_hash.equal ctxt_h expected_context_hash) + let data_t = Store.Tree.shallow index.repo data_hash in + Store.Tree.add_tree ctxt.tree current_data_key data_t >>= fun new_tree -> + Store.Commit.v ctxt.index.repo ~info ~parents new_tree >|= fun commit -> + let ctxt_h = Hash.to_context_hash (Store.Commit.hash commit) in + Context_hash.equal ctxt_h expected_context_hash else Lwt.return_false diff --git a/src/lib_storage/context.mli b/src/lib_storage/context.mli index c4ff1b737abc..ea9a79faebdc 100644 --- a/src/lib_storage/context.mli +++ b/src/lib_storage/context.mli @@ -87,8 +87,8 @@ val fold: val exists: index -> Context_hash.t -> bool Lwt.t val checkout: index -> Context_hash.t -> context option Lwt.t val checkout_exn: index -> Context_hash.t -> context Lwt.t -val hash: time:Time.Protocol.t -> - ?message:string -> t -> Context_hash.t Lwt.t +val hash: time:Time.Protocol.t -> ?message:string -> t -> Context_hash.t + val commit: time:Time.Protocol.t -> ?message:string -> diff --git a/src/lib_storage/context_dump.ml b/src/lib_storage/context_dump.ml index 135cb052f918..59997825e1f6 100644 --- a/src/lib_storage/context_dump.ml +++ b/src/lib_storage/context_dump.ml @@ -36,11 +36,12 @@ module type Dump_interface = sig type key = step list type commit_info + type batch + val batch : index -> (batch -> 'a Lwt.t) -> 'a Lwt.t + val commit_info_encoding : commit_info Data_encoding.t val hash_encoding : hash Data_encoding.t - val blob_encoding : [ `Blob of MBytes.t ] Data_encoding.t - val node_encoding : [ `Node of MBytes.t ] Data_encoding.t module Block_header : sig type t = Block_header.t @@ -80,18 +81,11 @@ module type Dump_interface = sig val encoding : t Data_encoding.t end - (* hash manipulation *) - val hash_export : hash -> [ `Node | `Blob ] * MBytes.t - val hash_import : [ `Node | `Blob ] -> MBytes.t -> hash tzresult - val hash_equal : hash -> hash -> bool - (* commit manipulation (for parents) *) - val context_parents : context -> Commit_hash.t list Lwt.t + val context_parents : context -> Commit_hash.t list (* Commit info *) val context_info : context -> commit_info - val context_info_export : commit_info -> ( Int64.t * string * string ) - val context_info_import : ( Int64.t * string * string ) -> commit_info (* block header manipulation *) val get_context : index -> Block_header.t -> context option Lwt.t @@ -102,17 +96,16 @@ module type Dump_interface = sig (* for dumping *) val context_tree : context -> tree - val tree_hash : context -> tree -> hash Lwt.t + val tree_hash : tree -> hash val sub_tree : tree -> key -> tree option Lwt.t val tree_list : tree -> ( step * [`Contents|`Node] ) list Lwt.t - val tree_content : tree -> MBytes.t option Lwt.t + val tree_content : tree -> string option Lwt.t (* for restoring *) val make_context : index -> context val update_context : context -> tree -> context - val add_hash : index -> tree -> key -> hash -> tree option Lwt.t - val add_mbytes : index -> MBytes.t -> tree Lwt.t - val add_dir : index -> ( step * hash ) list -> tree option Lwt.t + val add_mbytes : batch -> string -> tree Lwt.t + val add_dir : batch -> ( step * hash) list -> tree option Lwt.t end @@ -135,7 +128,8 @@ module type S = sig (block_header option -> Block_hash.t -> pruned_block -> unit tzresult Lwt.t) -> (block_header * block_data * History_mode.t * - Block_header.t option * Block_hash.t list * protocol_data list) tzresult Lwt.t + Block_header.t option * Block_hash.t list * + protocol_data list) tzresult Lwt.t end @@ -263,7 +257,7 @@ let () = begin "Internal error while restoring the context.") empty (function Restore_context_failure -> Some () | _ -> None) - (fun () -> Restore_context_failure); + (fun () -> Restore_context_failure) ; end @@ -277,7 +271,7 @@ module Make (I:Dump_interface) = struct block_data : I.Block_data.t ; } | Node of (string * I.hash) list - | Blob of MBytes.t + | Blob of string | Proot of I.Pruned_block.t | Loot of I.Protocol_data.t | End @@ -287,7 +281,7 @@ module Make (I:Dump_interface) = struct let blob_encoding = let open Data_encoding in case ~title:"blob" (Tag (Char.code 'b')) - bytes + string (function Blob bytes -> Some bytes | _ -> None) (function bytes -> Blob bytes) @@ -498,7 +492,7 @@ module Make (I:Dump_interface) = struct I.sub_tree tree [name] >>= function | None -> assert false | Some sub_tree -> - I.tree_hash ctxt sub_tree >>= fun hash -> + let hash = I.tree_hash sub_tree in begin if visited hash then Lwt.return_unit else @@ -521,8 +515,8 @@ module Make (I:Dump_interface) = struct maybe_flush () end end - end >>= fun () -> - Lwt.return (name, hash) + end >|= fun () -> + (name, hash) end keys >>= fun sub_keys -> set_node buf sub_keys; @@ -540,7 +534,7 @@ module Make (I:Dump_interface) = struct let tree = I.context_tree ctxt in fold_tree_path ctxt tree >>= fun () -> Tezos_stdlib_unix.Utils.display_progress_end (); - I.context_parents ctxt >>= fun parents -> + let parents = I.context_parents ctxt in set_root buf bh (I.context_info ctxt) parents block_data; (* Dump pruned blocks *) let dump_pruned cpt pruned = @@ -591,19 +585,19 @@ module Make (I:Dump_interface) = struct let rbuf = ref (fd, Bytes.empty, 0, read) in (* Editing the repository *) - let add_blob blob = - I.add_mbytes index blob >>= fun tree -> + let add_blob t blob = + I.add_mbytes t blob >>= fun tree -> return tree in - let add_dir keys = - I.add_dir index keys >>= function + let add_dir t keys = + I.add_dir t keys >>= function | None -> fail Restore_context_failure | Some tree -> return tree in let restore history_mode = - let rec first_pass ctxt cpt = + let rec first_pass batch ctxt cpt = Tezos_stdlib_unix.Utils.display_progress ~refresh_rate:(cpt, 1_000) "Context: %dK elements, %dMiB read" @@ -616,11 +610,11 @@ module Make (I:Dump_interface) = struct return (block_header, block_data) end | Node contents -> - add_dir contents >>=? fun tree -> - first_pass (I.update_context ctxt tree) (cpt + 1) + add_dir batch contents >>=? fun tree -> + first_pass batch (I.update_context ctxt tree) (cpt + 1) | Blob data -> - add_blob data >>=? fun tree -> - first_pass (I.update_context ctxt tree) (cpt + 1) + add_blob batch data >>=? fun tree -> + first_pass batch (I.update_context ctxt tree) (cpt + 1) | _ -> fail Inconsistent_snapshot_data in let rec second_pass pred_header (rev_block_hashes, protocol_datas) todo cpt = @@ -647,7 +641,9 @@ module Make (I:Dump_interface) = struct | End -> return (pred_header, rev_block_hashes, List.rev protocol_datas) | _ -> fail Inconsistent_snapshot_data in - first_pass (I.make_context index) 0 >>=? fun (block_header, block_data) -> + I.batch index (fun batch -> + first_pass batch (I.make_context index) 0 + ) >>=? fun (block_header, block_data) -> Tezos_stdlib_unix.Utils.display_progress_end () ; second_pass None ([], []) [] 0 >>=? fun (oldest_header_opt, rev_block_hashes, protocol_datas) -> Tezos_stdlib_unix.Utils.display_progress_end () ; diff --git a/src/lib_storage/context_dump.mli b/src/lib_storage/context_dump.mli index 511b2f6bcbb4..3bdefa5bc8ee 100644 --- a/src/lib_storage/context_dump.mli +++ b/src/lib_storage/context_dump.mli @@ -43,11 +43,12 @@ module type Dump_interface = sig type key = step list type commit_info + type batch + val batch : index -> (batch -> 'a Lwt.t) -> 'a Lwt.t + val commit_info_encoding : commit_info Data_encoding.t val hash_encoding : hash Data_encoding.t - val blob_encoding : [ `Blob of MBytes.t ] Data_encoding.t - val node_encoding : [ `Node of MBytes.t ] Data_encoding.t module Block_header : sig type t = Block_header.t @@ -87,18 +88,11 @@ module type Dump_interface = sig val encoding : t Data_encoding.t end - (* hash manipulation *) - val hash_export : hash -> [ `Node | `Blob ] * MBytes.t - val hash_import : [ `Node | `Blob ] -> MBytes.t -> hash tzresult - val hash_equal : hash -> hash -> bool - (* commit manipulation (for parents) *) - val context_parents : context -> Commit_hash.t list Lwt.t + val context_parents : context -> Commit_hash.t list (* Commit info *) val context_info : context -> commit_info - val context_info_export : commit_info -> ( Int64.t * string * string ) - val context_info_import : ( Int64.t * string * string ) -> commit_info (* block header manipulation *) val get_context : index -> Block_header.t -> context option Lwt.t @@ -109,17 +103,16 @@ module type Dump_interface = sig (* for dumping *) val context_tree : context -> tree - val tree_hash : context -> tree -> hash Lwt.t + val tree_hash : tree -> hash val sub_tree : tree -> key -> tree option Lwt.t val tree_list : tree -> ( step * [`Contents|`Node] ) list Lwt.t - val tree_content : tree -> MBytes.t option Lwt.t + val tree_content : tree -> string option Lwt.t (* for restoring *) val make_context : index -> context val update_context : context -> tree -> context - val add_hash : index -> tree -> key -> hash -> tree option Lwt.t - val add_mbytes : index -> MBytes.t -> tree Lwt.t - val add_dir : index -> ( step * hash ) list -> tree option Lwt.t + val add_mbytes : batch -> string -> tree Lwt.t + val add_dir : batch -> ( step * hash ) list -> tree option Lwt.t end diff --git a/src/lib_storage/dune b/src/lib_storage/dune index 513b4eb794d3..b963fa0f3564 100644 --- a/src/lib_storage/dune +++ b/src/lib_storage/dune @@ -4,7 +4,9 @@ (libraries tezos-base tezos-shell-services lmdb - irmin-lmdb + digestif.c + irmin + irmin-pack tezos-stdlib-unix) (flags (:standard -w -9+27-30-32-40@8 -safe-string diff --git a/src/lib_storage/tezos-storage.opam b/src/lib_storage/tezos-storage.opam index 8d2c5a138182..11ffb1a03f29 100644 --- a/src/lib_storage/tezos-storage.opam +++ b/src/lib_storage/tezos-storage.opam @@ -11,7 +11,8 @@ depends: [ "dune" { build & >= "1.7" } "tezos-base" "lmdb" - "irmin-lmdb" + "irmin" + "irmin-pack" "tezos-shell-services" "tezos-stdlib-unix" "alcotest-lwt" { with-test } diff --git a/src/proto_alpha/lib_delegate/client_baking_forge.ml b/src/proto_alpha/lib_delegate/client_baking_forge.ml index 3061c9381822..95b9a3d03fce 100644 --- a/src/proto_alpha/lib_delegate/client_baking_forge.ml +++ b/src/proto_alpha/lib_delegate/client_baking_forge.ml @@ -595,7 +595,7 @@ let finalize_block_header return context | Forking _ -> fail Forking_test_chain end >>=? fun context -> - Context.hash ~time:timestamp ?message context >>= fun context -> + let context = Context.hash ~time:timestamp ?message context in let header = Tezos_base.Block_header. { pred_shell_header with -- GitLab From 2aa258cc4a3ba48256d53910ea3fa29ef98af213 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Tue, 9 Jul 2019 19:38:57 +0200 Subject: [PATCH 03/17] storage: use digestif instead of ocaml-blake2 to compute tree hashes This allows unecessary allocations in the C and major heaps. --- src/lib_storage/context.ml | 34 +++++++++++++++--------------- src/lib_storage/tezos-storage.opam | 1 + 2 files changed, 18 insertions(+), 17 deletions(-) diff --git a/src/lib_storage/context.ml b/src/lib_storage/context.ml index 82a6aae926d3..83044efab117 100644 --- a/src/lib_storage/context.ml +++ b/src/lib_storage/context.ml @@ -37,35 +37,35 @@ module Hash : sig val to_context_hash: t -> Context_hash.t val of_context_hash: Context_hash.t -> t end = struct - module H = Context_hash + module H = Digestif.Make_BLAKE2B(struct + let digest_size = 32 + end) - type t = string + type t = H.t - let to_context_hash s = H.of_string_exn s + let of_context_hash s = H.of_raw_string (Context_hash.to_string s) - let of_context_hash h = H.to_string h + let to_context_hash h = Context_hash.of_string_exn (H.to_raw_string h) - let pp ppf t = H.pp ppf (H.of_string_exn t) + let pp ppf t = Context_hash.pp ppf (to_context_hash t) let of_string x = - match H.of_b58check x with - | Ok _ -> Ok x + match Context_hash.of_b58check x with + | Ok x -> Ok (of_context_hash x) | Error _ -> todo "Hash.of_string" - let short_hash h = H.hash (to_context_hash h) + let short_hash t = + Irmin.Type.(short_hash string (H.to_raw_string t)) let t : t Irmin.Type.t = - Irmin.Type.like - ~cli:(pp, of_string) Irmin.Type.(string_of (`Fixed H.size)) - ~short_hash + Irmin.Type.map + ~cli:(pp, of_string) Irmin.Type.(string_of (`Fixed H.digest_size)) + ~short_hash:short_hash + H.of_raw_string H.to_raw_string - let hash_size = H.size + let hash_size = H.digest_size - let hash f = - let init = ref [] in - f (fun x -> init := x :: !init); - let h = H.hash_string (List.rev !init) in - H.to_string h + let hash = H.digesti_string end module Node = struct diff --git a/src/lib_storage/tezos-storage.opam b/src/lib_storage/tezos-storage.opam index 11ffb1a03f29..14a74d94a183 100644 --- a/src/lib_storage/tezos-storage.opam +++ b/src/lib_storage/tezos-storage.opam @@ -13,6 +13,7 @@ depends: [ "lmdb" "irmin" "irmin-pack" + "digestif" {>= "0.7.3"} "tezos-shell-services" "tezos-stdlib-unix" "alcotest-lwt" { with-test } -- GitLab From 8f7979ef29edbc3c952a168219b5041f77bd39e2 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Wed, 31 Jul 2019 09:48:46 +0200 Subject: [PATCH 04/17] storage: use TEZOS_STORAGE=v to turn on debug message for storage --- src/lib_storage/context.ml | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/src/lib_storage/context.ml b/src/lib_storage/context.ml index 83044efab117..c1563470e28a 100644 --- a/src/lib_storage/context.ml +++ b/src/lib_storage/context.ml @@ -32,6 +32,34 @@ exception TODO of string let todo fmt = Fmt.kstrf (fun s -> raise (TODO s)) fmt +let reporter () = + let report src level ~over k msgf = + let k _ = + over (); + k () + in + let with_stamp h _tags k fmt = + let dt = Mtime.Span.to_us (Mtime_clock.elapsed ()) in + Fmt.kpf k Fmt.stderr + ("%+04.0fus %a %a @[" ^^ fmt ^^ "@]@.") + dt + Fmt.(styled `Magenta string) + (Logs.Src.name src) + Logs_fmt.pp_header (level, h) + in + msgf @@ fun ?header ?tags fmt -> + with_stamp header tags k fmt + in + { Logs.report } + +let () = + match Unix.getenv "TEZOS_STORAGE" with + | "v" | "verbose" | "vv" -> + Logs.set_level (Some Logs.Debug); + Logs.set_reporter (reporter ()) + | _ -> () + | exception Not_found -> () + module Hash : sig include Irmin.Hash.S val to_context_hash: t -> Context_hash.t -- GitLab From 81cac505e70525e8fd62da2d39febaeadab8072e Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Thu, 1 Aug 2019 11:34:13 +0200 Subject: [PATCH 05/17] storage: add the ability to fix the index log size via env variables Use TEZOS_STORAGE='index-log-size=10_000_000,v` to enable logs+increasing the index log size to 10m --- src/lib_storage/context.ml | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) diff --git a/src/lib_storage/context.ml b/src/lib_storage/context.ml index c1563470e28a..f7210f686998 100644 --- a/src/lib_storage/context.ml +++ b/src/lib_storage/context.ml @@ -52,13 +52,27 @@ let reporter () = in { Logs.report } +let index_log_size = ref None + let () = + let verbose () = + Logs.set_level (Some Logs.Debug); + Logs.set_reporter (reporter ()) + in + let index_log_size n = + index_log_size := Some (int_of_string n) + in match Unix.getenv "TEZOS_STORAGE" with - | "v" | "verbose" | "vv" -> - Logs.set_level (Some Logs.Debug); - Logs.set_reporter (reporter ()) - | _ -> () | exception Not_found -> () + | v -> + let args = String.split ',' v in + List.iter (function + | "v" | "verbose" | "vv" -> verbose () + | v -> + match String.split '=' v with + | ["index-log-size"; n] -> index_log_size n + | _ -> () + ) args module Hash : sig include Irmin.Hash.S @@ -361,7 +375,8 @@ let fork_test_chain v ~protocol ~expiration = (*-- Initialisation ----------------------------------------------------------*) let init ?patch_context ?mapsize:_ ?readonly root = - Store.Repo.v (Irmin_pack.config ?readonly root) + Store.Repo.v + (Irmin_pack.config ?readonly ?index_log_size:!index_log_size root) >>= fun repo -> Lwt.return { path= root -- GitLab From 97593b9fdf0cc03d341f4f24bf16a404e293e66e Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Fri, 19 Jul 2019 18:35:11 +0200 Subject: [PATCH 06/17] CI: fix build --- scripts/install_build_deps.raw.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scripts/install_build_deps.raw.sh b/scripts/install_build_deps.raw.sh index 9ba20aef3230..c9700e419004 100755 --- a/scripts/install_build_deps.raw.sh +++ b/scripts/install_build_deps.raw.sh @@ -12,7 +12,7 @@ export OPAMYES=${OPAMYES:=true} ## In another ideal world, this list should be extracted from the pinned ## packages and filter only conf-* packages -opam depext conf-gmp conf-libev conf-m4 conf-perl conf-pkg-config conf-which conf-hidapi +opam depext conf-gmp conf-libev conf-m4 conf-perl conf-pkg-config conf-which conf-hidapi conf-autoconf ## In an ideal world, `--with-test` should be present only when using ## `--dev`. But this would probably break the CI, so we postponed this -- GitLab From b869a1ed529d2e72d0aaf55e573a1d5982ee2292 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Thu, 8 Aug 2019 10:54:35 +0200 Subject: [PATCH 07/17] [irmin, irmin-pack, index] update to latest version --- vendors/index/src/index.ml | 167 ++++++++++++++++++------------- vendors/irmin-pack/pack_dict.ml | 14 ++- vendors/irmin-pack/pack_dict.mli | 16 +++ 3 files changed, 127 insertions(+), 70 deletions(-) create mode 100644 vendors/irmin-pack/pack_dict.mli diff --git a/vendors/index/src/index.ml b/vendors/index/src/index.ml index 6469fda1a51c..a62f3c5dbc74 100644 --- a/vendors/index/src/index.ml +++ b/vendors/index/src/index.ml @@ -126,14 +126,15 @@ module Make (K : Key) (V : Value) (IO : IO) = struct module Tbl = Hashtbl.Make (K) - type config = { log_size : int; readonly : bool } + type config = { fan_out_size : int; log_size : int; readonly : bool } + + type index = { io : IO.t; fan_out : Fan.t } type t = { config : config; root : string; mutable generation : int64; - fan_out : Fan.t; - mutable index : IO.t; + mutable index : index option; log : IO.t; log_mem : entry Tbl.t; entries : key Bloomf.t option; @@ -145,8 +146,11 @@ module Make (K : Key) (V : Value) (IO : IO) = struct IO.clear t.log; may Bloomf.clear t.entries; Tbl.clear t.log_mem; - Fan.clear t.fan_out; - IO.clear t.index + may + (fun i -> + Fan.clear i.fan_out; + IO.clear i.io) + t.index let ( // ) = Filename.concat @@ -179,9 +183,9 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let iter_io ?min ?max f io = iter_io_off ?min ?max (fun _ e -> f e) io - let get_entry t off = + let get_entry io off = let buf = Bytes.create entry_size in - let _ = IO.read t.index ~off buf in + let _ = IO.read io ~off buf in decode_entry buf 0 let with_cache ~v ~clear = @@ -216,7 +220,9 @@ module Make (K : Key) (V : Value) (IO : IO) = struct `Staged f let v_no_cache ~fresh ~readonly ~log_size ~fan_out_size root = - let config = { log_size = log_size * entry_size; readonly } in + let config = + { fan_out_size; log_size = log_size * entry_size; readonly } + in let log_path = log_path root in let index_path = index_path root in let entries = @@ -225,39 +231,40 @@ module Make (K : Key) (V : Value) (IO : IO) = struct in let log_mem = Tbl.create 1024 in let log = IO.v ~fresh ~readonly ~generation:0L log_path in - let index = IO.v ~fresh ~readonly ~generation:0L index_path in let generation = IO.get_generation log in - let fan_out = Fan.v fan_out_size in - let t = - { config; generation; fan_out; log_mem; root; log; index; entries } + let index = + if Sys.file_exists index_path then ( + let fan_out = Fan.v fan_out_size in + let io = IO.v ~fresh ~readonly ~generation:0L index_path in + iter_io_off + (fun off e -> + let hash = K.hash e.key in + Fan.update fan_out hash off; + may (fun bf -> Bloomf.add bf e.key) entries) + io; + Fan.flatten fan_out; + Some { fan_out; io } ) + else None in - if not fresh then ( - iter_io - (fun e -> - Tbl.add t.log_mem e.key e; - may (fun bf -> Bloomf.add bf e.key) t.entries) - t.log; - iter_io_off - (fun off e -> - let hash = K.hash e.key in - Fan.update t.fan_out hash off; - may (fun bf -> Bloomf.add bf e.key) t.entries) - t.index; - Fan.flatten t.fan_out ); - t + iter_io + (fun e -> + Tbl.add log_mem e.key e; + may (fun bf -> Bloomf.add bf e.key) entries) + log; + { config; generation; log_mem; root; log; index; entries } let (`Staged v) = with_cache ~v:v_no_cache ~clear - let get_entry_iff_needed t off = function + let get_entry_iff_needed io off = function | Some e -> e - | None -> get_entry t off + | None -> get_entry io off - let look_around t init key h_key off = + let look_around io init key h_key off = let rec search acc op curr = let off = op curr entry_sizeL in - if off < 0L || off >= IO.offset t.index then acc + if off < 0L || off >= IO.offset io then acc else - let e = get_entry t off in + let e = get_entry io off in let h_e = K.hash e.key in if h_e <> h_key then acc else @@ -267,20 +274,22 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let before = search init Int64.add off in search before Int64.sub off - let interpolation_search t key = + let interpolation_search index key = let hashed_key = K.hash key in - let low, high = Fan.search t.fan_out hashed_key in + let low, high = Fan.search index.fan_out hashed_key in let rec search low high lowest_entry highest_entry = if high < low then [] else - let lowest_entry = get_entry_iff_needed t low lowest_entry in + let lowest_entry = get_entry_iff_needed index.io low lowest_entry in if high = low then if K.equal lowest_entry.key key then [ lowest_entry.value ] else [] else let lowest_hash = K.hash lowest_entry.key in if lowest_hash > hashed_key then [] else - let highest_entry = get_entry_iff_needed t high highest_entry in + let highest_entry = + get_entry_iff_needed index.io high highest_entry + in let highest_hash = K.hash highest_entry.key in if highest_hash < hashed_key then [] else @@ -297,11 +306,11 @@ module Make (K : Key) (V : Value) (IO : IO) = struct in let off = lowf +. doff -. mod_float doff entry_sizef in let offL = Int64.of_float off in - let e = get_entry t offL in + let e = get_entry index.io offL in let hashed_e = K.hash e.key in if hashed_key = hashed_e then let init = if K.equal key e.key then [ e.value ] else [] in - look_around t init key hashed_key offL + look_around index.io init key hashed_key offL else if hashed_e < hashed_key then (search [@tailcall]) (Int64.add offL entry_sizeL) @@ -325,16 +334,16 @@ module Make (K : Key) (V : Value) (IO : IO) = struct Tbl.clear t.log_mem; iter_io add_log_entry t.log; let index_path = index_path t.root in - let index = IO.v ~fresh:false ~readonly:true ~generation index_path in - let _ = IO.force_offset index in - Fan.clear t.fan_out; + let io = IO.v ~fresh:false ~readonly:true ~generation index_path in + let _ = IO.force_offset io in + let fan_out = Fan.v t.config.log_size in iter_io_off (fun off e -> let hash = K.hash e.key in - Fan.update t.fan_out hash off) - index; - Fan.flatten t.fan_out; - t.index <- index; + Fan.update fan_out hash off) + io; + Fan.flatten fan_out; + t.index <- Some { fan_out; io }; t.generation <- generation ) else if log_offset < new_log_offset then iter_io add_log_entry t.log ~min:log_offset @@ -344,7 +353,11 @@ module Make (K : Key) (V : Value) (IO : IO) = struct Log.debug (fun l -> l "find %a" K.pp key); if t.config.readonly then sync_log t; let look_on_disk () = - let in_index = interpolation_search t key in + let in_index = + match t.index with + | None -> [] + | Some index -> interpolation_search index key + in let in_log = List.map (fun e -> e.value) (Tbl.find_all t.log_mem key) in in_index @ in_log in @@ -356,29 +369,30 @@ module Make (K : Key) (V : Value) (IO : IO) = struct Log.debug (fun l -> l "mem %a" K.pp key); match find_all t key with [] -> false | _ -> true - let append_entry_fanout t h io e = - Fan.update t.fan_out h (IO.offset io); + let append_entry_fanout fan_out h io e = + Fan.update fan_out h (IO.offset io); append_entry io e - let merge_with log t tmp = - Fan.clear t.fan_out; + let merge_with log index tmp = + Fan.clear index.fan_out; let offset = ref 0L in let get_index_entry = function | Some e -> Some e | None -> - if !offset >= IO.offset t.index then None + if !offset >= IO.offset index.io then None else - let e = get_entry t !offset in + let e = get_entry index.io !offset in offset := Int64.add !offset entry_sizeL; Some e in + let fan_out = index.fan_out in let rec go last_read l = match get_index_entry last_read with | None -> List.iter (fun v -> let hashed_v = K.hash v.key in - append_entry_fanout t hashed_v tmp v) + append_entry_fanout fan_out hashed_v tmp v) l | Some e -> ( let hashed_e = K.hash e.key in @@ -387,30 +401,30 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let last, rst = let hashed_v = K.hash v.key in if hashed_e = hashed_v then ( - append_entry_fanout t hashed_e tmp e; - append_entry_fanout t hashed_v tmp v; + append_entry_fanout fan_out hashed_e tmp e; + append_entry_fanout fan_out hashed_v tmp v; (None, r) ) else if hashed_e < hashed_v then ( - append_entry_fanout t hashed_e tmp e; + append_entry_fanout fan_out hashed_e tmp e; (None, l) ) else ( - append_entry_fanout t hashed_v tmp v; + append_entry_fanout fan_out hashed_v tmp v; (Some e, r) ) in - if !offset >= IO.offset t.index && last = None then + if !offset >= IO.offset index.io && last = None then List.iter (fun v -> let hashed_v = K.hash v.key in - append_entry_fanout t hashed_v tmp v) + append_entry_fanout fan_out hashed_v tmp v) rst else (go [@tailcall]) last rst | [] -> - append_entry_fanout t hashed_e tmp e; + append_entry_fanout fan_out hashed_e tmp e; iter_io (fun e -> let hashed_e = K.hash e.key in - append_entry_fanout t hashed_e tmp e) - t.index ~min:!offset ) + append_entry_fanout fan_out hashed_e tmp e) + index.io ~min:!offset ) in (go [@tailcall]) None log @@ -431,13 +445,28 @@ module Make (K : Key) (V : Value) (IO : IO) = struct Tbl.fold (fun _ e acc -> EntrySet.add e acc) t.log_mem EntrySet.empty |> EntrySet.elements in - merge_with log t tmp; - IO.rename ~src:tmp ~dst:t.index; - Fan.flatten t.fan_out; - IO.clear t.log; - Tbl.clear t.log_mem; - IO.set_generation t.log generation; - t.generation <- generation + ( match t.index with + | None -> + let fan_out = Fan.v t.config.fan_out_size in + let io = + IO.v ~fresh:true ~readonly:false ~generation:0L (index_path t.root) + in + List.iter + (fun v -> + let hashed_v = K.hash v.key in + append_entry_fanout fan_out hashed_v tmp v) + log; + t.index <- Some { io; fan_out } + | Some index -> merge_with log index tmp ); + match t.index with + | None -> assert false + | Some index -> + IO.rename ~src:tmp ~dst:index.io; + Fan.flatten index.fan_out; + IO.clear t.log; + Tbl.clear t.log_mem; + IO.set_generation t.log generation; + t.generation <- generation let add t key value = Log.debug (fun l -> l "add %a %a" K.pp key V.pp value); @@ -452,7 +481,7 @@ module Make (K : Key) (V : Value) (IO : IO) = struct (* XXX: Perform a merge beforehands to ensure duplicates are not hit twice. *) let iter f t = Tbl.iter (fun _ e -> f e.key e.value) t.log_mem; - iter_io (fun e -> f e.key e.value) t.index + may (fun index -> iter_io (fun e -> f e.key e.value) index.io) t.index let flush t = IO.sync t.log end diff --git a/vendors/irmin-pack/pack_dict.ml b/vendors/irmin-pack/pack_dict.ml index da370cb7a4bd..fd6fd92ce549 100644 --- a/vendors/irmin-pack/pack_dict.ml +++ b/vendors/irmin-pack/pack_dict.ml @@ -1,3 +1,15 @@ +(* Permission to use, copy, modify, and/or 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. *) + include Dict.Make (IO.Unix) (* Add IO caching around Dict.v *) @@ -5,5 +17,5 @@ let (`Staged v) = let v_no_cache ~fresh ~shared:_ ~readonly = v ~fresh ~readonly in IO.with_cache ~clear ~v:(fun capacity -> v_no_cache ~capacity) "store.dict" -let v ?fresh ?readonly ?shared ?(capacity = 100_000) root = +let v ?fresh ?shared ?readonly ?(capacity = 100_000) root = v capacity ?fresh ?shared ?readonly root diff --git a/vendors/irmin-pack/pack_dict.mli b/vendors/irmin-pack/pack_dict.mli new file mode 100644 index 000000000000..8319c2d17b99 --- /dev/null +++ b/vendors/irmin-pack/pack_dict.mli @@ -0,0 +1,16 @@ +(* Permission to use, copy, modify, and/or 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. *) + +include Dict.S + +val v : + ?fresh:bool -> ?shared:bool -> ?readonly:bool -> ?capacity:int -> string -> t -- GitLab From d7f1fffdb77814dcae7653808847275f90028b79 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Thu, 8 Aug 2019 19:34:11 +0200 Subject: [PATCH 08/17] [imrin, irmin-pack, index] update to latest versions - [index] remove the fan_out_size parameter - [irmin, irmin-pack] use ocamlformat 0.11 --- vendors/index/src/fan.ml | 46 +++ vendors/index/src/fan.mli | 17 ++ vendors/index/src/index.ml | 87 ++---- vendors/index/src/index.mli | 1 - vendors/irmin-pack/IO.ml | 14 +- vendors/irmin-pack/dict.ml | 2 +- vendors/irmin-pack/inode.ml | 225 +++++++-------- vendors/irmin-pack/inode.mli | 8 +- vendors/irmin-pack/irmin_pack.ml | 22 +- vendors/irmin-pack/irmin_pack.mli | 20 +- vendors/irmin-pack/lru.ml | 6 +- vendors/irmin-pack/pack.ml | 46 +-- vendors/irmin-pack/pack.mli | 2 +- vendors/irmin-pack/pack_index.ml | 1 - vendors/irmin-pack/pack_index.mli | 1 - vendors/irmin/commit.ml | 42 +-- vendors/irmin/commit.mli | 24 +- vendors/irmin/conf.ml | 6 +- vendors/irmin/contents.ml | 19 +- vendors/irmin/contents.mli | 6 +- vendors/irmin/diff.ml | 6 +- vendors/irmin/dot.ml | 20 +- vendors/irmin/irmin.ml | 8 +- vendors/irmin/irmin.mli | 453 +++++++++++++++--------------- vendors/irmin/merge.ml | 77 +++-- vendors/irmin/node.ml | 39 +-- vendors/irmin/node.mli | 44 +-- vendors/irmin/object_graph.ml | 13 +- vendors/irmin/object_graph.mli | 20 +- vendors/irmin/path.ml | 2 +- vendors/irmin/s.ml | 65 ++--- vendors/irmin/slice.ml | 13 +- vendors/irmin/slice.mli | 6 +- vendors/irmin/store.ml | 74 ++--- vendors/irmin/store.mli | 26 +- vendors/irmin/sync_ext.ml | 84 +++--- vendors/irmin/tree.ml | 389 ++++++++++++------------- vendors/irmin/tree.mli | 8 +- vendors/irmin/type.ml | 117 ++++---- vendors/irmin/watch.ml | 35 +-- 40 files changed, 1086 insertions(+), 1008 deletions(-) create mode 100644 vendors/index/src/fan.ml create mode 100644 vendors/index/src/fan.mli diff --git a/vendors/index/src/fan.ml b/vendors/index/src/fan.ml new file mode 100644 index 000000000000..4f6ac49c4461 --- /dev/null +++ b/vendors/index/src/fan.ml @@ -0,0 +1,46 @@ +type t = { + hash_size : int; + entry_size : int; + size : int; + fans : int64 array; + mask : int; + shift : int; +} + +let log2 a = log a /. log 2. + +let v ~hash_size ~entry_size n = + let entry_sizef = float_of_int entry_size in + let entries_per_page = 4096. /. entry_sizef in + let entries_fan = float_of_int n /. (entries_per_page *. entries_per_page) in + let size = max 0 (int_of_float (ceil (log2 entries_fan))) in + let nb_fans = 1 lsl size in + let shift = hash_size - size in + { + hash_size; + entry_size; + size; + fans = Array.make nb_fans 0L; + mask = (nb_fans - 1) lsl shift; + shift; + } + +let fan t h = (h land t.mask) lsr t.shift + +let search t h = + let fan = fan t h in + let low = if fan = 0 then 0L else t.fans.(fan - 1) in + (low, t.fans.(fan)) + +let update t hash off = + let fan = fan t hash in + t.fans.(fan) <- off + +let finalize t = + let rec loop curr i = + if i = Array.length t.fans then () + else ( + if t.fans.(i) = 0L then t.fans.(i) <- curr; + loop t.fans.(i) (i + 1) ) + in + loop 0L 0 diff --git a/vendors/index/src/fan.mli b/vendors/index/src/fan.mli new file mode 100644 index 000000000000..2c0dad92cb99 --- /dev/null +++ b/vendors/index/src/fan.mli @@ -0,0 +1,17 @@ +type t + +val v : hash_size:int -> entry_size:int -> int -> t +(** [v ~hash_size ~entry_size n] creates a fan_out for an index with [hash_size] + and [entry_size], containing [n] elements. *) + +val search : t -> int -> int64 * int64 +(** [search t hash] is the interval of offsets in witch [hash] is, if + present. *) + +val update : t -> int -> int64 -> unit +(** [update t hash off] updates [t] so that [hash] is registered to be at + offset [off]. *) + +val finalize : t -> unit +(** Finalizes the update of the fanout. This is mendatory before any [search] + query. *) diff --git a/vendors/index/src/index.ml b/vendors/index/src/index.ml index a62f3c5dbc74..a491b502675d 100644 --- a/vendors/index/src/index.ml +++ b/vendors/index/src/index.ml @@ -42,7 +42,6 @@ module type S = sig ?readonly:bool -> ?shared:bool -> log_size:int -> - fan_out_size:int -> string -> t @@ -80,40 +79,6 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let entry_sizeL = Int64.of_int entry_size - module Fan = struct - type t = { size : int; fans : int64 array; mask : int; shift : int } - - let v n = - let size = n in - let nb_fans = 1 lsl size in - let fans = Array.make nb_fans (-1L) in - let shift = K.hash_size - size in - let mask = (nb_fans - 1) lsl shift in - { size; fans; mask; shift } - - let fan t h = (h land t.mask) lsr t.shift - - let clear t = Array.fill t.fans 0 (Array.length t.fans) (-1L) - - let search t h = - let fan = fan t h in - let low = if fan = 0 then 0L else t.fans.(fan - 1) in - (low, t.fans.(fan)) - - let update t hash off = - let fan = fan t hash in - t.fans.(fan) <- off - - let flatten t = - let rec loop curr i = - if i = Array.length t.fans then () - else ( - if t.fans.(i) = -1L then t.fans.(i) <- curr; - loop t.fans.(i) (i + 1) ) - in - loop 0L 0 - end - let append_entry io e = IO.append io (K.encode e.key); IO.append io (V.encode e.value) @@ -126,7 +91,7 @@ module Make (K : Key) (V : Value) (IO : IO) = struct module Tbl = Hashtbl.Make (K) - type config = { fan_out_size : int; log_size : int; readonly : bool } + type config = { log_size : int; readonly : bool } type index = { io : IO.t; fan_out : Fan.t } @@ -146,11 +111,8 @@ module Make (K : Key) (V : Value) (IO : IO) = struct IO.clear t.log; may Bloomf.clear t.entries; Tbl.clear t.log_mem; - may - (fun i -> - Fan.clear i.fan_out; - IO.clear i.io) - t.index + may (fun i -> IO.clear i.io) t.index; + t.index <- None let ( // ) = Filename.concat @@ -190,13 +152,13 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let with_cache ~v ~clear = let roots = Hashtbl.create 0 in - let f ?(fresh = false) ?(readonly = false) ?(shared = true) ~log_size - ~fan_out_size root = + let f ?(fresh = false) ?(readonly = false) ?(shared = true) ~log_size root + = if not shared then ( Log.debug (fun l -> l "[%s] v fresh=%b shared=%b readonly=%b" (Filename.basename root) fresh shared readonly); - v ~fresh ~readonly ~log_size ~fan_out_size root ) + v ~fresh ~readonly ~log_size root ) else try if not (Sys.file_exists root) then ( @@ -213,16 +175,14 @@ module Make (K : Key) (V : Value) (IO : IO) = struct Log.debug (fun l -> l "[%s] v fresh=%b shared=%b readonly=%b" (Filename.basename root) fresh shared readonly); - let t = v ~fresh ~readonly ~log_size ~fan_out_size root in + let t = v ~fresh ~readonly ~log_size root in Hashtbl.add roots root t; t in `Staged f - let v_no_cache ~fresh ~readonly ~log_size ~fan_out_size root = - let config = - { fan_out_size; log_size = log_size * entry_size; readonly } - in + let v_no_cache ~fresh ~readonly ~log_size root = + let config = { log_size = log_size * entry_size; readonly } in let log_path = log_path root in let index_path = index_path root in let entries = @@ -234,15 +194,16 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let generation = IO.get_generation log in let index = if Sys.file_exists index_path then ( - let fan_out = Fan.v fan_out_size in let io = IO.v ~fresh ~readonly ~generation:0L index_path in + let fan_out_size = Int64.to_int (IO.offset io) / entry_size in + let fan_out = Fan.v ~hash_size:K.hash_size ~entry_size fan_out_size in iter_io_off (fun off e -> let hash = K.hash e.key in Fan.update fan_out hash off; may (fun bf -> Bloomf.add bf e.key) entries) io; - Fan.flatten fan_out; + Fan.finalize fan_out; Some { fan_out; io } ) else None in @@ -336,13 +297,17 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let index_path = index_path t.root in let io = IO.v ~fresh:false ~readonly:true ~generation index_path in let _ = IO.force_offset io in - let fan_out = Fan.v t.config.log_size in + let io_off = IO.force_offset io in + let fan_out_size = + Tbl.length t.log_mem + (Int64.to_int io_off / entry_size) + in + let fan_out = Fan.v ~hash_size:K.hash_size ~entry_size fan_out_size in iter_io_off (fun off e -> let hash = K.hash e.key in Fan.update fan_out hash off) io; - Fan.flatten fan_out; + Fan.finalize fan_out; t.index <- Some { fan_out; io }; t.generation <- generation ) else if log_offset < new_log_offset then @@ -374,7 +339,6 @@ module Make (K : Key) (V : Value) (IO : IO) = struct append_entry io e let merge_with log index tmp = - Fan.clear index.fan_out; let offset = ref 0L in let get_index_entry = function | Some e -> Some e @@ -447,7 +411,8 @@ module Make (K : Key) (V : Value) (IO : IO) = struct in ( match t.index with | None -> - let fan_out = Fan.v t.config.fan_out_size in + let fan_out_size = Tbl.length t.log_mem in + let fan_out = Fan.v ~hash_size:K.hash_size ~entry_size fan_out_size in let io = IO.v ~fresh:true ~readonly:false ~generation:0L (index_path t.root) in @@ -457,12 +422,20 @@ module Make (K : Key) (V : Value) (IO : IO) = struct append_entry_fanout fan_out hashed_v tmp v) log; t.index <- Some { io; fan_out } - | Some index -> merge_with log index tmp ); + | Some index -> + let fan_out_size = + (Int64.to_int (IO.offset index.io) / entry_size) + + Tbl.length t.log_mem + in + let fan_out = Fan.v ~hash_size:K.hash_size ~entry_size fan_out_size in + let index = { index with fan_out } in + merge_with log index tmp; + t.index <- Some index ); match t.index with | None -> assert false | Some index -> IO.rename ~src:tmp ~dst:index.io; - Fan.flatten index.fan_out; + Fan.finalize index.fan_out; IO.clear t.log; Tbl.clear t.log_mem; IO.set_generation t.log generation; diff --git a/vendors/index/src/index.mli b/vendors/index/src/index.mli index 43007df5f8bc..8cac503ccee7 100644 --- a/vendors/index/src/index.mli +++ b/vendors/index/src/index.mli @@ -79,7 +79,6 @@ module type S = sig ?readonly:bool -> ?shared:bool -> log_size:int -> - fan_out_size:int -> string -> t (** The constructor for indexes. diff --git a/vendors/irmin-pack/IO.ml b/vendors/irmin-pack/IO.ml index d7cac9304f7a..71b24bd50955 100644 --- a/vendors/irmin-pack/IO.ml +++ b/vendors/irmin-pack/IO.ml @@ -120,7 +120,7 @@ module Unix : S = struct mutable flushed : int64; readonly : bool; version : string; - buf : Buffer.t + buf : Buffer.t; } let name t = t.file @@ -137,6 +137,7 @@ module Unix : S = struct else ( Raw.unsafe_write t.raw ~off:t.flushed buf; Raw.unsafe_set_offset t.raw offset; + (* concurrent append might happen so here t.offset might differ from offset *) if not (t.flushed ++ Int64.of_int (String.length buf) = header ++ offset) @@ -218,13 +219,14 @@ module Unix : S = struct let v ~fresh ~version:current_version ~readonly file = assert (String.length current_version = 8); let v ~offset ~version raw = - { version; + { + version; file; offset; raw; readonly; buf = buffer file; - flushed = header ++ offset + flushed = header ++ offset; } in let mode = Unix.(if readonly then O_RDONLY else O_RDWR) in @@ -262,7 +264,7 @@ let with_cache ~v ~clear file = if not shared then ( Log.debug (fun l -> l "[%s] v fresh=%b shared=%b readonly=%b" (Filename.basename file) - fresh shared readonly ); + fresh shared readonly); let t = v extra_args ~fresh ~shared ~readonly file in if fresh then clear t; t ) @@ -271,7 +273,7 @@ let with_cache ~v ~clear file = if not (Sys.file_exists file) then ( Log.debug (fun l -> l "[%s] does not exist anymore, cleaning up the fd cache" - (Filename.basename file) ); + (Filename.basename file)); Hashtbl.remove files file; raise Not_found ); let t = Hashtbl.find files file in @@ -281,7 +283,7 @@ let with_cache ~v ~clear file = with Not_found -> Log.debug (fun l -> l "[%s] v fresh=%b shared=%b readonly=%b" (Filename.basename file) - fresh shared readonly ); + fresh shared readonly); let t = v extra_args ~fresh ~shared ~readonly file in if fresh then clear t; Hashtbl.add files file t; diff --git a/vendors/irmin-pack/dict.ml b/vendors/irmin-pack/dict.ml index 51fb9e607cc5..a038181e6aed 100644 --- a/vendors/irmin-pack/dict.ml +++ b/vendors/irmin-pack/dict.ml @@ -42,7 +42,7 @@ module Make (IO : IO.S) : S = struct capacity : int; cache : (string, int) Hashtbl.t; index : (int, string) Hashtbl.t; - io : IO.t + io : IO.t; } let append_string t v = diff --git a/vendors/irmin-pack/inode.ml b/vendors/irmin-pack/inode.ml index 2bef9731dadf..3a82ad6f5034 100644 --- a/vendors/irmin-pack/inode.ml +++ b/vendors/irmin-pack/inode.ml @@ -120,7 +120,7 @@ struct let inodes : inodes Irmin.Type.t = let open Irmin.Type in record "Bin.inodes" (fun seed length entries -> - { seed; length; entries } ) + { seed; length; entries }) |+ field "seed" int (fun t -> t.seed) |+ field "length" int (fun t -> t.length) |+ field "entries" (list inode) (fun t -> t.entries) @@ -128,8 +128,8 @@ struct let v_t : v Irmin.Type.t = let open Irmin.Type in - variant "Bin.v" (fun values inodes -> function - | Values l -> values l | Inodes i -> inodes i ) + variant "Bin.v" (fun values inodes -> + function Values l -> values l | Inodes i -> inodes i) |~ case1 "Values" (list (pair step_t value_t)) (fun t -> Values t) |~ case1 "Inodes" inodes (fun t -> Inodes t) |> sealv @@ -171,8 +171,8 @@ struct let address : address Irmin.Type.t = let open Irmin.Type in - variant "Compress.address" (fun i d -> function - | Indirect x -> i x | Direct x -> d x ) + variant "Compress.address" (fun i d -> + function Indirect x -> i x | Direct x -> d x) |~ case1 "Indirect" int64 (fun x -> Indirect x) |~ case1 "Direct" H.t (fun x -> Direct x) |> sealv @@ -191,7 +191,7 @@ struct let inodes : inodes Irmin.Type.t = let open Irmin.Type in record "Compress.inodes" (fun seed length entries -> - { seed; length; entries } ) + { seed; length; entries }) |+ field "seed" int (fun t -> t.seed) |+ field "length" int (fun t -> t.length) |+ field "entries" (list inode) (fun t -> t.entries) @@ -207,18 +207,19 @@ struct let open Irmin.Type in variant "Compress.value" (fun contents_ii - contents_x_ii - node_ii - contents_id - contents_x_id - node_id - contents_di - contents_x_di - node_di - contents_dd - contents_x_dd - node_dd - -> function + contents_x_ii + node_ii + contents_id + contents_x_id + node_id + contents_di + contents_x_di + node_di + contents_dd + contents_x_dd + node_dd + -> + function | Contents (Indirect n, Indirect h, m) -> if is_default m then contents_ii (n, h) else contents_x_ii (n, h, m) @@ -234,39 +235,39 @@ struct | Contents (Direct n, Direct h, m) -> if is_default m then contents_dd (n, h) else contents_x_dd (n, h, m) - | Node (Direct n, Direct h) -> node_dd (n, h) ) + | Node (Direct n, Direct h) -> node_dd (n, h)) |~ case1 "contents-ii" (pair int int64) (fun (n, i) -> - Contents (Indirect n, Indirect i, T.default) ) + Contents (Indirect n, Indirect i, T.default)) |~ case1 "contents-x-ii" (triple int int64 metadata_t) (fun (n, i, m) -> Contents (Indirect n, Indirect i, m)) |~ case1 "node-ii" (pair int int64) (fun (n, i) -> - Node (Indirect n, Indirect i) ) + Node (Indirect n, Indirect i)) |~ case1 "contents-id" (pair int H.t) (fun (n, h) -> - Contents (Indirect n, Direct h, T.default) ) + Contents (Indirect n, Direct h, T.default)) |~ case1 "contents-x-id" (triple int H.t metadata_t) (fun (n, h, m) -> - Contents (Indirect n, Direct h, m) ) + Contents (Indirect n, Direct h, m)) |~ case1 "node-id" (pair int H.t) (fun (n, h) -> - Node (Indirect n, Direct h) ) + Node (Indirect n, Direct h)) |~ case1 "contents-di" (pair step_t int64) (fun (n, i) -> - Contents (Direct n, Indirect i, T.default) ) + Contents (Direct n, Indirect i, T.default)) |~ case1 "contents-x-di" (triple step_t int64 metadata_t) (fun (n, i, m) -> Contents (Direct n, Indirect i, m)) |~ case1 "node-di" (pair step_t int64) (fun (n, i) -> - Node (Direct n, Indirect i) ) + Node (Direct n, Indirect i)) |~ case1 "contents-dd" (pair step_t H.t) (fun (n, i) -> - Contents (Direct n, Direct i, T.default) ) + Contents (Direct n, Direct i, T.default)) |~ case1 "contents-x-dd" (triple step_t H.t metadata_t) (fun (n, i, m) -> Contents (Direct n, Direct i, m)) |~ case1 "node-dd" (pair step_t H.t) (fun (n, i) -> - Node (Direct n, Direct i) ) + Node (Direct n, Direct i)) |> sealv type v = Values of value list | Inodes of inodes let v_t : v Irmin.Type.t = let open Irmin.Type in - variant "Compress.v" (fun values inodes -> function - | Values x -> values x | Inodes x -> inodes x ) + variant "Compress.v" (fun values inodes -> + function Values x -> values x | Inodes x -> inodes x) |~ case1 "Values" (list value) (fun x -> Values x) |~ case1 "Inodes" inodes (fun x -> Inodes x) |> sealv @@ -322,8 +323,8 @@ struct let entry_t inode : entry Irmin.Type.t = let open Irmin.Type in - variant "Node.entry" (fun empty inode -> function - | Empty -> empty | Inode i -> inode i ) + variant "Node.entry" (fun empty inode -> + function Empty -> empty | Inode i -> inode i) |~ case0 "Empty" Empty |~ case1 "Inode" inode (fun i -> Inode i) |> sealv @@ -331,7 +332,7 @@ struct let inodes entry : inodes Irmin.Type.t = let open Irmin.Type in record "Node.entries" (fun seed length entries -> - { seed; length; entries } ) + { seed; length; entries }) |+ field "seed" int (fun t -> t.seed) |+ field "length" int (fun t -> t.length) |+ field "entries" (array entry) (fun t -> t.entries) @@ -383,7 +384,7 @@ struct (fun (i, acc) -> function Empty -> (i + 1, acc) | Inode inode -> let hash = hash_of_inode inode in - (i + 1, { Bin.index = i; hash } :: acc) ) + (i + 1, { Bin.index = i; hash } :: acc)) (0, []) t.entries in let entries = List.rev entries in @@ -423,7 +424,7 @@ struct let entries = Array.make Conf.entries Empty in List.iter (fun { Bin.index; hash } -> - entries.(index) <- inode (lazy hash) ) + entries.(index) <- inode (lazy hash)) t.entries; Inodes { seed = t.Bin.seed; length = t.length; entries } in @@ -433,8 +434,8 @@ struct let open Irmin.Type in let pre_hash x = pre_hash Bin.v_t (to_bin_v x) in let entry = entry_t (inode_t t) in - variant "Inode.t" (fun values inodes -> function - | Values v -> values v | Inodes i -> inodes i ) + variant "Inode.t" (fun values inodes -> + function Values v -> values v | Inodes i -> inodes i) |~ case1 "Values" (StepMap.t value_t) (fun t -> Values t) |~ case1 "Inodes" (inodes entry) (fun t -> Inodes t) |> sealv |> like ~pre_hash @@ -478,7 +479,7 @@ struct let find_value ~seed ~find t s = let rec aux ~seed = function | Values vs -> ( - try Some (StepMap.find s vs) with Not_found -> None ) + try Some (StepMap.find s vs) with Not_found -> None ) | Inodes t -> ( let i = index ~seed s in let x = t.entries.(i) in @@ -494,49 +495,53 @@ struct match find_value ~seed ~find t s with | Some v' when Irmin.Type.equal value_t v v' -> k t | v' -> ( - match t.v with - | Values vs -> - let length = - match v' with - | None -> StepMap.cardinal vs + 1 - | Some _ -> StepMap.cardinal vs - in - let t = - if length <= Conf.entries then values (StepMap.add s v vs) - else - let vs = StepMap.bindings (StepMap.add s v vs) in - let empty = - inodes - { length = 0; - seed; - entries = Array.make Conf.entries Empty - } - in - let aux t (s, v) = - (add [@tailcall]) ~seed ~find ~copy:false t s v (fun x -> x) - in - List.fold_left aux empty vs - in - k t - | Inodes t -> ( - let length = - match v' with None -> t.length + 1 | Some _ -> t.length - in - let entries = if copy then Array.copy t.entries else t.entries in - let i = index ~seed s in - match entries.(i) with - | Empty -> - let tree = values (StepMap.singleton s v) in - entries.(i) <- inode ~tree tree.hash; - let t = inodes { seed; length; entries } in - k t - | Inode n -> - let t = get_tree ~find n in - add ~seed:(seed + 1) ~find ~copy t s v @@ fun tree -> - let inode = inode ~tree tree.hash in - entries.(i) <- inode; - let t = inodes { seed; length; entries } in - k t ) ) + match t.v with + | Values vs -> + let length = + match v' with + | None -> StepMap.cardinal vs + 1 + | Some _ -> StepMap.cardinal vs + in + let t = + if length <= Conf.entries then values (StepMap.add s v vs) + else + let vs = StepMap.bindings (StepMap.add s v vs) in + let empty = + inodes + { + length = 0; + seed; + entries = Array.make Conf.entries Empty; + } + in + let aux t (s, v) = + (add [@tailcall]) ~seed ~find ~copy:false t s v (fun x -> + x) + in + List.fold_left aux empty vs + in + k t + | Inodes t -> ( + let length = + match v' with None -> t.length + 1 | Some _ -> t.length + in + let entries = + if copy then Array.copy t.entries else t.entries + in + let i = index ~seed s in + match entries.(i) with + | Empty -> + let tree = values (StepMap.singleton s v) in + entries.(i) <- inode ~tree tree.hash; + let t = inodes { seed; length; entries } in + k t + | Inode n -> + let t = get_tree ~find n in + add ~seed:(seed + 1) ~find ~copy t s v @@ fun tree -> + let inode = inode ~tree tree.hash in + entries.(i) <- inode; + let t = inodes { seed; length; entries } in + k t ) ) let add ~find ~copy t s v = add ~seed:0 ~find ~copy t s v (stabilize ~find) @@ -545,29 +550,29 @@ struct match find_value ~seed ~find t s with | None -> k t | Some _ -> ( - match t.v with - | Values vs -> - let t = values (StepMap.remove s vs) in - k t - | Inodes t -> ( - let length = t.length - 1 in - if length <= Conf.entries then - let vs = list_inodes ~find [] t in - let vs = StepMap.of_list vs in - let vs = StepMap.remove s vs in - let t = values vs in + match t.v with + | Values vs -> + let t = values (StepMap.remove s vs) in k t - else - let entries = Array.copy t.entries in - let i = index ~seed s in - match entries.(i) with - | Empty -> assert false - | Inode t -> - let t = get_tree ~find t in - remove ~seed:(seed + 1) ~find t s @@ fun tree -> - entries.(i) <- inode ~tree (lazy (hash tree)); - let t = inodes { seed; length; entries } in - k t ) ) + | Inodes t -> ( + let length = t.length - 1 in + if length <= Conf.entries then + let vs = list_inodes ~find [] t in + let vs = StepMap.of_list vs in + let vs = StepMap.remove s vs in + let t = values vs in + k t + else + let entries = Array.copy t.entries in + let i = index ~seed s in + match entries.(i) with + | Empty -> assert false + | Inode t -> + let t = get_tree ~find t in + remove ~seed:(seed + 1) ~find t s @@ fun tree -> + entries.(i) <- inode ~tree (lazy (hash tree)); + let t = inodes { seed; length; entries } in + k t ) ) let remove ~find t s = remove ~find ~seed:0 t s (stabilize ~find) @@ -595,7 +600,7 @@ struct | Empty | Inode { tree = None; _ } -> () | Inode ({ tree = Some t; _ } as i) -> let hash = hash_of_inode i in - if mem hash then () else aux ~seed:(seed + 1) t ) + if mem hash then () else aux ~seed:(seed + 1) t) n.entries; add (Lazy.force t.hash) (to_bin t) in @@ -658,12 +663,12 @@ struct let step : Compress.name -> T.step = function | Direct n -> n | Indirect s -> ( - match dict s with - | None -> raise_notrace (Exit (`Msg "dict")) - | Some s -> ( - match Irmin.Type.of_bin_string T.step_t s with - | Error e -> raise_notrace (Exit e) - | Ok v -> v ) ) + match dict s with + | None -> raise_notrace (Exit (`Msg "dict")) + | Some s -> ( + match Irmin.Type.of_bin_string T.step_t s with + | Error e -> raise_notrace (Exit e) + | Ok v -> v ) ) in let hash : Compress.address -> H.t = function | Indirect off -> hash off diff --git a/vendors/irmin-pack/inode.mli b/vendors/irmin-pack/inode.mli index 273314e09a71..2391f06cf58e 100644 --- a/vendors/irmin-pack/inode.mli +++ b/vendors/irmin-pack/inode.mli @@ -47,7 +47,7 @@ module Make (P : Pack.MAKER with type key = H.t and type index = Pack_index.Make(H).t) (Node : Irmin.Private.Node.S with type hash = H.t) : S - with type key = H.t - and type Val.metadata = Node.metadata - and type Val.step = Node.step - and type index = Pack_index.Make(H).t + with type key = H.t + and type Val.metadata = Node.metadata + and type Val.step = Node.step + and type index = Pack_index.Make(H).t diff --git a/vendors/irmin-pack/irmin_pack.ml b/vendors/irmin-pack/irmin_pack.ml index 710ed6547c96..fb541960f977 100644 --- a/vendors/irmin-pack/irmin_pack.ml +++ b/vendors/irmin-pack/irmin_pack.ml @@ -108,7 +108,7 @@ module Atomic_write (K : Irmin.Type.S) (V : Irmin.Hash.S) = struct cache : V.t Tbl.t; block : IO.t; lock : Lwt_mutex.t; - w : W.t + w : W.t; } let read_length32 ~off block = @@ -159,7 +159,7 @@ module Atomic_write (K : Irmin.Type.S) (V : Irmin.Hash.S) = struct Log.debug (fun l -> l "[branches] remove %a" pp_branch k); Lwt_mutex.with_lock t.lock (fun () -> unsafe_remove t k; - Lwt.return () ) + Lwt.return ()) >>= fun () -> W.notify t.w k None let unsafe_clear t = @@ -207,7 +207,7 @@ module Atomic_write (K : Irmin.Type.S) (V : Irmin.Hash.S) = struct let v ?fresh ?shared ?readonly file = Lwt_mutex.with_lock create (fun () -> let v = unsafe_v () ?fresh ?shared ?readonly file in - Lwt.return v ) + Lwt.return v) let unsafe_set t k v = try @@ -224,7 +224,7 @@ module Atomic_write (K : Irmin.Type.S) (V : Irmin.Hash.S) = struct Log.debug (fun l -> l "[branches] set %a" pp_branch k); Lwt_mutex.with_lock t.lock (fun () -> unsafe_set t k v; - Lwt.return () ) + Lwt.return ()) >>= fun () -> W.notify t.w k (Some v) let unsafe_test_and_set t k ~test ~set = @@ -265,9 +265,9 @@ module Make_ext (B : Irmin.Branch.S) (H : Irmin.Hash.S) (Node : Irmin.Private.Node.S - with type metadata = M.t - and type hash = H.t - and type step = P.step) + with type metadata = M.t + and type hash = H.t + and type step = P.step) (Commit : Irmin.Private.Commit.S with type hash = H.t) = struct module Index = Pack_index.Make (H) @@ -365,7 +365,7 @@ struct node : [ `Read ] Node.CA.t; commit : [ `Read ] Commit.CA.t; branch : Branch.t; - index : Index.t + index : Index.t; } let contents_t t : 'a Contents.t = t.contents @@ -383,7 +383,7 @@ struct let contents : 'a Contents.t = contents in let node : 'a Node.t = (contents, node) in let commit : 'a Commit.t = (node, commit) in - f contents node commit ) ) ) + f contents node commit))) let v config = let root = root config in @@ -392,9 +392,7 @@ struct let readonly = readonly config in let shared = shared config in let log_size = index_log_size config in - let index = - Index.v ~fresh ~shared ~readonly ~log_size ~fan_out_size:16 root - in + let index = Index.v ~fresh ~shared ~readonly ~log_size root in Contents.CA.v ~fresh ~shared ~readonly ~lru_size ~index root >>= fun contents -> Node.CA.v ~fresh ~shared ~readonly ~lru_size ~index root diff --git a/vendors/irmin-pack/irmin_pack.mli b/vendors/irmin-pack/irmin_pack.mli index 39a1d7a1c872..434e18827adf 100644 --- a/vendors/irmin-pack/irmin_pack.mli +++ b/vendors/irmin-pack/irmin_pack.mli @@ -43,18 +43,18 @@ module Make_ext (Branch : Irmin.Branch.S) (Hash : Irmin.Hash.S) (N : Irmin.Private.Node.S - with type metadata = Metadata.t - and type hash = Hash.t - and type step = Path.step) + with type metadata = Metadata.t + and type hash = Hash.t + and type step = Path.step) (CT : Irmin.Private.Commit.S with type hash = Hash.t) : Irmin.S - with type key = Path.t - and type contents = Contents.t - and type branch = Branch.t - and type hash = Hash.t - and type step = Path.step - and type metadata = Metadata.t - and type Key.step = Path.step + with type key = Path.t + and type contents = Contents.t + and type branch = Branch.t + and type hash = Hash.t + and type step = Path.step + and type metadata = Metadata.t + and type Key.step = Path.step module Make (Config : CONFIG) : Irmin.S_MAKER diff --git a/vendors/irmin-pack/lru.ml b/vendors/irmin-pack/lru.ml index a4fbb4b960af..072376d43676 100644 --- a/vendors/irmin-pack/lru.ml +++ b/vendors/irmin-pack/lru.ml @@ -20,12 +20,12 @@ module Make (H : Hashtbl.HashedType) = struct type 'a node = { value : 'a; mutable next : 'a node option; - mutable prev : 'a node option + mutable prev : 'a node option; } type 'a t = { mutable first : 'a node option; - mutable last : 'a node option + mutable last : 'a node option; } let detach t n = @@ -63,7 +63,7 @@ module Make (H : Hashtbl.HashedType) = struct ht : (key * 'a) Q.node HT.t; q : (key * 'a) Q.t; mutable cap : int; - mutable w : int + mutable w : int; } let weight t = t.w diff --git a/vendors/irmin-pack/pack.ml b/vendors/irmin-pack/pack.ml index bf95efabe220..ab069ada7ca0 100644 --- a/vendors/irmin-pack/pack.ml +++ b/vendors/irmin-pack/pack.ml @@ -26,14 +26,15 @@ type all_stats = { mutable pack_finds : int; mutable pack_cache_misses : int; mutable appended_hashes : int; - mutable appended_offsets : int + mutable appended_offsets : int; } let fresh_stats () = - { pack_finds = 0; + { + pack_finds = 0; pack_cache_misses = 0; appended_hashes = 0; - appended_offsets = 0 + appended_offsets = 0; } let stats = fresh_stats () @@ -133,7 +134,7 @@ struct block : IO.t; index : Index.t; dict : Dict.t; - lock : Lwt_mutex.t + lock : Lwt_mutex.t; } let clear t = @@ -205,7 +206,7 @@ struct let v ?fresh ?shared ?readonly ?lru_size ~index root = Lwt_mutex.with_lock create (fun () -> let t = unsafe_v ?fresh ?shared ?readonly ?lru_size ~index root in - Lwt.return t ) + Lwt.return t) let pp_hash = Irmin.Type.pp K.t @@ -225,7 +226,7 @@ struct let mem t k = Lwt_mutex.with_lock create (fun () -> let b = unsafe_mem t k in - Lwt.return b ) + Lwt.return b) let check_key k v = let k' = V.hash v in @@ -252,22 +253,22 @@ struct Lru.add t.lru k v; Some v | exception Not_found -> ( - match Lru.find t.lru k with - | v -> Some v - | exception Not_found -> ( - stats.pack_cache_misses <- succ stats.pack_cache_misses; - match Index.find t.pack.index k with - | None -> None - | Some (off, len, _) -> - let v = io_read_and_decode ~off ~len t in - check_key k v; - Lru.add t.lru k v; - Some v ) ) + match Lru.find t.lru k with + | v -> Some v + | exception Not_found -> ( + stats.pack_cache_misses <- succ stats.pack_cache_misses; + match Index.find t.pack.index k with + | None -> None + | Some (off, len, _) -> + let v = io_read_and_decode ~off ~len t in + check_key k v; + Lru.add t.lru k v; + Some v ) ) let find t k = Lwt_mutex.with_lock t.pack.lock (fun () -> let v = unsafe_find t k in - Lwt.return v ) + Lwt.return v) let cast t = (t :> [ `Read | `Write ] t) @@ -312,7 +313,7 @@ struct let append t k v = Lwt_mutex.with_lock t.pack.lock (fun () -> unsafe_append t k v; - Lwt.return () ) + Lwt.return ()) let add t v = let k = V.hash v in @@ -327,13 +328,14 @@ let div_or_zero a b = if b = 0 then 0. else float_of_int a /. float_of_int b type stats = { pack_cache_misses : float; offset_ratio : float; - offset_significance : int + offset_significance : int; } let stats () = - { pack_cache_misses = div_or_zero stats.pack_cache_misses stats.pack_finds; + { + pack_cache_misses = div_or_zero stats.pack_cache_misses stats.pack_finds; offset_ratio = div_or_zero stats.appended_offsets (stats.appended_offsets + stats.appended_hashes); - offset_significance = stats.appended_offsets + stats.appended_hashes + offset_significance = stats.appended_offsets + stats.appended_hashes; } diff --git a/vendors/irmin-pack/pack.mli b/vendors/irmin-pack/pack.mli index 1aa64acb4719..8a44a09861d5 100644 --- a/vendors/irmin-pack/pack.mli +++ b/vendors/irmin-pack/pack.mli @@ -78,7 +78,7 @@ module File (Index : Pack_index.S) (K : Irmin.Hash.S with type t = Index.key) : type stats = { pack_cache_misses : float; offset_ratio : float; - offset_significance : int + offset_significance : int; } val reset_stats : unit -> unit diff --git a/vendors/irmin-pack/pack_index.ml b/vendors/irmin-pack/pack_index.ml index 448d6f6b8d30..c954c693ec3a 100644 --- a/vendors/irmin-pack/pack_index.ml +++ b/vendors/irmin-pack/pack_index.ml @@ -22,7 +22,6 @@ module type S = sig ?readonly:bool -> ?shared:bool -> log_size:int -> - fan_out_size:int -> string -> t diff --git a/vendors/irmin-pack/pack_index.mli b/vendors/irmin-pack/pack_index.mli index f09934ed073a..a3744ee22fd1 100644 --- a/vendors/irmin-pack/pack_index.mli +++ b/vendors/irmin-pack/pack_index.mli @@ -22,7 +22,6 @@ module type S = sig ?readonly:bool -> ?shared:bool -> log_size:int -> - fan_out_size:int -> string -> t diff --git a/vendors/irmin/commit.ml b/vendors/irmin/commit.ml index 7ab32e3baa26..832551101805 100644 --- a/vendors/irmin/commit.ml +++ b/vendors/irmin/commit.ml @@ -49,11 +49,11 @@ end module Store (N : S.NODE_STORE) (S : sig - include S.CONTENT_ADDRESSABLE_STORE with type key = N.key + include S.CONTENT_ADDRESSABLE_STORE with type key = N.key - module Key : S.HASH with type t = key + module Key : S.HASH with type t = key - module Val : S.COMMIT with type t = value and type hash = key + module Val : S.COMMIT with type t = value and type hash = key end) = struct module Node = N @@ -236,17 +236,17 @@ module History (S : S.COMMIT_STORE) = struct | (`Too_many_lcas | `Max_depth_reached) as x -> Lwt.return (Error x) | `Stop -> return () | `Continue -> ( - match unqueue todo seen with - | None -> return () - | Some (depth, commit) -> - (* Log.debug "lca %d: %s.%d %a" + match unqueue todo seen with + | None -> return () + | Some (depth, commit) -> + (* Log.debug "lca %d: %s.%d %a" !lca_calls (pp_key commit) depth force (pp ()); *) - let seen = KSet.add commit seen in - read_parents t commit >>= fun parents -> - let () = f depth commit parents in - let parents = KSet.diff parents seen in - KSet.iter (add_todo (depth + 1)) parents; - aux seen ) + let seen = KSet.add commit seen in + read_parents t commit >>= fun parents -> + let () = f depth commit parents in + let parents = KSet.diff parents seen in + KSet.iter (add_todo (depth + 1)) parents; + aux seen ) in aux KSet.empty @@ -282,7 +282,7 @@ module History (S : S.COMMIT_STORE) = struct (* the current exploration depth *) mutable lcas : int; (* number of commit marked with LCA *) - mutable complete : bool (* is the exploration complete? *) + mutable complete : bool; (* is the exploration complete? *) } let pp_state t = @@ -328,14 +328,15 @@ module History (S : S.COMMIT_STORE) = struct let empty_state c1 c2 = let t = - { marks = KHashtbl.create 10; + { + marks = KHashtbl.create 10; parents = KHashtbl.create 10; layers = Hashtbl.create 10; c1; c2; depth = 0; lcas = 0; - complete = false + complete = false; } in set_mark t c1 Seen1; @@ -394,6 +395,7 @@ module History (S : S.COMMIT_STORE) = struct add_to_layer t depth commit; if depth <> t.depth then ( assert (depth = t.depth + 1); + (* before starting to explore a new layer, check if we really have some work to do, ie. do we still have a commit seen only by one node? *) @@ -426,12 +428,12 @@ module History (S : S.COMMIT_STORE) = struct let t0 = Sys.time () in Lwt.finalize (fun () -> - traverse_bfs t ~f:(update_parents s) ~pp ~check ~init ~return ) + traverse_bfs t ~f:(update_parents s) ~pp ~check ~init ~return) (fun () -> let t1 = Sys.time () -. t0 in Log.debug (fun f -> - f "lcas %d: depth=%d time=%.4fs" !lca_calls s.depth t1 ); - Lwt.return_unit ) + f "lcas %d: depth=%d time=%.4fs" !lca_calls s.depth t1); + Lwt.return_unit) let rec three_way_merge t ~info ?max_depth ?n c1 c2 = Log.debug (fun f -> f "3-way merge between %a and %a" pp_key c1 pp_key c2); @@ -454,7 +456,7 @@ module History (S : S.COMMIT_STORE) = struct let merge = merge t ~info |> Merge.with_conflict (fun msg -> - Fmt.strf "Recursive merging of common ancestors: %s" msg ) + Fmt.strf "Recursive merging of common ancestors: %s" msg) |> Merge.f in merge ~old c1 c2 diff --git a/vendors/irmin/commit.mli b/vendors/irmin/commit.mli index ccc3c4fd636e..024bfc9d28ca 100644 --- a/vendors/irmin/commit.mli +++ b/vendors/irmin/commit.mli @@ -20,25 +20,25 @@ module Make (K : Type.S) : S.COMMIT with type hash = K.t module Store (N : S.NODE_STORE) (C : sig - include S.CONTENT_ADDRESSABLE_STORE with type key = N.key + include S.CONTENT_ADDRESSABLE_STORE with type key = N.key - module Key : S.HASH with type t = key + module Key : S.HASH with type t = key - module Val : S.COMMIT with type t = value and type hash = key + module Val : S.COMMIT with type t = value and type hash = key end) : S.COMMIT_STORE - with type 'a t = 'a N.t * 'a C.t - and type key = C.key - and type value = C.value - and type Key.t = C.Key.t - and module Val = C.Val + with type 'a t = 'a N.t * 'a C.t + and type key = C.key + and type value = C.value + and type Key.t = C.Key.t + and module Val = C.Val module History (C : S.COMMIT_STORE) : S.COMMIT_HISTORY - with type 'a t = 'a C.t - and type v = C.Val.t - and type node = C.Node.key - and type commit = C.key + with type 'a t = 'a C.t + and type v = C.Val.t + and type node = C.Node.key + and type commit = C.key module V1 (C : S.COMMIT) : sig include S.COMMIT with type hash = C.hash diff --git a/vendors/irmin/conf.ml b/vendors/irmin/conf.ml index d8278fba6688..57a9e6ea28f6 100644 --- a/vendors/irmin/conf.ml +++ b/vendors/irmin/conf.ml @@ -43,7 +43,7 @@ let bool = ( (fun s -> try Ok (bool_of_string s) with Invalid_argument _ -> - Error (`Msg (Err.invalid_val s (Err.alts [ "true"; "false" ]))) ), + Error (`Msg (Err.invalid_val s (Err.alts [ "true"; "false" ])))), Fmt.bool ) let parse_with t_of_str exp s = @@ -83,7 +83,7 @@ type 'a key = { docv : string option; docs : string option; conv : 'a converter; - default : 'a + default : 'a; } let name t = t.name @@ -103,7 +103,7 @@ let key ?docs ?docv ?doc name conv default = String.iter (function | '-' | '_' | 'a' .. 'z' | '0' .. '9' -> () - | _ -> raise @@ Invalid_argument name ) + | _ -> raise @@ Invalid_argument name) name in let to_univ, of_univ = Univ.create () in diff --git a/vendors/irmin/contents.ml b/vendors/irmin/contents.ml index 1ed0be4b740a..db0d855505f2 100644 --- a/vendors/irmin/contents.ml +++ b/vendors/irmin/contents.ml @@ -32,7 +32,7 @@ let rec encode_json e = function List.iter (fun (k, v) -> lexeme e (`Name k); - encode_json e v ) + encode_json e v) o; lexeme e `Oe @@ -91,20 +91,21 @@ module Json_value = struct let t = let open Type in mu (fun ty -> - variant "json" (fun null bool string float obj arr -> function + variant "json" (fun null bool string float obj arr -> + function | `Null -> null | `Bool b -> bool b | `String s -> string s | `Float f -> float f | `O o -> obj o - | `A a -> arr a ) + | `A a -> arr a) |~ case0 "null" `Null |~ case1 "bool" bool (fun x -> `Bool x) |~ case1 "string" string (fun x -> `String x) |~ case1 "float" float (fun x -> `Float x) |~ case1 "object" (list (pair string ty)) (fun obj -> `O obj) |~ case1 "array" (list ty) (fun arr -> `A arr) - |> sealv ) + |> sealv) let rec equal a b = match (a, b) with @@ -113,8 +114,8 @@ module Json_value = struct | `String a, `String b -> String.equal a b | `Float a, `Float b -> Type.(equal float) a b | `A a, `A b -> ( - try List.for_all2 (fun a' b' -> equal a' b') a b - with Invalid_argument _ -> false ) + try List.for_all2 (fun a' b' -> equal a' b') a b + with Invalid_argument _ -> false ) | `O a, `O b -> ( let compare_fst (a, _) (b, _) = compare a b in try @@ -216,9 +217,9 @@ module Json_tree (Store : S.STORE with type contents = json) = struct match j with | [] -> `Tree acc | (k, v) :: l -> ( - match Type.of_string Store.Key.step_t k with - | Ok key -> obj l ((key, node v []) :: acc) - | _ -> obj l acc ) + match Type.of_string Store.Key.step_t k with + | Ok key -> obj l ((key, node v []) :: acc) + | _ -> obj l acc ) and node j acc = match j with | `O j -> obj j acc diff --git a/vendors/irmin/contents.mli b/vendors/irmin/contents.mli index 9c48b925487f..4a1d0fd840a3 100644 --- a/vendors/irmin/contents.mli +++ b/vendors/irmin/contents.mli @@ -58,6 +58,6 @@ module Store (C : sig module Val : S.CONTENTS with type t = value end) : S.CONTENTS_STORE - with type 'a t = 'a C.t - and type key = C.key - and type value = C.value + with type 'a t = 'a C.t + and type key = C.key + and type value = C.value diff --git a/vendors/irmin/diff.ml b/vendors/irmin/diff.ml index 78b373b058e7..794237325fd3 100644 --- a/vendors/irmin/diff.ml +++ b/vendors/irmin/diff.ml @@ -18,9 +18,9 @@ type 'a t = [ `Updated of 'a * 'a | `Removed of 'a | `Added of 'a ] let t a = let open Type in - variant "diff" (fun updated removed added -> function - | `Updated x -> updated x | `Removed x -> removed x | `Added x -> added x - ) + variant "diff" (fun updated removed added -> + function + | `Updated x -> updated x | `Removed x -> removed x | `Added x -> added x) |~ case1 "updated" (pair a a) (fun x -> `Updated x) |~ case1 "removed" a (fun x -> `Removed x) |~ case1 "added" a (fun x -> `Added x) diff --git a/vendors/irmin/dot.ml b/vendors/irmin/dot.ml index 6fdb9eb176b3..30217f2a5d9e 100644 --- a/vendors/irmin/dot.ml +++ b/vendors/irmin/dot.ml @@ -62,7 +62,7 @@ module Make (S : S.STORE) = struct f "fprintf depth=%s html=%b full=%s" (match depth with None -> "" | Some d -> string_of_int d) html - (match full with None -> "" | Some b -> string_of_bool b) ); + (match full with None -> "" | Some b -> string_of_bool b)); S.Repo.export ?full ?depth (S.repo t) >>= fun slice -> let vertex = Hashtbl.create 102 in let add_vertex v l = Hashtbl.add vertex v l in @@ -155,21 +155,20 @@ module Make (S : S.STORE) = struct Lwt.return_unit | `Commit c -> commits := c :: !commits; - Lwt.return_unit ) + Lwt.return_unit) >>= fun () -> List.iter (fun (k, c) -> - add_vertex (`Contents k) [ `Shape `Box; label_of_contents k c ] ) + add_vertex (`Contents k) [ `Shape `Box; label_of_contents k c ]) !contents; List.iter (fun (k, t) -> - add_vertex (`Node k) [ `Shape `Box; `Style `Dotted; label_of_node k t ] - ) + add_vertex (`Node k) [ `Shape `Box; `Style `Dotted; label_of_node k t ]) !nodes; List.iter (fun (k, r) -> add_vertex (`Commit k) - [ `Shape `Box; `Style `Bold; label_of_commit k r ] ) + [ `Shape `Box; `Style `Bold; label_of_commit k r ]) !commits; List.iter (fun (k, t) -> @@ -181,16 +180,15 @@ module Make (S : S.STORE) = struct [ `Style `Dotted; label_of_step l ] (`Contents v) | `Node n -> - add_edge (`Node k) [ `Style `Solid; label_of_step l ] (`Node n) - ) - (Node.Val.list t) ) + add_edge (`Node k) [ `Style `Solid; label_of_step l ] (`Node n)) + (Node.Val.list t)) !nodes; List.iter (fun (k, r) -> List.iter (fun c -> add_edge (`Commit k) [ `Style `Bold ] (`Commit c)) (Commit.Val.parents r); - add_edge (`Commit k) [ `Style `Dashed ] (`Node (Commit.Val.node r)) ) + add_edge (`Commit k) [ `Style `Dashed ] (`Node (Commit.Val.node r))) !commits; let branch_t = S.Private.Repo.branch_t (S.repo t) in Branch.list branch_t >>= fun bs -> @@ -201,7 +199,7 @@ module Make (S : S.STORE) = struct | Some k -> add_vertex (`Branch r) [ `Shape `Plaintext; label_of_tag r; `Style `Filled ]; - add_edge (`Branch r) [ `Style `Bold ] (`Commit k) ) + add_edge (`Branch r) [ `Style `Bold ] (`Commit k)) bs >|= fun () -> let map = function diff --git a/vendors/irmin/irmin.ml b/vendors/irmin/irmin.ml index 3d815a7c9620..72907a616da9 100644 --- a/vendors/irmin/irmin.ml +++ b/vendors/irmin/irmin.ml @@ -63,9 +63,9 @@ module Make_ext (B : Branch.S) (H : Hash.S) (N : S.NODE - with type metadata = M.t - and type hash = H.t - and type step = P.step) + with type metadata = M.t + and type hash = H.t + and type step = P.step) (CT : S.COMMIT with type hash = H.t) = struct module X = struct @@ -116,7 +116,7 @@ struct contents : [ `Read ] Contents.t; nodes : [ `Read ] Node.t; commits : [ `Read ] Commit.t; - branch : Branch.t + branch : Branch.t; } let contents_t t = t.contents diff --git a/vendors/irmin/irmin.mli b/vendors/irmin/irmin.mli index 74913f4c5901..d358f07753d0 100644 --- a/vendors/irmin/irmin.mli +++ b/vendors/irmin/irmin.mli @@ -57,12 +57,12 @@ module Type : sig (** {1 Type Combinators} *) - (** The type for runtime representation of values of type ['a]. *) type 'a t + (** The type for runtime representation of values of type ['a]. *) + type len = [ `Int | `Int8 | `Int16 | `Int32 | `Int64 | `Fixed of int ] (** The type of integer used to store buffers, list or array lengths. *) - type len = [ `Int | `Int8 | `Int16 | `Int32 | `Int64 | `Fixed of int ] (** {1:primitives Primitives} *) @@ -122,20 +122,20 @@ module Type : sig (** {1:records Records} *) + type ('a, 'b, 'c) open_record (** The type for representing open records of type ['a] with a constructor of type ['b]. ['c] represents the remaining fields to be described using the {!(|+)} operator. An open record initially satisfies ['c = 'b] and can be {{!sealr}sealed} once ['c = 'a]. *) - type ('a, 'b, 'c) open_record val record : string -> 'b -> ('a, 'b, 'b) open_record (** [record n f] is an incomplete representation of the record called [n] of type ['a] with constructor [f]. To complete the representation, add fields with {!(|+)} and then seal the record with {!sealr}. *) + type ('a, 'b) field (** The type for fields holding values of type ['b] and belonging to a record of type ['a]. *) - type ('a, 'b) field val field : string -> 'a t -> ('b -> 'a) -> ('b, 'a) field (** [field n t g] is the representation of the field [n] of type [t] @@ -172,11 +172,11 @@ module Type : sig (** {1:variants Variants} *) + type ('a, 'b, 'c) open_variant (** The type for representing open variants of type ['a] with pattern matching of type ['b]. ['c] represents the remaining constructors to be described using the {!(|~)} operator. An open variant initially satisfies [c' = 'b] and can be {{!sealv}sealed} once ['c = 'a]. *) - type ('a, 'b, 'c) open_variant val variant : string -> 'b -> ('a, 'b, 'b) open_variant (** [variant n p] is an incomplete representation of the variant type @@ -184,12 +184,12 @@ module Type : sig the representation, add cases with {!(|~)} and then seal the variant with {!sealv}. *) + type ('a, 'b) case (** The type for representing variant cases of type ['a] with patterns of type ['b]. *) - type ('a, 'b) case - (** The type for representing patterns for a variant of type ['a]. *) type 'a case_p + (** The type for representing patterns for a variant of type ['a]. *) val case0 : string -> 'a -> ('a, 'a case_p) case (** [case0 n v] is a representation of a variant constructor [v] with no @@ -314,11 +314,11 @@ module Type : sig val short_hash : 'a t -> ?seed:int -> 'a -> int (** [hash t x] is a short hash of [x] of type [t]. *) - (** The type for pretty-printers. *) type 'a pp = 'a Fmt.t + (** The type for pretty-printers. *) - (** The type for parsers. *) type 'a of_string = string -> ('a, [ `Msg of string ]) result + (** The type for parsers. *) val pp : 'a t -> 'a pp (** [pp t] is the pretty-printer for values of type [t]. *) @@ -334,8 +334,8 @@ module Type : sig module Json : sig (** Overlay on top of Jsonm to work with rewindable streams. *) - (** The type for JSON decoder. *) type decoder + (** The type for JSON decoder. *) val decoder : ?encoding:[< Jsonm.encoding ] -> [< Jsonm.src ] -> decoder (** Same as {!Jsonm.decoder}. *) @@ -350,11 +350,11 @@ module Type : sig [d]. This allows to put back lexemes already seen. *) end - (** The type for JSON encoders. *) type 'a encode_json = Jsonm.encoder -> 'a -> unit + (** The type for JSON encoders. *) - (** The type for JSON decoders. *) type 'a decode_json = Json.decoder -> ('a, [ `Msg of string ]) result + (** The type for JSON decoders. *) val pp_json : ?minify:bool -> 'a t -> 'a Fmt.t (** Similar to {!dump} but pretty-prints the JSON representation instead @@ -422,17 +422,17 @@ module Type : sig type 'a bin_seq = 'a -> (string -> unit) -> unit + type 'a encode_bin = ?headers:bool -> 'a bin_seq (** The type for binary encoders. If [headers] is not set, do not output extra length headers for buffers. *) - type 'a encode_bin = ?headers:bool -> 'a bin_seq + type 'a decode_bin = ?headers:bool -> string -> int -> int * 'a (** The type for binary decoders. IF [headers] is not set, do not read extra length header for buffers and consider the whole buffer instead. *) - type 'a decode_bin = ?headers:bool -> string -> int -> int * 'a - (** The type for size function related to binary encoder/decoders. *) type 'a size_of = ?headers:bool -> 'a -> int option + (** The type for size function related to binary encoder/decoders. *) val pre_hash : 'a t -> 'a bin_seq (** [pre_hash t x] is the string representation of [x], of type @@ -517,8 +517,8 @@ end module Info : sig (** {1 Commit Info} *) - (** The type for commit info. *) type t + (** The type for commit info. *) val v : date:int64 -> author:string -> string -> t (** Create a new commit info. *) @@ -549,8 +549,8 @@ module Info : sig (** {1 Info Functions} *) - (** Alias for functions which can build commit info. *) type f = unit -> t + (** Alias for functions which can build commit info. *) val none : f (** The empty info function. [none ()] is [empty] *) @@ -564,8 +564,8 @@ end (** [Merge] provides functions to build custom 3-way merge operators for various user-defined contents. *) module Merge : sig - (** The type for merge errors. *) type conflict = [ `Conflict of string ] + (** The type for merge errors. *) val ok : 'a -> ('a, conflict) result Lwt.t (** Return [Ok x]. *) @@ -587,10 +587,10 @@ module Merge : sig (** {1 Merge Combinators} *) + type 'a promise = unit -> ('a option, conflict) result Lwt.t (** An ['a] promise is a function which, when called, will eventually return a value type of ['a]. A promise is an optional, lazy and non-blocking value. *) - type 'a promise = unit -> ('a option, conflict) result Lwt.t val promise : 'a -> 'a promise (** [promise a] is the promise containing [a]. *) @@ -603,6 +603,7 @@ module Merge : sig (** [bind_promise a f] is the promise returned by [f] applied to what is promised by [a]. *) + type 'a f = old:'a promise -> 'a -> 'a -> ('a, conflict) result Lwt.t (** Signature of a merge function. [old] is the value of the least-common ancestor. @@ -612,10 +613,9 @@ module Merge : sig \----> t2 ----/ v} *) - type 'a f = old:'a promise -> 'a -> 'a -> ('a, conflict) result Lwt.t - (** The type for merge combinators. *) type 'a t + (** The type for merge combinators. *) val v : 'a Type.t -> 'a f -> 'a t (** [v dt f] create a merge combinator. *) @@ -697,12 +697,12 @@ module Merge : sig (** {1 Counters and Multisets} *) + type counter = int64 (** The type for counter values. It is expected that the only valid operations on counters are {e increment} and {e decrement}. The following merge functions ensure that the counter semantics are preserved: {e i.e.} it ensures that the number of increments and decrements is preserved. *) - type counter = int64 val counter : counter t (** The merge function for mergeable counters. *) @@ -787,7 +787,7 @@ module Merge : sig val ( >|=? ) : 'a promise -> ('a -> 'b) -> 'b promise (** [>|=?] is {!map_promise}. *) end - (** {1 Value Types} *) + (** {1 Value Types} *) val conflict_t : conflict Type.t (** [conflict_t] is the value type for {!conflict}. *) @@ -798,8 +798,8 @@ end (** Differences between values. *) module Diff : sig - (** The type for representing differences betwen values. *) type 'a t = [ `Updated of 'a * 'a | `Removed of 'a | `Added of 'a ] + (** The type for representing differences betwen values. *) (** {1 Value Types} *) @@ -807,8 +807,8 @@ module Diff : sig (** [t typ] is the value type for differences between values of type [typ]. *) end -(** The type for representing differences betwen values. *) type 'a diff = 'a Diff.t +(** The type for representing differences betwen values. *) (** {1 Low-level Stores} *) @@ -827,15 +827,15 @@ module type CONTENT_ADDRESSABLE_STORE = sig and add new values. Keys are derived from the values raw contents and hence are deterministic. *) + type 'a t (** The type for content-addressable backend stores. The ['a] phantom type carries information about the store mutability. *) - type 'a t - (** The type for keys. *) type key + (** The type for keys. *) - (** The type for raw values. *) type value + (** The type for raw values. *) val mem : [> `Read ] t -> key -> bool Lwt.t (** [mem t k] is true iff [k] is present in [t]. *) @@ -862,15 +862,15 @@ module type APPEND_ONLY_STORE = sig Append-onlye stores are store where it is possible to read and add new values. *) + type 'a t (** The type for append-only backend stores. The ['a] phantom type carries information about the store mutability. *) - type 'a t - (** The type for keys. *) type key + (** The type for keys. *) - (** The type for raw values. *) type value + (** The type for raw values. *) val mem : [> `Read ] t -> key -> bool Lwt.t (** [mem t k] is true iff [k] is present in [t]. *) @@ -890,14 +890,14 @@ module type ATOMIC_WRITE_STORE = sig Atomic-write stores are stores where it is possible to read, update and remove elements, with atomically guarantees. *) - (** The type for atomic-write backend stores. *) type t + (** The type for atomic-write backend stores. *) - (** The type for keys. *) type key + (** The type for keys. *) - (** The type for raw values. *) type value + (** The type for raw values. *) val mem : t -> key -> bool Lwt.t (** [mem t k] is true iff [k] is present in [t]. *) @@ -927,8 +927,8 @@ module type ATOMIC_WRITE_STORE = sig val list : t -> key list Lwt.t (** [list t] it the list of keys in [t]. *) - (** The type of watch handlers. *) type watch + (** The type of watch handlers. *) val watch : t -> @@ -966,11 +966,11 @@ module Path : sig module type S = sig (** {1 Path} *) - (** The type for path values. *) type t + (** The type for path values. *) - (** Type type for path's steps. *) type step + (** Type type for path's steps. *) val empty : t (** The empty path. *) @@ -1027,8 +1027,8 @@ module Hash : sig module type S = sig (** Signature for digest hashes, inspired by Digestif. *) - (** The type for digest hashes. *) type t + (** The type for digest hashes. *) val hash : ((string -> unit) -> unit) -> t (** Compute a deterministic store key from a sequence of strings. *) @@ -1069,8 +1069,8 @@ module Hash : sig (** [t] is the value type for {!t}. *) end - (** Digestif hashes. *) module Make (H : Digestif.S) : S with type t = H.t + (** Digestif hashes. *) module SHA1 : S @@ -1088,8 +1088,8 @@ module Hash : sig module BLAKE2S : S - (** v1 serialisation *) module V1 (H : S) : S with type t = H.t + (** v1 serialisation *) (** Typed hashes. *) @@ -1102,8 +1102,8 @@ end executable or symlink). *) module Metadata : sig module type S = sig - (** The type for metadata. *) type t + (** The type for metadata. *) val t : t Type.t (** [t] is the value type for {!t}. *) @@ -1116,8 +1116,8 @@ module Metadata : sig care about metadata. *) end - (** A metadata definition for systems that don't use metadata. *) module None : S with type t = unit + (** A metadata definition for systems that don't use metadata. *) end (** [Contents] specifies how user-defined contents need to be {e @@ -1138,8 +1138,8 @@ module Contents : sig module type S = sig (** {1 Signature for store contents} *) - (** The type for user-defined contents. *) type t + (** The type for user-defined contents. *) val t : t Type.t (** [t] is the value type for {!t}. *) @@ -1153,10 +1153,10 @@ module Contents : sig should be deleted. *) end + module String : S with type t = string (** Contents of type [string], with the {{!Irmin.Merge.default}default} 3-way merge strategy: assume that update operations are idempotent and conflict iff values are modified concurrently. *) - module String : S with type t = string type json = [ `Null @@ -1166,18 +1166,18 @@ module Contents : sig | `O of (string * json) list | `A of json list ] + module Json : S with type t = (string * json) list (** [Json] contents are associations from strings to [json] values stored as JSON encoded strings. If the same JSON key has been modified concurrently with different values then the [merge] function conflicts. *) - module Json : S with type t = (string * json) list - (** [Json_value] allows any kind of json value to be stored, not only objects. *) module Json_value : S with type t = json + (** [Json_value] allows any kind of json value to be stored, not only objects. *) module V1 : sig - (** Same as {!String} but use v1 serialisation format. *) module String : S with type t = string + (** Same as {!String} but use v1 serialisation format. *) end (** Contents store. *) @@ -1197,8 +1197,8 @@ module Contents : sig (** [Key] provides base functions for user-defined contents keys. *) module Key : Hash.TYPED with type t = key and type value = value - (** [Val] provides base functions for user-defined contents values. *) module Val : S with type t = value + (** [Val] provides base functions for user-defined contents values. *) end (** [Store] creates a contents store. *) @@ -1223,8 +1223,8 @@ module Branch : sig module type S = sig (** {1 Signature for Branches} *) - (** The type for branches. *) type t + (** The type for branches. *) val t : t Type.t (** [t] is the value type for {!t}. *) @@ -1236,11 +1236,11 @@ module Branch : sig (** Check if the branch is valid. *) end + module String : S with type t = string (** [String] is an implementation of {{!Branch.S}S} where branches are strings. The [master] branch is ["master"]. Valid branch names contain only alpha-numeric characters, [-], [_], [.], and [/]. *) - module String : S with type t = string (** [STORE] specifies the signature for branch stores. @@ -1252,22 +1252,22 @@ module Branch : sig include ATOMIC_WRITE_STORE - (** Base functions on keys. *) module Key : S with type t = key + (** Base functions on keys. *) - (** Base functions on values. *) module Val : Hash.S with type t = value + (** Base functions on values. *) end end -(** The type for remote stores. *) type remote = .. +(** The type for remote stores. *) +type config (** The type for backend-specific configuration values. Every backend has different configuration options, which are kept abstract to the user. *) -type config (** [Private] defines functions only useful for creating new backends. If you are just using the library (and not developing a @@ -1284,14 +1284,14 @@ module Private : sig value and vice-versa. There are a few {{!builtin_converters}built-in converters}. *) - (** The type for configuration converter parsers. *) type 'a parser = string -> ('a, [ `Msg of string ]) result + (** The type for configuration converter parsers. *) - (** The type for configuration converter printers. *) type 'a printer = 'a Fmt.t + (** The type for configuration converter printers. *) - (** The type for configuration converters. *) type 'a converter = 'a parser * 'a printer + (** The type for configuration converters. *) val parser : 'a converter -> 'a parser (** [parser c] is [c]'s parser. *) @@ -1301,8 +1301,8 @@ module Private : sig (** {1:keys Keys} *) - (** The type for configuration keys whose lookup value is ['a]. *) type 'a key + (** The type for configuration keys whose lookup value is ['a]. *) val key : ?docs:string -> @@ -1352,8 +1352,8 @@ module Private : sig (** {1:conf Configurations} *) - (** The type for configurations. *) type t = config + (** The type for configurations. *) val empty : t (** [empty] is the empty configuration. *) @@ -1411,17 +1411,17 @@ module Private : sig module type S = sig (** {1 Watch Helpers} *) - (** The type for store keys. *) type key + (** The type for store keys. *) - (** The type for store values. *) type value + (** The type for store values. *) - (** The type for watch handlers. *) type watch + (** The type for watch handlers. *) - (** The type for watch state. *) type t + (** The type for watch state. *) val stats : t -> int * int (** [stats t] is a tuple [(k,a)] represeting watch stats. [k] is @@ -1469,9 +1469,9 @@ module Private : sig (** [workers ()] is the number of background worker threads managing event notification currently active. *) - (** The type for watch hooks. *) type hook = int -> string -> (string -> unit Lwt.t) -> (unit -> unit Lwt.t) Lwt.t + (** The type for watch hooks. *) val none : hook (** [none] is the hooks which asserts false. *) @@ -1491,11 +1491,11 @@ module Private : sig (** {1 Process locking helpers} *) module type S = sig - (** The type for lock manager. *) type t + (** The type for lock manager. *) - (** The type for key to be locked. *) type key + (** The type for key to be locked. *) val v : unit -> t (** Create a lock manager. *) @@ -1507,8 +1507,8 @@ module Private : sig val stats : t -> int end - (** Create a lock manager implementation. *) module Make (K : Type.S) : S with type key = K.t + (** Create a lock manager implementation. *) end (** [Node] provides functions to describe the graph-like structured @@ -1524,21 +1524,21 @@ module Private : sig module type S = sig (** {1 Node values} *) - (** The type for node values. *) type t + (** The type for node values. *) - (** The type for node metadata. *) type metadata + (** The type for node metadata. *) - (** The type for keys. *) type hash + (** The type for keys. *) - (** The type for steps between nodes. *) type step + (** The type for steps between nodes. *) + type value = [ `Node of hash | `Contents of hash * metadata ] (** The type for either (node) keys or (contents) keys combined with their metadata. *) - type value = [ `Node of hash | `Contents of hash * metadata ] val v : (step * value) list -> t (** [create l] is a new node. *) @@ -1592,9 +1592,9 @@ module Private : sig the contents and notes keys [K], paths [P] and metadata [M]. *) module Make (K : Type.S) (P : sig - type step + type step - val step_t : step Type.t + val step_t : step Type.t end) (M : Metadata.S) : S with type hash = K.t and type step = P.step and type metadata = M.t @@ -1603,9 +1603,9 @@ module Private : sig module V1 (S : S) : sig include S - with type hash = S.hash - and type step = S.step - and type metadata = S.metadata + with type hash = S.hash + and type step = S.step + and type metadata = S.metadata val import : S.t -> t @@ -1616,8 +1616,8 @@ module Private : sig module type STORE = sig include CONTENT_ADDRESSABLE_STORE - (** [Path] provides base functions on node paths. *) module Path : Path.S + (** [Path] provides base functions on node paths. *) val merge : [ `Read | `Write ] t -> key option Merge.t (** [merge] is the 3-way merge function for nodes keys. *) @@ -1625,19 +1625,19 @@ module Private : sig (** [Key] provides base functions for node keys. *) module Key : Hash.TYPED with type t = key and type value = value - (** [Metadata] provides base functions for node metadata. *) module Metadata : Metadata.S + (** [Metadata] provides base functions for node metadata. *) (** [Val] provides base functions for node values. *) module Val : S - with type t = value - and type hash = key - and type metadata = Metadata.t - and type step = Path.step + with type t = value + and type hash = key + and type metadata = Metadata.t + and type step = Path.step - (** [Contents] is the underlying contents store. *) module Contents : Contents.STORE with type key = Val.hash + (** [Contents] is the underlying contents store. *) end (** [Store] creates node stores. *) @@ -1645,53 +1645,53 @@ module Private : sig (C : Contents.STORE) (P : Path.S) (M : Metadata.S) (S : sig - include CONTENT_ADDRESSABLE_STORE with type key = C.key + include CONTENT_ADDRESSABLE_STORE with type key = C.key - module Key : Hash.S with type t = key + module Key : Hash.S with type t = key - module Val : - S + module Val : + S with type t = value and type hash = key and type metadata = M.t and type step = P.step end) : STORE - with type 'a t = 'a C.t * 'a S.t - and type key = S.key - and type value = S.value - and module Path = P - and module Metadata = M - and type Key.t = S.Key.t - and module Val = S.Val + with type 'a t = 'a C.t * 'a S.t + and type key = S.key + and type value = S.value + and module Path = P + and module Metadata = M + and type Key.t = S.Key.t + and module Val = S.Val (** [Graph] specifies the signature for node graphs. A node graph is a deterministic DAG, labeled by steps. *) module type GRAPH = sig (** {1 Node Graphs} *) - (** The type for store handles. *) type 'a t + (** The type for store handles. *) - (** The type for node metadata. *) type metadata + (** The type for node metadata. *) - (** The type of user-defined contents. *) type contents + (** The type of user-defined contents. *) - (** The type for node values. *) type node + (** The type for node values. *) + type step (** The type of steps. A step is used to pass from one node to another. *) - type step + type path (** The type of store paths. A path is composed of {{!step}steps}. *) - type path - (** The type for store values. *) type value = [ `Node of node | `Contents of contents * metadata ] + (** The type for store values. *) val empty : [> `Write ] t -> node Lwt.t (** The empty node. *) @@ -1753,12 +1753,12 @@ module Private : sig module Graph (S : STORE) : GRAPH - with type 'a t = 'a S.t - and type contents = S.Contents.key - and type metadata = S.Val.metadata - and type node = S.key - and type path = S.Path.t - and type step = S.Path.step + with type 'a t = 'a S.t + and type contents = S.Contents.key + and type metadata = S.Val.metadata + and type node = S.key + and type path = S.Path.t + and type step = S.Path.step end (** Commit values represent the store history. @@ -1774,11 +1774,11 @@ module Private : sig module type S = sig (** {1 Commit values} *) - (** The type for commit values. *) type t + (** The type for commit values. *) - (** Type for keys. *) type hash + (** Type for keys. *) val v : info:Info.t -> node:hash -> parents:hash list -> t (** Create a commit. *) @@ -1801,9 +1801,9 @@ module Private : sig (** [hash_t] is the value type for {!hash}. *) end + module Make (K : Type.S) : S with type hash = K.t (** [Make] provides a simple implementation of commit values, parameterized by the commit and node keys [K]. *) - module Make (K : Type.S) : S with type hash = K.t (** V1 serialisation. *) module V1 (S : S) : sig @@ -1829,25 +1829,25 @@ module Private : sig (** [Val] provides functions for commit values. *) module Val : S with type t = value and type hash = key - (** [Node] is the underlying node store. *) module Node : Node.STORE with type key = Val.hash + (** [Node] is the underlying node store. *) end (** [Store] creates a new commit store. *) module Store (N : Node.STORE) (S : sig - include CONTENT_ADDRESSABLE_STORE with type key = N.key + include CONTENT_ADDRESSABLE_STORE with type key = N.key - module Key : Hash.S with type t = key + module Key : Hash.S with type t = key - module Val : S with type t = value and type hash = key + module Val : S with type t = value and type hash = key end) : STORE - with type 'a t = 'a N.t * 'a S.t - and type key = S.key - and type value = S.value - and type Key.t = S.Key.t - and module Val = S.Val + with type 'a t = 'a N.t * 'a S.t + and type key = S.key + and type value = S.value + and type Key.t = S.Key.t + and module Val = S.Val (** [History] specifies the signature for commit history. The history is represented as a partial-order of commits and basic @@ -1858,17 +1858,17 @@ module Private : sig module type HISTORY = sig (** {1 Commit History} *) - (** The type for store handles. *) type 'a t + (** The type for store handles. *) - (** The type for node values. *) type node + (** The type for node values. *) - (** The type for commit values. *) type commit + (** The type for commit values. *) - (** The type for commit objects. *) type v + (** The type for commit objects. *) val v : [> `Write ] t -> @@ -1940,9 +1940,9 @@ module Private : sig (** Build a commit history. *) module History (S : STORE) : HISTORY - with type 'a t = 'a S.t - and type node = S.Node.key - and type commit = S.key + with type 'a t = 'a S.t + and type node = S.Node.key + and type commit = S.key end (** The signature for slices. *) @@ -1950,20 +1950,20 @@ module Private : sig module type S = sig (** {1 Slices} *) - (** The type for slices. *) type t + (** The type for slices. *) - (** The type for exported contents. *) type contents + (** The type for exported contents. *) - (** The type for exported nodes. *) type node + (** The type for exported nodes. *) - (** The type for exported commits. *) type commit + (** The type for exported commits. *) - (** The type for exported values. *) type value = [ `Contents of contents | `Node of node | `Commit of commit ] + (** The type for exported values. *) val empty : unit -> t Lwt.t (** Create a new empty slice. *) @@ -1995,26 +1995,26 @@ module Private : sig (** Build simple slices. *) module Make (C : Contents.STORE) (N : Node.STORE) (H : Commit.STORE) : S - with type contents = C.key * C.value - and type node = N.key * N.value - and type commit = H.key * H.value + with type contents = C.key * C.value + and type node = N.key * N.value + and type commit = H.key * H.value end module Sync : sig module type S = sig (** {1 Remote synchronization} *) - (** The type for store handles. *) type t + (** The type for store handles. *) - (** The type for store heads. *) type commit + (** The type for store heads. *) - (** The type for branch IDs. *) type branch + (** The type for branch IDs. *) - (** The type for sync endpoints. *) type endpoint + (** The type for sync endpoints. *) val fetch : t -> @@ -2051,11 +2051,11 @@ module Private : sig module type S = sig (** {1 Private Implementations} *) - (** Internal hashes. *) module Hash : Hash.S + (** Internal hashes. *) - (** Private content store. *) module Contents : Contents.STORE with type key = Hash.t + (** Private content store. *) (** Private node store. *) module Node : @@ -2065,15 +2065,15 @@ module Private : sig module Commit : Commit.STORE with type key = Hash.t and type Val.hash = Node.key - (** Private branch store. *) module Branch : Branch.STORE with type value = Commit.key + (** Private branch store. *) (** Private slices. *) module Slice : Slice.S - with type contents = Contents.key * Contents.value - and type node = Node.key * Node.value - and type commit = Commit.key * Commit.value + with type contents = Contents.key * Contents.value + and type node = Node.key * Node.value + and type commit = Commit.key * Commit.value (** Private repositories. *) module Repo : sig @@ -2092,9 +2092,9 @@ module Private : sig val batch : t -> ([ `Read | `Write ] Contents.t -> - [ `Read | `Write ] Node.t -> - [ `Read | `Write ] Commit.t -> - 'a Lwt.t) -> + [ `Read | `Write ] Node.t -> + [ `Read | `Write ] Commit.t -> + 'a Lwt.t) -> 'a Lwt.t end @@ -2148,50 +2148,50 @@ module type S = sig systems, that the informed user can see as an implicit purely functional data-structure. *) - (** The type for Irmin repositories. *) type repo + (** The type for Irmin repositories. *) - (** The type for Irmin stores. *) type t + (** The type for Irmin stores. *) - (** The type for {!key} steps. *) type step + (** The type for {!key} steps. *) - (** The type for store keys. A key is a sequence of {!step}s. *) type key + (** The type for store keys. A key is a sequence of {!step}s. *) - (** The type for store metadata. *) type metadata + (** The type for store metadata. *) - (** The type for store contents. *) type contents + (** The type for store contents. *) - (** The type for store nodes. *) type node + (** The type for store nodes. *) - (** The type for store trees. *) type tree = [ `Node of node | `Contents of contents * metadata ] + (** The type for store trees. *) - (** The type for object hashes. *) type hash + (** The type for object hashes. *) - (** Type for commit identifiers. Similar to Git's commit SHA1s. *) type commit + (** Type for commit identifiers. Similar to Git's commit SHA1s. *) + type branch (** Type for persistent branch names. Branches usually share a common global namespace and it's the user's responsibility to avoid name clashes. *) - type branch - (** Type for store slices. *) type slice + (** Type for store slices. *) + type lca_error = [ `Max_depth_reached | `Too_many_lcas ] (** The type for errors associated with functions computing least common ancestors *) - type lca_error = [ `Max_depth_reached | `Too_many_lcas ] - (** The type for errors for {!fast_forward}. *) type ff_error = [ `No_change | `Rejected | lca_error ] + (** The type for errors for {!fast_forward}. *) (** Repositories. *) module Repo : sig @@ -2199,8 +2199,8 @@ module type S = sig A repository contains a set of branches. *) - (** The type of repository handles. *) type t = repo + (** The type of repository handles. *) val v : config -> t Lwt.t (** [v config] connects to a repository in a backend-specific @@ -2273,8 +2273,8 @@ module type S = sig (** [Status] provides base functions for store statuses. *) module Status : sig - (** The type for store status. *) type t = [ `Empty | `Branch of branch | `Commit of commit ] + (** The type for store status. *) val t : repo -> t Type.t (** [t] is the value type for {!t}. *) @@ -2356,13 +2356,13 @@ module type S = sig lowest common ancestors (see {!lcas}). *) end - (** Object hashes. *) module Hash : Hash.S with type t = hash + (** Object hashes. *) (** [Commit] defines immutable objects to describe store updates. *) module Commit : sig - (** The type for store commits. *) type t = commit + (** The type for store commits. *) val t : repo -> t Type.t (** [t] is the value type for {!t}. *) @@ -2503,26 +2503,26 @@ module type S = sig (** {1 Folds} *) - (** The type for fold marks. *) type marks + (** The type for fold marks. *) val empty_marks : unit -> marks (** [empty_marks ()] is an empty collection of marks. *) + type 'a force = [ `True | `False of key -> 'a -> 'a Lwt.t ] (** The type for {!fold}'s [force] parameter. [`True] forces the fold to read the objects of the lazy nodes. [`False f] is applying [f] on every lazy node instead. *) - type 'a force = [ `True | `False of key -> 'a -> 'a Lwt.t ] + type uniq = [ `False | `True | `Marks of marks ] (** The type for {!fold}'s [uniq] parameters. [`False] folds over all the nodes. [`True] does not recurse on nodes already seen. [`Marks m] uses the collection of marks [m] to store the cache of keys: the fold will modify [m]. This can be used for incremental folds. *) - type uniq = [ `False | `True | `Marks of marks ] - (** The type for {!fold}'s [pre] and [post] parameters. *) type 'a node_fn = key -> step list -> 'a -> 'a Lwt.t + (** The type for {!fold}'s [pre] and [post] parameters. *) val fold : ?force:'a force -> @@ -2551,14 +2551,14 @@ module type S = sig (** {1 Stats} *) - (** The type for tree stats. *) type stats = { nodes : int; (** Number of node. *) leafs : int; (** Number of leafs. *) skips : int; (** Number of lazy nodes. *) depth : int; (** Maximal depth. *) - width : int (** Maximal width. *) + width : int; (** Maximal width. *) } + (** The type for tree stats. *) val pp_stats : stats Fmt.t (** [pp_stats] is the pretty printer for tree statistics. *) @@ -2570,9 +2570,9 @@ module type S = sig (** {1 Concrete Trees} *) - (** The type for concrete trees. *) type concrete = [ `Tree of (step * concrete) list | `Contents of contents * metadata ] + (** The type for concrete trees. *) val of_concrete : concrete -> tree (** [of_concrete c] is the subtree equivalent to the concrete tree @@ -2620,7 +2620,7 @@ module type S = sig mutable node_cache_miss : int; mutable node_val_v : int; mutable node_val_find : int; - mutable node_val_list : int + mutable node_val_list : int; } val counters : unit -> counters @@ -2684,6 +2684,8 @@ module type S = sig (** {1 Udpates} *) + type write_error = + [ Merge.conflict | `Too_many_retries of int | `Test_was of tree option ] (** The type for write errors. {ul @@ -2694,8 +2696,6 @@ module type S = sig {- A "test and set" operation has failed and the current value is [v] instead of the one we were waiting for. }} *) - type write_error = - [ Merge.conflict | `Too_many_retries of int | `Test_was of tree option ] val set : ?retries:int -> @@ -2955,8 +2955,8 @@ module type S = sig (** {1 Watches} *) - (** The type for store watches. *) type watch + (** The type for store watches. *) val watch : t -> ?init:commit -> (commit diff -> unit Lwt.t) -> watch Lwt.t (** [watch t f] calls [f] every time the contents of [t]'s head is @@ -2983,13 +2983,13 @@ module type S = sig (** {1 Merges and Common Ancestors.} *) - (** The type for merge functions. *) type 'a merge = info:Info.f -> ?max_depth:int -> ?n:int -> 'a -> (unit, Merge.conflict) result Lwt.t + (** The type for merge functions. *) val merge_into : into:t -> t merge (** [merge_into ~into i t] merges [t]'s current branch into [x]'s @@ -3035,8 +3035,8 @@ module type S = sig (** {1 History} *) - (** An history is a DAG of heads. *) module History : Graph.Sig.P with type V.t = commit + (** An history is a DAG of heads. *) val history : ?depth:int -> ?min:commit list -> ?max:commit list -> t -> History.t Lwt.t @@ -3094,15 +3094,15 @@ module type S = sig (** [watch_all t f] calls [f] on every branch-related change in [t], including creation/deletion events. *) - (** Base functions for branches. *) include Branch.S with type t = branch + (** Base functions for branches. *) end (** [Key] provides base functions for the stores's paths. *) module Key : Path.S with type t = key and type step = step - (** [Metadata] provides base functions for node metadata. *) module Metadata : Metadata.S with type t = metadata + (** [Metadata] provides base functions for node metadata. *) (** {1 Value Types} *) @@ -3149,13 +3149,13 @@ module type S = sig module Private : sig include Private.S - with type Contents.value = contents - and module Node.Path = Key - and type Hash.t = Hash.t - and type Node.Metadata.t = metadata - and type Branch.key = branch - and type Slice.t = slice - and type Repo.t = repo + with type Contents.value = contents + and module Node.Path = Key + and type Hash.t = Hash.t + and type Node.Metadata.t = metadata + and type Branch.key = branch + and type Slice.t = slice + and type Repo.t = repo end type remote += @@ -3232,22 +3232,23 @@ module type S_MAKER = functor (P : Path.S) (B : Branch.S) (H : Hash.S) - -> S - with type key = P.t - and type step = P.step - and type metadata = M.t - and type contents = C.t - and type branch = B.t - and type hash = H.t + -> + S + with type key = P.t + and type step = P.step + and type metadata = M.t + and type contents = C.t + and type branch = B.t + and type hash = H.t (** [KV] is similar to {!S} but chooses sensible implementations for path and branch. *) module type KV = S with type key = string list and type step = string and type branch = string +module type KV_MAKER = functor (C : Contents.S) -> KV with type contents = C.t (** [KV_MAKER] is like {!S_MAKER} but where everything except the contents is replaced by sensible default implementations. *) -module type KV_MAKER = functor (C : Contents.S) -> KV with type contents = C.t (** {2 Synchronization} *) @@ -3263,14 +3264,14 @@ val remote_store : (module S with type t = 'a) -> 'a -> remote module type SYNC = sig (** {1 Native Synchronization} *) - (** Type type for store handles. *) type db + (** Type type for store handles. *) - (** The type for store heads. *) type commit + (** The type for store heads. *) - (** The type for remote status. *) type status = [ `Empty | `Head of commit ] + (** The type for remote status. *) val status_t : db -> status Type.t (** [status_t db] is the value type for {!status} of remote [db]. *) @@ -3289,8 +3290,8 @@ module type SYNC = sig (** Same as {!fetch} but raise [Invalid_argument] if either the local or remote store do not have a valid head. *) - (** The type for pull errors. *) type pull_error = [ `Msg of string | Merge.conflict ] + (** The type for pull errors. *) val pp_pull_error : pull_error Fmt.t (** [pp_push_error] pretty-prints pull errors. *) @@ -3313,8 +3314,8 @@ module type SYNC = sig db -> ?depth:int -> remote -> [ `Merge of Info.f | `Set ] -> status Lwt.t (** Same as {!pull} but raise [Invalid_arg] in case of conflict. *) - (** The type for push errors. *) type push_error = [ `Msg of string | `Detached_head ] + (** The type for push errors. *) val pp_push_error : push_error Fmt.t (** [pp_push_error] pretty-prints push errors. *) @@ -3626,9 +3627,9 @@ module Content_addressable (V : Type.S) : sig include CONTENT_ADDRESSABLE_STORE - with type 'a t = 'a S(K)(V).t - and type key = K.t - and type value = V.t + with type 'a t = 'a S(K)(V).t + and type key = K.t + and type value = V.t val batch : [ `Read ] t -> ([ `Read | `Write ] t -> 'a Lwt.t) -> 'a Lwt.t (** [batch t f] applies the writes in [f] in a separate batch. The @@ -3650,11 +3651,11 @@ module type ATOMIC_WRITE_STORE_MAKER = functor (K : Type.S) (V : Type.S) -> sig configuration [config], which is provided by the backend. *) end -(** Simple store creator. Use the same type of all of the internal - keys and store all the values in the same store. *) module Make (CA : CONTENT_ADDRESSABLE_STORE_MAKER) (AW : ATOMIC_WRITE_STORE_MAKER) : S_MAKER +(** Simple store creator. Use the same type of all of the internal + keys and store all the values in the same store. *) module Make_ext (CA : CONTENT_ADDRESSABLE_STORE_MAKER) @@ -3665,29 +3666,29 @@ module Make_ext (Branch : Branch.S) (Hash : Hash.S) (Node : Private.Node.S - with type metadata = Metadata.t - and type hash = Hash.t - and type step = Path.step) + with type metadata = Metadata.t + and type hash = Hash.t + and type step = Path.step) (Commit : Private.Commit.S with type hash = Hash.t) : S - with type key = Path.t - and type contents = Contents.t - and type branch = Branch.t - and type hash = Hash.t - and type step = Path.step - and type metadata = Metadata.t - and type Key.step = Path.step + with type key = Path.t + and type contents = Contents.t + and type branch = Branch.t + and type hash = Hash.t + and type step = Path.step + and type metadata = Metadata.t + and type Key.step = Path.step (** Advanced store creator. *) module Of_private (P : Private.S) : S - with type key = P.Node.Path.t - and type contents = P.Contents.value - and type branch = P.Branch.key - and type hash = P.Hash.t - and type step = P.Node.Path.step - and type metadata = P.Node.Val.metadata - and type Key.step = P.Node.Path.step - and type repo = P.Repo.t - and type slice = P.Slice.t - and module Private = P + with type key = P.Node.Path.t + and type contents = P.Contents.value + and type branch = P.Branch.key + and type hash = P.Hash.t + and type step = P.Node.Path.step + and type metadata = P.Node.Val.metadata + and type Key.step = P.Node.Path.step + and type repo = P.Repo.t + and type slice = P.Slice.t + and module Private = P diff --git a/vendors/irmin/merge.ml b/vendors/irmin/merge.ml index 857053be7681..3b752e2369bc 100644 --- a/vendors/irmin/merge.ml +++ b/vendors/irmin/merge.ml @@ -49,7 +49,7 @@ let conflict fmt = ksprintf (fun msg -> Log.debug (fun f -> f "conflict: %s" msg); - Lwt.return (Error (`Conflict msg)) ) + Lwt.return (Error (`Conflict msg))) fmt let bind x f = x >>= function Error _ as x -> Lwt.return x | Ok x -> f x @@ -110,7 +110,7 @@ let seq = function fun ~old v1 v2 -> Lwt_list.fold_left_s (fun acc (_, merge) -> - match acc with Ok x -> ok x | Error _ -> merge ~old v1 v2 ) + match acc with Ok x -> ok x | Error _ -> merge ~old v1 v2) (Error (`Conflict "nothing to merge")) ts ) @@ -123,26 +123,26 @@ let option (type a) ((a, t) : a t) : a option t = f (default Type.(option a)) ~old t1 t2 >>= function | Ok x -> ok x | Error _ -> ( - match (t1, t2) with - | None, None -> ok None - | Some v1, Some v2 -> - let open Infix in - let old () = + match (t1, t2) with + | None, None -> ok None + | Some v1, Some v2 -> + let open Infix in + let old () = + old () >>=* function + | None -> ok None + | Some o -> + Log.debug (fun f -> f "option old=%a" pp o); + ok o + in + t ~old v1 v2 >|=* fun x -> Some x + | Some x, None | None, Some x -> ( + let open Infix in old () >>=* function - | None -> ok None - | Some o -> + | None | Some None -> ok (Some x) + | Some (Some o) -> + let pp = Type.pp a and ( = ) = Type.equal a in Log.debug (fun f -> f "option old=%a" pp o); - ok o - in - t ~old v1 v2 >|=* fun x -> Some x - | Some x, None | None, Some x -> ( - let open Infix in - old () >>=* function - | None | Some None -> ok (Some x) - | Some (Some o) -> - let pp = Type.pp a and ( = ) = Type.equal a in - Log.debug (fun f -> f "option old=%a" pp o); - if x = o then ok (Some x) else conflict "option: add/del" ) ) + if x = o then ok (Some x) else conflict "option: add/del" ) ) ) let pair (da, a) (db, b) = @@ -157,8 +157,8 @@ let pair (da, a) (db, b) = let (a1, b1), (a2, b2) = (x, y) in let o1 = map_promise fst old in let o2 = map_promise snd old in - a ~old:o1 a1 a2 >>=* fun a3 -> b ~old:o2 b1 b2 >|=* fun b3 -> (a3, b3) - ) + a ~old:o1 a1 a2 >>=* fun a3 -> + b ~old:o2 b1 b2 >|=* fun b3 -> (a3, b3) ) let triple (da, a) (db, b) (dc, c) = let dt = Type.triple da db dc in @@ -198,17 +198,17 @@ let alist_iter2 compare_k f l1 l2 = | [], 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 ) ) + 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 @@ -256,8 +256,7 @@ let alist dx dy merge_v = let merge_v k = f (merge_v k) in Lwt.catch (fun () -> - alist_merge_lwt Type.(compare dx) (merge_elt merge_v old) x y >>= ok - ) + alist_merge_lwt Type.(compare dx) (merge_elt merge_v old) x y >>= ok) (function C msg -> conflict "%s" msg | e -> Lwt.fail e) ) module MultiSet (K : sig @@ -363,7 +362,7 @@ struct in ok (Some old) in - merge_maps (merge_elt merge_v old) m1 m2 >>= ok ) + merge_maps (merge_elt merge_v old) m1 m2 >>= ok) (function C msg -> conflict "%s" msg | e -> Lwt.fail e) ) end @@ -392,7 +391,7 @@ let like_lwt (type a b) da (t : b t) (a_to_b : a -> b Lwt.t) memo (fun () -> bind (old ()) @@ function | None -> ok None - | Some a -> a_to_b a >|= fun b -> Ok (Some b) ) + | Some a -> a_to_b a >|= fun b -> Ok (Some b)) in bind ((f t) ~old b1 b2) @@ fun b3 -> b_to_a b3 >>= ok with Not_found -> conflict "biject'" @@ -436,8 +435,8 @@ let conflict_t = let result_t ok = let open Type in - variant "result" (fun ok error -> function - | Ok x -> ok x | Error x -> error x ) + variant "result" (fun ok error -> + function Ok x -> ok x | Error x -> error x) |~ case1 "ok" ok (fun x -> Ok x) |~ case1 "error" conflict_t (fun x -> Error x) |> sealv diff --git a/vendors/irmin/node.ml b/vendors/irmin/node.ml index 2469f7774515..48999dbc9387 100644 --- a/vendors/irmin/node.ml +++ b/vendors/irmin/node.ml @@ -33,9 +33,9 @@ end module Make (K : Type.S) (P : sig - type step + type step - val step_t : step Type.t + val step_t : step Type.t end) (M : S.METADATA) = struct @@ -51,10 +51,11 @@ struct let kind_t = let open Type in - variant "Tree.kind" (fun node contents contents_m -> function + variant "Tree.kind" (fun node contents contents_m -> + function | `Node -> node | `Contents m -> - if Type.equal M.t m M.default then contents else contents_m m ) + if Type.equal M.t m M.default then contents else contents_m m) |~ case0 "node" `Node |~ case0 "contents" (`Contents M.default) |~ case1 "contents" M.t (fun m -> `Contents m) @@ -110,7 +111,7 @@ struct let e = to_entry (k, v) in StepMap.update k (fun e' -> - if Type.equal (Type.option entry_t) (Some e) e' then e' else Some e ) + if Type.equal (Type.option entry_t) (Some e) e' then e' else Some e) t let remove t k = StepMap.remove k t @@ -125,10 +126,10 @@ struct let value_t = let open Type in - variant "value" (fun n c x -> function + variant "value" (fun n c x -> + function | `Node h -> n h - | `Contents (h, m) -> if Type.equal M.t m M.default then c h else x (h, m) - ) + | `Contents (h, m) -> if Type.equal M.t m M.default then c h else x (h, m)) |~ case1 "node" K.t (fun k -> `Node k) |~ case1 "contents" K.t (fun h -> `Contents (h, M.default)) |~ case1 "contents-x" (pair K.t M.t) (fun (h, m) -> `Contents (h, m)) @@ -145,12 +146,12 @@ module Store (C : S.CONTENTS_STORE) (P : S.PATH) (M : S.METADATA) (S : sig - include S.CONTENT_ADDRESSABLE_STORE with type key = C.key + include S.CONTENT_ADDRESSABLE_STORE with type key = C.key - module Key : S.HASH with type t = key + module Key : S.HASH with type t = key - module Val : - S.NODE + module Val : + S.NODE with type t = value and type hash = key and type metadata = M.t @@ -230,7 +231,7 @@ struct let rec merge t = let merge_key = Merge.v (Type.option S.Key.t) (fun ~old x y -> - Merge.(f (merge t)) ~old x y ) + Merge.(f (merge t)) ~old x y) in let merge = merge_value t merge_key in let read = function @@ -356,9 +357,9 @@ module Graph (S : S.NODE_STORE) = struct match Path.rdecons path with | Some (path, file) -> map t node path (fun node -> S.Val.add node file n) | None -> ( - match n with - | `Node n -> Lwt.return n - | `Contents _ -> failwith "TODO: Node.add" ) + match n with + | `Node n -> Lwt.return n + | `Contents _ -> failwith "TODO: Node.add" ) let rdecons_exn path = match Path.rdecons path with @@ -458,13 +459,13 @@ module V1 (N : S.NODE) = struct | Some c, None, None -> `Contents (c, N.default) | Some c, Some m, None -> `Contents (c, m) | None, None, Some n -> `Node n - | _ -> failwith "invalid node" ) + | _ -> failwith "invalid node") |+ field "contents" (option K.t) (function | `Contents (x, _) -> Some x - | _ -> None ) + | _ -> None) |+ field "metadata" (option N.metadata_t) (function | `Contents (_, x) when not (equal N.metadata_t N.default x) -> Some x - | _ -> None ) + | _ -> None) |+ field "node" (option K.t) (function `Node n -> Some n | _ -> None) |> sealr diff --git a/vendors/irmin/node.mli b/vendors/irmin/node.mli index 472effb73578..d2d706587a20 100644 --- a/vendors/irmin/node.mli +++ b/vendors/irmin/node.mli @@ -22,9 +22,9 @@ module No_metadata : S.METADATA with type t = unit module Make (K : Type.S) (P : sig - type step + type step - val step_t : step Type.t + val step_t : step Type.t end) (M : S.METADATA) : S.NODE with type hash = K.t and type step = P.step and type metadata = M.t @@ -33,41 +33,41 @@ module Store (C : S.CONTENTS_STORE) (P : S.PATH) (M : S.METADATA) (N : sig - include S.CONTENT_ADDRESSABLE_STORE with type key = C.key + include S.CONTENT_ADDRESSABLE_STORE with type key = C.key - module Key : S.HASH with type t = key + module Key : S.HASH with type t = key - module Val : - S.NODE + module Val : + S.NODE with type t = value and type hash = key and type metadata = M.t and type step = P.step end) : S.NODE_STORE - with type 'a t = 'a C.t * 'a N.t - and type key = N.key - and type value = N.value - and module Path = P - and module Metadata = M - and type Key.t = N.key - and module Val = N.Val + with type 'a t = 'a C.t * 'a N.t + and type key = N.key + and type value = N.value + and module Path = P + and module Metadata = M + and type Key.t = N.key + and module Val = N.Val module Graph (N : S.NODE_STORE) : S.NODE_GRAPH - with type 'a t = 'a N.t - and type contents = N.Contents.key - and type metadata = N.Val.metadata - and type node = N.key - and type step = N.Path.step - and type path = N.Path.t + with type 'a t = 'a N.t + and type contents = N.Contents.key + and type metadata = N.Val.metadata + and type node = N.key + and type step = N.Path.step + and type path = N.Path.t module V1 (N : S.NODE) : sig include S.NODE - with type hash = N.hash - and type step = N.step - and type metadata = N.metadata + with type hash = N.hash + and type step = N.step + and type metadata = N.metadata val import : N.t -> t diff --git a/vendors/irmin/object_graph.ml b/vendors/irmin/object_graph.ml index 1ecf6acaed3d..2e3bd7786df4 100644 --- a/vendors/irmin/object_graph.ml +++ b/vendors/irmin/object_graph.ml @@ -24,9 +24,9 @@ let list_partition_map f t = let rec aux fst snd = function | [] -> (List.rev fst, List.rev snd) | h :: t -> ( - match f h with - | `Fst x -> aux (x :: fst) snd t - | `Snd x -> aux fst (x :: snd) t ) + match f h with + | `Fst x -> aux (x :: fst) snd t + | `Snd x -> aux fst (x :: snd) t ) in aux [] [] t @@ -87,11 +87,12 @@ struct let t = let open Type in - variant "vertex" (fun contents node commit branch -> function + variant "vertex" (fun contents node commit branch -> + function | `Contents x -> contents x | `Node x -> node x | `Commit x -> commit x - | `Branch x -> branch x ) + | `Branch x -> branch x) |~ case1 "contents" (pair Contents.t Metadata.t) (fun x -> `Contents x) |~ case1 "node" Node.t (fun x -> `Node x) |~ case1 "commit" Commit.t (fun x -> `Commit x) @@ -135,7 +136,7 @@ struct let closure ?(depth = max_int) ~pred ~min ~max () = Log.debug (fun f -> - f "closure depth=%d (%d elements)" depth (List.length max) ); + f "closure depth=%d (%d elements)" depth (List.length max)); let g = G.create ~size:1024 () in let marks = Table.create 1024 in let mark key level = Table.add marks key level in diff --git a/vendors/irmin/object_graph.mli b/vendors/irmin/object_graph.mli index 0108fea77e47..a74c52b02a3b 100644 --- a/vendors/irmin/object_graph.mli +++ b/vendors/irmin/object_graph.mli @@ -17,11 +17,11 @@ (** Graphs. *) module type S = sig - (** Directed graph *) include Graph.Sig.I + (** Directed graph *) - (** Basic operations. *) include Graph.Oper.S with type g := t + (** Basic operations. *) (** Topoogical traversal *) module Topological : sig @@ -61,8 +61,8 @@ module type S = sig val max : t -> vertex list (** Compute the maximun vertex. *) - (** Expose the graph internals. *) type dump = vertex list * (vertex * vertex) list + (** Expose the graph internals. *) val export : t -> dump (** Expose the graph as a pair of vertices and edges. *) @@ -70,11 +70,10 @@ module type S = sig val import : dump -> t (** Import a graph. *) - (** The base functions over graph internals. *) module Dump : Type.S with type t = dump + (** The base functions over graph internals. *) end -(** Build a graph. *) module Make (Contents : Type.S) (Metadata : Type.S) @@ -82,8 +81,9 @@ module Make (Commit : Type.S) (Branch : Type.S) : S - with type V.t = - [ `Contents of Contents.t * Metadata.t - | `Node of Node.t - | `Commit of Commit.t - | `Branch of Branch.t ] + with type V.t = + [ `Contents of Contents.t * Metadata.t + | `Node of Node.t + | `Commit of Commit.t + | `Branch of Branch.t ] +(** Build a graph. *) diff --git a/vendors/irmin/path.ml b/vendors/irmin/path.ml index 4841ccded6b5..9dff18499953 100644 --- a/vendors/irmin/path.ml +++ b/vendors/irmin/path.ml @@ -46,7 +46,7 @@ module String_list = struct List.iter (fun s -> Buffer.add_char buf '/'; - Buffer.add_string buf s ) + Buffer.add_string buf s) t; Fmt.string ppf (Buffer.contents buf) diff --git a/vendors/irmin/s.ml b/vendors/irmin/s.ml index 5d138d252032..18d4fa687608 100644 --- a/vendors/irmin/s.ml +++ b/vendors/irmin/s.ml @@ -235,10 +235,10 @@ module type NODE_STORE = sig module Val : NODE - with type t = value - and type hash = key - and type metadata = Metadata.t - and type step = Path.step + with type t = value + and type hash = key + and type metadata = Metadata.t + and type step = Path.step module Contents : CONTENTS_STORE with type key = Val.hash end @@ -454,9 +454,9 @@ module type PRIVATE = sig module Slice : SLICE - with type contents = Contents.key * Contents.value - and type node = Node.key * Node.value - and type commit = Commit.key * Commit.value + with type contents = Contents.key * Contents.value + and type node = Node.key * Node.value + and type commit = Commit.key * Commit.value module Repo : sig type t @@ -474,9 +474,9 @@ module type PRIVATE = sig val batch : t -> ([ `Read | `Write ] Contents.t -> - [ `Read | `Write ] Node.t -> - [ `Read | `Write ] Commit.t -> - 'a Lwt.t) -> + [ `Read | `Write ] Node.t -> + [ `Read | `Write ] Commit.t -> + 'a Lwt.t) -> 'a Lwt.t end @@ -561,7 +561,7 @@ module type TREE = sig leafs : int; skips : int; depth : int; - width : int + width : int; } val pp_stats : stats Fmt.t @@ -601,7 +601,7 @@ module type TREE = sig mutable node_cache_miss : int; mutable node_val_v : int; mutable node_val_find : int; - mutable node_val_list : int + mutable node_val_list : int; } val counters : unit -> counters @@ -741,12 +741,12 @@ module type STORE = sig module Tree : sig include TREE - with type step := step - and type key := key - and type metadata := metadata - and type contents := contents - and type node := node - and type tree := tree + with type step := step + and type key := key + and type metadata := metadata + and type contents := contents + and type node := node + and type tree := tree val hash : tree -> hash @@ -1062,13 +1062,13 @@ module type STORE = sig module Private : sig include PRIVATE - with type Contents.value = contents - and module Hash = Hash - and module Node.Path = Key - and type Node.Metadata.t = metadata - and type Branch.key = branch - and type Slice.t = slice - and type Repo.t = repo + with type Contents.value = contents + and module Hash = Hash + and module Node.Path = Key + and type Node.Metadata.t = metadata + and type Branch.key = branch + and type Slice.t = slice + and type Repo.t = repo end type remote += E of Private.Sync.endpoint @@ -1098,13 +1098,14 @@ module type MAKER = functor (P : PATH) (B : BRANCH) (H : HASH) - -> STORE - with type key = P.t - and type step = P.step - and type metadata = M.t - and type contents = C.t - and type branch = B.t - and type hash = H.t + -> + STORE + with type key = P.t + and type step = P.step + and type metadata = M.t + and type contents = C.t + and type branch = B.t + and type hash = H.t type remote += Store : (module STORE with type t = 'a) * 'a -> remote diff --git a/vendors/irmin/slice.ml b/vendors/irmin/slice.ml index 1d553bed1b27..54cd89bc2fb0 100644 --- a/vendors/irmin/slice.ml +++ b/vendors/irmin/slice.ml @@ -30,7 +30,7 @@ struct type t = { mutable contents : (Contents.key * Contents.value) list; mutable nodes : (Node.key * Node.value) list; - mutable commits : (Commit.key * Commit.value) list + mutable commits : (Commit.key * Commit.value) list; } let t = @@ -60,9 +60,10 @@ struct let iter t f = Lwt.choose - [ Lwt_list.iter_p (fun c -> f (`Contents c)) t.contents; + [ + Lwt_list.iter_p (fun c -> f (`Contents c)) t.contents; Lwt_list.iter_p (fun n -> f (`Node n)) t.nodes; - Lwt_list.iter_p (fun c -> f (`Commit c)) t.commits + Lwt_list.iter_p (fun c -> f (`Commit c)) t.commits; ] let contents_t = Type.pair Contents.Key.t Contents.Val.t @@ -73,9 +74,9 @@ struct let value_t = let open Type in - variant "slice" (fun contents node commit -> function - | `Contents x -> contents x | `Node x -> node x | `Commit x -> commit x - ) + variant "slice" (fun contents node commit -> + function + | `Contents x -> contents x | `Node x -> node x | `Commit x -> commit x) |~ case1 "contents" contents_t (fun x -> `Contents x) |~ case1 "node" node_t (fun x -> `Node x) |~ case1 "commit" commit_t (fun x -> `Commit x) diff --git a/vendors/irmin/slice.mli b/vendors/irmin/slice.mli index 7c91911a21e4..a45db8006fa8 100644 --- a/vendors/irmin/slice.mli +++ b/vendors/irmin/slice.mli @@ -16,6 +16,6 @@ module Make (C : S.CONTENTS_STORE) (N : S.NODE_STORE) (H : S.COMMIT_STORE) : S.SLICE - with type contents = C.key * C.value - and type node = N.key * N.value - and type commit = H.key * H.value + with type contents = C.key * C.value + and type node = N.key * N.value + and type commit = H.key * H.value diff --git a/vendors/irmin/store.ml b/vendors/irmin/store.ml index a476f81c41fc..a93d310d0e73 100644 --- a/vendors/irmin/store.ml +++ b/vendors/irmin/store.ml @@ -216,14 +216,14 @@ module Make (P : S.PRIVATE) = struct | Some h -> ( Commit.of_hash repo h >|= function | None -> acc - | Some h -> h :: acc ) ) + | Some h -> h :: acc )) [] bs let export ?(full = true) ?depth ?(min = []) ?(max = []) t = Log.debug (fun f -> f "export depth=%s full=%b min=%d max=%d" (match depth with None -> "" | Some d -> string_of_int d) - full (List.length min) (List.length max) ); + full (List.length min) (List.length max)); (match max with [] -> heads t | m -> Lwt.return m) >>= fun max -> P.Slice.empty () >>= fun slice -> let max = List.map (fun x -> `Commit x.Commit.h) max in @@ -247,7 +247,7 @@ module Make (P : S.PRIVATE) = struct | None -> Lwt.return_unit | Some c -> root_nodes := P.Commit.Val.node c :: !root_nodes; - P.Slice.add slice (`Commit (k, c)) ) + P.Slice.add slice (`Commit (k, c))) keys >>= fun () -> if not full then Lwt.return slice @@ -268,16 +268,16 @@ module Make (P : S.PRIVATE) = struct List.iter (function | _, `Contents (c, _) -> contents := KSet.add c !contents - | _ -> () ) + | _ -> ()) (P.Node.Val.list v); - P.Slice.add slice (`Node (k, v)) ) + P.Slice.add slice (`Node (k, v))) nodes >>= fun () -> Lwt_list.iter_p (fun k -> P.Contents.find (contents_t t) k >>= function | None -> Lwt.return_unit - | Some m -> P.Slice.add slice (`Contents (k, m)) ) + | Some m -> P.Slice.add slice (`Contents (k, m))) (KSet.elements !contents) >|= fun () -> slice @@ -308,7 +308,7 @@ module Make (P : S.PRIVATE) = struct Lwt.return_unit | `Commit c -> commits := c :: !commits; - Lwt.return_unit ) + Lwt.return_unit) >>= fun () -> P.Repo.batch t @@ fun contents_t node_t commit_t -> Lwt.catch @@ -322,10 +322,10 @@ module Make (P : S.PRIVATE) = struct Lwt_list.iter_p (aux "Commit" (P.Commit.add commit_t) P.Commit.Key.t) !commits - >|= fun () -> Ok () ) + >|= fun () -> Ok ()) (function | Import_error e -> Lwt.return (Error (`Msg e)) - | e -> Fmt.kstrf Lwt.fail_invalid_arg "impot error: %a" Fmt.exn e ) + | e -> Fmt.kstrf Lwt.fail_invalid_arg "impot error: %a" Fmt.exn e) end type t = { @@ -333,7 +333,7 @@ module Make (P : S.PRIVATE) = struct head_ref : head_ref; mutable tree : (commit * tree) option; (* cache for the store tree *) - lock : Lwt_mutex.t + lock : Lwt_mutex.t; } type step = Key.step @@ -449,15 +449,16 @@ module Make (P : S.PRIVATE) = struct head t >|= function | None -> None | Some h -> ( - match t.tree with - | Some (o, t) when Commit.equal o h -> Some (o, t) - | _ -> - t.tree <- None; - (* the tree cache needs to be invalidated *) - let n = Tree.import_no_check (repo t) (Commit.node h) in - let tree = `Node n in - t.tree <- Some (h, tree); - Some (h, tree) ) + match t.tree with + | Some (o, t) when Commit.equal o h -> Some (o, t) + | _ -> + t.tree <- None; + + (* the tree cache needs to be invalidated *) + let n = Tree.import_no_check (repo t) (Commit.node h) in + let tree = `Node n in + t.tree <- Some (h, tree); + Some (h, tree) ) let tree t = tree_and_head t >|= function @@ -494,7 +495,7 @@ module Make (P : S.PRIVATE) = struct Branch_store.watch (branch_t t) ?init (fun name head -> if Type.equal Branch_store.Key.t name0 name then lift_head_diff t.repo fn head - else Lwt.return_unit ) + else Lwt.return_unit) >|= fun id () -> Branch_store.unwatch (branch_t t) id let pp_key = Type.pp Key.t @@ -544,7 +545,7 @@ module Make (P : S.PRIVATE) = struct | Some old_head -> ( Log.debug (fun f -> f "fast-forward-head old=%a new=%a" Commit.pp_hash old_head - Commit.pp_hash new_head ); + Commit.pp_hash new_head); if Commit.equal new_head old_head then (* we only update if there is a change *) Lwt.return (Error `No_change) @@ -610,7 +611,7 @@ module Make (P : S.PRIVATE) = struct (* [head] is protected by [t.lock] *) head := Some c; t.tree <- Some tree; - Lwt.return true ) ) + Lwt.return true )) | `Branch name -> (* concurrent handlers and/or process can modify the branch. Need to check that we are still working on the same @@ -646,7 +647,7 @@ module Make (P : S.PRIVATE) = struct root : tree; tree : tree option; (* the subtree used by the transaction *) - parents : commit list + parents : commit list; } let snapshot t key = @@ -842,6 +843,7 @@ module Make (P : S.PRIVATE) = struct | Ok _ as x -> Lwt.return x | Error (`Conflict _) when retries > 0 && n <= retries -> done_once := true; + (* use the store's current tree as the new 'old store' *) (tree_and_head t >>= function | None -> Lwt.return None @@ -947,7 +949,7 @@ module Make (P : S.PRIVATE) = struct let t = Dst.add_vertex t x in let t = Dst.add_vertex t y in Dst.add_edge t x y - | _ -> t ) + | _ -> t) g (Lwt.return t) end @@ -985,7 +987,7 @@ module Make (P : S.PRIVATE) = struct let last_modified ?depth ?(n = 1) t key = Log.debug (fun l -> l "last_modified depth=%a number=%d key=%a" pp_option depth n pp_key - key ); + key); Head.get t >>= fun commit -> let heap = Heap.create 5 in let () = Heap.add heap (commit, 0) in @@ -1019,7 +1021,7 @@ module Make (P : S.PRIVATE) = struct | Some x, Some y -> not (Type.equal Contents.t x y) | Some _, None -> true | _, _ -> false ) - | None -> Lwt.return_false ) + | None -> Lwt.return_false) parents >>= fun found -> if found then search (current :: acc) else search acc @@ -1069,8 +1071,9 @@ module Make (P : S.PRIVATE) = struct let t r = let open Type in - variant "status" (fun empty branch commit -> function - | `Empty -> empty | `Branch b -> branch b | `Commit c -> commit c ) + variant "status" (fun empty branch commit -> + function + | `Empty -> empty | `Branch b -> branch b | `Commit c -> commit c) |~ case0 "empty" `Empty |~ case1 "branch" Branch.t (fun b -> `Branch b) |~ case1 "commit" (Commit.t r) (fun c -> `Commit c) @@ -1104,22 +1107,25 @@ module Make (P : S.PRIVATE) = struct let lca_error_t = Type.enum "lca-error" - [ ("max-depth-reached", `Max_depth_reached); - ("too-many-lcas", `Too_many_lcas) + [ + ("max-depth-reached", `Max_depth_reached); + ("too-many-lcas", `Too_many_lcas); ] let ff_error_t = Type.enum "ff-error" - [ ("max-depth-reached", `Max_depth_reached); + [ + ("max-depth-reached", `Max_depth_reached); ("too-many-lcas", `Too_many_lcas); ("no-change", `No_change); - ("rejected", `Rejected) + ("rejected", `Rejected); ] let write_error_t = let open Type in - variant "write-error" (fun c m e -> function - | `Conflict x -> c x | `Too_many_retries x -> m x | `Test_was x -> e x ) + variant "write-error" (fun c m e -> + function + | `Conflict x -> c x | `Too_many_retries x -> m x | `Test_was x -> e x) |~ case1 "conflict" string (fun x -> `Conflict x) |~ case1 "too-many-retries" int (fun x -> `Too_many_retries x) |~ case1 "test-got" (option tree_t) (fun x -> `Test_was x) diff --git a/vendors/irmin/store.mli b/vendors/irmin/store.mli index 9c421eb44d8b..d572c20dced5 100644 --- a/vendors/irmin/store.mli +++ b/vendors/irmin/store.mli @@ -19,16 +19,16 @@ module Make (P : S.PRIVATE) : S.STORE - with type key = P.Node.Path.t - and type contents = P.Contents.value - and type branch = P.Branch.key - and type hash = P.Hash.t - and type slice = P.Slice.t - and type step = P.Node.Path.step - and type metadata = P.Node.Val.metadata - and module Key = P.Node.Path - and type repo = P.Repo.t - and module Private = P + with type key = P.Node.Path.t + and type contents = P.Contents.value + and type branch = P.Branch.key + and type hash = P.Hash.t + and type slice = P.Slice.t + and type step = P.Node.Path.step + and type metadata = P.Node.Val.metadata + and module Key = P.Node.Path + and type repo = P.Repo.t + and module Private = P module Content_addressable (X : S.APPEND_ONLY_STORE_MAKER) @@ -36,9 +36,9 @@ module Content_addressable (V : Type.S) : sig include S.CONTENT_ADDRESSABLE_STORE - with type 'a t = 'a X(K)(V).t - and type key = K.t - and type value = V.t + with type 'a t = 'a X(K)(V).t + and type key = K.t + and type value = V.t val batch : [ `Read ] t -> ([ `Read | `Write ] t -> 'a Lwt.t) -> 'a Lwt.t diff --git a/vendors/irmin/sync_ext.ml b/vendors/irmin/sync_ext.ml index 1b73c3715b5f..be803ee2c84e 100644 --- a/vendors/irmin/sync_ext.ml +++ b/vendors/irmin/sync_ext.ml @@ -57,7 +57,7 @@ module Make (S : S.STORE) = struct let v = conv RP.Commit.Val.t SP.Commit.Val.t v in match (k, v) with | Ok k, Ok v -> SP.Slice.add s (`Commit (k, v)) - | _ -> Lwt.return_unit ) ) + | _ -> Lwt.return_unit )) >>= fun () -> Lwt.return s let convs src dst l = @@ -77,8 +77,8 @@ module Make (S : S.STORE) = struct let status_t t = let open Type in - variant "status" (fun empty head -> function - | `Empty -> empty | `Head c -> head c ) + variant "status" (fun empty head -> + function `Empty -> empty | `Head c -> head c) |~ case0 "empty" `Empty |~ case1 "head" S.(commit_t @@ repo t) (fun c -> `Head c) |> sealv @@ -100,26 +100,26 @@ module Make (S : S.STORE) = struct S.Repo.import s_repo s_slice >|= function | Error e -> Error e | Ok () -> ( - match conv R.(commit_t r_repo) S.(commit_t s_repo) h with - | Ok h -> Ok (`Head h) - | Error e -> Error e ) ) ) + match conv R.(commit_t r_repo) S.(commit_t s_repo) h with + | Ok h -> Ok (`Head h) + | Error e -> Error e ) ) ) | S.E e -> ( - match S.status t with - | `Empty | `Commit _ -> Lwt.return_ok `Empty - | `Branch br -> ( - Log.debug (fun l -> l "Fetching branch %a" pp_branch br); - B.v (S.repo t) >>= fun g -> - B.fetch g ?depth e br >>= function - | Error _ as e -> Lwt.return e - | Ok (Some c) -> ( - Log.debug (fun l -> l "Fetched %a" pp_hash c); - S.Commit.of_hash (S.repo t) c >|= function - | None -> Ok `Empty - | Some x -> Ok (`Head x) ) - | Ok None -> ( - S.Head.find t >>= function - | Some h -> Lwt.return_ok (`Head h) - | None -> Lwt.return_ok `Empty ) ) ) + match S.status t with + | `Empty | `Commit _ -> Lwt.return_ok `Empty + | `Branch br -> ( + Log.debug (fun l -> l "Fetching branch %a" pp_branch br); + B.v (S.repo t) >>= fun g -> + B.fetch g ?depth e br >>= function + | Error _ as e -> Lwt.return e + | Ok (Some c) -> ( + Log.debug (fun l -> l "Fetched %a" pp_hash c); + S.Commit.of_hash (S.repo t) c >|= function + | None -> Ok `Empty + | Some x -> Ok (`Head x) ) + | Ok None -> ( + S.Head.find t >>= function + | Some h -> Lwt.return_ok (`Head h) + | None -> Lwt.return_ok `Empty ) ) ) | _ -> Lwt.return_error (`Msg "fetch operation is not available") let fetch_exn t ?depth remote = @@ -137,12 +137,12 @@ module Make (S : S.STORE) = struct fetch t ?depth remote >>= function | Error e -> Lwt.return_error (e :> pull_error) | Ok (`Head k) -> ( - match kind with - | `Set -> S.Head.set t k >|= fun () -> Ok (`Head k) - | `Merge info -> ( - S.Head.merge ~into:t ~info k >>= function - | Ok () -> Lwt.return_ok (`Head k) - | Error e -> Lwt.return_error (e :> pull_error) ) ) + match kind with + | `Set -> S.Head.set t k >|= fun () -> Ok (`Head k) + | `Merge info -> ( + S.Head.merge ~into:t ~info k >>= function + | Ok () -> Lwt.return_ok (`Head k) + | Error e -> Lwt.return_error (e :> pull_error) ) ) | Ok `Empty -> Lwt.return_ok `Empty let pull_exn t ?depth remote kind = @@ -174,21 +174,21 @@ module Make (S : S.STORE) = struct R.Repo.import (R.repo r) r_slice >>= function | Error e -> Lwt.return (Error (e :> push_error)) | Ok () -> ( - match conv S.(commit_t s_repo) R.(commit_t r_repo) h with - | Error e -> Lwt.return (Error (e :> push_error)) - | Ok h -> - R.Head.set r h >>= fun () -> - S.Head.get t >|= fun head -> Ok (`Head head) ) ) ) + match conv S.(commit_t s_repo) R.(commit_t r_repo) h with + | Error e -> Lwt.return (Error (e :> push_error)) + | Ok h -> + R.Head.set r h >>= fun () -> + S.Head.get t >|= fun head -> Ok (`Head head) ) ) ) | S.E e -> ( - match S.status t with - | `Empty -> Lwt.return_ok `Empty - | `Commit _ -> Lwt.return (Error `Detached_head) - | `Branch br -> ( - S.of_branch (S.repo t) br >>= S.Head.get >>= fun head -> - B.v (S.repo t) >>= fun g -> - B.push g ?depth e br >>= function - | Ok () -> Lwt.return_ok (`Head head) - | Error err -> Lwt.return_error (err :> push_error) ) ) + match S.status t with + | `Empty -> Lwt.return_ok `Empty + | `Commit _ -> Lwt.return (Error `Detached_head) + | `Branch br -> ( + S.of_branch (S.repo t) br >>= S.Head.get >>= fun head -> + B.v (S.repo t) >>= fun g -> + B.push g ?depth e br >>= function + | Ok () -> Lwt.return_ok (`Head head) + | Error err -> Lwt.return_error (err :> push_error) ) ) | _ -> Lwt.return_error (`Msg "push operation is not available") let push_exn t ?depth remote = diff --git a/vendors/irmin/tree.ml b/vendors/irmin/tree.ml index 35299e81955e..c6b996841ffa 100644 --- a/vendors/irmin/tree.ml +++ b/vendors/irmin/tree.ml @@ -28,17 +28,17 @@ let alist_iter2 compare_k f l1 l2 = | [], 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 [@tailcall]) t1 t2 - | x -> - if x < 0 then ( - f k1 (`Left v1); - (aux [@tailcall]) t1 l2 ) - else ( - f k2 (`Right v2); - (aux [@tailcall]) l1 t2 ) ) + match compare_k k1 k2 with + | 0 -> + f k1 (`Both (v1, v2)); + (aux [@tailcall]) t1 t2 + | x -> + if x < 0 then ( + f k1 (`Left v1); + (aux [@tailcall]) t1 l2 ) + else ( + f k2 (`Right v2); + (aux [@tailcall]) l1 t2 ) ) in aux l1 l2 @@ -104,30 +104,31 @@ module Make (P : S.PRIVATE) = struct mutable node_cache_miss : int; mutable node_val_v : int; mutable node_val_find : int; - mutable node_val_list : int + mutable node_val_list : int; } let counters_t = let open Type in record "counters" (fun contents_hash - contents_find - contents_add - contents_cache_length - contents_cache_find - contents_cache_miss - node_hash - node_mem - node_add - node_find - node_cache_length - node_cache_find - node_cache_miss - node_val_v - node_val_find - node_val_list - -> - { contents_hash; + contents_find + contents_add + contents_cache_length + contents_cache_find + contents_cache_miss + node_hash + node_mem + node_add + node_find + node_cache_length + node_cache_find + node_cache_miss + node_val_v + node_val_find + node_val_list + -> + { + contents_hash; contents_find; contents_add; contents_cache_length; @@ -142,8 +143,8 @@ module Make (P : S.PRIVATE) = struct node_cache_miss; node_val_v; node_val_find; - node_val_list - } ) + node_val_list; + }) |+ field "contents_hash" int (fun x -> x.contents_hash) |+ field "contents_find" int (fun x -> x.contents_find) |+ field "contents_add" int (fun x -> x.contents_add) @@ -165,7 +166,8 @@ module Make (P : S.PRIVATE) = struct let dump_counters ppf t = Type.pp_json ~minify:false counters_t ppf t let fresh_counters () = - { contents_hash = 0; + { + contents_hash = 0; contents_add = 0; contents_find = 0; contents_cache_length = 0; @@ -180,7 +182,7 @@ module Make (P : S.PRIVATE) = struct node_cache_miss = 0; node_val_v = 0; node_val_find = 0; - node_val_list = 0 + node_val_list = 0; } let reset_counters t = @@ -248,7 +250,7 @@ module Make (P : S.PRIVATE) = struct type info = { mutable hash : hash option; mutable value : contents option; - mutable color : [ `White | `Black ] + mutable color : [ `White | `Black ]; } type t = { mutable v : v; mutable info : info } @@ -270,8 +272,8 @@ module Make (P : S.PRIVATE) = struct let v = let open Type in - variant "Node.Contents.v" (fun hash value -> function - | Hash (_, x) -> hash x | Value v -> value v ) + variant "Node.Contents.v" (fun hash value -> + function Hash (_, x) -> hash x | Value v -> value v) |~ case1 "hash" P.Hash.t (fun _ -> assert false) |~ case1 "value" P.Contents.Val.t (fun v -> Value v) |> sealv @@ -394,7 +396,9 @@ module Make (P : S.PRIVATE) = struct match hash c with | Some k -> k | None -> ( - match value c with None -> assert false | Some v -> hash_of_value c v ) + match value c with + | None -> assert false + | Some v -> hash_of_value c v ) let value_of_hash t repo k = cnt.contents_find <- cnt.contents_find + 1; @@ -420,9 +424,9 @@ module Make (P : S.PRIVATE) = struct match value t with | Some v -> Lwt.return (Some v) | None -> ( - match t.v with - | Value v -> Lwt.return (Some v) - | Hash (repo, k) -> value_of_hash t repo k ) + match t.v with + | Value v -> Lwt.return (Some v) + | Hash (repo, k) -> value_of_hash t repo k ) let equal (x : t) (y : t) = x == y @@ -436,7 +440,7 @@ module Make (P : S.PRIVATE) = struct let f ~old x y = let old = Merge.bind_promise old (fun old () -> - to_value old >|= fun c -> Ok (Some c) ) + to_value old >|= fun c -> Ok (Some c)) in to_value x >>= fun x -> to_value y >>= fun y -> @@ -452,9 +456,9 @@ module Make (P : S.PRIVATE) = struct match force with | `True -> to_value t >>= aux | `False skip -> ( - match t.info.value with - | None -> skip path acc - | Some c -> aux (Some c) ) + match t.info.value with + | None -> skip path acc + | Some c -> aux (Some c) ) end module Node = struct @@ -469,7 +473,7 @@ module Make (P : S.PRIVATE) = struct mutable map : map option; mutable hash : hash option; mutable color : [ `White | `Black ]; - mutable findv_cache : map option + mutable findv_cache : map option; } and v = @@ -481,11 +485,12 @@ module Make (P : S.PRIVATE) = struct let elt_t t : elt Type.t = let open Type in - variant "Node.value" (fun node contents contents_m -> function + variant "Node.value" (fun node contents contents_m -> + function | `Node x -> node x | `Contents (c, m) -> if Type.equal Metadata.t m Metadata.default then contents c - else contents_m (c, m) ) + else contents_m (c, m)) |~ case1 "Node" t (fun x -> `Node x) |~ case1 "Contents" Contents.t (fun x -> `Contents (x, Metadata.default)) |~ case1 "Contents-x" (pair Contents.t Metadata.t) (fun x -> `Contents x) @@ -501,10 +506,11 @@ module Make (P : S.PRIVATE) = struct let v_t (m : map Type.t) : v Type.t = let open Type in - variant "Node.node" (fun map hash value -> function + variant "Node.node" (fun map hash value -> + function | Map m -> map m | Hash (_, y) -> hash y - | Value (_, v, m) -> value (v, m) ) + | Value (_, v, m) -> value (v, m)) |~ case1 "map" m (fun m -> Map m) |~ case1 "hash" P.Hash.t (fun _ -> assert false) |~ case1 "value" (pair P.Node.Val.t (option m)) (fun _ -> assert false) @@ -548,7 +554,7 @@ module Make (P : S.PRIVATE) = struct let m = StepMap.union (fun _ a b -> - (merge_elt [@tailcall]) ~into:a b (fun () -> Some a) ) + (merge_elt [@tailcall]) ~into:a b (fun () -> Some a)) a b in if m != a then x.findv_cache <- Some m @@ -570,7 +576,7 @@ module Make (P : S.PRIVATE) = struct match v with | `Contents _ -> k (max acc (depth + 1)) | `Node t -> - (aux [@tailcall]) (depth + 1) t (fun d -> k (max acc d)) ) + (aux [@tailcall]) (depth + 1) t (fun d -> k (max acc d))) m depth and aux depth t k = match (t.v, t.info.map) with @@ -648,7 +654,7 @@ module Make (P : S.PRIVATE) = struct let elt = elt_t y in let v = v_t (map_t elt) in let t = t v in - (v, t) ) + (v, t)) let elt_t = elt_t t @@ -659,7 +665,7 @@ module Make (P : S.PRIVATE) = struct | `Contents (c, _) -> Contents.mark `Black c.Contents.info; if depth + 1 > max_depth then Contents.clear c - | `Node t -> (clear [@tailcall]) ~max_depth (depth + 1) t ) + | `Node t -> (clear [@tailcall]) ~max_depth (depth + 1) t) m and clear_info ~max_depth ?v depth i = @@ -705,9 +711,9 @@ module Make (P : S.PRIVATE) = struct | Map m when StepMap.is_empty m -> t.v <- Value (repo, P.Node.Val.empty, None) | _ -> ( - match hash with - | None -> t.v <- Hash (repo, k) - | Some k -> t.v <- Hash (repo, k) ) + match hash with + | None -> t.v <- Hash (repo, k) + | Some k -> t.v <- Hash (repo, k) ) let dump = Type.pp_json ~minify:false t @@ -782,11 +788,11 @@ module Make (P : S.PRIVATE) = struct match value t with | Some v -> of_value v | None -> ( - match t.v with - | Hash (_, h) -> h - | Value (_, v, None) -> of_value v - | Value (_, v, Some a) -> of_value (value_of_adds t v a) - | Map m -> of_value (value_of_map t m) ) ) + match t.v with + | Hash (_, h) -> h + | Value (_, v, None) -> of_value v + | Value (_, v, Some a) -> of_value (value_of_adds t v a) + | Map m -> of_value (value_of_map t m) ) ) let rec value_of_map t ~value_of_adds map = if StepMap.is_empty map then ( @@ -800,18 +806,18 @@ module Make (P : S.PRIVATE) = struct cnt.node_val_v <- cnt.node_val_v + 1; P.Node.Val.v alist | (step, v) :: rest -> ( - match v with - | `Contents (c, m) -> - let v = `Contents (Contents.to_hash c, m) in - (aux [@tailcall]) ((step, v) :: acc) rest - | `Node n -> - let n = - to_hash ~value_of_adds - ~value_of_map:(value_of_map ~value_of_adds) - n - in - let v = `Node n in - (aux [@tailcall]) ((step, v) :: acc) rest ) + match v with + | `Contents (c, m) -> + let v = `Contents (Contents.to_hash c, m) in + (aux [@tailcall]) ((step, v) :: acc) rest + | `Node n -> + let n = + to_hash ~value_of_adds + ~value_of_map:(value_of_map ~value_of_adds) + n + in + let v = `Node n in + (aux [@tailcall]) ((step, v) :: acc) rest ) in let v = aux [] alist in t.info.value <- Some v; @@ -834,7 +840,7 @@ module Make (P : S.PRIVATE) = struct List.fold_left (fun v (k, e) -> let e = value_of_elt ~value_of_adds e in - P.Node.Val.add v k e ) + P.Node.Val.add v k e) v added in t.info.value <- Some v; @@ -859,13 +865,13 @@ module Make (P : S.PRIVATE) = struct match value t with | Some v -> Lwt.return (Some v) | None -> ( - match t.v with - | Value (_, v, None) -> Lwt.return (Some v) - | Value (_, v, Some m) -> - let v = value_of_adds t v m in - Lwt.return (Some v) - | Map m -> Lwt.return (Some (value_of_map t m)) - | Hash (repo, h) -> value_of_hash t repo h ) + match t.v with + | Value (_, v, None) -> Lwt.return (Some v) + | Value (_, v, Some m) -> + let v = value_of_adds t v m in + Lwt.return (Some v) + | Map m -> Lwt.return (Some (value_of_map t m)) + | Hash (repo, h) -> value_of_hash t repo h ) let to_map t = match map t with @@ -914,12 +920,12 @@ module Make (P : S.PRIVATE) = struct | Value (_, x, Some a), Value (_, y, Some b) -> Type.equal P.Node.Val.t x y && map_equal a b | _ -> ( - match (value x, value y) with - | Some x, Some y -> Type.equal P.Node.Val.t x y - | _ -> ( - match (map x, map y) with - | Some x, Some y -> map_equal x y - | _ -> hash_equal (to_hash x) (to_hash y) ) ) + match (value x, value y) with + | Some x, Some y -> Type.equal P.Node.Val.t x y + | _ -> ( + match (map x, map y) with + | Some x, Some y -> map_equal x y + | _ -> hash_equal (to_hash x) (to_hash y) ) ) let is_empty t = match map t with @@ -933,7 +939,7 @@ module Make (P : S.PRIVATE) = struct let trim l = List.rev_map (fun (s, v) -> - (s, match v with `Contents _ -> `Contents | `Node _ -> `Node) ) + (s, match v with `Contents _ -> `Contents | `Node _ -> `Node)) l |> List.rev in @@ -989,22 +995,22 @@ module Make (P : S.PRIVATE) = struct | Some _ as v -> Lwt.return v | None -> of_value repo v ) | Hash (repo, h) -> ( - match value t with - | Some v -> of_value repo v - | None -> ( - value_of_hash t repo h >>= function - | None -> Lwt.return None - | Some v -> of_value repo v ) ) + match value t with + | Some v -> of_value repo v + | None -> ( + value_of_hash t repo h >>= function + | None -> Lwt.return None + | Some v -> of_value repo v ) ) in match map t with | Some m -> of_map m | None -> ( - match t.info.findv_cache with - | None -> of_t () - | Some m -> ( - of_map m >>= function - | None -> of_t () - | Some _ as r -> Lwt.return r ) ) + match t.info.findv_cache with + | None -> of_t () + | Some m -> ( + of_map m >>= function + | None -> of_t () + | Some _ as r -> Lwt.return r ) ) let dummy_marks = Hashes.create 0 @@ -1023,9 +1029,9 @@ module Make (P : S.PRIVATE) = struct match force with | `True -> to_map t >>= fun m -> (map [@tailcall]) ~path acc m k | `False skip -> ( - match t.info.map with - | Some n -> (map [@tailcall]) ~path acc (Some n) k - | _ -> skip path acc ) + match t.info.map with + | Some n -> (map [@tailcall]) ~path acc (Some n) k + | _ -> skip path acc ) and aux_uniq ~path acc t k = if uniq = `False then (aux [@tailcall]) ~path acc t k else @@ -1083,27 +1089,27 @@ module Make (P : S.PRIVATE) = struct | Value (repo, n, None) -> Lwt.return (of_value repo n StepMap.empty) | Value (repo, n, Some m) -> Lwt.return (of_value repo n m) | Hash (repo, h) -> ( - match (value t, map t) with - | Some v, _ -> Lwt.return (of_value repo v StepMap.empty) - | _, Some m -> Lwt.return (of_map m) - | None, None -> - (value_of_hash t repo h >|= function - | Some v -> v - | None -> P.Node.Val.empty) - >|= fun v -> of_value repo v StepMap.empty ) + match (value t, map t) with + | Some v, _ -> Lwt.return (of_value repo v StepMap.empty) + | _, Some m -> Lwt.return (of_map m) + | None, None -> + (value_of_hash t repo h >|= function + | Some v -> v + | None -> P.Node.Val.empty) + >|= fun v -> of_value repo v StepMap.empty ) let rec merge : type a. (t Merge.t -> a) -> a = fun k -> let f ~old x y = let old = Merge.bind_promise old (fun old () -> - to_map old >|= fun m -> Ok (Some m) ) + to_map old >|= fun m -> Ok (Some m)) in to_map x >>= fun x -> to_map y >>= fun y -> let m = StepMap.merge elt_t (fun _step -> - (merge_elt [@tailcall]) Merge.option ) + (merge_elt [@tailcall]) Merge.option) in Merge.(f @@ option m) ~old x y >|= function | Ok (Some map) -> Ok (of_map map) @@ -1123,14 +1129,14 @@ module Make (P : S.PRIVATE) = struct Merge.bind_promise old (fun old () -> match old with | `Contents (_, m) -> Lwt.return (Ok (Some m)) - | `Node _ -> Lwt.return (Ok None) ) + | `Node _ -> Lwt.return (Ok None)) in Merge.(f Metadata.merge) ~old:mold cx cy >>=* fun m -> let old = Merge.bind_promise old (fun old () -> match old with | `Contents (c, _) -> Lwt.return (Ok (Some c)) - | `Node _ -> Lwt.return (Ok None) ) + | `Node _ -> Lwt.return (Ok None)) in Merge.(f Contents.merge) ~old x y >>=* fun c -> Merge.ok (`Contents (c, m)) @@ -1140,9 +1146,9 @@ module Make (P : S.PRIVATE) = struct Merge.bind_promise old (fun old () -> match old with | `Contents _ -> Lwt.return (Ok None) - | `Node n -> Lwt.return (Ok (Some n)) ) + | `Node n -> Lwt.return (Ok (Some n))) in - Merge.(f m ~old x y) >>=* fun n -> Merge.ok (`Node n) ) + Merge.(f m ~old x y) >>=* fun n -> Merge.ok (`Node n)) | _ -> Merge.conflict "add/add values" in k (Merge.seq [ Merge.default elt_t; Merge.v elt_t f ]) @@ -1164,11 +1170,11 @@ module Make (P : S.PRIVATE) = struct let tree_t = let open Type in - variant "tree" (fun node contents -> function - | `Node n -> node n | `Contents c -> contents c ) + variant "tree" (fun node contents -> + function `Node n -> node n | `Contents c -> contents c) |~ case1 "node" Node.t (fun n -> `Node n) |~ case1 "contents" (pair P.Contents.Val.t Metadata.t) (fun c -> - `Contents c ) + `Contents c) |> sealv let dump ppf = function @@ -1246,7 +1252,7 @@ module Make (P : S.PRIVATE) = struct leafs : int; skips : int; depth : int; - width : int + width : int; } let empty_stats = { nodes = 0; leafs = 0; skips = 0; depth = 0; width = 0 } @@ -1349,8 +1355,7 @@ module Make (P : S.PRIVATE) = struct Node.is_empty child' >>= function | true -> may_remove view h >>= k - | false -> Node.add view h (`Node child') >>= some ) ) - ) + | false -> Node.add view h (`Node child') >>= some )) ) in let n = match t with `Node n -> n | _ -> empty in (aux [@tailcall]) n path @@ function @@ -1376,11 +1381,11 @@ module Make (P : S.PRIVATE) = struct | None | Some (`Contents _) -> (aux [@tailcall]) empty p (function | None -> k None - | Some child' -> Node.add n h (`Node child') >>= some ) + | Some child' -> Node.add n h (`Node child') >>= some) | Some (`Node child) -> (aux [@tailcall]) child p (function | None -> k None - | Some child' -> Node.add n h (`Node child') >>= some ) ) + | Some child' -> Node.add n h (`Node child') >>= some) ) in let n = match t with `Node n -> n | _ -> empty in (aux [@tailcall]) n path @@ function @@ -1392,9 +1397,9 @@ module Make (P : S.PRIVATE) = struct let empty = empty_node t in match Path.rdecons k with | None -> ( - match t with - | `Contents c' when contents_equal c' (c, metadata) -> Lwt.return t - | _ -> Lwt.return (`Contents (c, metadata)) ) + match t with + | `Contents c' when contents_equal c' (c, metadata) -> Lwt.return t + | _ -> Lwt.return (`Contents (c, metadata)) ) | Some (path, file) -> ( let rec aux n path k = let some n = k (Some n) in @@ -1411,11 +1416,11 @@ module Make (P : S.PRIVATE) = struct | None | Some (`Contents _) -> (aux [@tailcall]) empty p (function | None -> assert false - | Some child -> Node.add n h (`Node child) >>= some ) + | Some child -> Node.add n h (`Node child) >>= some) | Some (`Node child) -> (aux [@tailcall]) child p (function | None -> k None - | Some child' -> Node.add n h (`Node child') >>= some ) ) + | Some child' -> Node.add n h (`Node child') >>= some) ) in let n = match t with `Node n -> n | _ -> empty in (aux [@tailcall]) n path @@ function @@ -1468,54 +1473,56 @@ module Make (P : S.PRIVATE) = struct Node.export ?clear repo n h; k () | false -> ( - match n.v with - | Hash _ | Value (_, _, None) -> - (* might happen if the node has already been added + match n.v with + | Hash _ | Value (_, _, None) -> + (* might happen if the node has already been added (while the thread was block on P.Node.mem *) - k () - | Map children | Value (_, _, Some children) -> - (* 1. convert partial values to total values *) - ( match n.v with - | Value (_, _, Some _) -> ( - Node.to_value n >|= function - | None -> () - | Some v -> n.v <- Value (repo, v, None) ) - | _ -> Lwt.return () ) - >>= fun () -> - (* 2. push the current node job on the stack. *) - let () = - match (n.v, Node.value n) with - | _, Some v -> Stack.push (add_node n v) todo - | Map x, None -> Stack.push (add_node_map n x) todo - | _ -> assert false - in - let contents = ref [] in - let nodes = ref [] in - StepMap.iter - (fun _ -> function - | `Contents c -> contents := c :: !contents - | `Node n -> nodes := n :: !nodes ) - children; - (* 2. push the contents job on the stack. *) - List.iter - (fun (c, _) -> - let h = Contents.to_hash c in - if Hashes.mem seen h then () - else ( - Hashes.add seen h (); - match c.Contents.v with - | Contents.Hash _ -> () - | Contents.Value x -> - Stack.push (add_contents c x) todo ) ) - !contents; - (* 3. push the children jobs on the stack. *) - List.iter - (fun n -> - Stack.push - (fun () -> (add_to_todo [@tailcall]) n Lwt.return) - todo ) - !nodes; - k () ) ) ) + k () + | Map children | Value (_, _, Some children) -> + (* 1. convert partial values to total values *) + ( match n.v with + | Value (_, _, Some _) -> ( + Node.to_value n >|= function + | None -> () + | Some v -> n.v <- Value (repo, v, None) ) + | _ -> Lwt.return () ) + >>= fun () -> + (* 2. push the current node job on the stack. *) + let () = + match (n.v, Node.value n) with + | _, Some v -> Stack.push (add_node n v) todo + | Map x, None -> Stack.push (add_node_map n x) todo + | _ -> assert false + in + let contents = ref [] in + let nodes = ref [] in + StepMap.iter + (fun _ -> function + | `Contents c -> contents := c :: !contents + | `Node n -> nodes := n :: !nodes) + children; + + (* 2. push the contents job on the stack. *) + List.iter + (fun (c, _) -> + let h = Contents.to_hash c in + if Hashes.mem seen h then () + else ( + Hashes.add seen h (); + match c.Contents.v with + | Contents.Hash _ -> () + | Contents.Value x -> + Stack.push (add_contents c x) todo )) + !contents; + + (* 3. push the children jobs on the stack. *) + List.iter + (fun n -> + Stack.push + (fun () -> (add_to_todo [@tailcall]) n Lwt.return) + todo) + !nodes; + k () ) ) ) in let rec loop () = let task = try Some (Stack.pop todo) with Stack.Empty -> None in @@ -1560,7 +1567,7 @@ module Make (P : S.PRIVATE) = struct let path = Path.rcons path k in match v with | `Node v -> (acc, (path, v) :: todo) - | `Contents c -> ((path, c) :: acc, todo) ) + | `Contents c -> ((path, c) :: acc, todo)) (acc, todo) childs in (aux [@tailcall]) acc todo @@ -1636,7 +1643,7 @@ module Make (P : S.PRIVATE) = struct | Some cx, Some cy -> let x = (cx, snd x) in let y = (cy, snd y) in - acc := (path, `Updated (x, y)) :: !acc ) ) + acc := (path, `Updated (x, y)) :: !acc )) x y >>= fun () -> (aux [@tailcall]) !acc !todo in @@ -1672,7 +1679,7 @@ module Make (P : S.PRIVATE) = struct (contents [@tailcall]) (fun v -> (tree [@tailcall]) (StepMap.add s v map) k t) c - | `Node _ as v -> (tree [@tailcall]) (StepMap.add s v map) k t ) + | `Node _ as v -> (tree [@tailcall]) (StepMap.add s v map) k t) n in (concrete [@tailcall]) (fun x -> x) c @@ -1693,15 +1700,15 @@ module Make (P : S.PRIVATE) = struct and node childs k = function | [] -> k childs | (s, n) :: t -> ( - match n with - | `Node _ as n -> - (tree [@tailcall]) (fun tree -> node ((s, tree) :: childs) k t) n - | `Contents c -> - (contents [@tailcall]) - (function - | None -> (node [@tailcall]) childs k t - | Some c -> (node [@tailcall]) ((s, c) :: childs) k t ) - c ) + match n with + | `Node _ as n -> + (tree [@tailcall]) (fun tree -> node ((s, tree) :: childs) k t) n + | `Contents c -> + (contents [@tailcall]) + (function + | None -> (node [@tailcall]) childs k t + | Some c -> (node [@tailcall]) ((s, c) :: childs) k t) + c ) in tree (fun x -> Lwt.return x) t @@ -1729,7 +1736,7 @@ module Make (P : S.PRIVATE) = struct Node.iter_info (Node.mark `White); Node.iter_info (fun i -> Node.clear_info ~depth i); Contents.iter_info (fun i -> - if i.Contents.color = `White then Contents.clear_info i ) + if i.Contents.color = `White then Contents.clear_info i) let dump ppf () = let ppo t ppf = function @@ -1739,7 +1746,7 @@ module Make (P : S.PRIVATE) = struct Contents.Hashes.iter (fun k v -> Fmt.pf ppf "C|%a: %a@." pp_hash k (ppo P.Contents.Val.t) - v.Contents.value ) + v.Contents.value) Contents.hashes; Node.Cache.iter (fun k v -> Fmt.pf ppf "N|%a: %a@." pp_hash k Node.dump_info v) diff --git a/vendors/irmin/tree.mli b/vendors/irmin/tree.mli index b2aeab12acdd..526529845014 100644 --- a/vendors/irmin/tree.mli +++ b/vendors/irmin/tree.mli @@ -18,10 +18,10 @@ module Make (P : S.PRIVATE) : sig include S.TREE - with type key = P.Node.Path.t - and type step = P.Node.Path.step - and type metadata = P.Node.Val.metadata - and type contents = P.Contents.value + with type key = P.Node.Path.t + and type step = P.Node.Path.step + and type metadata = P.Node.Val.metadata + and type contents = P.Contents.value val import : P.Repo.t -> P.Node.key -> node option Lwt.t diff --git a/vendors/irmin/type.ml b/vendors/irmin/type.ml index b766d088a122..18619ccaec70 100644 --- a/vendors/irmin/type.ml +++ b/vendors/irmin/type.ml @@ -115,14 +115,14 @@ and 'a custom = { pre_hash : 'a bin_seq; size_of : 'a size_of; compare : 'a compare; - equal : 'a equal + equal : 'a equal; } and ('a, 'b) map = { x : 'a t; f : 'a -> 'b; g : 'b -> 'a; - mwit : 'b Witness.t + mwit : 'b Witness.t; } and 'a self = { mutable self : 'a t } @@ -145,7 +145,7 @@ and 'a tuple = and 'a record = { rwit : 'a Witness.t; rname : string; - rfields : 'a fields_and_constr + rfields : 'a fields_and_constr; } and 'a fields_and_constr = @@ -161,7 +161,7 @@ and 'a variant = { vwit : 'a Witness.t; vname : string; vcases : 'a a_case array; - vget : 'a -> 'a case_v + vget : 'a -> 'a case_v; } and 'a a_case = C0 : 'a case0 -> 'a a_case | C1 : ('a, 'b) case1 -> 'a a_case @@ -176,7 +176,7 @@ and ('a, 'b) case1 = { ctag1 : int; cname1 : string; ctype1 : 'b t; - c1 : 'b -> 'a + c1 : 'b -> 'a; } type _ a_field = Field : ('a, 'b) field -> 'a a_field @@ -245,12 +245,12 @@ module Refl = struct | Custom a, Custom b -> custom a b | Prim a, Prim b -> prim a b | Array a, Array b -> ( - match t a.v b.v with Some Refl -> Some Refl | None -> None ) + match t a.v b.v with Some Refl -> Some Refl | None -> None ) | List a, List b -> ( - match t a.v b.v with Some Refl -> Some Refl | None -> None ) + match t a.v b.v with Some Refl -> Some Refl | None -> None ) | Tuple a, Tuple b -> tuple a b | Option a, Option b -> ( - match t a b with Some Refl -> Some Refl | None -> None ) + match t a b with Some Refl -> Some Refl | None -> None ) | Record a, Record b -> Witness.eq a.rwit b.rwit | Variant a, Variant b -> Witness.eq a.vwit b.vwit | _ -> None @@ -266,13 +266,13 @@ module Refl = struct fun a b -> match (a, b) with | Pair (a0, a1), Pair (b0, b1) -> ( - match (t a0 b0, t a1 b1) with - | Some Refl, Some Refl -> Some Refl - | _ -> None ) + match (t a0 b0, t a1 b1) with + | Some Refl, Some Refl -> Some Refl + | _ -> None ) | Triple (a0, a1, a2), Triple (b0, b1, b2) -> ( - match (t a0 b0, t a1 b1, t a2 b2) with - | Some Refl, Some Refl, Some Refl -> Some Refl - | _ -> None ) + match (t a0 b0, t a1 b1, t a2 b2) with + | Some Refl, Some Refl, Some Refl -> Some Refl + | _ -> None ) | _ -> None end @@ -313,7 +313,8 @@ let v ~cli ~json ~bin ~equal ~compare ~short_hash ~pre_hash = let encode_json, decode_json = json in let encode_bin, decode_bin, size_of = bin in Custom - { cwit = `Witness (Witness.make ()); + { + cwit = `Witness (Witness.make ()); pp; of_string; pre_hash; @@ -324,7 +325,7 @@ let v ~cli ~json ~bin ~equal ~compare ~short_hash ~pre_hash = size_of; compare; equal; - short_hash + short_hash; } (* fix points *) @@ -354,7 +355,8 @@ let field fname ftype fget = { fname; ftype; fget } let record : string -> 'b -> ('a, 'b, 'b) open_record = fun n c fs -> (n, c, fs) -let app : type a b c d. +let app : + type a b c d. (a, b, c -> d) open_record -> (a, c) field -> (a, b, d) open_record = fun r f fs -> let n, c, fs = r (F1 (f, fs)) in @@ -405,7 +407,7 @@ let enum vname l = List.fold_left (fun (ctag0, cases, mk) (n, v) -> let c = { ctag0; cname0 = n; c0 = v } in - (ctag0 + 1, C0 c :: cases, (v, CV0 c) :: mk) ) + (ctag0 + 1, C0 c :: cases, (v, CV0 c) :: mk)) (0, [], []) l in let vcases = Array.of_list (List.rev vcases) in @@ -418,8 +420,8 @@ let rec fields_aux : type a b. (a, b) fields -> a a_field list = function let fields r = match r.rfields with Fields (f, _) -> fields_aux f let result a b = - variant "result" (fun ok error -> function - | Ok x -> ok x | Error x -> error x ) + variant "result" (fun ok error -> + function Ok x -> ok x | Error x -> error x) |~ case1 "ok" a (fun a -> Ok a) |~ case1 "error" b (fun b -> Error b) |> sealv @@ -645,9 +647,9 @@ module Compare = struct | CV0 x, CV1 (y, _) -> int x.ctag0 y.ctag1 | CV1 (x, _), CV0 y -> int x.ctag1 y.ctag0 | CV1 (x, vx), CV1 (y, vy) -> ( - match int x.ctag1 y.ctag1 with - | 0 -> compare (x.ctype1, vx) (y.ctype1, vy) - | i -> i ) + match int x.ctag1 y.ctag1 with + | 0 -> compare (x.ctype1, vx) (y.ctype1, vy) + | i -> i ) and compare : type a b. a t * a -> b t * b -> int = fun (tx, x) (ty, y) -> @@ -771,7 +773,7 @@ module Encode_json = struct | List _, [] -> () | tx, x -> lexeme e (`Name f.fname); - t tx e x ) + t tx e x) fields; lexeme e `Oe @@ -877,13 +879,13 @@ module Decode_json = struct let get_base64_value e = match lexeme e with | Ok (`Name "base64") -> ( - match lexeme e with - | Ok (`String b) -> ( - match expect_lexeme e `Oe with - | Ok () -> Ok (Base64.decode_exn b) + match lexeme e with + | Ok (`String b) -> ( + match expect_lexeme e `Oe with + | Ok () -> Ok (Base64.decode_exn b) + | Error e -> Error e ) + | Ok l -> error e l "Bad base64 encoded character" | Error e -> Error e ) - | Ok l -> error e l "Bad base64 encoded character" - | Error e -> Error e ) | Ok l -> error e l "Invalid base64 object" | Error e -> Error e @@ -897,9 +899,9 @@ module Decode_json = struct lexeme e >>= function | `String s -> Ok (Bytes.unsafe_of_string s) | `Os -> ( - match get_base64_value e with - | Ok s -> Ok (Bytes.unsafe_of_string s) - | Error e -> Error e ) + match get_base64_value e with + | Ok s -> Ok (Bytes.unsafe_of_string s) + | Error e -> Error e ) | l -> error e l "`String" let float e = @@ -909,7 +911,7 @@ module Decode_json = struct lexeme e >>= function | `String s when String.length s = 1 -> Ok s.[0] | `Os -> ( - match get_base64_value e with Ok s -> Ok s.[0] | Error x -> Error x ) + match get_base64_value e with Ok s -> Ok s.[0] | Error x -> Error x ) | l -> error e l "`String[0]" let int32 e = float e >|= Int32.of_float @@ -935,13 +937,16 @@ module Decode_json = struct let pair a b e = expect_lexeme e `As >>= fun () -> - a e >>= fun x -> b e >>= fun y -> expect_lexeme e `Ae >|= fun () -> (x, y) + a e >>= fun x -> + b e >>= fun y -> + expect_lexeme e `Ae >|= fun () -> (x, y) let triple a b c e = expect_lexeme e `As >>= fun () -> a e >>= fun x -> b e >>= fun y -> - c e >>= fun z -> expect_lexeme e `Ae >|= fun () -> (x, y, z) + c e >>= fun z -> + expect_lexeme e `Ae >|= fun () -> (x, y, z) let option o e = lexeme e >>= function @@ -992,8 +997,8 @@ module Decode_json = struct | l -> error e l "`Record-contents" in soup [] >>= fun soup -> - let rec aux : type a b. - (a, b) fields -> b -> (a, [ `Msg of string ]) result = + let rec aux : + type a b. (a, b) fields -> b -> (a, [ `Msg of string ]) result = fun f c -> match f with | F0 -> Ok c @@ -1045,7 +1050,8 @@ module Decode_json = struct if i < Array.length v.vcases then aux (i + 1) else Error (`Msg "variant") in - aux 0 >>= fun c -> expect_lexeme e `Oe >|= fun () -> c + aux 0 >>= fun c -> + expect_lexeme e `Oe >|= fun () -> c | l -> error e l "`Name" end @@ -1097,19 +1103,27 @@ module Size_of = struct let list l n x = let init = len (List.length x) n in List.fold_left - (fun acc x -> acc >>= fun acc -> l x >|= fun l -> acc + l) + (fun acc x -> + acc >>= fun acc -> + l x >|= fun l -> acc + l) (Some init) x let array l n x = let init = len (Array.length x) n in Array.fold_left - (fun acc x -> acc >>= fun acc -> l x >|= fun l -> acc + l) + (fun acc x -> + acc >>= fun acc -> + l x >|= fun l -> acc + l) (Some init) x - let pair a b (x, y) = a x >>= fun a -> b y >|= fun b -> a + b + let pair a b (x, y) = + a x >>= fun a -> + b y >|= fun b -> a + b let triple a b c (x, y, z) = - a x >>= fun a -> b y >>= fun b -> c z >|= fun c -> a + b + c + a x >>= fun a -> + b y >>= fun b -> + c z >|= fun c -> a + b + c let option o = function | None -> Some (char '\000') @@ -1155,7 +1169,9 @@ module Size_of = struct fun r ?headers:_ x -> let fields = fields r in List.fold_left - (fun acc (Field f) -> acc >>= fun acc -> field f x >|= fun f -> acc + f) + (fun acc (Field f) -> + acc >>= fun acc -> + field f x >|= fun f -> acc + f) (Some 0) fields and field : type a b. (a, b) field -> a size_of = @@ -1454,11 +1470,13 @@ module Decode_bin = struct let array l len buf ofs = list l len buf ofs >|= Array.of_list let pair a b buf ofs = - a buf ofs >>= fun (ofs, a) -> b buf ofs >|= fun b -> (a, b) + a buf ofs >>= fun (ofs, a) -> + b buf ofs >|= fun b -> (a, b) let triple a b c buf ofs = a buf ofs >>= fun (ofs, a) -> - b buf ofs >>= fun (ofs, b) -> c buf ofs >|= fun c -> (a, b, c) + b buf ofs >>= fun (ofs, b) -> + c buf ofs >|= fun c -> (a, b, c) let option : type a. a decode_bin -> a option decode_bin = fun o ?headers:_ buf ofs -> @@ -1620,7 +1638,7 @@ let like ?cli ?json ?bin ?equal ?compare ?short_hash:h ?pre_hash:p t = match equal with | Some x -> x | None -> ( - match compare with Some f -> fun x y -> f x y = 0 | None -> Equal.t t ) + match compare with Some f -> fun x y -> f x y = 0 | None -> Equal.t t ) in let compare = match compare with Some x -> x | None -> Compare.t t in let short_hash ?seed = @@ -1630,7 +1648,8 @@ let like ?cli ?json ?bin ?equal ?compare ?short_hash:h ?pre_hash:p t = match p with Some x -> x | None -> encode_bin ?headers:(Some false) in Custom - { cwit = `Type t; + { + cwit = `Type t; pp; of_string; encode_json; @@ -1641,7 +1660,7 @@ let like ?cli ?json ?bin ?equal ?compare ?short_hash:h ?pre_hash:p t = compare; equal; short_hash; - pre_hash + pre_hash; } let map ?cli ?json ?bin ?equal ?compare ?short_hash ?pre_hash x f g = diff --git a/vendors/irmin/watch.ml b/vendors/irmin/watch.ml index cd188da31d6b..779440e06808 100644 --- a/vendors/irmin/watch.ml +++ b/vendors/irmin/watch.ml @@ -92,7 +92,7 @@ let scheduler () = Lwt.async (fun () -> (* FIXME: we would like to skip some updates if more recent ones are at the back of the queue. *) - Lwt_stream.iter_s (fun f -> f ()) stream ); + Lwt_stream.iter_s (fun f -> f ()) stream); p := Some push; (c := fun () -> push None); push elt @@ -161,7 +161,7 @@ struct (* destroy the notification thread. *) mutable listeners : int; (* number of listeners. *) - mutable stop_listening : unit -> unit Lwt.t + mutable stop_listening : unit -> unit Lwt.t; (* clean-up listen resources. *) } @@ -186,12 +186,13 @@ struct let clear t = Lwt_mutex.with_lock t.lock (fun () -> clear_unsafe t; - Lwt.return_unit ) + Lwt.return_unit) let v () = let lock = Lwt_mutex.create () in let clean, enqueue = scheduler () in - { lock; + { + lock; clean; enqueue; id = global (); @@ -199,7 +200,7 @@ struct keys = IMap.empty; glob = IMap.empty; listeners = 0; - stop_listening = (fun () -> Lwt.return_unit) + stop_listening = (fun () -> Lwt.return_unit); } let unwatch_unsafe t id = @@ -213,7 +214,7 @@ struct Lwt_mutex.with_lock t.lock (fun () -> unwatch_unsafe t id; if is_empty t then t.clean (); - Lwt.return_unit ) + Lwt.return_unit) let mk old value = match (old, value) with @@ -226,8 +227,8 @@ struct Lwt.catch f (fun e -> Log.err (fun l -> l "watch callback got: %a\n%s" Fmt.exn e - (Printexc.get_backtrace ()) ); - Lwt.return_unit ) + (Printexc.get_backtrace ())); + Lwt.return_unit) let notify_all_unsafe t key value = let todo = ref [] in @@ -238,7 +239,7 @@ struct Log.debug (fun f -> f "notify-all[%d.%d]: firing! (v=%a)" t.id id Fmt.(Dump.option pp_value) - old_value ); + old_value); todo := protect (fun () -> f key (mk old_value value)) :: !todo; let init = match value with @@ -252,9 +253,9 @@ struct in if equal_opt_values old_value value then ( Log.debug (fun f -> - f "notify-all[%d:%d]: same value, skipping." t.id id ); + f "notify-all[%d:%d]: same value, skipping." t.id id); IMap.add id arg acc ) - else fire old_value ) + else fire old_value) t.glob IMap.empty in t.glob <- glob; @@ -270,12 +271,12 @@ struct if not (equal_keys key k) then IMap.add id arg acc else if equal_opt_values value old_value then ( Log.debug (fun f -> - f "notify-key[%d.%d]: same value, skipping." t.id id ); + f "notify-key[%d.%d]: same value, skipping." t.id id); IMap.add id arg acc ) else ( Log.debug (fun f -> f "notify-key[%d:%d] firing!" t.id id); todo := protect (fun () -> f (mk old_value value)) :: !todo; - IMap.add id (k, value, f) acc ) ) + IMap.add id (k, value, f) acc )) t.keys IMap.empty in t.keys <- keys; @@ -289,7 +290,7 @@ struct else ( notify_all_unsafe t key value; notify_key_unsafe t key value; - Lwt.return_unit ) ) + Lwt.return_unit )) let watch_key_unsafe t key ?init f = let id = next t in @@ -300,7 +301,7 @@ struct let watch_key t key ?init f = Lwt_mutex.with_lock t.lock (fun () -> let id = watch_key_unsafe t ?init key f in - Lwt.return id ) + Lwt.return id) let kmap_of_alist l = List.fold_left (fun map (k, v) -> KMap.add k v map) KMap.empty l @@ -314,7 +315,7 @@ struct let watch t ?init f = Lwt_mutex.with_lock t.lock (fun () -> let id = watch_unsafe t ?init f in - Lwt.return id ) + Lwt.return id) let listen_dir t dir ~key ~value = let init () = @@ -323,7 +324,7 @@ struct !listen_dir_hook t.id dir (fun file -> match key file with | None -> Lwt.return_unit - | Some key -> value key >>= notify t key ) + | Some key -> value key >>= notify t key) >|= fun f -> t.stop_listening <- f ) else ( Log.debug (fun f -> f "%s: already listening on %s" (to_string t) dir); -- GitLab From 02e1f0bcf1a7a7a35f9117884dc1b7cf79c48e18 Mon Sep 17 00:00:00 2001 From: Pierre Boutillier Date: Wed, 14 Aug 2019 14:26:35 +0200 Subject: [PATCH 09/17] Irmin-pack: bigger constants --- vendors/irmin-pack/irmin_pack.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/vendors/irmin-pack/irmin_pack.ml b/vendors/irmin-pack/irmin_pack.ml index fb541960f977..47535f1163d6 100644 --- a/vendors/irmin-pack/irmin_pack.ml +++ b/vendors/irmin-pack/irmin_pack.ml @@ -26,11 +26,11 @@ let fresh_key = let lru_size_key = Irmin.Private.Conf.key ~doc:"Size of the LRU cache for pack entries." - "lru-size" Irmin.Private.Conf.int 10_000 + "lru-size" Irmin.Private.Conf.int 100_000 let index_log_size_key = Irmin.Private.Conf.key ~doc:"Size of index logs." "index-log-size" - Irmin.Private.Conf.int 10_000 + Irmin.Private.Conf.int 500_000 let readonly_key = Irmin.Private.Conf.key ~doc:"Start with a read-only disk." "readonly" @@ -61,7 +61,7 @@ let root config = | Some r -> r let config ?(fresh = false) ?(shared = true) ?(readonly = false) - ?(lru_size = 10_000) ?(index_log_size = 10_000) root = + ?(lru_size = 100_000) ?(index_log_size = 500_000) root = let config = Irmin.Private.Conf.empty in let config = Irmin.Private.Conf.add config fresh_key fresh in let config = Irmin.Private.Conf.add config root_key (Some root) in -- GitLab From 89e376b520881ca35c2777471a7953a21d1966b8 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Mon, 26 Aug 2019 23:09:09 +0200 Subject: [PATCH 10/17] [irmin, irmin-pack, index] update to latest versions --- vendors/index/src/index.ml | 281 ++++++++++++++------------- vendors/index/src/index.mli | 14 +- vendors/index/src/io.mli | 2 + vendors/index/src/unix/index_unix.ml | 2 + vendors/irmin-pack/irmin_pack.ml | 8 +- vendors/irmin-pack/pack_index.ml | 8 +- vendors/irmin-pack/pack_index.mli | 8 +- vendors/irmin/type.ml | 12 +- 8 files changed, 169 insertions(+), 166 deletions(-) diff --git a/vendors/index/src/index.ml b/vendors/index/src/index.ml index a491b502675d..8d5167e1a1a5 100644 --- a/vendors/index/src/index.ml +++ b/vendors/index/src/index.ml @@ -37,13 +37,7 @@ module type S = sig type value - val v : - ?fresh:bool -> - ?readonly:bool -> - ?shared:bool -> - log_size:int -> - string -> - t + val v : ?fresh:bool -> ?readonly:bool -> log_size:int -> string -> t val clear : t -> unit @@ -51,6 +45,10 @@ module type S = sig val mem : t -> key -> bool + exception Invalid_Key_Size of key + + exception Invalid_Value_Size of value + val add : t -> key -> value -> unit val iter : (key -> value -> unit) -> t -> unit @@ -71,7 +69,7 @@ module Make (K : Key) (V : Value) (IO : IO) = struct type value = V.t - type entry = { key : key; value : value } + type entry = { key : key; key_hash : int; value : value } let entry_size = K.encoded_size + V.encoded_size @@ -79,15 +77,25 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let entry_sizeL = Int64.of_int entry_size + exception Invalid_Key_Size of key + + exception Invalid_Value_Size of value + let append_entry io e = - IO.append io (K.encode e.key); - IO.append io (V.encode e.value) + let encoded_key = K.encode e.key in + let encoded_value = V.encode e.value in + if String.length encoded_key <> K.encoded_size then + raise (Invalid_Key_Size e.key); + if String.length encoded_value <> V.encoded_size then + raise (Invalid_Value_Size e.value); + IO.append io encoded_key; + IO.append io encoded_value let decode_entry bytes off = let string = Bytes.unsafe_to_string bytes in let key = K.decode string off in let value = V.decode string (off + K.encoded_size) in - { key; value } + { key; key_hash = K.hash key; value } module Tbl = Hashtbl.Make (K) @@ -111,7 +119,11 @@ module Make (K : Key) (V : Value) (IO : IO) = struct IO.clear t.log; may Bloomf.clear t.entries; Tbl.clear t.log_mem; - may (fun i -> IO.clear i.io) t.index; + may + (fun i -> + IO.clear i.io; + IO.close i.io) + t.index; t.index <- None let ( // ) = Filename.concat @@ -145,39 +157,40 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let iter_io ?min ?max f io = iter_io_off ?min ?max (fun _ e -> f e) io - let get_entry io off = - let buf = Bytes.create entry_size in - let _ = IO.read io ~off buf in - decode_entry buf 0 + type window = { buf: bytes; off: int64 } + + let get_entry io ~window off = + match window with + | None -> + let buf = Bytes.create entry_size in + let _ = IO.read io ~off buf in + decode_entry buf 0 + | Some w -> + let off = Int64.(to_int @@ sub off w.off) in + decode_entry w.buf off let with_cache ~v ~clear = let roots = Hashtbl.create 0 in - let f ?(fresh = false) ?(readonly = false) ?(shared = true) ~log_size root - = - if not shared then ( - Log.debug (fun l -> - l "[%s] v fresh=%b shared=%b readonly=%b" (Filename.basename root) - fresh shared readonly); - v ~fresh ~readonly ~log_size root ) - else - try - if not (Sys.file_exists root) then ( - Log.debug (fun l -> - l "[%s] does not exist anymore, cleaning up the fd cache" - (Filename.basename root)); - Hashtbl.remove roots root; - raise Not_found ); - let t = Hashtbl.find roots root in - Log.debug (fun l -> l "%s found in cache" root); - if fresh then clear t; - t - with Not_found -> + let f ?(fresh = false) ?(readonly = false) ~log_size root = + try + if not (Sys.file_exists root) then ( Log.debug (fun l -> - l "[%s] v fresh=%b shared=%b readonly=%b" - (Filename.basename root) fresh shared readonly); - let t = v ~fresh ~readonly ~log_size root in - Hashtbl.add roots root t; - t + l "[%s] does not exist anymore, cleaning up the fd cache" + (Filename.basename root)); + Hashtbl.remove roots (root, true); + Hashtbl.remove roots (root, false); + raise Not_found ); + let t = Hashtbl.find roots (root, readonly) in + Log.debug (fun l -> l "%s found in cache" root); + if fresh then clear t; + t + with Not_found -> + Log.debug (fun l -> + l "[%s] v fresh=%b readonly=%b" (Filename.basename root) fresh + readonly); + let t = v ~fresh ~readonly ~log_size root in + Hashtbl.add roots (root, readonly) t; + t in `Staged f @@ -216,17 +229,17 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let (`Staged v) = with_cache ~v:v_no_cache ~clear - let get_entry_iff_needed io off = function + let get_entry_iff_needed ~window io off = function | Some e -> e - | None -> get_entry io off + | None -> get_entry ~window io off - let look_around io init key h_key off = + let look_around ~window io init ~low ~high key h_key off = let rec search acc op curr = let off = op curr entry_sizeL in - if off < 0L || off >= IO.offset io then acc + if off < 0L || off >= IO.offset io || off < low || off > high then acc else - let e = get_entry io off in - let h_e = K.hash e.key in + let e = get_entry ~window io off in + let h_e = e.key_hash in if h_e <> h_key then acc else let new_acc = if K.equal e.key key then e.value :: acc else acc in @@ -238,20 +251,32 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let interpolation_search index key = let hashed_key = K.hash key in let low, high = Fan.search index.fan_out hashed_key in - let rec search low high lowest_entry highest_entry = + let rec search steps ~window low high lowest_entry highest_entry = if high < low then [] else - let lowest_entry = get_entry_iff_needed index.io low lowest_entry in + let window = match window with + | Some _ as w -> w + | None -> + let len = Int64.(add (sub high low) entry_sizeL) in + if len <= 4_096L then ( + let buf = Bytes.create (Int64.to_int len) in + let _ = IO.read index.io ~off:low buf in + Some { buf; off = low } + ) else None + in + let lowest_entry = + get_entry_iff_needed ~window index.io low lowest_entry + in if high = low then if K.equal lowest_entry.key key then [ lowest_entry.value ] else [] else - let lowest_hash = K.hash lowest_entry.key in + let lowest_hash = lowest_entry.key_hash in if lowest_hash > hashed_key then [] else let highest_entry = - get_entry_iff_needed index.io high highest_entry + get_entry_iff_needed ~window index.io high highest_entry in - let highest_hash = K.hash highest_entry.key in + let highest_hash = highest_entry.key_hash in if highest_hash < hashed_key then [] else let lowest_hashf = float_of_int lowest_hash in @@ -267,21 +292,22 @@ module Make (K : Key) (V : Value) (IO : IO) = struct in let off = lowf +. doff -. mod_float doff entry_sizef in let offL = Int64.of_float off in - let e = get_entry index.io offL in - let hashed_e = K.hash e.key in + let e = get_entry ~window index.io offL in + let hashed_e = e.key_hash in if hashed_key = hashed_e then let init = if K.equal key e.key then [ e.value ] else [] in - look_around index.io init key hashed_key offL + look_around ~window ~low ~high index.io init key hashed_key offL else if hashed_e < hashed_key then - (search [@tailcall]) + (search [@tailcall]) (steps + 1) ~window (Int64.add offL entry_sizeL) high None (Some highest_entry) else - (search [@tailcall]) low + (search [@tailcall]) (steps + 1) ~window low (Int64.sub offL entry_sizeL) (Some lowest_entry) None in - if high < 0L then [] else (search [@tailcall]) low high None None + if high < 0L then [] else + (search [@tailcall]) ~window:None 0 low high None None let sync_log t = let generation = IO.get_generation t.log in @@ -295,6 +321,7 @@ module Make (K : Key) (V : Value) (IO : IO) = struct Tbl.clear t.log_mem; iter_io add_log_entry t.log; let index_path = index_path t.root in + may (fun i -> IO.close i.io) t.index; let io = IO.v ~fresh:false ~readonly:true ~generation index_path in let _ = IO.force_offset io in let io_off = IO.force_offset io in @@ -304,7 +331,7 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let fan_out = Fan.v ~hash_size:K.hash_size ~entry_size fan_out_size in iter_io_off (fun off e -> - let hash = K.hash e.key in + let hash = e.key_hash in Fan.update fan_out hash off) io; Fan.finalize fan_out; @@ -334,80 +361,74 @@ module Make (K : Key) (V : Value) (IO : IO) = struct Log.debug (fun l -> l "mem %a" K.pp key); match find_all t key with [] -> false | _ -> true - let append_entry_fanout fan_out h io e = - Fan.update fan_out h (IO.offset io); - append_entry io e - - let merge_with log index tmp = - let offset = ref 0L in - let get_index_entry = function - | Some e -> Some e - | None -> - if !offset >= IO.offset index.io then None - else - let e = get_entry index.io !offset in - offset := Int64.add !offset entry_sizeL; - Some e - in + let append_buf_fanout fan_out hash buf_str dst_io = + Fan.update fan_out hash (IO.offset dst_io); + IO.append dst_io buf_str + + let append_entry_fanout fan_out entry dst_io = + Fan.update fan_out entry.key_hash (IO.offset dst_io); + append_entry dst_io entry + + let rec merge_from_log fan_out log log_i hash_e dst_io = + if log_i >= Array.length log then log_i + else + let v = log.(log_i) in + if v.key_hash > hash_e then log_i + else ( + append_entry_fanout fan_out v dst_io; + (merge_from_log [@tailcall]) fan_out log (log_i + 1) hash_e dst_io ) + + let append_remaining_log fan_out log log_i dst_io = + for log_i = log_i to Array.length log - 1 do + append_entry_fanout fan_out log.(log_i) dst_io + done + + (** Merge [log] with [t] into [dst_io]. + [log] must be sorted by key hashes. *) + let merge_with log index dst_io = + let entries = 10_000 in + let buf = Bytes.create (entries * entry_size) in + let refill off = ignore (IO.read index.io ~off buf) in + let index_end = IO.offset index.io in let fan_out = index.fan_out in - let rec go last_read l = - match get_index_entry last_read with - | None -> - List.iter - (fun v -> - let hashed_v = K.hash v.key in - append_entry_fanout fan_out hashed_v tmp v) - l - | Some e -> ( - let hashed_e = K.hash e.key in - match l with - | v :: r -> - let last, rst = - let hashed_v = K.hash v.key in - if hashed_e = hashed_v then ( - append_entry_fanout fan_out hashed_e tmp e; - append_entry_fanout fan_out hashed_v tmp v; - (None, r) ) - else if hashed_e < hashed_v then ( - append_entry_fanout fan_out hashed_e tmp e; - (None, l) ) - else ( - append_entry_fanout fan_out hashed_v tmp v; - (Some e, r) ) - in - if !offset >= IO.offset index.io && last = None then - List.iter - (fun v -> - let hashed_v = K.hash v.key in - append_entry_fanout fan_out hashed_v tmp v) - rst - else (go [@tailcall]) last rst - | [] -> - append_entry_fanout fan_out hashed_e tmp e; - iter_io - (fun e -> - let hashed_e = K.hash e.key in - append_entry_fanout fan_out hashed_e tmp e) - index.io ~min:!offset ) + refill 0L; + let rec go index_offset buf_offset log_i = + if index_offset >= index_end then + append_remaining_log fan_out log log_i dst_io + else ( + let buf_str = Bytes.sub_string buf buf_offset entry_size in + let index_offset = Int64.add index_offset entry_sizeL in + let key_e = K.decode buf_str 0 in + let hash_e = K.hash key_e in + let log_i = merge_from_log fan_out log log_i hash_e dst_io in + append_buf_fanout fan_out hash_e buf_str dst_io; + let buf_offset = + let n = buf_offset + entry_size in + if n >= Bytes.length buf then ( + refill index_offset; + 0 + ) else n + in + (go [@tailcall]) index_offset buf_offset log_i ) in - (go [@tailcall]) None log - - module EntrySet = Set.Make (struct - type t = entry - - let compare e e' = - let c = compare (K.hash e.key) (K.hash e'.key) in - if c = 0 then 1 else c - end) + (go [@tailcall]) 0L 0 0 - let merge t = + let merge ~witness t = Log.debug (fun l -> l "merge %S" t.root); let tmp_path = t.root // "tmp" // "index" in let generation = Int64.succ t.generation in let tmp = IO.v ~readonly:false ~fresh:true ~generation tmp_path in let log = - Tbl.fold (fun _ e acc -> EntrySet.add e acc) t.log_mem EntrySet.empty - |> EntrySet.elements + let compare_entry e e' = compare e.key_hash e'.key_hash in + let b = Array.make (Tbl.length t.log_mem) witness in + Tbl.fold + (fun _ e i -> + b.(i) <- e; + i + 1) + t.log_mem 0 + |> ignore; + Array.fast_sort compare_entry b; + b in ( match t.index with | None -> @@ -416,11 +437,7 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let io = IO.v ~fresh:true ~readonly:false ~generation:0L (index_path t.root) in - List.iter - (fun v -> - let hashed_v = K.hash v.key in - append_entry_fanout fan_out hashed_v tmp v) - log; + append_remaining_log fan_out log 0 tmp; t.index <- Some { io; fan_out } | Some index -> let fan_out_size = @@ -444,12 +461,12 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let add t key value = Log.debug (fun l -> l "add %a %a" K.pp key V.pp value); if t.config.readonly then raise RO_Not_Allowed; - let entry = { key; value } in + let entry = { key; key_hash = K.hash key; value } in append_entry t.log entry; Tbl.add t.log_mem key entry; may (fun bf -> Bloomf.add bf key) t.entries; if Int64.compare (IO.offset t.log) (Int64.of_int t.config.log_size) > 0 - then merge t + then merge ~witness:entry t (* XXX: Perform a merge beforehands to ensure duplicates are not hit twice. *) let iter f t = diff --git a/vendors/index/src/index.mli b/vendors/index/src/index.mli index 8cac503ccee7..1c48451bdb39 100644 --- a/vendors/index/src/index.mli +++ b/vendors/index/src/index.mli @@ -74,13 +74,7 @@ module type S = sig type value (** The type for values. *) - val v : - ?fresh:bool -> - ?readonly:bool -> - ?shared:bool -> - log_size:int -> - string -> - t + val v : ?fresh:bool -> ?readonly:bool -> log_size:int -> string -> t (** The constructor for indexes. @param fresh @param read_only whether read-only mode is enabled for this index. @@ -98,6 +92,12 @@ module type S = sig val mem : t -> key -> bool (** [mem t k] is [true] iff [k] is bound in [t]. *) + exception Invalid_Key_Size of key + + exception Invalid_Value_Size of value + (** The exceptions raised when trying to add a key or a value of different + size than encoded_size *) + val add : t -> key -> value -> unit (** [add t k v] binds [k] to [v] in [t]. *) diff --git a/vendors/index/src/io.mli b/vendors/index/src/io.mli index 02ecfdb9f937..84c974bfe1e7 100644 --- a/vendors/index/src/io.mli +++ b/vendors/index/src/io.mli @@ -26,4 +26,6 @@ module type S = sig val rename : src:t -> dst:t -> unit val append : t -> string -> unit + + val close : t -> unit end diff --git a/vendors/index/src/unix/index_unix.ml b/vendors/index/src/unix/index_unix.ml index 4c04a5b6b3a1..02924a7ccbf1 100644 --- a/vendors/index/src/unix/index_unix.ml +++ b/vendors/index/src/unix/index_unix.ml @@ -137,6 +137,8 @@ module IO : Index.IO = struct dst.flushed <- src.flushed; dst.raw <- src.raw + let close t = Unix.close t.raw.fd + let auto_flush_limit = 1_000_000L let append t buf = diff --git a/vendors/irmin-pack/irmin_pack.ml b/vendors/irmin-pack/irmin_pack.ml index 47535f1163d6..15a00e26b648 100644 --- a/vendors/irmin-pack/irmin_pack.ml +++ b/vendors/irmin-pack/irmin_pack.ml @@ -26,11 +26,11 @@ let fresh_key = let lru_size_key = Irmin.Private.Conf.key ~doc:"Size of the LRU cache for pack entries." - "lru-size" Irmin.Private.Conf.int 100_000 + "lru-size" Irmin.Private.Conf.int 10_000 let index_log_size_key = Irmin.Private.Conf.key ~doc:"Size of index logs." "index-log-size" - Irmin.Private.Conf.int 500_000 + Irmin.Private.Conf.int 10_000 let readonly_key = Irmin.Private.Conf.key ~doc:"Start with a read-only disk." "readonly" @@ -61,7 +61,7 @@ let root config = | Some r -> r let config ?(fresh = false) ?(shared = true) ?(readonly = false) - ?(lru_size = 100_000) ?(index_log_size = 500_000) root = + ?(lru_size = 10_000) ?(index_log_size = 10_000) root = let config = Irmin.Private.Conf.empty in let config = Irmin.Private.Conf.add config fresh_key fresh in let config = Irmin.Private.Conf.add config root_key (Some root) in @@ -392,7 +392,7 @@ struct let readonly = readonly config in let shared = shared config in let log_size = index_log_size config in - let index = Index.v ~fresh ~shared ~readonly ~log_size root in + let index = Index.v ~fresh ~readonly ~log_size root in Contents.CA.v ~fresh ~shared ~readonly ~lru_size ~index root >>= fun contents -> Node.CA.v ~fresh ~shared ~readonly ~lru_size ~index root diff --git a/vendors/irmin-pack/pack_index.ml b/vendors/irmin-pack/pack_index.ml index c954c693ec3a..c49f82b48d4f 100644 --- a/vendors/irmin-pack/pack_index.ml +++ b/vendors/irmin-pack/pack_index.ml @@ -17,13 +17,7 @@ module type S = sig type value = int64 * int * char - val v : - ?fresh:bool -> - ?readonly:bool -> - ?shared:bool -> - log_size:int -> - string -> - t + val v : ?fresh:bool -> ?readonly:bool -> log_size:int -> string -> t val clear : t -> unit diff --git a/vendors/irmin-pack/pack_index.mli b/vendors/irmin-pack/pack_index.mli index a3744ee22fd1..1950425920bb 100644 --- a/vendors/irmin-pack/pack_index.mli +++ b/vendors/irmin-pack/pack_index.mli @@ -17,13 +17,7 @@ module type S = sig type value = int64 * int * char - val v : - ?fresh:bool -> - ?readonly:bool -> - ?shared:bool -> - log_size:int -> - string -> - t + val v : ?fresh:bool -> ?readonly:bool -> log_size:int -> string -> t val clear : t -> unit diff --git a/vendors/irmin/type.ml b/vendors/irmin/type.ml index 18619ccaec70..92d580492203 100644 --- a/vendors/irmin/type.ml +++ b/vendors/irmin/type.ml @@ -1593,19 +1593,13 @@ let of_string t = type 'a ty = 'a t -let ( %% ) (h1 : int) (h2 : int) : int = Hashtbl.hash (h1, h2) - let short_hash t ?seed x = match t with | Custom c -> c.short_hash ?seed x | _ -> - let hash = - match seed with - | None -> Hashtbl.hash - | Some s -> Hashtbl.seeded_hash s - in - let h = ref 0 in - pre_hash t x (fun s -> h := hash s %% !h); + let seed = match seed with None -> 0 | Some t -> t in + let h = ref seed in + pre_hash t x (fun s -> h := Hashtbl.seeded_hash !h s); !h let like ?cli ?json ?bin ?equal ?compare ?short_hash:h ?pre_hash:p t = -- GitLab From b55e68c089d048231327f175d28de494707d2e5c Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Tue, 27 Aug 2019 08:33:53 +0200 Subject: [PATCH 11/17] [index] use pread and pwrite instead of lseek --- vendors/index/src/unix/dune | 1 + vendors/index/src/unix/index_unix.ml | 47 ++++++++++++++-------------- vendors/index/src/unix/pread.c | 28 +++++++++++++++++ vendors/index/src/unix/pwrite.c | 29 +++++++++++++++++ vendors/irmin-pack/irmin_pack.ml | 27 +++++++++++----- 5 files changed, 102 insertions(+), 30 deletions(-) create mode 100644 vendors/index/src/unix/pread.c create mode 100644 vendors/index/src/unix/pwrite.c diff --git a/vendors/index/src/unix/dune b/vendors/index/src/unix/dune index 4744ee748595..22261fcb8e34 100644 --- a/vendors/index/src/unix/dune +++ b/vendors/index/src/unix/dune @@ -1,4 +1,5 @@ (library (public_name index.unix) (name index_unix) + (c_names pread pwrite) (libraries unix index)) diff --git a/vendors/index/src/unix/index_unix.ml b/vendors/index/src/unix/index_unix.ml index 02924a7ccbf1..7d4c658441ca 100644 --- a/vendors/index/src/unix/index_unix.ml +++ b/vendors/index/src/unix/index_unix.ml @@ -32,37 +32,38 @@ module IO : Index.IO = struct let v fd = { fd; cursor = 0L } - let really_write fd buf = - let rec aux off len = - let w = Unix.write fd buf off len in - if w = 0 then () else (aux [@tailcall]) (off + w) (len - w) - in - (aux [@tailcall]) 0 (Bytes.length buf) - - let really_read fd len buf = - let rec aux off len = - let r = Unix.read fd buf off len in - if r = 0 then off (* end of file *) - else if r = len then off + r - else (aux [@tailcall]) (off + r) (len - r) + external pread : Unix.file_descr -> int64 -> bytes -> int -> int -> int + = "caml_pread" + + external pwrite : Unix.file_descr -> int64 -> bytes -> int -> int -> int + = "caml_pwrite" + + let really_write fd off buf = + let rec aux fd_off buf_off len = + let w = pwrite fd fd_off buf buf_off len in + if w = 0 then () + else + (aux [@tailcall]) (fd_off ++ Int64.of_int w) (buf_off + w) (len - w) in - (aux [@tailcall]) 0 len + (aux [@tailcall]) off 0 (Bytes.length buf) - let lseek t off = - if off = t.cursor then () - else - let _ = Unix.LargeFile.lseek t.fd off Unix.SEEK_SET in - t.cursor <- off + let really_read fd off len buf = + let rec aux fd_off buf_off len = + let r = pread fd fd_off buf buf_off len in + if r = 0 then buf_off (* end of file *) + else if r = len then buf_off + r + else + (aux [@tailcall]) (fd_off ++ Int64.of_int r) (buf_off + r) (len - r) + in + (aux [@tailcall]) off 0 len let unsafe_write t ~off buf = - lseek t off; let buf = Bytes.unsafe_of_string buf in - really_write t.fd buf; + really_write t.fd off buf; t.cursor <- off ++ Int64.of_int (Bytes.length buf) let unsafe_read t ~off ~len buf = - lseek t off; - let n = really_read t.fd len buf in + let n = really_read t.fd off len buf in t.cursor <- off ++ Int64.of_int n; n diff --git a/vendors/index/src/unix/pread.c b/vendors/index/src/unix/pread.c new file mode 100644 index 000000000000..319be8bb9371 --- /dev/null +++ b/vendors/index/src/unix/pread.c @@ -0,0 +1,28 @@ +#include +#include +#include +#include +#include + +CAMLprim value caml_pread +(value v_fd, value v_fd_off, value v_buf, value v_buf_off, value v_len) +{ + CAMLparam5(v_fd, v_fd_off, v_buf, v_buf_off, v_len); + + ssize_t ret; + size_t fd = Int_val(v_fd); + size_t fd_off = Int64_val(v_fd_off); + size_t buf_off = Long_val(v_buf_off); + size_t len = Long_val(v_len); + char iobuf[UNIX_BUFFER_SIZE]; + + size_t numbytes = (len > UNIX_BUFFER_SIZE) ? UNIX_BUFFER_SIZE : len; + caml_enter_blocking_section(); + ret = pread(fd, iobuf, numbytes, fd_off); + caml_leave_blocking_section(); + + if (ret == -1) uerror("read", Nothing); + memcpy(&Byte(v_buf, buf_off), iobuf, ret); + + CAMLreturn(Val_long(ret)); +} diff --git a/vendors/index/src/unix/pwrite.c b/vendors/index/src/unix/pwrite.c new file mode 100644 index 000000000000..16b05f47f425 --- /dev/null +++ b/vendors/index/src/unix/pwrite.c @@ -0,0 +1,29 @@ +#include +#include +#include +#include +#include + +CAMLprim value caml_pwrite +(value v_fd, value v_fd_off, value v_buf, value v_buf_off, value v_len) +{ + CAMLparam5(v_fd, v_fd_off, v_buf, v_buf_off, v_len); + + ssize_t ret; + size_t fd = Int_val(v_fd); + size_t fd_off = Int64_val(v_fd_off); + size_t buf_off = Long_val(v_buf_off); + size_t len = Long_val(v_len); + char iobuf[UNIX_BUFFER_SIZE]; + + size_t numbytes = (len > UNIX_BUFFER_SIZE) ? UNIX_BUFFER_SIZE : len; + memcpy(iobuf, &Byte(v_buf, buf_off), numbytes); + + caml_enter_blocking_section(); + ret = pwrite(fd, iobuf, numbytes, fd_off); + caml_leave_blocking_section(); + + if (ret == -1) uerror("read", Nothing); + + CAMLreturn(Val_long(ret)); +} diff --git a/vendors/irmin-pack/irmin_pack.ml b/vendors/irmin-pack/irmin_pack.ml index 15a00e26b648..ec249fbe563a 100644 --- a/vendors/irmin-pack/irmin_pack.ml +++ b/vendors/irmin-pack/irmin_pack.ml @@ -20,28 +20,40 @@ module Log = (val Logs.src_log src : Logs.LOG) let current_version = "00000001" +module Default = struct + let fresh = false + + let lru_size = 100_000 + + let index_log_size = 500_000 + + let readonly = false + + let shared = true +end + let fresh_key = Irmin.Private.Conf.key ~doc:"Start with a fresh disk." "fresh" - Irmin.Private.Conf.bool false + Irmin.Private.Conf.bool Default.fresh let lru_size_key = Irmin.Private.Conf.key ~doc:"Size of the LRU cache for pack entries." - "lru-size" Irmin.Private.Conf.int 10_000 + "lru-size" Irmin.Private.Conf.int Default.lru_size let index_log_size_key = Irmin.Private.Conf.key ~doc:"Size of index logs." "index-log-size" - Irmin.Private.Conf.int 10_000 + Irmin.Private.Conf.int Default.index_log_size let readonly_key = Irmin.Private.Conf.key ~doc:"Start with a read-only disk." "readonly" - Irmin.Private.Conf.bool false + Irmin.Private.Conf.bool Default.readonly let shared_key = Irmin.Private.Conf.key ~doc: "Share resources (file-descriptors, caches) with other instances when \ possible." - "shared" Irmin.Private.Conf.bool false + "shared" Irmin.Private.Conf.bool Default.shared let fresh config = Irmin.Private.Conf.get config fresh_key @@ -60,8 +72,9 @@ let root config = | None -> failwith "no root set" | Some r -> r -let config ?(fresh = false) ?(shared = true) ?(readonly = false) - ?(lru_size = 10_000) ?(index_log_size = 10_000) root = +let config ?(fresh = Default.fresh) ?(shared = Default.shared) + ?(readonly = Default.readonly) ?(lru_size = Default.lru_size) + ?(index_log_size = Default.index_log_size) root = let config = Irmin.Private.Conf.empty in let config = Irmin.Private.Conf.add config fresh_key fresh in let config = Irmin.Private.Conf.add config root_key (Some root) in -- GitLab From dfbae98bef626fd08096fce50f96003165a7c60b Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Tue, 27 Aug 2019 08:55:15 +0200 Subject: [PATCH 12/17] add an import script --- dune | 2 + import.ml | 172 ++++++++++++++++++++++++++++++++++++ src/lib_storage/context.ml | 2 + src/lib_storage/context.mli | 2 + 4 files changed, 178 insertions(+) create mode 100644 import.ml diff --git a/dune b/dune index 739ed4a262fd..a313a1921b5e 100644 --- a/dune +++ b/dune @@ -11,3 +11,5 @@ (alias (name runtest) (deps (alias_rec runtest_sandbox))) + +(executable (name import) (libraries tezos-storage irmin-pack)) \ No newline at end of file diff --git a/import.ml b/import.ml new file mode 100644 index 000000000000..dc9a296ad743 --- /dev/null +++ b/import.ml @@ -0,0 +1,172 @@ +open Lwt.Infix + +module Store = Tezos_storage.Context.Irmin +module P = Store.Private + +module Commit = Irmin.Private.Commit.V1(P.Commit.Val) + +module Node = struct + + module M = Irmin.Private.Node.Make (P.Hash) (Store.Key) (Store.Metadata) + + module Hash = Irmin.Hash.V1 (P.Hash) + + type kind = [`Node | `Contents] + + type entry = {key: string Lazy.t; kind: kind; name: M.step; node: Hash.t} + + (* Irmin 1.4 uses int64 to store string lengths *) + let step_t = + let pre_hash = Irmin.Type.(pre_hash (string_of `Int64)) in + Irmin.Type.like M.step_t ~pre_hash + + let metadata_t = + let some = "\255\000\000\000\000\000\000\000" in + let none = "\000\000\000\000\000\000\000\000" in + Irmin.Type.(map (string_of (`Fixed 8))) + (fun s -> + match s.[0] with + | '\255' -> Some () + | '\000' -> None + | _ -> assert false ) + (function Some _ -> some | None -> none) + + (* Irmin 1.4 uses int64 to store list lengths *) + let entry_t : entry Irmin.Type.t = + let open Irmin.Type in + record "Tree.entry" (fun kind name node -> + let kind = match kind with None -> `Node | Some () -> `Contents in + let key = + match kind with + | `Node -> lazy (name ^ "/") + | `Contents -> lazy name + in + {key; kind; name; node} ) + |+ field "kind" metadata_t (function + | {kind= `Node; _} -> None + | {kind= `Contents; _} -> Some () ) + |+ field "name" step_t (fun {name; _} -> name) + |+ field "node" Hash.t (fun {node; _} -> node) + |> sealr + + type t = entry list + + let t : t Irmin.Type.t = Irmin.Type.(list ~len:`Int64 entry_t) + + let export_entry e = match e.kind with + | `Node -> e.name, `Node e.node + | `Contents -> e.name, `Contents (e.node, ()) + + let export (t:t) = P.Node.Val.v (List.map export_entry t) +end + +let (>>*) v f = + match v with + | Ok v -> f v + | Error e -> failwith (Lmdb.string_of_error e) + +let lmdb root = + Fmt.epr "Opening lmdb context in %s...\n%!" root; + let mapsize = 409_600_000_000L in + let flags = [ Lmdb.NoRdAhead ;Lmdb.NoTLS ] in + let file_flags = 0o444 in + Lmdb.opendir ~mapsize ~flags root file_flags >>* fun t -> + Lmdb.create_ro_txn t >>* fun txn -> + Lmdb.opendb txn >>* fun db -> + db, txn + +let of_string t s = match Irmin.Type.of_bin_string t s with + | Ok s -> s + | Error (`Msg e) -> failwith e + +let hash_of_string = of_string Store.Hash.t +let contents_of_string = of_string P.Contents.Val.t +let node_of_string = of_string Node.t +let commit_of_string = of_string Commit.t + +let commits = ref 0 +let contents = ref 0 +let nodes = ref 0 + +let pp_stats ppf () = + Fmt.pf ppf "%4dk blobs / %4dk trees / %4dk commits" + (!contents / 1000) (!nodes / 1000) (!commits / 1000) + +let classify k = + match Astring.String.cut ~sep:"/" k with + | Some ("commit", key) -> `Commit (hash_of_string key) + | Some ("contents", key) -> `Contents (hash_of_string key) + | Some ("node",key) -> `Node (hash_of_string key) + | _ -> failwith "invalid key" + +let skip _ = Lwt.return () + +let key_of_entry e = + let hash = Irmin.Type.to_bin_string Store.Hash.t Node.(e.node) in + assert (String.length hash = 32); + match Node.(e.kind) with + | `Node -> "node/" ^ hash + | `Contents -> "contents/" ^ hash + +let rec append (db, txn) x y z k v = + let v = Bigstring.to_string v in + match classify k with + | `Contents k -> + incr contents; + P.Contents.unsafe_add x k (contents_of_string v) + | `Commit k -> + let c = commit_of_string v in + let c = Commit.export c in + incr commits; + P.Commit.unsafe_add z k c + | `Node k -> + P.Node.mem y k >>= function + | true -> Lwt.return () + | false -> + let n = node_of_string v in + Lwt_list.iter_s (fun e -> + P.Node.mem y Node.(e.node) >>= function + | true -> Lwt.return () + | false -> + let k = key_of_entry e in + match Lmdb.get txn db k with + | Ok v -> (append[@tailcall]) (db, txn) x y z k v + | Error e -> + Fmt.epr "\n[error] %S: %a\n%!" k Lmdb.pp_error e; + Lwt.return () + ) n + >>= fun () -> + let n = Node.export n in + incr nodes; + P.Node.unsafe_add y k n + +let move ~src:(db, txn) ~dst:repo = + let count = ref 0 in + Lmdb.opencursor txn db >>* fun c -> + Lmdb.cursor_first c >>* fun () -> + P.Repo.batch repo (fun x y z -> + Lmdb.cursor_fold_left c ~init:() ~f:(fun () (key, value) -> + incr count; + if !count mod 100 = 0 then Fmt.epr "\r%a%!" pp_stats (); + Lwt.async (fun () -> + append (db, txn) x y z (Bigstring.to_string key) value); + Ok () + ) >>* fun () -> + Lwt.return () + ) >|= fun () -> + Fmt.epr "\n[done]\n" + +let irmin root = + Fmt.epr "Creating an Irmin repository in %s...\n%!" root; + let config = Irmin_pack.config root in + Store.Repo.v config + +let run root = + let lmdb = lmdb (Filename.concat root "context") in + irmin (Filename.concat root "context-pack") >>= fun irmin -> + move ~src:lmdb ~dst:irmin + +let () = + if Array.length Sys.argv <> 2 then Fmt.epr "usage: %s " Sys.argv.(0); + let datadir = Sys.argv.(1) in + Lwt_main.run (run datadir) diff --git a/src/lib_storage/context.ml b/src/lib_storage/context.ml index f7210f686998..20d8be37b80f 100644 --- a/src/lib_storage/context.ml +++ b/src/lib_storage/context.ml @@ -903,3 +903,5 @@ let restore_contexts idx ~filename k_store_pruned_block pipeline_validation = else fail @@ Suspicious_file (total - current) ) (fun () -> Lwt_unix.close fd) + +module Irmin = Store diff --git a/src/lib_storage/context.mli b/src/lib_storage/context.mli index ea9a79faebdc..0d24b51a09d2 100644 --- a/src/lib_storage/context.mli +++ b/src/lib_storage/context.mli @@ -193,3 +193,5 @@ val validate_context_hash_consistency_and_commit : parents:Context_hash.t list -> index:index -> bool Lwt.t + +module Irmin: Irmin.KV with type metadata = unit -- GitLab From 7617f681e15e34419eb9405f1600aa7cb6b7b0fa Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Tue, 27 Aug 2019 17:16:44 +0200 Subject: [PATCH 13/17] [index, irmin] latest updates - index: minor cosmetic changes - irmin: fix perf issue with Store.Tree.is_empty --- vendors/index/src/fan.ml | 18 ++------------ vendors/index/src/index.ml | 50 +++++++++++++++++++------------------- vendors/irmin/tree.ml | 9 ++++--- 3 files changed, 33 insertions(+), 44 deletions(-) diff --git a/vendors/index/src/fan.ml b/vendors/index/src/fan.ml index 4f6ac49c4461..f63d2a5eb4dd 100644 --- a/vendors/index/src/fan.ml +++ b/vendors/index/src/fan.ml @@ -1,11 +1,4 @@ -type t = { - hash_size : int; - entry_size : int; - size : int; - fans : int64 array; - mask : int; - shift : int; -} +type t = { fans : int64 array; mask : int; shift : int } let log2 a = log a /. log 2. @@ -16,14 +9,7 @@ let v ~hash_size ~entry_size n = let size = max 0 (int_of_float (ceil (log2 entries_fan))) in let nb_fans = 1 lsl size in let shift = hash_size - size in - { - hash_size; - entry_size; - size; - fans = Array.make nb_fans 0L; - mask = (nb_fans - 1) lsl shift; - shift; - } + { fans = Array.make nb_fans 0L; mask = (nb_fans - 1) lsl shift; shift } let fan t h = (h land t.mask) lsr t.shift diff --git a/vendors/index/src/index.ml b/vendors/index/src/index.ml index 8d5167e1a1a5..6707face6c7a 100644 --- a/vendors/index/src/index.ml +++ b/vendors/index/src/index.ml @@ -157,17 +157,18 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let iter_io ?min ?max f io = iter_io_off ?min ?max (fun _ e -> f e) io - type window = { buf: bytes; off: int64 } + type window = { buf : bytes; off : int64 } let get_entry io ~window off = match window with | None -> - let buf = Bytes.create entry_size in - let _ = IO.read io ~off buf in - decode_entry buf 0 + let buf = Bytes.create entry_size in + let n = IO.read io ~off buf in + assert (n = entry_size); + decode_entry buf 0 | Some w -> - let off = Int64.(to_int @@ sub off w.off) in - decode_entry w.buf off + let off = Int64.(to_int @@ sub off w.off) in + decode_entry w.buf off let with_cache ~v ~clear = let roots = Hashtbl.create 0 in @@ -254,15 +255,17 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let rec search steps ~window low high lowest_entry highest_entry = if high < low then [] else - let window = match window with + let window = + match window with | Some _ as w -> w | None -> - let len = Int64.(add (sub high low) entry_sizeL) in - if len <= 4_096L then ( - let buf = Bytes.create (Int64.to_int len) in - let _ = IO.read index.io ~off:low buf in - Some { buf; off = low } - ) else None + let len = Int64.(add (sub high low) entry_sizeL) in + if len <= 4_096L then ( + let buf = Bytes.create (Int64.to_int len) in + let n = IO.read index.io ~off:low buf in + assert (n = Bytes.length buf); + Some { buf; off = low } ) + else None in let lowest_entry = get_entry_iff_needed ~window index.io low lowest_entry @@ -296,7 +299,8 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let hashed_e = e.key_hash in if hashed_key = hashed_e then let init = if K.equal key e.key then [ e.value ] else [] in - look_around ~window ~low ~high index.io init key hashed_key offL + look_around ~window ~low ~high index.io init key hashed_key + offL else if hashed_e < hashed_key then (search [@tailcall]) (steps + 1) ~window (Int64.add offL entry_sizeL) @@ -306,24 +310,20 @@ module Make (K : Key) (V : Value) (IO : IO) = struct (Int64.sub offL entry_sizeL) (Some lowest_entry) None in - if high < 0L then [] else - (search [@tailcall]) ~window:None 0 low high None None + if high < 0L then [] + else (search [@tailcall]) ~window:None 0 low high None None let sync_log t = let generation = IO.get_generation t.log in let log_offset = IO.offset t.log in let new_log_offset = IO.force_offset t.log in - let add_log_entry e = - Tbl.add t.log_mem e.key e; - may (fun bf -> Bloomf.add bf e.key) t.entries - in + let add_log_entry e = Tbl.add t.log_mem e.key e in if t.generation <> generation then ( Tbl.clear t.log_mem; iter_io add_log_entry t.log; let index_path = index_path t.root in may (fun i -> IO.close i.io) t.index; let io = IO.v ~fresh:false ~readonly:true ~generation index_path in - let _ = IO.force_offset io in let io_off = IO.force_offset io in let fan_out_size = Tbl.length t.log_mem + (Int64.to_int io_off / entry_size) @@ -395,7 +395,7 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let rec go index_offset buf_offset log_i = if index_offset >= index_end then append_remaining_log fan_out log log_i dst_io - else ( + else let buf_str = Bytes.sub_string buf buf_offset entry_size in let index_offset = Int64.add index_offset entry_sizeL in let key_e = K.decode buf_str 0 in @@ -406,10 +406,10 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let n = buf_offset + entry_size in if n >= Bytes.length buf then ( refill index_offset; - 0 - ) else n + 0 ) + else n in - (go [@tailcall]) index_offset buf_offset log_i ) + (go [@tailcall]) index_offset buf_offset log_i in (go [@tailcall]) 0L 0 0 diff --git a/vendors/irmin/tree.ml b/vendors/irmin/tree.ml index c6b996841ffa..e9c7b2de5b68 100644 --- a/vendors/irmin/tree.ml +++ b/vendors/irmin/tree.ml @@ -931,9 +931,12 @@ module Make (P : S.PRIVATE) = struct match map t with | Some m -> Lwt.return (StepMap.is_empty m) | None -> ( - to_value t >|= function - | None -> false - | Some n -> P.Node.Val.is_empty n ) + match t.v with + | Value (_, _, Some _) -> Lwt.return false + | _ -> ( + to_value t >|= function + | None -> false + | Some n -> P.Node.Val.is_empty n ) ) let list t = let trim l = -- GitLab From cbd9f3b239d4ebc9234d07a6fa98e21261c666a0 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Mon, 2 Sep 2019 16:38:05 +0200 Subject: [PATCH 14/17] [index, irmin-pack, irmin] updates - index: improve startup time by storing the fanout on disk - index: expose the merge operation in the API - index: add a close function - index: it's fine to create a new file in read-only mode - irmin-pack: add an integrity check - irmin-pack: add a close function - irmin-pack: it's fine to create a new file in read-only mode --- vendors/index/src/dune | 2 +- vendors/index/src/fan.ml | 56 +++++++ vendors/index/src/fan.mli | 15 ++ vendors/index/src/index.ml | 220 +++++++++++++++------------ vendors/index/src/index.mli | 41 ++++- vendors/index/src/io.mli | 20 ++- vendors/index/src/unix/index_unix.ml | 201 ++++++++++++++++-------- vendors/irmin-pack/IO.ml | 69 +++++---- vendors/irmin-pack/IO.mli | 10 +- vendors/irmin-pack/dict.ml | 21 ++- vendors/irmin-pack/dict.mli | 4 + vendors/irmin-pack/inode.ml | 11 +- vendors/irmin-pack/inode.mli | 5 +- vendors/irmin-pack/irmin_pack.ml | 121 ++++++++++----- vendors/irmin-pack/irmin_pack.mli | 46 ++++-- vendors/irmin-pack/lru.ml | 2 + vendors/irmin-pack/lru.mli | 2 + vendors/irmin-pack/pack.ml | 98 ++++++++---- vendors/irmin-pack/pack.mli | 5 +- vendors/irmin-pack/pack_dict.ml | 10 +- vendors/irmin-pack/pack_dict.mli | 3 +- vendors/irmin-pack/pack_index.ml | 38 +---- vendors/irmin-pack/pack_index.mli | 16 +- vendors/irmin/commit.ml | 12 +- vendors/irmin/contents.ml | 2 +- vendors/irmin/irmin.ml | 120 +++++++++++++++ vendors/irmin/irmin.mli | 24 ++- vendors/irmin/merge.ml | 12 +- vendors/irmin/node.ml | 4 +- vendors/irmin/s.ml | 10 ++ vendors/irmin/store.ml | 46 +++--- vendors/irmin/store.mli | 2 + vendors/irmin/sync.ml | 2 +- vendors/irmin/sync_ext.ml | 6 +- vendors/irmin/tree.ml | 70 ++++----- vendors/irmin/type.ml | 47 +++--- 36 files changed, 942 insertions(+), 431 deletions(-) diff --git a/vendors/index/src/dune b/vendors/index/src/dune index 1b3c2ff2c88c..44208bb911ee 100644 --- a/vendors/index/src/dune +++ b/vendors/index/src/dune @@ -2,4 +2,4 @@ (public_name index) (name index) (modules_without_implementation io) - (libraries bloomf logs fmt)) + (libraries logs fmt)) diff --git a/vendors/index/src/fan.ml b/vendors/index/src/fan.ml index f63d2a5eb4dd..1f8da3f10715 100644 --- a/vendors/index/src/fan.ml +++ b/vendors/index/src/fan.ml @@ -1,5 +1,15 @@ type t = { fans : int64 array; mask : int; shift : int } +let equal t t' = + let rec loop i = + if i >= Array.length t.fans then true + else if Int64.equal t.fans.(i) t'.fans.(i) then loop (i + 1) + else false + in + t.mask = t'.mask && t.shift = t'.shift + && Array.length t.fans = Array.length t'.fans + && loop 0 + let log2 a = log a /. log 2. let v ~hash_size ~entry_size n = @@ -30,3 +40,49 @@ let finalize t = loop t.fans.(i) (i + 1) ) in loop 0L 0 + +external set_64 : Bytes.t -> int -> int64 -> unit = "%caml_string_set64u" + +external get_64 : string -> int -> int64 = "%caml_string_get64" + +external swap64 : int64 -> int64 = "%bswap_int64" + +let encode_int64 i = + let set_uint64 s off v = + if not Sys.big_endian then set_64 s off (swap64 v) else set_64 s off v + in + let b = Bytes.create 8 in + set_uint64 b 0 i; + Bytes.to_string b + +let decode_int64 buf = + let get_uint64 s off = + if not Sys.big_endian then swap64 (get_64 s off) else get_64 s off + in + get_uint64 buf 0 + +let exported_size t = Array.length t.fans * 8 + +let export t = + let encoded_size = exported_size t in + let buf = Buffer.create encoded_size in + let rec loop i = + if i >= Array.length t.fans then () + else ( + Buffer.add_string buf (encode_int64 t.fans.(i)); + loop (i + 1) ) + in + loop 0; + Buffer.contents buf + +let import ~hash_size buf = + let nb_fans = String.length buf / 8 in + let fans = + Array.init nb_fans (fun i -> + let sub = String.sub buf (i * 8) 8 in + decode_int64 sub) + in + let size = int_of_float (log2 (float_of_int nb_fans)) in + let shift = hash_size - size in + let mask = (nb_fans - 1) lsl shift in + { fans; mask; shift } diff --git a/vendors/index/src/fan.mli b/vendors/index/src/fan.mli index 2c0dad92cb99..fb6620fb1600 100644 --- a/vendors/index/src/fan.mli +++ b/vendors/index/src/fan.mli @@ -1,5 +1,8 @@ type t +val equal : t -> t -> bool +(** The equality function for fan-out. *) + val v : hash_size:int -> entry_size:int -> int -> t (** [v ~hash_size ~entry_size n] creates a fan_out for an index with [hash_size] and [entry_size], containing [n] elements. *) @@ -15,3 +18,15 @@ val update : t -> int -> int64 -> unit val finalize : t -> unit (** Finalizes the update of the fanout. This is mendatory before any [search] query. *) + +val exported_size : t -> int +(** [exported_size t] is the size of [export t]. This does not actually + compute the encoding of [t]. *) + +val export : t -> string +(** [export t] is a string encoded form of [t]. *) + +val import : hash_size:int -> string -> t +(** [import ~hash_size buf] decodes [buf] such that + [import ~hash_size (export t) = t] if [t] was initially created with + ~hash_size. *) diff --git a/vendors/index/src/index.ml b/vendors/index/src/index.ml index 6707face6c7a..1c05db5997a4 100644 --- a/vendors/index/src/index.ml +++ b/vendors/index/src/index.ml @@ -1,3 +1,7 @@ +module Private = struct + module Fan = Fan +end + module type Key = sig type t @@ -41,24 +45,28 @@ module type S = sig val clear : t -> unit - val find_all : t -> key -> value list + val find : t -> key -> value val mem : t -> key -> bool - exception Invalid_Key_Size of key + exception Invalid_key_size of key - exception Invalid_Value_Size of value + exception Invalid_value_size of value - val add : t -> key -> value -> unit + val replace : t -> key -> value -> unit val iter : (key -> value -> unit) -> t -> unit val flush : t -> unit + + val close : t -> unit + + val force_merge : t -> key -> value -> unit end let may f = function None -> () | Some bf -> f bf -exception RO_Not_Allowed +exception RO_not_allowed let src = Logs.Src.create "index" ~doc:"Index" @@ -77,17 +85,17 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let entry_sizeL = Int64.of_int entry_size - exception Invalid_Key_Size of key + exception Invalid_key_size of key - exception Invalid_Value_Size of value + exception Invalid_value_size of value let append_entry io e = let encoded_key = K.encode e.key in let encoded_value = V.encode e.value in if String.length encoded_key <> K.encoded_size then - raise (Invalid_Key_Size e.key); + raise (Invalid_key_size e.key); if String.length encoded_value <> V.encoded_size then - raise (Invalid_Value_Size e.value); + raise (Invalid_value_size e.value); IO.append io encoded_key; IO.append io encoded_value @@ -110,14 +118,14 @@ module Make (K : Key) (V : Value) (IO : IO) = struct mutable index : index option; log : IO.t; log_mem : entry Tbl.t; - entries : key Bloomf.t option; + mutable counter : int; + lock : IO.lock; } let clear t = Log.debug (fun l -> l "clear %S" t.root); t.generation <- 0L; IO.clear t.log; - may Bloomf.clear t.entries; Tbl.clear t.log_mem; may (fun i -> @@ -132,6 +140,8 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let index_path root = root // "index" // "index" + let lock_path root = root // "index" // ".lock" + let page_size = Int64.mul entry_sizeL 1_000L let iter_io_off ?(min = 0L) ?max f io = @@ -182,9 +192,14 @@ module Make (K : Key) (V : Value) (IO : IO) = struct Hashtbl.remove roots (root, false); raise Not_found ); let t = Hashtbl.find roots (root, readonly) in - Log.debug (fun l -> l "%s found in cache" root); - if fresh then clear t; - t + if IO.valid_fd t.log then ( + Log.debug (fun l -> l "%s found in cache" root); + t.counter <- t.counter + 1; + if fresh then clear t; + t ) + else ( + Hashtbl.remove roots (root, readonly); + raise Not_found ) with Not_found -> Log.debug (fun l -> l "[%s] v fresh=%b readonly=%b" (Filename.basename root) fresh @@ -196,37 +211,24 @@ module Make (K : Key) (V : Value) (IO : IO) = struct `Staged f let v_no_cache ~fresh ~readonly ~log_size root = + let lock = IO.lock (lock_path root) in let config = { log_size = log_size * entry_size; readonly } in let log_path = log_path root in let index_path = index_path root in - let entries = - if readonly then None - else Some (Bloomf.create ~error_rate:0.01 100_000_000) - in let log_mem = Tbl.create 1024 in - let log = IO.v ~fresh ~readonly ~generation:0L log_path in + let log = IO.v ~fresh ~readonly ~generation:0L ~fan_size:0L log_path in let generation = IO.get_generation log in let index = - if Sys.file_exists index_path then ( - let io = IO.v ~fresh ~readonly ~generation:0L index_path in - let fan_out_size = Int64.to_int (IO.offset io) / entry_size in - let fan_out = Fan.v ~hash_size:K.hash_size ~entry_size fan_out_size in - iter_io_off - (fun off e -> - let hash = K.hash e.key in - Fan.update fan_out hash off; - may (fun bf -> Bloomf.add bf e.key) entries) - io; - Fan.finalize fan_out; - Some { fan_out; io } ) + if Sys.file_exists index_path then + let io = + IO.v ~fresh ~readonly ~generation:0L ~fan_size:0L index_path + in + let fan_out = Fan.import ~hash_size:K.hash_size (IO.get_fanout io) in + Some { fan_out; io } else None in - iter_io - (fun e -> - Tbl.add log_mem e.key e; - may (fun bf -> Bloomf.add bf e.key) entries) - log; - { config; generation; log_mem; root; log; index; entries } + iter_io (fun e -> Tbl.replace log_mem e.key e) log; + { config; generation; log_mem; root; log; index; counter = 1; lock } let (`Staged v) = with_cache ~v:v_no_cache ~clear @@ -234,26 +236,26 @@ module Make (K : Key) (V : Value) (IO : IO) = struct | Some e -> e | None -> get_entry ~window io off - let look_around ~window io init ~low ~high key h_key off = - let rec search acc op curr = + let look_around ~window io ~low ~high key h_key off = + let rec search op curr = let off = op curr entry_sizeL in - if off < 0L || off >= IO.offset io || off < low || off > high then acc + if off < low || off > high then raise Not_found else let e = get_entry ~window io off in let h_e = e.key_hash in - if h_e <> h_key then acc - else - let new_acc = if K.equal e.key key then e.value :: acc else acc in - search new_acc op off + if h_e <> h_key then raise Not_found + else if K.equal e.key key then e.value + else search op off in - let before = search init Int64.add off in - search before Int64.sub off + match search Int64.add off with + | e -> e + | exception Not_found -> search Int64.sub off - let interpolation_search index key = + let interpolation_search index key : value = let hashed_key = K.hash key in let low, high = Fan.search index.fan_out hashed_key in let rec search steps ~window low high lowest_entry highest_entry = - if high < low then [] + if high < low then raise Not_found else let window = match window with @@ -271,16 +273,17 @@ module Make (K : Key) (V : Value) (IO : IO) = struct get_entry_iff_needed ~window index.io low lowest_entry in if high = low then - if K.equal lowest_entry.key key then [ lowest_entry.value ] else [] + if K.equal lowest_entry.key key then lowest_entry.value + else raise Not_found else let lowest_hash = lowest_entry.key_hash in - if lowest_hash > hashed_key then [] + if lowest_hash > hashed_key then raise Not_found else let highest_entry = get_entry_iff_needed ~window index.io high highest_entry in let highest_hash = highest_entry.key_hash in - if highest_hash < hashed_key then [] + if highest_hash < hashed_key then raise Not_found else let lowest_hashf = float_of_int lowest_hash in let highest_hashf = float_of_int highest_hash in @@ -298,9 +301,9 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let e = get_entry ~window index.io offL in let hashed_e = e.key_hash in if hashed_key = hashed_e then - let init = if K.equal key e.key then [ e.value ] else [] in - look_around ~window ~low ~high index.io init key hashed_key - offL + if K.equal key e.key then e.value + else + look_around ~window ~low ~high index.io key hashed_key offL else if hashed_e < hashed_key then (search [@tailcall]) (steps + 1) ~window (Int64.add offL entry_sizeL) @@ -310,56 +313,49 @@ module Make (K : Key) (V : Value) (IO : IO) = struct (Int64.sub offL entry_sizeL) (Some lowest_entry) None in - if high < 0L then [] + if high < 0L then raise Not_found else (search [@tailcall]) ~window:None 0 low high None None let sync_log t = let generation = IO.get_generation t.log in let log_offset = IO.offset t.log in let new_log_offset = IO.force_offset t.log in - let add_log_entry e = Tbl.add t.log_mem e.key e in + let add_log_entry e = Tbl.replace t.log_mem e.key e in if t.generation <> generation then ( Tbl.clear t.log_mem; iter_io add_log_entry t.log; - let index_path = index_path t.root in may (fun i -> IO.close i.io) t.index; - let io = IO.v ~fresh:false ~readonly:true ~generation index_path in - let io_off = IO.force_offset io in - let fan_out_size = - Tbl.length t.log_mem + (Int64.to_int io_off / entry_size) - in - let fan_out = Fan.v ~hash_size:K.hash_size ~entry_size fan_out_size in - iter_io_off - (fun off e -> - let hash = e.key_hash in - Fan.update fan_out hash off) - io; - Fan.finalize fan_out; - t.index <- Some { fan_out; io }; - t.generation <- generation ) + if Int64.equal generation 0L then t.index <- None + else + let index_path = index_path t.root in + let io = + IO.v ~fresh:false ~readonly:true ~generation ~fan_size:0L index_path + in + let fan_out = + Fan.import ~hash_size:K.encoded_size (IO.get_fanout io) + in + t.index <- Some { fan_out; io }; + t.generation <- generation ) else if log_offset < new_log_offset then iter_io add_log_entry t.log ~min:log_offset else if log_offset > new_log_offset then assert false - let find_all t key = + let find t key = Log.debug (fun l -> l "find %a" K.pp key); if t.config.readonly then sync_log t; let look_on_disk () = - let in_index = - match t.index with - | None -> [] - | Some index -> interpolation_search index key - in - let in_log = List.map (fun e -> e.value) (Tbl.find_all t.log_mem key) in - in_index @ in_log + match Tbl.find t.log_mem key with + | e -> e.value + | exception Not_found -> ( + match t.index with + | Some index -> interpolation_search index key + | None -> raise Not_found ) in - match t.entries with - | None -> look_on_disk () - | Some bf -> if not (Bloomf.mem bf key) then [] else look_on_disk () + look_on_disk () let mem t key = Log.debug (fun l -> l "mem %a" K.pp key); - match find_all t key with [] -> false | _ -> true + match find t key with _ -> true | exception Not_found -> false let append_buf_fanout fan_out hash buf_str dst_io = Fan.update fan_out hash (IO.offset dst_io); @@ -401,7 +397,12 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let key_e = K.decode buf_str 0 in let hash_e = K.hash key_e in let log_i = merge_from_log fan_out log log_i hash_e dst_io in - append_buf_fanout fan_out hash_e buf_str dst_io; + if + log_i >= Array.length log + || + let key = log.(log_i).key in + not (K.equal key key_e) + then append_buf_fanout fan_out hash_e buf_str dst_io; let buf_offset = let n = buf_offset + entry_size in if n >= Bytes.length buf then ( @@ -414,10 +415,9 @@ module Make (K : Key) (V : Value) (IO : IO) = struct (go [@tailcall]) 0L 0 0 let merge ~witness t = - Log.debug (fun l -> l "merge %S" t.root); + Log.debug (fun l -> l "unforced merge %S\n" t.root); let tmp_path = t.root // "tmp" // "index" in let generation = Int64.succ t.generation in - let tmp = IO.v ~readonly:false ~fresh:true ~generation tmp_path in let log = let compare_entry e e' = compare e.key_hash e'.key_hash in let b = Array.make (Tbl.length t.log_mem) witness in @@ -430,41 +430,52 @@ module Make (K : Key) (V : Value) (IO : IO) = struct Array.fast_sort compare_entry b; b in + let fan_size = + match t.index with + | None -> Tbl.length t.log_mem + | Some index -> + (Int64.to_int (IO.offset index.io) / entry_size) + + Tbl.length t.log_mem + in + let fan_out = Fan.v ~hash_size:K.hash_size ~entry_size fan_size in + let tmp = + IO.v ~readonly:false ~fresh:true ~generation + ~fan_size:(Int64.of_int (Fan.exported_size fan_out)) + tmp_path + in ( match t.index with | None -> - let fan_out_size = Tbl.length t.log_mem in - let fan_out = Fan.v ~hash_size:K.hash_size ~entry_size fan_out_size in let io = - IO.v ~fresh:true ~readonly:false ~generation:0L (index_path t.root) + IO.v ~fresh:true ~readonly:false ~generation:0L ~fan_size:0L + (index_path t.root) in append_remaining_log fan_out log 0 tmp; t.index <- Some { io; fan_out } | Some index -> - let fan_out_size = - (Int64.to_int (IO.offset index.io) / entry_size) - + Tbl.length t.log_mem - in - let fan_out = Fan.v ~hash_size:K.hash_size ~entry_size fan_out_size in let index = { index with fan_out } in merge_with log index tmp; t.index <- Some index ); match t.index with | None -> assert false | Some index -> - IO.rename ~src:tmp ~dst:index.io; Fan.finalize index.fan_out; + IO.set_fanout tmp (Fan.export index.fan_out); + IO.rename ~src:tmp ~dst:index.io; IO.clear t.log; Tbl.clear t.log_mem; IO.set_generation t.log generation; t.generation <- generation - let add t key value = + let force_merge t key value = + Log.debug (fun l -> l "forced merge %S\n" t.root); + merge ~witness:{ key; key_hash = K.hash key; value } t + + let replace t key value = Log.debug (fun l -> l "add %a %a" K.pp key V.pp value); - if t.config.readonly then raise RO_Not_Allowed; + if t.config.readonly then raise RO_not_allowed; let entry = { key; key_hash = K.hash key; value } in append_entry t.log entry; - Tbl.add t.log_mem key entry; - may (fun bf -> Bloomf.add bf key) t.entries; + Tbl.replace t.log_mem key entry; if Int64.compare (IO.offset t.log) (Int64.of_int t.config.log_size) > 0 then merge ~witness:entry t @@ -474,4 +485,15 @@ module Make (K : Key) (V : Value) (IO : IO) = struct may (fun index -> iter_io (fun e -> f e.key e.value) index.io) t.index let flush t = IO.sync t.log + + let close t = + t.counter <- t.counter - 1; + if t.counter = 0 then ( + Log.debug (fun l -> l "close %S" t.root); + if not t.config.readonly then flush t; + IO.close t.log; + may (fun i -> IO.close i.io) t.index; + t.index <- None; + Tbl.reset t.log_mem; + IO.unlock t.lock ) end diff --git a/vendors/index/src/index.mli b/vendors/index/src/index.mli index 1c48451bdb39..d3467fc53ab7 100644 --- a/vendors/index/src/index.mli +++ b/vendors/index/src/index.mli @@ -59,7 +59,7 @@ end module type IO = Io.S -exception RO_Not_Allowed +exception RO_not_allowed (** The exception raised when illegal operation is attempted on a read_only index. *) @@ -85,21 +85,22 @@ module type S = sig val clear : t -> unit (** [clear t] clears [t] so that there are no more bindings in it. *) - val find_all : t -> key -> value list + val find : t -> key -> value (** [find t k] are all the bindings of [k] in [t]. The order is not specified *) val mem : t -> key -> bool (** [mem t k] is [true] iff [k] is bound in [t]. *) - exception Invalid_Key_Size of key + exception Invalid_key_size of key - exception Invalid_Value_Size of value + exception Invalid_value_size of value (** The exceptions raised when trying to add a key or a value of different size than encoded_size *) - val add : t -> key -> value -> unit - (** [add t k v] binds [k] to [v] in [t]. *) + val replace : t -> key -> value -> unit + (** [replace t k v] binds [k] to [v] in [t], replacing any exising binding + of [k]. *) val iter : (key -> value -> unit) -> t -> unit (** Iterates over the index bindings. Order is not specified. @@ -108,6 +109,34 @@ module type S = sig val flush : t -> unit (** Flushes all buffers to the disk. *) + + val close : t -> unit + (** Closes the files and clears the caches of [t].*) + + val force_merge : t -> key -> value -> unit + (** [force_merge t k v] forces a merge for [t], where [k] and [v] are any key and value of [t]. *) +end + +module Private : sig + module Fan : sig + type t + + val equal : t -> t -> bool + + val v : hash_size:int -> entry_size:int -> int -> t + + val search : t -> int -> int64 * int64 + + val update : t -> int -> int64 -> unit + + val finalize : t -> unit + + val exported_size : t -> int + + val export : t -> string + + val import : hash_size:int -> string -> t + end end module Make (K : Key) (V : Value) (IO : IO) : diff --git a/vendors/index/src/io.mli b/vendors/index/src/io.mli index 84c974bfe1e7..b65bcd788559 100644 --- a/vendors/index/src/io.mli +++ b/vendors/index/src/io.mli @@ -1,7 +1,13 @@ module type S = sig type t - val v : readonly:bool -> fresh:bool -> generation:int64 -> string -> t + val v : + readonly:bool -> + fresh:bool -> + generation:int64 -> + fan_size:int64 -> + string -> + t val name : t -> string @@ -23,9 +29,21 @@ module type S = sig val get_generation : t -> int64 + val set_fanout : t -> string -> unit + + val get_fanout : t -> string + val rename : src:t -> dst:t -> unit val append : t -> string -> unit val close : t -> unit + + val valid_fd : t -> bool + + type lock + + val lock : string -> lock + + val unlock : lock -> unit end diff --git a/vendors/index/src/unix/index_unix.ml b/vendors/index/src/unix/index_unix.ml index 7d4c658441ca..68376adefa61 100644 --- a/vendors/index/src/unix/index_unix.ml +++ b/vendors/index/src/unix/index_unix.ml @@ -1,4 +1,4 @@ -exception RO_Not_Allowed +exception RO_not_allowed let current_version = "00000001" @@ -67,66 +67,97 @@ module IO : Index.IO = struct t.cursor <- off ++ Int64.of_int n; n - let unsafe_set_offset t n = - let buf = encode_int64 n in - unsafe_write t ~off:0L buf - - let unsafe_get_offset t = - let buf = Bytes.create 8 in - let n = unsafe_read t ~off:0L ~len:8 buf in - assert (n = 8); - decode_int64 (Bytes.unsafe_to_string buf) - - let unsafe_get_version t = - let buf = Bytes.create 8 in - let n = unsafe_read t ~off:8L ~len:8 buf in - assert (n = 8); - Bytes.unsafe_to_string buf - - let unsafe_set_version t = unsafe_write t ~off:8L current_version - - let unsafe_get_generation t = - let buf = Bytes.create 8 in - let n = unsafe_read t ~off:16L ~len:8 buf in - assert (n = 8); - decode_int64 (Bytes.unsafe_to_string buf) - - let unsafe_set_generation t gen = - let buf = encode_int64 gen in - unsafe_write t ~off:16L buf + module Offset = struct + let set t n = + let buf = encode_int64 n in + unsafe_write t ~off:0L buf + + let get t = + let buf = Bytes.create 8 in + let n = unsafe_read t ~off:0L ~len:8 buf in + assert (n = 8); + decode_int64 (Bytes.unsafe_to_string buf) + end + + module Version = struct + let get t = + let buf = Bytes.create 8 in + let n = unsafe_read t ~off:8L ~len:8 buf in + assert (n = 8); + Bytes.unsafe_to_string buf + + let set t = unsafe_write t ~off:8L current_version + end + + module Generation = struct + let get t = + let buf = Bytes.create 8 in + let n = unsafe_read t ~off:16L ~len:8 buf in + assert (n = 8); + decode_int64 (Bytes.unsafe_to_string buf) + + let set t gen = + let buf = encode_int64 gen in + unsafe_write t ~off:16L buf + end + + module Fan = struct + let set t buf = + let size = encode_int64 (Int64.of_int (String.length buf)) in + unsafe_write t ~off:24L size; + if buf <> "" then unsafe_write t ~off:(24L ++ 8L) buf + + let get_size t = + let size_buf = Bytes.create 8 in + let n = unsafe_read t ~off:24L ~len:8 size_buf in + assert (n = 8); + decode_int64 (Bytes.unsafe_to_string size_buf) + + let set_size t size = + let buf = encode_int64 size in + unsafe_write t ~off:24L buf + + let get t = + let size = Int64.to_int (get_size t) in + let buf = Bytes.create size in + let n = unsafe_read t ~off:(24L ++ 8L) ~len:size buf in + assert (n = size); + Bytes.unsafe_to_string buf + end end type t = { file : string; + mutable header : int64; mutable raw : Raw.t; mutable offset : int64; mutable flushed : int64; + mutable fan_size : int64; readonly : bool; version : string; buf : Buffer.t; } - let header = 24L (* offset + version + generation *) - let sync t = - if t.readonly then raise RO_Not_Allowed; + if t.readonly then raise RO_not_allowed; let buf = Buffer.contents t.buf in let offset = t.offset in Buffer.clear t.buf; if buf = "" then () else ( Raw.unsafe_write t.raw ~off:t.flushed buf; - Raw.unsafe_set_offset t.raw offset; + Raw.Offset.set t.raw offset; (* concurrent append might happen so here t.offset might differ from offset *) - if not (t.flushed ++ Int64.of_int (String.length buf) = header ++ offset) + if + not (t.flushed ++ Int64.of_int (String.length buf) = t.header ++ offset) then Fmt.failwith "sync error: %s flushed=%Ld buf=%Ld offset+header=%Ld\n%!" t.file t.flushed (Int64.of_int (String.length buf)) - (offset ++ header); - t.flushed <- offset ++ header ) + (offset ++ t.header); + t.flushed <- offset ++ t.header ) let name t = t.file @@ -134,6 +165,8 @@ module IO : Index.IO = struct sync src; Unix.close dst.raw.fd; Unix.rename src.file dst.file; + dst.header <- src.header; + dst.fan_size <- src.fan_size; dst.offset <- src.offset; dst.flushed <- src.flushed; dst.raw <- src.raw @@ -143,27 +176,33 @@ module IO : Index.IO = struct let auto_flush_limit = 1_000_000L let append t buf = - if t.readonly then raise RO_Not_Allowed; + if t.readonly then raise RO_not_allowed; Buffer.add_string t.buf buf; let len = Int64.of_int (String.length buf) in t.offset <- t.offset ++ len; if t.offset -- t.flushed > auto_flush_limit then sync t let read t ~off buf = - if not t.readonly then assert (header ++ off <= t.flushed); - Raw.unsafe_read t.raw ~off:(header ++ off) ~len:(Bytes.length buf) buf + if not t.readonly then assert (t.header ++ off <= t.flushed); + Raw.unsafe_read t.raw ~off:(t.header ++ off) ~len:(Bytes.length buf) buf let offset t = t.offset let force_offset t = - t.offset <- Raw.unsafe_get_offset t.raw; + t.offset <- Raw.Offset.get t.raw; t.offset let version t = t.version - let get_generation t = Raw.unsafe_get_generation t.raw + let get_generation t = Raw.Generation.get t.raw + + let set_generation t = Raw.Generation.set t.raw - let set_generation t gen = Raw.unsafe_set_generation t.raw gen + let get_fanout t = Raw.Fan.get t.raw + + let set_fanout t buf = + assert (Int64.equal (Int64.of_int (String.length buf)) t.fan_size); + Raw.Fan.set t.raw buf let readonly t = t.readonly @@ -192,9 +231,10 @@ module IO : Index.IO = struct let clear t = t.offset <- 0L; - t.flushed <- header; - Raw.unsafe_set_generation t.raw 0L; - Raw.unsafe_set_offset t.raw t.offset; + t.flushed <- t.header; + Raw.Generation.set t.raw 0L; + Raw.Offset.set t.raw t.offset; + Raw.Fan.set t.raw ""; Buffer.clear t.buf let buffers = Hashtbl.create 256 @@ -211,14 +251,17 @@ module IO : Index.IO = struct let () = assert (String.length current_version = 8) - let v ~readonly ~fresh ~generation file = - let v ~offset ~version raw = + let v ~readonly ~fresh ~generation ~fan_size file = + let v ~fan_size ~offset ~version raw = + let header = 8L ++ 8L ++ 8L ++ 8L ++ fan_size in { version; + header; file; offset; raw; readonly; + fan_size; buf = buffer file; flushed = header ++ offset; } @@ -227,27 +270,65 @@ module IO : Index.IO = struct mkdir (Filename.dirname file); match Sys.file_exists file with | false -> - if readonly then raise RO_Not_Allowed; - let x = Unix.openfile file Unix.[ O_CREAT; mode ] 0o644 in + let x = Unix.openfile file Unix.[ O_CREAT; O_CLOEXEC; mode ] 0o644 in let raw = Raw.v x in - Raw.unsafe_set_offset raw 0L; - Raw.unsafe_set_version raw; - Raw.unsafe_set_generation raw generation; - v ~offset:0L ~version:current_version raw + Raw.Offset.set raw 0L; + Raw.Fan.set_size raw fan_size; + Raw.Version.set raw; + Raw.Generation.set raw generation; + v ~fan_size ~offset:0L ~version:current_version raw | true -> - let x = Unix.openfile file Unix.[ O_EXCL; mode ] 0o644 in + let x = Unix.openfile file Unix.[ O_EXCL; O_CLOEXEC; mode ] 0o644 in let raw = Raw.v x in if readonly && fresh then Fmt.failwith "IO.v: cannot reset a readonly file" else if fresh then ( - Raw.unsafe_set_offset raw 0L; - Raw.unsafe_set_version raw; - Raw.unsafe_set_generation raw generation; - v ~offset:0L ~version:current_version raw ) + Raw.Offset.set raw 0L; + Raw.Fan.set_size raw fan_size; + Raw.Version.set raw; + Raw.Generation.set raw generation; + v ~fan_size ~offset:0L ~version:current_version raw ) else - let offset = Raw.unsafe_get_offset raw in - let version = Raw.unsafe_get_version raw in - v ~offset ~version raw + let () = Fmt.epr "HERE\n%!" in + let offset = Raw.Offset.get raw in + let version = Raw.Version.get raw in + let fan_size = Raw.Fan.get_size raw in + let () = Fmt.epr "Got fan_size %Ld\n%!" fan_size in + v ~fan_size ~offset ~version raw + + let valid_fd t = + try + let _ = Unix.fstat t.raw.fd in + true + with Unix.Unix_error (Unix.EBADF, _, _) -> false + + type lock = Unix.file_descr + + let unsafe_lock op f = + mkdir (Filename.dirname f); + let fd = Unix.openfile f [ Unix.O_CREAT; Unix.O_RDWR ] 0o600 + and pid = string_of_int (Unix.getpid ()) in + let pid_len = String.length pid in + try + Unix.lockf fd op 0; + if Unix.single_write_substring fd pid 0 pid_len <> pid_len then ( + Unix.close fd; + failwith "Unable to write PID to lock file" ) + else Some fd + with + | Unix.Unix_error (Unix.EAGAIN, _, _) -> + Unix.close fd; + None + | e -> + Unix.close fd; + raise e + + let lock path = + match unsafe_lock Unix.F_TLOCK path with + | Some fd -> fd + | None -> failwith ("Lock didn't succeed: file " ^ path ^ " is present") + + let unlock fd = Unix.close fd end module Make (K : Index.Key) (V : Index.Value) = Index.Make (K) (V) (IO) diff --git a/vendors/irmin-pack/IO.ml b/vendors/irmin-pack/IO.ml index 71b24bd50955..937fc349c1a6 100644 --- a/vendors/irmin-pack/IO.ml +++ b/vendors/irmin-pack/IO.ml @@ -44,6 +44,10 @@ module type S = sig val version : t -> string val sync : t -> unit + + val close : t -> unit + + val is_valid : t -> bool end let ( ++ ) = Int64.add @@ -233,14 +237,13 @@ module Unix : S = struct mkdir (Filename.dirname file); match Sys.file_exists file with | false -> - if readonly then raise RO_Not_Allowed; - let x = Unix.openfile file Unix.[ O_CREAT; mode ] 0o644 in + let x = Unix.openfile file Unix.[ O_CREAT; mode; O_CLOEXEC ] 0o644 in let raw = Raw.v x in Raw.unsafe_set_offset raw 0L; Raw.unsafe_set_version raw current_version; v ~offset:0L ~version:current_version raw | true -> - let x = Unix.openfile file Unix.[ O_EXCL; mode ] 0o644 in + let x = Unix.openfile file Unix.[ O_EXCL; mode; O_CLOEXEC ] 0o644 in let raw = Raw.v x in if fresh then ( Raw.unsafe_set_offset raw 0L; @@ -251,42 +254,46 @@ module Unix : S = struct let version = Raw.unsafe_get_version raw in assert (version = current_version); v ~offset ~version raw + + let close t = Unix.close t.raw.fd + + let is_valid t = + try + let _ = Unix.fstat t.raw.fd in + true + with Unix.Unix_error (Unix.EBADF, _, _) -> false end let ( // ) = Filename.concat -let with_cache ~v ~clear file = +let with_cache ~v ~clear ~valid file = let files = Hashtbl.create 13 in - let cached_constructor extra_args ?(fresh = false) ?(shared = true) - ?(readonly = false) root = + let cached_constructor extra_args ?(fresh = false) ?(readonly = false) root = let file = root // file in if fresh && readonly then invalid_arg "Read-only IO cannot be fresh"; - if not shared then ( - Log.debug (fun l -> - l "[%s] v fresh=%b shared=%b readonly=%b" (Filename.basename file) - fresh shared readonly); - let t = v extra_args ~fresh ~shared ~readonly file in - if fresh then clear t; - t ) - else - try - if not (Sys.file_exists file) then ( - Log.debug (fun l -> - l "[%s] does not exist anymore, cleaning up the fd cache" - (Filename.basename file)); - Hashtbl.remove files file; - raise Not_found ); - let t = Hashtbl.find files file in - Log.debug (fun l -> l "%s found in cache" file); - if fresh then clear t; - t - with Not_found -> + try + if not (Sys.file_exists file) then ( Log.debug (fun l -> - l "[%s] v fresh=%b shared=%b readonly=%b" (Filename.basename file) - fresh shared readonly); - let t = v extra_args ~fresh ~shared ~readonly file in + l "[%s] does not exist anymore, cleaning up the fd cache" + (Filename.basename file)); + Hashtbl.remove files (file, true); + Hashtbl.remove files (file, false); + raise Not_found ); + let t = Hashtbl.find files (file, readonly) in + if valid t then ( + Log.debug (fun l -> l "%s found in cache" file); if fresh then clear t; - Hashtbl.add files file t; - t + t ) + else ( + Hashtbl.remove files (file, readonly); + raise Not_found ) + with Not_found -> + Log.debug (fun l -> + l "[%s] v fresh=%b readonly=%b" (Filename.basename file) fresh + readonly); + let t = v extra_args ~fresh ~readonly file in + if fresh then clear t; + Hashtbl.add files (file, readonly) t; + t in `Staged cached_constructor diff --git a/vendors/irmin-pack/IO.mli b/vendors/irmin-pack/IO.mli index 67e6043c203b..478e9d855a2c 100644 --- a/vendors/irmin-pack/IO.mli +++ b/vendors/irmin-pack/IO.mli @@ -40,13 +40,17 @@ module type S = sig val version : t -> string val sync : t -> unit + + val close : t -> unit + + val is_valid : t -> bool end module Unix : S val with_cache : - v:('a -> fresh:bool -> shared:bool -> readonly:bool -> string -> 'b) -> + v:('a -> fresh:bool -> readonly:bool -> string -> 'b) -> clear:('b -> unit) -> + valid:('b -> bool) -> string -> - [ `Staged of - 'a -> ?fresh:bool -> ?shared:bool -> ?readonly:bool -> string -> 'b ] + [ `Staged of 'a -> ?fresh:bool -> ?readonly:bool -> string -> 'b ] diff --git a/vendors/irmin-pack/dict.ml b/vendors/irmin-pack/dict.ml index a038181e6aed..3f8e268ac0fa 100644 --- a/vendors/irmin-pack/dict.ml +++ b/vendors/irmin-pack/dict.ml @@ -35,6 +35,10 @@ module type S = sig val v : ?fresh:bool -> ?readonly:bool -> ?capacity:int -> string -> t val clear : t -> unit + + val close : t -> unit + + val valid : t -> bool end module Make (IO : IO.S) : S = struct @@ -43,6 +47,7 @@ module Make (IO : IO.S) : S = struct cache : (string, int) Hashtbl.t; index : (int, string) Hashtbl.t; io : IO.t; + mutable counter : int; } let append_string t v = @@ -104,7 +109,21 @@ module Make (IO : IO.S) : S = struct let io = IO.v ~fresh ~version:current_version ~readonly file in let cache = Hashtbl.create 997 in let index = Hashtbl.create 997 in - let t = { capacity; index; cache; io } in + let t = { capacity; index; cache; io; counter = 1 } in refill ~from:0L t; t + + let close t = + t.counter <- t.counter - 1; + if t.counter = 0 then ( + if not (IO.readonly t.io) then sync t; + IO.close t.io; + Hashtbl.reset t.cache; + Hashtbl.reset t.index ) + + let valid t = + if IO.is_valid t.io then ( + t.counter <- t.counter + 1; + true ) + else false end diff --git a/vendors/irmin-pack/dict.mli b/vendors/irmin-pack/dict.mli index 136f4e94ef6d..6f8748f0b7d3 100644 --- a/vendors/irmin-pack/dict.mli +++ b/vendors/irmin-pack/dict.mli @@ -26,6 +26,10 @@ module type S = sig val v : ?fresh:bool -> ?readonly:bool -> ?capacity:int -> string -> t val clear : t -> unit + + val close : t -> unit + + val valid : t -> bool end module Make (IO : IO.S) : S diff --git a/vendors/irmin-pack/inode.ml b/vendors/irmin-pack/inode.ml index 3a82ad6f5034..ca93d23eaa03 100644 --- a/vendors/irmin-pack/inode.ml +++ b/vendors/irmin-pack/inode.ml @@ -28,7 +28,6 @@ module type S = sig val v : ?fresh:bool -> - ?shared:bool -> ?readonly:bool -> ?lru_size:int -> index:index -> @@ -40,6 +39,10 @@ module type S = sig module Key : Irmin.Hash.S with type t = key module Val : Irmin.Private.Node.S with type t = value and type hash = key + + val integrity_check : offset:int64 -> length:int -> key -> 'a t -> unit + + val close : 'a t -> unit Lwt.t end module type CONFIG = sig @@ -780,9 +783,13 @@ struct let unsafe_add t k v = check_hash k (hash v); save t v.Val.v; - Lwt.return () + Lwt.return_unit let batch = Inode.batch let v = Inode.v + + let integrity_check = Inode.integrity_check + + let close = Inode.close end diff --git a/vendors/irmin-pack/inode.mli b/vendors/irmin-pack/inode.mli index 2391f06cf58e..2fdb0be88642 100644 --- a/vendors/irmin-pack/inode.mli +++ b/vendors/irmin-pack/inode.mli @@ -27,7 +27,6 @@ module type S = sig val v : ?fresh:bool -> - ?shared:bool -> ?readonly:bool -> ?lru_size:int -> index:index -> @@ -39,6 +38,10 @@ module type S = sig module Key : Irmin.Hash.S with type t = key module Val : Irmin.Private.Node.S with type t = value and type hash = key + + val integrity_check : offset:int64 -> length:int -> key -> 'a t -> unit + + val close : 'a t -> unit Lwt.t end module Make diff --git a/vendors/irmin-pack/irmin_pack.ml b/vendors/irmin-pack/irmin_pack.ml index ec249fbe563a..2f109e9233b0 100644 --- a/vendors/irmin-pack/irmin_pack.ml +++ b/vendors/irmin-pack/irmin_pack.ml @@ -28,8 +28,6 @@ module Default = struct let index_log_size = 500_000 let readonly = false - - let shared = true end let fresh_key = @@ -48,21 +46,12 @@ let readonly_key = Irmin.Private.Conf.key ~doc:"Start with a read-only disk." "readonly" Irmin.Private.Conf.bool Default.readonly -let shared_key = - Irmin.Private.Conf.key - ~doc: - "Share resources (file-descriptors, caches) with other instances when \ - possible." - "shared" Irmin.Private.Conf.bool Default.shared - let fresh config = Irmin.Private.Conf.get config fresh_key let lru_size config = Irmin.Private.Conf.get config lru_size_key let readonly config = Irmin.Private.Conf.get config readonly_key -let shared config = Irmin.Private.Conf.get config shared_key - let index_log_size config = Irmin.Private.Conf.get config index_log_size_key let root_key = Irmin.Private.Conf.root @@ -72,9 +61,9 @@ let root config = | None -> failwith "no root set" | Some r -> r -let config ?(fresh = Default.fresh) ?(shared = Default.shared) - ?(readonly = Default.readonly) ?(lru_size = Default.lru_size) - ?(index_log_size = Default.index_log_size) root = +let config ?(fresh = Default.fresh) ?(readonly = Default.readonly) + ?(lru_size = Default.lru_size) ?(index_log_size = Default.index_log_size) + root = let config = Irmin.Private.Conf.empty in let config = Irmin.Private.Conf.add config fresh_key fresh in let config = Irmin.Private.Conf.add config root_key (Some root) in @@ -83,7 +72,6 @@ let config ?(fresh = Default.fresh) ?(shared = Default.shared) Irmin.Private.Conf.add config index_log_size_key index_log_size in let config = Irmin.Private.Conf.add config readonly_key readonly in - let config = Irmin.Private.Conf.add config shared_key shared in config let ( ++ ) = Int64.add @@ -122,6 +110,7 @@ module Atomic_write (K : Irmin.Type.S) (V : Irmin.Hash.S) = struct block : IO.t; lock : Lwt_mutex.t; w : W.t; + mutable counter : int; } let read_length32 ~off block = @@ -145,14 +134,14 @@ module Atomic_write (K : Irmin.Type.S) (V : Irmin.Hash.S) = struct let unsafe_find t k = Log.debug (fun l -> l "[branches] find %a" pp_branch k); - try Lwt.return (Some (Tbl.find t.cache k)) - with Not_found -> Lwt.return None + try Lwt.return_some (Tbl.find t.cache k) + with Not_found -> Lwt.return_none let find t k = Lwt_mutex.with_lock t.lock (fun () -> unsafe_find t k) let unsafe_mem t k = Log.debug (fun l -> l "[branches] mem %a" pp_branch k); - try Lwt.return (Tbl.mem t.cache k) with Not_found -> Lwt.return false + try Lwt.return (Tbl.mem t.cache k) with Not_found -> Lwt.return_false let mem t v = Lwt_mutex.with_lock t.lock (fun () -> unsafe_mem t v) @@ -172,7 +161,7 @@ module Atomic_write (K : Irmin.Type.S) (V : Irmin.Hash.S) = struct Log.debug (fun l -> l "[branches] remove %a" pp_branch k); Lwt_mutex.with_lock t.lock (fun () -> unsafe_remove t k; - Lwt.return ()) + Lwt.return_unit) >>= fun () -> W.notify t.w k None let unsafe_clear t = @@ -185,7 +174,13 @@ module Atomic_write (K : Irmin.Type.S) (V : Irmin.Hash.S) = struct let watches = W.v () - let unsafe_v ~fresh ~shared:_ ~readonly file = + let valid t = + if IO.is_valid t.block then ( + t.counter <- t.counter + 1; + true ) + else false + + let unsafe_v ~fresh ~readonly file = let block = IO.v ~fresh ~version:current_version ~readonly file in let cache = Tbl.create 997 in let index = Tbl.create 997 in @@ -212,14 +207,23 @@ module Atomic_write (K : Irmin.Type.S) (V : Irmin.Hash.S) = struct (aux [@tailcall]) (off ++ Int64.(of_int @@ (len + V.hash_size))) k in (aux [@tailcall]) 0L @@ fun () -> - { cache; index; block; w = watches; lock = Lwt_mutex.create () } + { + cache; + index; + block; + w = watches; + lock = Lwt_mutex.create (); + counter = 1; + } let (`Staged unsafe_v) = - with_cache ~clear:unsafe_clear ~v:(fun () -> unsafe_v) "store.branches" + with_cache ~clear:unsafe_clear ~valid + ~v:(fun () -> unsafe_v) + "store.branches" - let v ?fresh ?shared ?readonly file = + let v ?fresh ?readonly file = Lwt_mutex.with_lock create (fun () -> - let v = unsafe_v () ?fresh ?shared ?readonly file in + let v = unsafe_v () ?fresh ?readonly file in Lwt.return v) let unsafe_set t k v = @@ -237,14 +241,14 @@ module Atomic_write (K : Irmin.Type.S) (V : Irmin.Hash.S) = struct Log.debug (fun l -> l "[branches] set %a" pp_branch k); Lwt_mutex.with_lock t.lock (fun () -> unsafe_set t k v; - Lwt.return ()) + Lwt.return_unit) >>= fun () -> W.notify t.w k (Some v) let unsafe_test_and_set t k ~test ~set = let v = try Some (Tbl.find t.cache k) with Not_found -> None in - if not (Irmin.Type.(equal (option V.t)) v test) then Lwt.return false + if not (Irmin.Type.(equal (option V.t)) v test) then Lwt.return_false else - let return () = Lwt.return true in + let return () = Lwt.return_true in match set with | None -> unsafe_remove t k |> return | Some v -> unsafe_set t k v |> return @@ -254,7 +258,7 @@ module Atomic_write (K : Irmin.Type.S) (V : Irmin.Hash.S) = struct Lwt_mutex.with_lock t.lock (fun () -> unsafe_test_and_set t k ~test ~set) >>= function | true -> W.notify t.w k set >|= fun () -> true - | false -> Lwt.return false + | false -> Lwt.return_false let list t = Log.debug (fun l -> l "[branches] list"); @@ -266,6 +270,18 @@ module Atomic_write (K : Irmin.Type.S) (V : Irmin.Hash.S) = struct let watch t = W.watch t.w let unwatch t = W.unwatch t.w + + let unsafe_close t = + t.counter <- t.counter - 1; + if t.counter = 0 then ( + Tbl.reset t.index; + Tbl.reset t.cache; + if not (IO.readonly t.block) then IO.sync t.block; + IO.close t.block; + W.clear t.w ) + else Lwt.return_unit + + let close t = Lwt_mutex.with_lock t.lock (fun () -> unsafe_close t) end module type CONFIG = Inode.CONFIG @@ -403,20 +419,55 @@ struct let fresh = fresh config in let lru_size = lru_size config in let readonly = readonly config in - let shared = shared config in let log_size = index_log_size config in let index = Index.v ~fresh ~readonly ~log_size root in - Contents.CA.v ~fresh ~shared ~readonly ~lru_size ~index root + Contents.CA.v ~fresh ~readonly ~lru_size ~index root >>= fun contents -> - Node.CA.v ~fresh ~shared ~readonly ~lru_size ~index root - >>= fun node -> - Commit.CA.v ~fresh ~shared ~readonly ~lru_size ~index root - >>= fun commit -> - Branch.v ~fresh ~shared ~readonly root >|= fun branch -> + Node.CA.v ~fresh ~readonly ~lru_size ~index root >>= fun node -> + Commit.CA.v ~fresh ~readonly ~lru_size ~index root >>= fun commit -> + Branch.v ~fresh ~readonly root >|= fun branch -> { contents; node; commit; branch; config; index } + + let close t = + Contents.CA.close (contents_t t) >>= fun () -> + Node.CA.close (snd (node_t t)) >>= fun () -> + Commit.CA.close (snd (commit_t t)) >>= fun () -> Branch.close t.branch end end + let integrity_check ppf (t : X.Repo.t) = + Fmt.pf ppf "running the integrity check\n%!"; + let commits = ref 0 in + let contents = ref 0 in + let nodes = ref 0 in + let pp_stats ppf () = + Fmt.pf ppf "%4dk blobs / %4dk trees / %4dk commits" (!contents / 1000) + (!nodes / 1000) (!commits / 1000) + in + let pr_stats () = Fmt.epr "\r%a%!" pp_stats () in + let count_increment count = + incr count; + if !count mod 100 = 0 then pr_stats () + in + Index.iter + (fun k (offset, length, m) -> + match m with + | 'B' -> + let capability = X.Repo.contents_t t in + X.Contents.CA.integrity_check ~offset ~length k capability; + count_increment contents + | 'N' | 'I' -> + let _, capability = X.Repo.node_t t in + X.Node.CA.integrity_check ~offset ~length k capability; + count_increment nodes + | 'C' -> + let _, capability = X.Repo.commit_t t in + X.Commit.CA.integrity_check ~offset ~length k capability; + count_increment commits + | _ -> invalid_arg "unknown content type") + t.index; + pr_stats () + include Irmin.Of_private (X) end diff --git a/vendors/irmin-pack/irmin_pack.mli b/vendors/irmin-pack/irmin_pack.mli index 434e18827adf..a77fbcf877ec 100644 --- a/vendors/irmin-pack/irmin_pack.mli +++ b/vendors/irmin-pack/irmin_pack.mli @@ -16,7 +16,6 @@ val config : ?fresh:bool -> - ?shared:bool -> ?readonly:bool -> ?lru_size:int -> ?index_log_size:int -> @@ -46,22 +45,45 @@ module Make_ext with type metadata = Metadata.t and type hash = Hash.t and type step = Path.step) - (CT : Irmin.Private.Commit.S with type hash = Hash.t) : - Irmin.S - with type key = Path.t - and type contents = Contents.t - and type branch = Branch.t - and type hash = Hash.t - and type step = Path.step - and type metadata = Metadata.t - and type Key.step = Path.step + (CT : Irmin.Private.Commit.S with type hash = Hash.t) : sig + include + Irmin.S + with type key = Path.t + and type contents = Contents.t + and type branch = Branch.t + and type hash = Hash.t + and type step = Path.step + and type metadata = Metadata.t + and type Key.step = Path.step -module Make (Config : CONFIG) : Irmin.S_MAKER + val integrity_check : Format.formatter -> repo -> unit +end + +module Make + (Config : CONFIG) + (M : Irmin.Metadata.S) + (C : Irmin.Contents.S) + (P : Irmin.Path.S) + (B : Irmin.Branch.S) + (H : Irmin.Hash.S) : sig + include + Irmin.S + with type key = P.t + and type step = P.step + and type metadata = M.t + and type contents = C.t + and type branch = B.t + and type hash = H.t + + val integrity_check : Format.formatter -> repo -> unit +end module KV (Config : CONFIG) : Irmin.KV_MAKER module Atomic_write (K : Irmin.Type.S) (V : Irmin.Hash.S) : sig include Irmin.ATOMIC_WRITE_STORE with type key = K.t and type value = V.t - val v : ?fresh:bool -> ?shared:bool -> ?readonly:bool -> string -> t Lwt.t + val v : ?fresh:bool -> ?readonly:bool -> string -> t Lwt.t + + val close : t -> unit Lwt.t end diff --git a/vendors/irmin-pack/lru.ml b/vendors/irmin-pack/lru.ml index 072376d43676..c13199dfcee2 100644 --- a/vendors/irmin-pack/lru.ml +++ b/vendors/irmin-pack/lru.ml @@ -115,4 +115,6 @@ module Make (H : Hashtbl.HashedType) = struct | true -> promote t k; true + + let clear t = create t.cap end diff --git a/vendors/irmin-pack/lru.mli b/vendors/irmin-pack/lru.mli index 510c7395a220..a39d80d8d490 100644 --- a/vendors/irmin-pack/lru.mli +++ b/vendors/irmin-pack/lru.mli @@ -23,4 +23,6 @@ module Make (H : Hashtbl.HashedType) : sig val find : 'a t -> H.t -> 'a val mem : 'a t -> H.t -> bool + + val clear : 'a t -> 'a t end diff --git a/vendors/irmin-pack/pack.ml b/vendors/irmin-pack/pack.ml index ab069ada7ca0..fed2db70fdac 100644 --- a/vendors/irmin-pack/pack.ml +++ b/vendors/irmin-pack/pack.ml @@ -74,7 +74,6 @@ module type S = sig val v : ?fresh:bool -> - ?shared:bool -> ?readonly:bool -> ?lru_size:int -> index:index -> @@ -90,6 +89,10 @@ module type S = sig val unsafe_find : 'a t -> key -> value option val sync : 'a t -> unit + + val integrity_check : offset:int64 -> length:int -> key -> 'a t -> unit + + val close : 'a t -> unit Lwt.t end module type MAKER = sig @@ -135,6 +138,7 @@ struct index : Index.t; dict : Dict.t; lock : Lwt_mutex.t; + mutable counter : int; } let clear t = @@ -142,7 +146,13 @@ struct Index.clear t.index; Dict.clear t.dict - let unsafe_v ~index ~fresh ~shared:_ ~readonly file = + let valid t = + if IO.is_valid t.block then ( + t.counter <- t.counter + 1; + true ) + else false + + let unsafe_v ~index ~fresh ~readonly file = let root = Filename.dirname file in let lock = Lwt_mutex.create () in let dict = Dict.v ~fresh ~readonly root in @@ -150,18 +160,33 @@ struct if IO.version block <> current_version then Fmt.failwith "invalid version: got %S, expecting %S" (IO.version block) current_version; - { block; index; lock; dict } + { block; index; lock; dict; counter = 1 } let (`Staged v) = - with_cache ~clear ~v:(fun index -> unsafe_v ~index) "store.pack" + with_cache ~clear ~valid ~v:(fun index -> unsafe_v ~index) "store.pack" type key = K.t + let close t = + t.counter <- t.counter - 1; + if t.counter = 0 then ( + if not (IO.readonly t.block) then IO.sync t.block; + IO.close t.block; + Index.close t.index; + Dict.close t.dict ) + + let valid t = IO.is_valid t.block + module Make (V : ELT with type hash := K.t) = struct module Tbl = Table (K) module Lru = Cache (K) - type nonrec 'a t = { pack : 'a t; lru : V.t Lru.t; staging : V.t Tbl.t } + type nonrec 'a t = { + pack : 'a t; + lru : V.t Lru.t; + staging : V.t Tbl.t; + mutable counter : int; + } type key = K.t @@ -180,32 +205,32 @@ struct let create = Lwt_mutex.create () - let unsafe_v_no_cache ~fresh ~readonly ~shared ~lru_size ~index root = - let pack = v index ~fresh ~shared ~readonly root in + let unsafe_v_no_cache ~fresh ~readonly ~lru_size ~index root = + let pack = v index ~fresh ~readonly root in let staging = Tbl.create 127 in let lru = Lru.create lru_size in - { staging; lru; pack } - - let unsafe_v ?(fresh = false) ?(shared = true) ?(readonly = false) - ?(lru_size = 10_000) ~index root = - if not shared then - unsafe_v_no_cache ~fresh ~readonly ~shared ~lru_size ~index root - else - try - let t = Hashtbl.find roots root in + { staging; lru; pack; counter = 1 } + + let unsafe_v ?(fresh = false) ?(readonly = false) ?(lru_size = 10_000) + ~index root = + try + let t = Hashtbl.find roots (root, readonly) in + if valid t.pack then ( + t.counter <- t.counter + 1; if fresh then clear t; - t - with Not_found -> - let t = - unsafe_v_no_cache ~fresh ~readonly ~shared ~lru_size ~index root - in - if fresh then clear t; - Hashtbl.add roots root t; - t - - let v ?fresh ?shared ?readonly ?lru_size ~index root = + t ) + else ( + Hashtbl.remove roots (root, readonly); + raise Not_found ) + with Not_found -> + let t = unsafe_v_no_cache ~fresh ~readonly ~lru_size ~index root in + if fresh then clear t; + Hashtbl.add roots (root, readonly) t; + t + + let v ?fresh ?readonly ?lru_size ~index root = Lwt_mutex.with_lock create (fun () -> - let t = unsafe_v ?fresh ?shared ?readonly ?lru_size ~index root in + let t = unsafe_v ?fresh ?readonly ?lru_size ~index root in Lwt.return t) let pp_hash = Irmin.Type.pp K.t @@ -278,6 +303,10 @@ struct IO.sync t.pack.block; Tbl.clear t.staging + let integrity_check ~offset ~length k t = + let value = io_read_and_decode ~off:offset ~len:length t in + check_key k value + let batch t f = f (cast t) >>= fun r -> if Tbl.length t.staging = 0 then Lwt.return r @@ -313,13 +342,26 @@ struct let append t k v = Lwt_mutex.with_lock t.pack.lock (fun () -> unsafe_append t k v; - Lwt.return ()) + Lwt.return_unit) let add t v = let k = V.hash v in append t k v >|= fun () -> k let unsafe_add t k v = append t k v + + let unsafe_close t = + t.counter <- t.counter - 1; + if t.counter = 0 then ( + Log.debug (fun l -> l "[pack] closing %s" (IO.name t.pack.block)); + Tbl.clear t.staging; + ignore (Lru.clear t.lru); + close t.pack ) + + let close t = + Lwt_mutex.with_lock t.pack.lock (fun () -> + unsafe_close t; + Lwt.return_unit) end end diff --git a/vendors/irmin-pack/pack.mli b/vendors/irmin-pack/pack.mli index 8a44a09861d5..271084625329 100644 --- a/vendors/irmin-pack/pack.mli +++ b/vendors/irmin-pack/pack.mli @@ -42,7 +42,6 @@ module type S = sig val v : ?fresh:bool -> - ?shared:bool -> ?readonly:bool -> ?lru_size:int -> index:index -> @@ -58,6 +57,10 @@ module type S = sig val unsafe_find : 'a t -> key -> value option val sync : 'a t -> unit + + val integrity_check : offset:int64 -> length:int -> key -> 'a t -> unit + + val close : 'a t -> unit Lwt.t end module type MAKER = sig diff --git a/vendors/irmin-pack/pack_dict.ml b/vendors/irmin-pack/pack_dict.ml index fd6fd92ce549..f5ce5c5dd26f 100644 --- a/vendors/irmin-pack/pack_dict.ml +++ b/vendors/irmin-pack/pack_dict.ml @@ -14,8 +14,10 @@ include Dict.Make (IO.Unix) (* Add IO caching around Dict.v *) let (`Staged v) = - let v_no_cache ~fresh ~shared:_ ~readonly = v ~fresh ~readonly in - IO.with_cache ~clear ~v:(fun capacity -> v_no_cache ~capacity) "store.dict" + let v_no_cache ~fresh ~readonly = v ~fresh ~readonly in + IO.with_cache ~clear ~valid + ~v:(fun capacity -> v_no_cache ~capacity) + "store.dict" -let v ?fresh ?shared ?readonly ?(capacity = 100_000) root = - v capacity ?fresh ?shared ?readonly root +let v ?fresh ?readonly ?(capacity = 100_000) root = + v capacity ?fresh ?readonly root diff --git a/vendors/irmin-pack/pack_dict.mli b/vendors/irmin-pack/pack_dict.mli index 8319c2d17b99..5de6b126f796 100644 --- a/vendors/irmin-pack/pack_dict.mli +++ b/vendors/irmin-pack/pack_dict.mli @@ -12,5 +12,4 @@ include Dict.S -val v : - ?fresh:bool -> ?shared:bool -> ?readonly:bool -> ?capacity:int -> string -> t +val v : ?fresh:bool -> ?readonly:bool -> ?capacity:int -> string -> t diff --git a/vendors/irmin-pack/pack_index.ml b/vendors/irmin-pack/pack_index.ml index c49f82b48d4f..6b4c0d636bff 100644 --- a/vendors/irmin-pack/pack_index.ml +++ b/vendors/irmin-pack/pack_index.ml @@ -11,23 +11,13 @@ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) module type S = sig - type t + include Index.S with type value = int64 * int * char - type key - - type value = int64 * int * char - - val v : ?fresh:bool -> ?readonly:bool -> log_size:int -> string -> t - - val clear : t -> unit - - val flush : t -> unit + val find : t -> key -> value option val add : t -> key -> value -> unit - val mem : t -> key -> bool - - val find : t -> key -> value option + val close : t -> unit end module Make (K : Irmin.Hash.S) = struct @@ -70,26 +60,10 @@ module Make (K : Irmin.Hash.S) = struct end module Index = Index_unix.Make (Key) (Val) + include Index - type t = Index.t - - type key = K.t - - type value = Val.t - - let v = Index.v - - let clear = Index.clear - - let flush = Index.flush - - let add t k v = if not (Index.mem t k) then Index.add t k v - - let mem = Index.mem + let add t k v = replace t k v let find t k = - match Index.find_all t k with - | [] -> None - | [ h ] -> Some h - | _ -> assert false + match find t k with exception Not_found -> None | h -> Some h end diff --git a/vendors/irmin-pack/pack_index.mli b/vendors/irmin-pack/pack_index.mli index 1950425920bb..c43bc79d8cb7 100644 --- a/vendors/irmin-pack/pack_index.mli +++ b/vendors/irmin-pack/pack_index.mli @@ -11,23 +11,13 @@ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) module type S = sig - type t + include Index.S with type value = int64 * int * char - type key - - type value = int64 * int * char - - val v : ?fresh:bool -> ?readonly:bool -> log_size:int -> string -> t - - val clear : t -> unit - - val flush : t -> unit + val find : t -> key -> value option val add : t -> key -> value -> unit - val mem : t -> key -> bool - - val find : t -> key -> value option + val close : t -> unit end module Make (K : Irmin.Hash.S) : S with type key = K.t diff --git a/vendors/irmin/commit.ml b/vendors/irmin/commit.ml index 832551101805..f0a3f5814cea 100644 --- a/vendors/irmin/commit.ml +++ b/vendors/irmin/commit.ml @@ -101,7 +101,7 @@ struct (old () >>= function | Error (`Conflict msg) -> Log.debug (fun f -> f "old: conflict %s" msg); - Lwt.return None + Lwt.return_none | Ok o -> Lwt.return o) >>= fun old -> if equal_opt_keys old (Some k1) then Merge.ok k2 @@ -233,7 +233,7 @@ module History (S : S.COMMIT_STORE) = struct KSet.iter (add_todo 0) init; let rec aux seen = match check () with - | (`Too_many_lcas | `Max_depth_reached) as x -> Lwt.return (Error x) + | (`Too_many_lcas | `Max_depth_reached) as x -> Lwt.return_error x | `Stop -> return () | `Continue -> ( match unqueue todo seen with @@ -416,15 +416,15 @@ module History (S : S.COMMIT_STORE) = struct let lcas t ?(max_depth = max_int) ?(n = max_int) c1 c2 = incr lca_calls; - if max_depth < 0 then Lwt.return (Error `Max_depth_reached) - else if n <= 0 then Lwt.return (Error `Too_many_lcas) - else if equal_keys c1 c2 then Lwt.return (Ok [ c1 ]) + if max_depth < 0 then Lwt.return_error `Max_depth_reached + else if n <= 0 then Lwt.return_error `Too_many_lcas + else if equal_keys c1 c2 then Lwt.return_ok [ c1 ] else let init = KSet.of_list [ c1; c2 ] in let s = empty_state c1 c2 in let check () = check ~max_depth ~n s in let pp () = pp_state s in - let return () = Lwt.return (Ok (lcas s)) in + let return () = Lwt.return_ok (lcas s) in let t0 = Sys.time () in Lwt.finalize (fun () -> diff --git a/vendors/irmin/contents.ml b/vendors/irmin/contents.ml index db0d855505f2..16f39bbdac38 100644 --- a/vendors/irmin/contents.ml +++ b/vendors/irmin/contents.ml @@ -294,7 +294,7 @@ struct let add_opt t = function | None -> Lwt.return_none - | Some v -> add t v >>= fun k -> Lwt.return (Some k) + | Some v -> add t v >>= fun k -> Lwt.return_some k let merge t = Merge.like_lwt Type.(option Key.t) Val.merge (read_opt t) (add_opt t) diff --git a/vendors/irmin/irmin.ml b/vendors/irmin/irmin.ml index 72907a616da9..129b56047859 100644 --- a/vendors/irmin/irmin.ml +++ b/vendors/irmin/irmin.ml @@ -54,6 +54,118 @@ module Path = struct module type S = S.PATH end +exception Closed + +module CA_check_closed (CA : S.CONTENT_ADDRESSABLE_STORE_MAKER) : + S.CONTENT_ADDRESSABLE_STORE_MAKER = +functor + (K : S.HASH) + (V : Type.S) + -> + struct + module S = CA (K) (V) + + type 'a t = { closed : bool ref; t : 'a S.t } + + type key = S.key + + type value = S.value + + let check_closed t = if !(t.closed) then raise Closed + + let mem t k = + check_closed t; + S.mem t.t k + + let find t k = + check_closed t; + S.find t.t k + + let add t v = + check_closed t; + S.add t.t v + + let unsafe_add t k v = + check_closed t; + S.unsafe_add t.t k v + + let batch t f = + check_closed t; + S.batch t.t (fun w -> f { t = w; closed = t.closed }) + + let v conf = S.v conf >|= fun t -> { closed = ref false; t } + + let close t = + if !(t.closed) then Lwt.return_unit + else ( + t.closed := true; + S.close t.t ) + end + +module AW_check_closed (AW : S.ATOMIC_WRITE_STORE_MAKER) : + S.ATOMIC_WRITE_STORE_MAKER = +functor + (K : Type.S) + (V : Type.S) + -> + struct + module S = AW (K) (V) + + type t = { closed : bool ref; t : S.t } + + type key = S.key + + type value = S.value + + let check_closed t = if !(t.closed) then raise Closed + + let mem t k = + check_closed t; + S.mem t.t k + + let find t k = + check_closed t; + S.find t.t k + + let set t k v = + check_closed t; + S.set t.t k v + + let test_and_set t k ~test ~set = + check_closed t; + S.test_and_set t.t k ~test ~set + + let remove t k = + check_closed t; + S.remove t.t k + + let list t = + check_closed t; + S.list t.t + + type watch = S.watch + + let watch t ?init f = + check_closed t; + S.watch t.t ?init f + + let watch_key t k ?init f = + check_closed t; + S.watch_key t.t k ?init f + + let unwatch t w = + check_closed t; + S.unwatch t.t w + + let v conf = S.v conf >|= fun t -> { closed = ref false; t } + + let close t = + if !(t.closed) then Lwt.return_unit + else ( + t.closed := true; + S.close t.t ) + end + module Make_ext (CA : S.CONTENT_ADDRESSABLE_STORE_MAKER) (AW : S.ATOMIC_WRITE_STORE_MAKER) @@ -68,6 +180,9 @@ module Make_ext and type step = P.step) (CT : S.COMMIT with type hash = H.t) = struct + module CA = CA_check_closed (CA) + module AW = AW_check_closed (AW) + module X = struct module Hash = H @@ -144,6 +259,11 @@ struct let commits = (nodes, commits) in Branch.v config >|= fun branch -> { contents; nodes; commits; branch; config } + + let close t = + Contents.CA.close t.contents >>= fun () -> + Node.CA.close (snd t.nodes) >>= fun () -> + Commit.CA.close (snd t.commits) >>= fun () -> Branch.close t.branch end end diff --git a/vendors/irmin/irmin.mli b/vendors/irmin/irmin.mli index d358f07753d0..28d4d95e3656 100644 --- a/vendors/irmin/irmin.mli +++ b/vendors/irmin/irmin.mli @@ -2081,6 +2081,8 @@ module Private : sig val v : config -> t Lwt.t + val close : t -> unit Lwt.t + val contents_t : t -> [ `Read ] Contents.t val node_t : t -> [ `Read ] Node.t @@ -2206,6 +2208,10 @@ module type S = sig (** [v config] connects to a repository in a backend-specific manner. *) + val close : t -> unit Lwt.t + (** [close t] frees up all resources associated with [t]. Any + operations run on a closed repository will raise [Closed]. *) + val heads : t -> commit list Lwt.t (** [heads] is {!Head.list}. *) @@ -3601,6 +3607,10 @@ module type APPEND_ONLY_STORE_MAKER = functor (K : Type.S) (V : Type.S) -> sig val v : config -> [ `Read ] t Lwt.t (** [v config] is a function returning fresh store handles, with the configuration [config], which is provided by the backend. *) + + val close : 'a t -> unit Lwt.t + (** [close t] frees up all the resources associated to [t]. Any + operations run on a closed store will raise [Closed].*) end (** [CONTENT_ADDRESSABLE_STOREMAKER] is the signature exposed by @@ -3619,6 +3629,10 @@ module type CONTENT_ADDRESSABLE_STORE_MAKER = functor val v : config -> [ `Read ] t Lwt.t (** [v config] is a function returning fresh store handles, with the configuration [config], which is provided by the backend. *) + + val close : 'a t -> unit Lwt.t + (** [close t] frees up all the resources associated to [t]. Any + operations run on a closed store will raise [Closed].*) end module Content_addressable @@ -3633,11 +3647,15 @@ module Content_addressable val batch : [ `Read ] t -> ([ `Read | `Write ] t -> 'a Lwt.t) -> 'a Lwt.t (** [batch t f] applies the writes in [f] in a separate batch. The - exact guarantees depends on the backends. *) + exact guarantees depends on the backends. *) val v : config -> [ `Read ] t Lwt.t (** [v config] is a function returning fresh store handles, with the configuration [config], which is provided by the backend. *) + + val close : 'a t -> unit Lwt.t + (** [close t] frees up all the resources associated to [t]. Any + operations run on a closed store will raise [Closed]. *) end (** [ATOMIC_WRITE_STORE_MAKER] is the signature exposed by atomic-write @@ -3649,6 +3667,10 @@ module type ATOMIC_WRITE_STORE_MAKER = functor (K : Type.S) (V : Type.S) -> sig val v : config -> t Lwt.t (** [v config] is a function returning fresh store handles, with the configuration [config], which is provided by the backend. *) + + val close : t -> unit Lwt.t + (** [close t] frees up all the resources associated to [t]. Any + operations run on a closed store will raise [Closed]. *) end module Make diff --git a/vendors/irmin/merge.ml b/vendors/irmin/merge.ml index 3b752e2369bc..cc1d8b3b0fd1 100644 --- a/vendors/irmin/merge.ml +++ b/vendors/irmin/merge.ml @@ -25,7 +25,7 @@ type conflict = [ `Conflict of string ] type 'a promise = unit -> ('a option, conflict) result Lwt.t -let promise t : 'a promise = fun () -> Lwt.return (Ok (Some t)) +let promise t : 'a promise = fun () -> Lwt.return_ok (Some t) let memo fn = let r = ref None in @@ -49,10 +49,10 @@ let conflict fmt = ksprintf (fun msg -> Log.debug (fun f -> f "conflict: %s" msg); - Lwt.return (Error (`Conflict msg))) + Lwt.return_error (`Conflict msg)) fmt -let bind x f = x >>= function Error _ as x -> Lwt.return x | Ok x -> f x +let bind x f = x >>= function Error e -> Lwt.return_error e | Ok x -> f x let map f x = x >|= function Error _ as x -> x | Ok x -> Ok (f x) @@ -64,11 +64,11 @@ let map_promise f t () = let bind_promise t f () = t () >>= function - | Error _ as x -> Lwt.return x - | Ok None -> Lwt.return @@ Ok None + | Error e -> Lwt.return_error e + | Ok None -> Lwt.return_ok None | Ok (Some a) -> f a () -let ok x = Lwt.return (Ok x) +let ok x = Lwt.return_ok x module Infix = struct let ( >>=* ) = bind diff --git a/vendors/irmin/node.ml b/vendors/irmin/node.ml index 48999dbc9387..8bdc0d57abf8 100644 --- a/vendors/irmin/node.ml +++ b/vendors/irmin/node.ml @@ -240,7 +240,7 @@ struct in let add v = if S.Val.is_empty v then Lwt.return_none - else add t v >>= fun k -> Lwt.return (Some k) + else add t v >>= fun k -> Lwt.return_some k in Merge.like_lwt Type.(option S.Key.t) merge read add @@ -317,7 +317,7 @@ module Graph (S : S.NODE_STORE) = struct Log.debug (fun f -> f "read_node_exn %a %a" pp_key node pp_path path); let rec aux node path = match Path.decons path with - | None -> Lwt.return (Some (`Node node)) + | None -> Lwt.return_some (`Node node) | Some (h, tl) -> ( find_step t node h >>= function | (None | Some (`Contents _)) as x -> Lwt.return x diff --git a/vendors/irmin/s.ml b/vendors/irmin/s.ml index 18d4fa687608..495ab50e315d 100644 --- a/vendors/irmin/s.ml +++ b/vendors/irmin/s.ml @@ -99,6 +99,8 @@ module type CONTENT_ADDRESSABLE_STORE_MAKER = functor val batch : [ `Read ] t -> ([ `Read | `Write ] t -> 'a Lwt.t) -> 'a Lwt.t val v : Conf.t -> [ `Read ] t Lwt.t + + val close : 'a t -> unit Lwt.t end module type APPEND_ONLY_STORE = sig @@ -121,6 +123,8 @@ module type APPEND_ONLY_STORE_MAKER = functor (K : Type.S) (V : Type.S) -> sig val batch : [ `Read ] t -> ([ `Read | `Write ] t -> 'a Lwt.t) -> 'a Lwt.t val v : Conf.t -> [ `Read ] t Lwt.t + + val close : 'a t -> unit Lwt.t end module type METADATA = sig @@ -403,6 +407,8 @@ module type ATOMIC_WRITE_STORE_MAKER = functor (K : Type.S) (V : Type.S) -> sig include ATOMIC_WRITE_STORE with type key = K.t and type value = V.t val v : Conf.t -> t Lwt.t + + val close : t -> unit Lwt.t end module type BRANCH_STORE = sig @@ -463,6 +469,8 @@ module type PRIVATE = sig val v : Conf.t -> t Lwt.t + val close : t -> unit Lwt.t + val contents_t : t -> [ `Read ] Contents.t val node_t : t -> [ `Read ] Node.t @@ -647,6 +655,8 @@ module type STORE = sig val v : config -> t Lwt.t + val close : t -> unit Lwt.t + val heads : t -> commit list Lwt.t val branches : t -> branch list Lwt.t diff --git a/vendors/irmin/store.ml b/vendors/irmin/store.ml index a93d310d0e73..aeedf0826aa6 100644 --- a/vendors/irmin/store.ml +++ b/vendors/irmin/store.ml @@ -36,7 +36,7 @@ struct let find t k = find t k >>= function - | None -> Lwt.return None + | None -> Lwt.return_none | Some v as r -> let k' = hash v in if Type.equal K.t k k' then Lwt.return r @@ -192,6 +192,8 @@ module Make (P : S.PRIVATE) = struct let v = P.Repo.v + let close = P.Repo.close + let graph_t t = P.Repo.node_t t let history_t t = P.Repo.commit_t t @@ -324,7 +326,7 @@ module Make (P : S.PRIVATE) = struct !commits >|= fun () -> Ok ()) (function - | Import_error e -> Lwt.return (Error (`Msg e)) + | Import_error e -> Lwt.return_error (`Msg e) | e -> Fmt.kstrf Lwt.fail_invalid_arg "impot error: %a" Fmt.exn e) end @@ -358,7 +360,7 @@ module Make (P : S.PRIVATE) = struct let branch t = match head_ref t with - | `Branch t -> Lwt.return (Some t) + | `Branch t -> Lwt.return_some t | `Empty | `Head _ -> Lwt.return_none let err_no_head s = Fmt.kstrf Lwt.fail_invalid_arg "Irmin.%s: no head" s @@ -398,7 +400,7 @@ module Make (P : S.PRIVATE) = struct let skip_key key = Log.debug (fun l -> l "[watch-key] key %a has not changed" pp_key key); - Lwt.return () + Lwt.return_unit let changed_key key = Log.debug (fun l -> l "[watch-key] key %a has changed" pp_key key) @@ -434,7 +436,7 @@ module Make (P : S.PRIVATE) = struct let head t = let h = match head_ref t with - | `Head key -> Lwt.return (Some key) + | `Head key -> Lwt.return_some key | `Empty -> Lwt.return_none | `Branch name -> ( Branch_store.find (branch_t t) name >>= function @@ -526,8 +528,8 @@ module Make (P : S.PRIVATE) = struct (* [head] is protected by [t.lock]. *) if Commit.equal_opt !head test then ( head := set; - Lwt.return true ) - else Lwt.return false + Lwt.return_true ) + else Lwt.return_false | `Branch name -> let h = function None -> None | Some c -> Some c.Commit.h in Branch_store.test_and_set (branch_t t) name ~test:(h test) @@ -548,7 +550,7 @@ module Make (P : S.PRIVATE) = struct Commit.pp_hash new_head); if Commit.equal new_head old_head then (* we only update if there is a change *) - Lwt.return (Error `No_change) + Lwt.return_error `No_change else H.lcas (history_t t) ?max_depth ?n new_head.Commit.h old_head.Commit.h @@ -557,8 +559,8 @@ module Make (P : S.PRIVATE) = struct (* we only update if new_head > old_head *) test_and_set t ~test:(Some old_head) ~set:(Some new_head) >|= return - | Ok _ -> Lwt.return (Error `Rejected) - | Error e -> Lwt.return (Error (e :> ff_error)) ) + | Ok _ -> Lwt.return_error `Rejected + | Error e -> Lwt.return_error (e :> ff_error) ) (* Merge two commits: - Search for common ancestors @@ -589,11 +591,11 @@ module Make (P : S.PRIVATE) = struct let done_once = ref false in let rec aux i = if !done_once && i > retries then - Lwt.return (Error (`Too_many_retries retries)) + Lwt.return_error (`Too_many_retries retries) else fn () >>= function - | Ok true -> Lwt.return (Ok ()) - | Error e -> Lwt.return (Error e) + | Ok true -> Lwt.return_ok () + | Error e -> Lwt.return_error e | Ok false -> done_once := true; aux (i + 1) @@ -606,12 +608,12 @@ module Make (P : S.PRIVATE) = struct match t.head_ref with | `Head head -> Lwt_mutex.with_lock t.lock (fun () -> - if not (Commit.equal_opt old_head !head) then Lwt.return false + if not (Commit.equal_opt old_head !head) then Lwt.return_false else ( (* [head] is protected by [t.lock] *) head := Some c; t.tree <- Some tree; - Lwt.return true )) + Lwt.return_true )) | `Branch name -> (* concurrent handlers and/or process can modify the branch. Need to check that we are still working on the same @@ -638,7 +640,7 @@ module Make (P : S.PRIVATE) = struct Type.(pp (option Tree.tree_t)) t - let write_error e : ('a, write_error) result Lwt.t = Lwt.return (Error e) + let write_error e : ('a, write_error) result Lwt.t = Lwt.return_error e let err_test v = write_error (`Test_was v) @@ -674,16 +676,16 @@ module Make (P : S.PRIVATE) = struct f s.tree >>= fun new_tree -> (* if no change and [allow_empty = true] then, do nothing *) if same_tree s.tree new_tree && (not allow_empty) && s.head <> None then - Lwt.return (Ok true) + Lwt.return_ok true else merge_tree s.root key ~current_tree:s.tree ~new_tree >>= function - | Error _ as e -> Lwt.return e + | Error e -> Lwt.return_error e | Ok root -> let info = info () in let parents = match parents with None -> s.parents | Some p -> p in let parents = List.map Commit.hash parents in Commit.v (repo t) ~info ~parents root >>= fun c -> - add_commit t s.head (c, root_tree root) >|= fun r -> Ok r + add_commit t s.head (c, root_tree root) >>= Lwt.return_ok let ok x = Ok x @@ -700,7 +702,7 @@ module Make (P : S.PRIVATE) = struct Log.debug (fun l -> l "set %a" pp_key k); retry ~retries @@ fun () -> update t k ?allow_empty ?parents ~info set_tree_once @@ fun _tree -> - Lwt.return (Some v) + Lwt.return_some v let set_tree_exn ?retries ?allow_empty ?parents ~info t k v = set_tree ?retries ?allow_empty ?parents ~info t k v >>= fail "set_exn" @@ -709,7 +711,7 @@ module Make (P : S.PRIVATE) = struct Log.debug (fun l -> l "debug %a" pp_key k); retry ~retries @@ fun () -> update t k ?allow_empty ?parents ~info set_tree_once @@ fun _tree -> - Lwt.return None + Lwt.return_none let remove_exn ?retries ?allow_empty ?parents ~info t k = remove ?retries ?allow_empty ?parents ~info t k >>= fail "remove_exn" @@ -846,7 +848,7 @@ module Make (P : S.PRIVATE) = struct (* use the store's current tree as the new 'old store' *) (tree_and_head t >>= function - | None -> Lwt.return None + | None -> Lwt.return_none | Some (_, tr) -> Tree.find_tree (tr :> tree) key) >>= fun old_tree -> aux (n + 1) old_tree | Error e -> write_error e ) diff --git a/vendors/irmin/store.mli b/vendors/irmin/store.mli index d572c20dced5..69a473dcf219 100644 --- a/vendors/irmin/store.mli +++ b/vendors/irmin/store.mli @@ -43,4 +43,6 @@ module Content_addressable val batch : [ `Read ] t -> ([ `Read | `Write ] t -> 'a Lwt.t) -> 'a Lwt.t val v : Conf.t -> [ `Read ] t Lwt.t + + val close : 'a t -> unit Lwt.t end diff --git a/vendors/irmin/sync.ml b/vendors/irmin/sync.ml index 7ea3f779bb53..d5e6f7efde85 100644 --- a/vendors/irmin/sync.ml +++ b/vendors/irmin/sync.ml @@ -17,7 +17,7 @@ module None (H : Type.S) (R : Type.S) = struct type t = unit - let v _ = Lwt.return () + let v _ = Lwt.return_unit type endpoint = unit diff --git a/vendors/irmin/sync_ext.ml b/vendors/irmin/sync_ext.ml index be803ee2c84e..5099e0ae6a87 100644 --- a/vendors/irmin/sync_ext.ml +++ b/vendors/irmin/sync_ext.ml @@ -172,17 +172,17 @@ module Make (S : S.STORE) = struct convert_slice (module S.Private) (module R.Private) s_slice >>= fun r_slice -> R.Repo.import (R.repo r) r_slice >>= function - | Error e -> Lwt.return (Error (e :> push_error)) + | Error e -> Lwt.return_error (e :> push_error) | Ok () -> ( match conv S.(commit_t s_repo) R.(commit_t r_repo) h with - | Error e -> Lwt.return (Error (e :> push_error)) + | Error e -> Lwt.return_error (e :> push_error) | Ok h -> R.Head.set r h >>= fun () -> S.Head.get t >|= fun head -> Ok (`Head head) ) ) ) | S.E e -> ( match S.status t with | `Empty -> Lwt.return_ok `Empty - | `Commit _ -> Lwt.return (Error `Detached_head) + | `Commit _ -> Lwt.return_error `Detached_head | `Branch br -> ( S.of_branch (S.repo t) br >>= S.Head.get >>= fun head -> B.v (S.repo t) >>= fun g -> diff --git a/vendors/irmin/tree.ml b/vendors/irmin/tree.ml index e9c7b2de5b68..dc1e1c400986 100644 --- a/vendors/irmin/tree.ml +++ b/vendors/irmin/tree.ml @@ -422,10 +422,10 @@ module Make (P : S.PRIVATE) = struct let to_value t = match value t with - | Some v -> Lwt.return (Some v) + | Some v -> Lwt.return_some v | None -> ( match t.v with - | Value v -> Lwt.return (Some v) + | Value v -> Lwt.return_some v | Hash (repo, k) -> value_of_hash t repo k ) let equal (x : t) (y : t) = @@ -863,19 +863,19 @@ module Make (P : S.PRIVATE) = struct let to_value t = match value t with - | Some v -> Lwt.return (Some v) + | Some v -> Lwt.return_some v | None -> ( match t.v with - | Value (_, v, None) -> Lwt.return (Some v) + | Value (_, v, None) -> Lwt.return_some v | Value (_, v, Some m) -> let v = value_of_adds t v m in - Lwt.return (Some v) - | Map m -> Lwt.return (Some (value_of_map t m)) + Lwt.return_some v + | Map m -> Lwt.return_some (value_of_map t m) | Hash (repo, h) -> value_of_hash t repo h ) let to_map t = match map t with - | Some m -> Lwt.return (Some m) + | Some m -> Lwt.return_some m | None -> ( let of_value repo v added = let m = map_of_value repo v in @@ -888,7 +888,7 @@ module Make (P : S.PRIVATE) = struct Some m in match t.v with - | Map m -> Lwt.return (Some m) + | Map m -> Lwt.return_some m | Value (repo, v, m) -> Lwt.return (of_value repo v m) | Hash (repo, k) -> ( value_of_hash t repo k >|= function @@ -932,7 +932,7 @@ module Make (P : S.PRIVATE) = struct | Some m -> Lwt.return (StepMap.is_empty m) | None -> ( match t.v with - | Value (_, _, Some _) -> Lwt.return false + | Value (_, _, Some _) -> Lwt.return_false | _ -> ( to_value t >|= function | None -> false @@ -966,8 +966,8 @@ module Make (P : S.PRIVATE) = struct let findv t step = let of_map m = match StepMap.find step m with - | exception Not_found -> Lwt.return None - | `Node n -> Lwt.return (Some (`Node n)) + | exception Not_found -> Lwt.return_none + | `Node n -> Lwt.return_some (`Node n) | `Contents (c, m) -> ( Contents.to_value c >|= function | None -> None @@ -975,7 +975,7 @@ module Make (P : S.PRIVATE) = struct in let of_value repo v = match P.Node.Val.find v step with - | None -> Lwt.return None + | None -> Lwt.return_none | Some (`Contents (c, m)) -> ( let c = Contents.of_hash repo c in let (v : elt) = `Contents (c, m) in @@ -987,7 +987,7 @@ module Make (P : S.PRIVATE) = struct let n = of_hash repo n in let v = `Node n in add_to_findv_cache t step v; - Lwt.return (Some v) + Lwt.return_some v in let of_t () = match t.v with @@ -1002,7 +1002,7 @@ module Make (P : S.PRIVATE) = struct | Some v -> of_value repo v | None -> ( value_of_hash t repo h >>= function - | None -> Lwt.return None + | None -> Lwt.return_none | Some v -> of_value repo v ) ) in match map t with @@ -1131,15 +1131,15 @@ module Make (P : S.PRIVATE) = struct let mold = Merge.bind_promise old (fun old () -> match old with - | `Contents (_, m) -> Lwt.return (Ok (Some m)) - | `Node _ -> Lwt.return (Ok None)) + | `Contents (_, m) -> Lwt.return_ok (Some m) + | `Node _ -> Lwt.return_ok None) in Merge.(f Metadata.merge) ~old:mold cx cy >>=* fun m -> let old = Merge.bind_promise old (fun old () -> match old with - | `Contents (c, _) -> Lwt.return (Ok (Some c)) - | `Node _ -> Lwt.return (Ok None)) + | `Contents (c, _) -> Lwt.return_ok (Some c) + | `Node _ -> Lwt.return_ok None) in Merge.(f Contents.merge) ~old x y >>=* fun c -> Merge.ok (`Contents (c, m)) @@ -1148,8 +1148,8 @@ module Make (P : S.PRIVATE) = struct let old = Merge.bind_promise old (fun old () -> match old with - | `Contents _ -> Lwt.return (Ok None) - | `Node n -> Lwt.return (Ok (Some n))) + | `Contents _ -> Lwt.return_ok None + | `Node n -> Lwt.return_ok (Some n)) in Merge.(f m ~old x y) >>=* fun n -> Merge.ok (`Node n)) | _ -> Merge.conflict "add/add values" @@ -1200,7 +1200,7 @@ module Make (P : S.PRIVATE) = struct let is_empty = function | `Node n -> Node.is_empty n - | `Contents _ -> Lwt.return false + | `Contents _ -> Lwt.return_false let of_node n = `Node n @@ -1213,7 +1213,7 @@ module Make (P : S.PRIVATE) = struct let sub t path = let rec aux node path = match Path.decons path with - | None -> Lwt.return (Some node) + | None -> Lwt.return_some node | Some (h, p) -> ( Node.findv node h >>= function | None | Some (`Contents _) -> Lwt.return_none @@ -1226,10 +1226,10 @@ module Make (P : S.PRIVATE) = struct let find_tree (t : tree) path = Log.debug (fun l -> l "Tree.find_tree %a" pp_path path); match (t, Path.rdecons path) with - | v, None -> Lwt.return (Some v) + | v, None -> Lwt.return_some v | _, Some (path, file) -> ( sub t path >>= function - | None -> Lwt.return None + | None -> Lwt.return_none | Some n -> Node.findv n file ) type marks = Node.marks @@ -1309,25 +1309,25 @@ module Make (P : S.PRIVATE) = struct let kind t path = Log.debug (fun l -> l "Tree.kind %a" pp_path path); match (t, Path.rdecons path) with - | `Contents _, None -> Lwt.return (Some `Contents) - | _, None -> Lwt.return None + | `Contents _, None -> Lwt.return_some `Contents + | _, None -> Lwt.return_none | _, Some (dir, file) -> ( sub t dir >>= function - | None -> Lwt.return None + | None -> Lwt.return_none | Some m -> ( Node.findv m file >>= function - | None -> Lwt.return None - | Some (`Contents _) -> Lwt.return (Some `Contents) - | Some (`Node _) -> Lwt.return (Some `Node) ) ) + | None -> Lwt.return_none + | Some (`Contents _) -> Lwt.return_some `Contents + | Some (`Node _) -> Lwt.return_some `Node ) ) let list t path = Log.debug (fun l -> l "Tree.list %a" pp_path path); - sub t path >>= function None -> Lwt.return [] | Some n -> Node.list n + sub t path >>= function None -> Lwt.return_nil | Some n -> Node.list n let may_remove t k = Node.findv t k >>= function | None -> Lwt.return_none - | Some _ -> Node.remove t k >>= fun t -> Lwt.return (Some t) + | Some _ -> Node.remove t k >>= fun t -> Lwt.return_some t let empty = `Node (Node.of_map StepMap.empty) @@ -1488,7 +1488,7 @@ module Make (P : S.PRIVATE) = struct Node.to_value n >|= function | None -> () | Some v -> n.v <- Value (repo, v, None) ) - | _ -> Lwt.return () ) + | _ -> Lwt.return_unit ) >>= fun () -> (* 2. push the current node job on the stack. *) let () = @@ -1555,7 +1555,7 @@ module Make (P : S.PRIVATE) = struct | None -> Merge.conflict "conflict: contents" | Some c -> Merge.ok (`Contents (c, m)) ) | Ok (`Node _ as n) -> Merge.ok n - | Error _ as e -> Lwt.return e + | Error e -> Lwt.return_error e in Merge.v tree_t f @@ -1655,7 +1655,7 @@ module Make (P : S.PRIVATE) = struct let diff (x : tree) (y : tree) = match (x, y) with | `Contents x, `Contents y -> - if contents_equal x y then Lwt.return [] + if contents_equal x y then Lwt.return_nil else Lwt.return [ (Path.empty, `Updated (y, x)) ] | `Node x, `Node y -> diff_node x y | `Contents x, `Node y -> diff --git a/vendors/irmin/type.ml b/vendors/irmin/type.ml index 92d580492203..b8ecb1e97ac0 100644 --- a/vendors/irmin/type.ml +++ b/vendors/irmin/type.ml @@ -532,23 +532,23 @@ end let equal = Equal.t module Compare = struct - let unit (_ : unit) (_ : unit) = 0 + let unit (_ : unit) (_ : unit) = 0 [@@inline always] - let bool (x : bool) (y : bool) = compare x y + let bool (x : bool) (y : bool) = compare x y [@@inline always] - let char = Char.compare + let char x y = Char.compare x y [@@inline always] - let int (x : int) (y : int) = compare x y + let int (x : int) (y : int) = compare x y [@@inline always] - let int32 = Int32.compare + let int32 x y = Int32.compare x y [@@inline always] - let int64 = Int64.compare + let int64 x y = Int64.compare x y [@@inline always] - let float (x : float) (y : float) = compare x y + let float (x : float) (y : float) = compare x y [@@inline always] - let string x y = if x == y then 0 else String.compare x y + let string x y = if x == y then 0 else String.compare x y [@@inline always] - let bytes x y = if x == y then 0 else Bytes.compare x y + let bytes x y = if x == y then 0 else Bytes.compare x y [@@inline always] let list c x y = if x == y then 0 @@ -594,13 +594,27 @@ module Compare = struct | None, Some _ -> -1 | Some x, Some y -> c x y + let prim : type a. a prim -> a compare = + fun ty a b -> + match ty with + | Unit -> (unit [@inlined]) a b + | Bool -> (bool [@inlined]) a b + | Char -> (char [@inlined]) a b + | Int -> (int [@inlined]) a b + | Int32 -> (int32 [@inlined]) a b + | Int64 -> (int64 [@inlined]) a b + | Float -> (float [@inlined]) a b + | String _ -> (string [@inlined]) a b + | Bytes _ -> (bytes [@inlined]) a b + [@@inline always] + let rec t : type a. a t -> a compare = fun ty a b -> match ty with | Self s -> t s.self a b | Custom c -> c.compare a b | Map m -> map m a b - | Prim p -> prim p a b + | Prim p -> (prim [@inlined]) p a b | List l -> list (t l.v) a b | Array x -> array (t x.v) a b | Tuple t -> tuple t a b @@ -615,17 +629,6 @@ module Compare = struct and map : type a b. (a, b) map -> b compare = fun { x; g; _ } u v -> t x (g u) (g v) - and prim : type a. a prim -> a compare = function - | Unit -> unit - | Bool -> bool - | Char -> char - | Int -> int - | Int32 -> int32 - | Int64 -> int64 - | Float -> float - | String _ -> string - | Bytes _ -> bytes - and record : type a. a record -> a compare = fun r x y -> let rec aux = function @@ -658,7 +661,7 @@ module Compare = struct (* this should never happen *) end -let compare = Compare.t +let compare t x y = Compare.t t x y exception Not_utf8 -- GitLab From 4745c01e7289c01b7094d81ae0374f2bab01b5a2 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Mon, 2 Sep 2019 18:55:07 +0200 Subject: [PATCH 15/17] lib_storage: automatically close the underlying database resources --- src/lib_storage/context.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/lib_storage/context.ml b/src/lib_storage/context.ml index 20d8be37b80f..20351d7c5983 100644 --- a/src/lib_storage/context.ml +++ b/src/lib_storage/context.ml @@ -378,13 +378,16 @@ let init ?patch_context ?mapsize:_ ?readonly root = Store.Repo.v (Irmin_pack.config ?readonly ?index_log_size:!index_log_size root) >>= fun repo -> - Lwt.return + let v = { path= root ; repo ; patch_context= ( match patch_context with | None -> fun ctxt -> Lwt.return ctxt | Some patch_context -> patch_context ) } + in + Gc.finalise (fun v -> Lwt.async (fun () -> Store.Repo.close v.repo)) v; + Lwt.return v let get_branch chain_id = Format.asprintf "%a" Chain_id.pp chain_id -- GitLab From a752c434eaf3bba37b9a186d410ed8a0b44c5f00 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Wed, 4 Sep 2019 10:19:31 +0200 Subject: [PATCH 16/17] [index] update to latest version - rename files (and move everything under an index/ subdirectory) * index/log : write ahead log file * index/data : index data * index/merge : temporary merge file x* index/lock : concurrent writer lock file - cleaner search API - fix opening of concurrent readers - better check to test if an fd is valid --- vendors/index/src/index.ml | 184 ++++++++++---------------- vendors/index/src/index.mli | 71 +++++----- vendors/index/src/io.mli | 2 - vendors/index/src/io_array.ml | 105 +++++++++++++++ vendors/index/src/io_array.mli | 20 +++ vendors/index/src/log.ml | 5 + vendors/index/src/log.mli | 1 + vendors/index/src/search.ml | 142 ++++++++++++++++++++ vendors/index/src/search.mli | 58 ++++++++ vendors/index/src/unix/index_unix.ml | 28 ++-- vendors/index/src/unix/index_unix.mli | 5 + 11 files changed, 456 insertions(+), 165 deletions(-) create mode 100644 vendors/index/src/io_array.ml create mode 100644 vendors/index/src/io_array.mli create mode 100644 vendors/index/src/log.ml create mode 100644 vendors/index/src/log.mli create mode 100644 vendors/index/src/search.ml create mode 100644 vendors/index/src/search.mli diff --git a/vendors/index/src/index.ml b/vendors/index/src/index.ml index 1c05db5997a4..2501ab8a0653 100644 --- a/vendors/index/src/index.ml +++ b/vendors/index/src/index.ml @@ -1,5 +1,7 @@ module Private = struct module Fan = Fan + module Io_array = Io_array + module Search = Search end module type Key = sig @@ -68,10 +70,6 @@ let may f = function None -> () | Some bf -> f bf exception RO_not_allowed -let src = Logs.Src.create "index" ~doc:"Index" - -module Log = (val Logs.src_log src : Logs.LOG) - module Make (K : Key) (V : Value) (IO : IO) = struct type key = K.t @@ -81,8 +79,6 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let entry_size = K.encoded_size + V.encoded_size - let entry_sizef = float_of_int entry_size - let entry_sizeL = Int64.of_int entry_size exception Invalid_key_size of key @@ -119,7 +115,7 @@ module Make (K : Key) (V : Value) (IO : IO) = struct log : IO.t; log_mem : entry Tbl.t; mutable counter : int; - lock : IO.lock; + lock : IO.lock option; } let clear t = @@ -136,11 +132,15 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let ( // ) = Filename.concat - let log_path root = root // "index.log" + let index_dir root = root // "index" + + let log_path root = index_dir root // "log" - let index_path root = root // "index" // "index" + let index_path root = index_dir root // "data" - let lock_path root = root // "index" // ".lock" + let lock_path root = index_dir root // "lock" + + let merge_path root = index_dir root // "merge" let page_size = Int64.mul entry_sizeL 1_000L @@ -167,24 +167,56 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let iter_io ?min ?max f io = iter_io_off ?min ?max (fun _ e -> f e) io - type window = { buf : bytes; off : int64 } + module Entry = struct + type t = entry - let get_entry io ~window off = - match window with - | None -> - let buf = Bytes.create entry_size in - let n = IO.read io ~off buf in - assert (n = entry_size); - decode_entry buf 0 - | Some w -> - let off = Int64.(to_int @@ sub off w.off) in - decode_entry w.buf off + module Key = K + module Value = V + + let encoded_size = entry_size + + let decode = decode_entry + + let to_key e = e.key + + let to_value e = e.value + end + + module IOArray = Io_array.Make (IO) (Entry) + + module Search = + Search.Make (Entry) (IOArray) + (struct + type t = int + + module Entry = Entry + + let compare : int -> int -> int = compare + + let of_entry e = e.key_hash + + let of_key = K.hash + + let linear_interpolate ~low:(low_index, low_metric) + ~high:(high_index, high_metric) key_metric = + let low_in = float_of_int low_metric in + let high_in = float_of_int high_metric in + let target_in = float_of_int key_metric in + let low_out = Int64.to_float low_index in + let high_out = Int64.to_float high_index in + (* Fractional position of [target_in] along the line from [low_in] to [high_in] *) + let proportion = (target_in -. low_in) /. (high_in -. low_in) in + (* Convert fractional position to position in output space *) + let position = low_out +. (proportion *. (high_out -. low_out)) in + let rounded = ceil (position -. 0.5) +. 0.5 in + Int64.of_float rounded + end) let with_cache ~v ~clear = let roots = Hashtbl.create 0 in let f ?(fresh = false) ?(readonly = false) ~log_size root = try - if not (Sys.file_exists root) then ( + if not (Sys.file_exists (index_dir root)) then ( Log.debug (fun l -> l "[%s] does not exist anymore, cleaning up the fd cache" (Filename.basename root)); @@ -192,7 +224,7 @@ module Make (K : Key) (V : Value) (IO : IO) = struct Hashtbl.remove roots (root, false); raise Not_found ); let t = Hashtbl.find roots (root, readonly) in - if IO.valid_fd t.log then ( + if t.counter <> 0 then ( Log.debug (fun l -> l "%s found in cache" root); t.counter <- t.counter + 1; if fresh then clear t; @@ -211,7 +243,9 @@ module Make (K : Key) (V : Value) (IO : IO) = struct `Staged f let v_no_cache ~fresh ~readonly ~log_size root = - let lock = IO.lock (lock_path root) in + let lock = + if not readonly then Some (IO.lock (lock_path root)) else None + in let config = { log_size = log_size * entry_size; readonly } in let log_path = log_path root in let index_path = index_path root in @@ -232,89 +266,13 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let (`Staged v) = with_cache ~v:v_no_cache ~clear - let get_entry_iff_needed ~window io off = function - | Some e -> e - | None -> get_entry ~window io off - - let look_around ~window io ~low ~high key h_key off = - let rec search op curr = - let off = op curr entry_sizeL in - if off < low || off > high then raise Not_found - else - let e = get_entry ~window io off in - let h_e = e.key_hash in - if h_e <> h_key then raise Not_found - else if K.equal e.key key then e.value - else search op off - in - match search Int64.add off with - | e -> e - | exception Not_found -> search Int64.sub off - - let interpolation_search index key : value = + let interpolation_search index key = let hashed_key = K.hash key in - let low, high = Fan.search index.fan_out hashed_key in - let rec search steps ~window low high lowest_entry highest_entry = - if high < low then raise Not_found - else - let window = - match window with - | Some _ as w -> w - | None -> - let len = Int64.(add (sub high low) entry_sizeL) in - if len <= 4_096L then ( - let buf = Bytes.create (Int64.to_int len) in - let n = IO.read index.io ~off:low buf in - assert (n = Bytes.length buf); - Some { buf; off = low } ) - else None - in - let lowest_entry = - get_entry_iff_needed ~window index.io low lowest_entry - in - if high = low then - if K.equal lowest_entry.key key then lowest_entry.value - else raise Not_found - else - let lowest_hash = lowest_entry.key_hash in - if lowest_hash > hashed_key then raise Not_found - else - let highest_entry = - get_entry_iff_needed ~window index.io high highest_entry - in - let highest_hash = highest_entry.key_hash in - if highest_hash < hashed_key then raise Not_found - else - let lowest_hashf = float_of_int lowest_hash in - let highest_hashf = float_of_int highest_hash in - let hashed_keyf = float_of_int hashed_key in - let lowf = Int64.to_float low in - let highf = Int64.to_float high in - let doff = - floor - ( (highf -. lowf) - *. (hashed_keyf -. lowest_hashf) - /. (highest_hashf -. lowest_hashf) ) - in - let off = lowf +. doff -. mod_float doff entry_sizef in - let offL = Int64.of_float off in - let e = get_entry ~window index.io offL in - let hashed_e = e.key_hash in - if hashed_key = hashed_e then - if K.equal key e.key then e.value - else - look_around ~window ~low ~high index.io key hashed_key offL - else if hashed_e < hashed_key then - (search [@tailcall]) (steps + 1) ~window - (Int64.add offL entry_sizeL) - high None (Some highest_entry) - else - (search [@tailcall]) (steps + 1) ~window low - (Int64.sub offL entry_sizeL) - (Some lowest_entry) None + let low_bytes, high_bytes = Fan.search index.fan_out hashed_key in + let low, high = + Int64.(div low_bytes entry_sizeL, div high_bytes entry_sizeL) in - if high < 0L then raise Not_found - else (search [@tailcall]) ~window:None 0 low high None None + Search.interpolation_search (IOArray.v index.io) key ~low ~high let sync_log t = let generation = IO.get_generation t.log in @@ -416,7 +374,7 @@ module Make (K : Key) (V : Value) (IO : IO) = struct let merge ~witness t = Log.debug (fun l -> l "unforced merge %S\n" t.root); - let tmp_path = t.root // "tmp" // "index" in + let merge_path = merge_path t.root in let generation = Int64.succ t.generation in let log = let compare_entry e e' = compare e.key_hash e'.key_hash in @@ -438,10 +396,10 @@ module Make (K : Key) (V : Value) (IO : IO) = struct + Tbl.length t.log_mem in let fan_out = Fan.v ~hash_size:K.hash_size ~entry_size fan_size in - let tmp = + let merge = IO.v ~readonly:false ~fresh:true ~generation ~fan_size:(Int64.of_int (Fan.exported_size fan_out)) - tmp_path + merge_path in ( match t.index with | None -> @@ -449,18 +407,18 @@ module Make (K : Key) (V : Value) (IO : IO) = struct IO.v ~fresh:true ~readonly:false ~generation:0L ~fan_size:0L (index_path t.root) in - append_remaining_log fan_out log 0 tmp; + append_remaining_log fan_out log 0 merge; t.index <- Some { io; fan_out } | Some index -> let index = { index with fan_out } in - merge_with log index tmp; + merge_with log index merge; t.index <- Some index ); match t.index with | None -> assert false | Some index -> Fan.finalize index.fan_out; - IO.set_fanout tmp (Fan.export index.fan_out); - IO.rename ~src:tmp ~dst:index.io; + IO.set_fanout merge (Fan.export index.fan_out); + IO.rename ~src:merge ~dst:index.io; IO.clear t.log; Tbl.clear t.log_mem; IO.set_generation t.log generation; @@ -495,5 +453,5 @@ module Make (K : Key) (V : Value) (IO : IO) = struct may (fun i -> IO.close i.io) t.index; t.index <- None; Tbl.reset t.log_mem; - IO.unlock t.lock ) + may (fun lock -> IO.unlock lock) t.lock ) end diff --git a/vendors/index/src/index.mli b/vendors/index/src/index.mli index d3467fc53ab7..e9161ce4d51a 100644 --- a/vendors/index/src/index.mli +++ b/vendors/index/src/index.mli @@ -1,15 +1,18 @@ -(** Deudex - - deudex is a scalable implementation of persistent indexes in Ocaml. - - deudex is append-only, which means it provides [append], [find] and [mem] - primitives. - Multiples IOs are created when using the index : - - A `log` IO contains all the recently added bindings, it is also kept in - memory. - - When the `log` IO is full, it is merged into multiple `index` IOs. - Search is done first in `log` then in `index`, which makes recently added - bindings search faster. +(** Index + + [Index] is a scalable implementation of persistent indices in OCaml. + + [Index] provides the standard key-value interface: [find], [mem] and + [replace]. It requires three IO instances: + + - A `log` IO containing all of the recently-added bindings; this is also + kept in memory. + + - When the `log` IO is full, it is merged into the `index` IO. Search + is done first in `log` then in `index`, which makes recently added + bindings search faster. + + - A `lock` IO to ensure safe concurrent access. *) (** The input of [Make] for keys. *) @@ -29,8 +32,8 @@ module type Key = sig bits. *) val encode : t -> string - (** [encode] is an encoding function. The encoded resulting values must be of - fixed size. *) + (** [encode] is an encoding function. The resultant encoded values must have + size {!encoded_size} bytes. *) val decode : string -> int -> t (** [decode] is a decoding function such that [decode (encode t) 0 = t]. *) @@ -44,7 +47,7 @@ module type Key = sig end (** The input of [Make] for values. The same requirements as for [Key] - applies. *) + apply. *) module type Value = sig type t @@ -63,7 +66,7 @@ exception RO_not_allowed (** The exception raised when illegal operation is attempted on a read_only index. *) -(** Index module signature. *) +(** Index module signature. *) module type S = sig type t (** The type for indexes. *) @@ -79,15 +82,13 @@ module type S = sig @param fresh @param read_only whether read-only mode is enabled for this index. @param log_size the maximum number of bindings in the `log` IO. - @param fan_out_size the number of bits of the fan out for index IO. *) val clear : t -> unit (** [clear t] clears [t] so that there are no more bindings in it. *) val find : t -> key -> value - (** [find t k] are all the bindings of [k] in [t]. The order is not - specified *) + (** [find t k] is the binding of [k] in [t]. *) val mem : t -> key -> bool (** [mem t k] is [true] iff [k] is bound in [t]. *) @@ -111,33 +112,21 @@ module type S = sig (** Flushes all buffers to the disk. *) val close : t -> unit - (** Closes the files and clears the caches of [t].*) + (** Closes the files and clears the caches of [t]. *) val force_merge : t -> key -> value -> unit - (** [force_merge t k v] forces a merge for [t], where [k] and [v] are any key and value of [t]. *) + (** [force_merge t k v] forces a merge for [t], where [k] and [v] are any key + and value of [t]. *) end -module Private : sig - module Fan : sig - type t - - val equal : t -> t -> bool - - val v : hash_size:int -> entry_size:int -> int -> t - - val search : t -> int -> int64 * int64 - - val update : t -> int -> int64 -> unit - - val finalize : t -> unit +module Make (K : Key) (V : Value) (IO : IO) : + S with type key = K.t and type value = V.t - val exported_size : t -> int +(** These modules should not be used. They are exposed purely for testing purposes. *) +module Private : sig + module Search : module type of Search - val export : t -> string + module Io_array : module type of Io_array - val import : hash_size:int -> string -> t - end + module Fan : module type of Fan end - -module Make (K : Key) (V : Value) (IO : IO) : - S with type key = K.t and type value = V.t diff --git a/vendors/index/src/io.mli b/vendors/index/src/io.mli index b65bcd788559..815955ad3e04 100644 --- a/vendors/index/src/io.mli +++ b/vendors/index/src/io.mli @@ -39,8 +39,6 @@ module type S = sig val close : t -> unit - val valid_fd : t -> bool - type lock val lock : string -> lock diff --git a/vendors/index/src/io_array.ml b/vendors/index/src/io_array.ml new file mode 100644 index 000000000000..405316b1b31d --- /dev/null +++ b/vendors/index/src/io_array.ml @@ -0,0 +1,105 @@ +module type ELT = sig + type t + + val encoded_size : int + + val decode : Bytes.t -> int -> t +end + +module type S = sig + include Search.ARRAY + + type io + + val v : io -> t +end + +module Make (IO : Io.S) (Elt : ELT) : + S with type io = IO.t and type elt = Elt.t = struct + module Elt = struct + include Elt + + let encoded_sizeL = Int64.of_int encoded_size + end + + type io = IO.t + + type elt = Elt.t + + type buffer = { buf : bytes; low_off : int64; high_off : int64 } + + type t = { io : IO.t; mutable buffer : buffer option } + + let v io = { io; buffer = None } + + let get_entry_from_io io off = + let buf = Bytes.create Elt.encoded_size in + let n = IO.read io ~off buf in + assert (n = Elt.encoded_size); + Elt.decode buf 0 + + let ( -- ) = Int64.sub + + let get_entry_from_buffer buf off = + let buf_off = Int64.(to_int @@ (off -- buf.low_off)) in + assert (buf_off <= Bytes.length buf.buf); + Elt.decode buf.buf buf_off + + let is_in_buffer t off = + match t.buffer with + | None -> false + | Some b -> + Int64.compare off b.low_off >= 0 && Int64.compare off b.high_off <= 0 + + let get t i = + let off = Int64.(mul i Elt.encoded_sizeL) in + match t.buffer with + | Some b when is_in_buffer t off -> ( + try get_entry_from_buffer b off with _ -> assert false ) + | _ -> get_entry_from_io t.io off + + let length t = Int64.(div (IO.offset t.io) Elt.encoded_sizeL) + + let set_buffer t ~low ~high = + let range = Elt.encoded_size * (1 + Int64.to_int (high -- low)) in + let low_off = Int64.mul low Elt.encoded_sizeL in + let high_off = Int64.mul high Elt.encoded_sizeL in + let buf = Bytes.create range in + let n = IO.read t.io ~off:low_off buf in + assert (n = range); + t.buffer <- Some { buf; low_off; high_off } + + let pre_fetch t ~low ~high = + let range = Elt.encoded_size * (1 + Int64.to_int (high -- low)) in + if Int64.compare low high > 0 then + Log.warn (fun m -> + m "Requested pre-fetch region is empty: [%Ld, %Ld]" low high) + else if range > 4096 then + Log.debug (fun m -> + m "Requested pre-fetch [%Ld, %Ld] is larger than 4096" low high) + else + match t.buffer with + | Some b -> + let low_buf, high_buf = + Int64. + ( div b.low_off Elt.encoded_sizeL, + div b.high_off Elt.encoded_sizeL ) + in + if low >= low_buf && high <= high_buf then + Log.debug (fun m -> + m + "Pre-existing buffer [%Ld, %Ld] encloses requested \ + pre-fetch [%Ld, %Ld]" + low_buf high_buf low high) + else ( + Log.debug (fun m -> + m + "Current buffer [%Ld, %Ld] insufficient. Prefetching in \ + range [%Ld, %Ld]" + low_buf high_buf low high); + set_buffer t ~low ~high ) + | None -> + Log.debug (fun m -> + m "No existing buffer. Prefetching in range [%Ld, %Ld]" low high); + set_buffer t ~low ~high +end diff --git a/vendors/index/src/io_array.mli b/vendors/index/src/io_array.mli new file mode 100644 index 000000000000..bc855576a006 --- /dev/null +++ b/vendors/index/src/io_array.mli @@ -0,0 +1,20 @@ +module type ELT = sig + type t + + val encoded_size : int + + val decode : Bytes.t -> int -> t +end + +module type S = sig + include Search.ARRAY + + type io + + val v : io -> t +end + +(** Takes an IO instance and wraps it in an Array interface with support for + prefetching sections of the array. *) +module Make (IO : Io.S) (Elt : ELT) : + S with type io = IO.t and type elt = Elt.t diff --git a/vendors/index/src/log.ml b/vendors/index/src/log.ml new file mode 100644 index 000000000000..23d9e8d82155 --- /dev/null +++ b/vendors/index/src/log.ml @@ -0,0 +1,5 @@ +let src = Logs.Src.create "index" ~doc:"Index" + +module Log = (val Logs.src_log src : Logs.LOG) + +include Log diff --git a/vendors/index/src/log.mli b/vendors/index/src/log.mli new file mode 100644 index 000000000000..a813e55aba74 --- /dev/null +++ b/vendors/index/src/log.mli @@ -0,0 +1 @@ +include Logs.LOG diff --git a/vendors/index/src/search.ml b/vendors/index/src/search.ml new file mode 100644 index 000000000000..a1603df058ef --- /dev/null +++ b/vendors/index/src/search.ml @@ -0,0 +1,142 @@ +module type ARRAY = sig + type t + + type elt + + val get : t -> int64 -> elt + + val length : t -> int64 + + val pre_fetch : t -> low:int64 -> high:int64 -> unit +end + +module type ENTRY = sig + type t + + module Key : sig + type t + + val equal : t -> t -> bool + end + + module Value : sig + type t + end + + val to_key : t -> Key.t + + val to_value : t -> Value.t +end + +(* Metrics must be + - totally ordered + - computable from entries and (potentially redundantly) from keys + - linearly interpolate-able on the int64 type *) +module type METRIC = sig + type t + + module Entry : ENTRY + + val compare : t -> t -> int + + val of_entry : Entry.t -> t + + val of_key : Entry.Key.t -> t + + val linear_interpolate : low:int64 * t -> high:int64 * t -> t -> int64 +end + +module type S = sig + module Entry : ENTRY + + module Array : ARRAY with type elt = Entry.t + + val interpolation_search : + Array.t -> Entry.Key.t -> low:int64 -> high:int64 -> Entry.Value.t +end + +module Make + (Entry : ENTRY) + (Array : ARRAY with type elt = Entry.t) + (Metric : METRIC with module Entry := Entry) : + S with module Entry := Entry and module Array := Array = struct + module Entry = Entry + module Array = Array + module Value = Entry.Value + + module Key = struct + include Entry.Key + + let ( = ) a b = compare a b = 0 + end + + module Metric = struct + include Metric + + let ( < ) a b = compare a b < 0 + + let ( = ) a b = compare a b = 0 + + let ( > ) a b = compare a b > 0 + end + + let look_around array key key_metric index = + let rec search (op : int64 -> int64) curr = + let i = op curr in + if i < 0L || i >= Array.length array then raise Not_found + else + let e = array.(i) in + let e_metric = Metric.of_entry e in + if not Metric.(key_metric = e_metric) then raise Not_found + else if Key.equal (Entry.to_key e) key then Entry.to_value e + else (search [@tailcall]) op i + in + match search Int64.succ index with + | e -> e + | exception Not_found -> (search [@tailcall]) Int64.pred index + + (** Improves over binary search in cases where the values in some array are + uniformly distributed according to some metric (such as a hash). *) + let interpolation_search array key ~low ~high = + let key_metric = Metric.of_key key in + (* The core of the search *) + let rec search low high lowest_entry highest_entry = + if high < low then raise Not_found + else ( + Array.pre_fetch array ~low ~high; + let lowest_entry = Lazy.force lowest_entry in + if high = low then + if Key.(key = Entry.to_key lowest_entry) then + Entry.to_value lowest_entry + else raise Not_found + else + let lowest_metric = Metric.of_entry lowest_entry in + if Metric.(lowest_metric > key_metric) then raise Not_found + else + let highest_entry = Lazy.force highest_entry in + let highest_metric = Metric.of_entry highest_entry in + if Metric.(highest_metric < key_metric) then raise Not_found + else + let next_index = + Metric.linear_interpolate ~low:(low, lowest_metric) + ~high:(high, highest_metric) key_metric + in + let e = array.(next_index) in + let e_metric = Metric.of_entry e in + if Metric.(key_metric = e_metric) then + if Key.(key = Entry.to_key e) then Entry.to_value e + else look_around array key key_metric next_index + else if Metric.(key_metric > e_metric) then + (search [@tailcall]) + Int64.(succ next_index) + high + (lazy array.(Int64.(succ next_index))) + (Lazy.from_val highest_entry) + else + (search [@tailcall]) low (Int64.pred next_index) + (Lazy.from_val lowest_entry) + (lazy array.(Int64.(pred next_index))) ) + in + if high < 0L then raise Not_found + else (search [@tailcall]) low high (lazy array.(low)) (lazy array.(high)) +end diff --git a/vendors/index/src/search.mli b/vendors/index/src/search.mli new file mode 100644 index 000000000000..8ab54261e259 --- /dev/null +++ b/vendors/index/src/search.mli @@ -0,0 +1,58 @@ +module type ARRAY = sig + type t + + type elt + + val get : t -> int64 -> elt + + val length : t -> int64 + + val pre_fetch : t -> low:int64 -> high:int64 -> unit +end + +module type ENTRY = sig + type t + + module Key : sig + type t + + val equal : t -> t -> bool + end + + module Value : sig + type t + end + + val to_key : t -> Key.t + + val to_value : t -> Value.t +end + +module type METRIC = sig + type t + + module Entry : ENTRY + + val compare : t -> t -> int + + val of_entry : Entry.t -> t + + val of_key : Entry.Key.t -> t + + val linear_interpolate : low:int64 * t -> high:int64 * t -> t -> int64 +end + +module type S = sig + module Entry : ENTRY + + module Array : ARRAY with type elt = Entry.t + + val interpolation_search : + Array.t -> Entry.Key.t -> low:int64 -> high:int64 -> Entry.Value.t +end + +module Make + (Entry : ENTRY) + (Array : ARRAY with type elt = Entry.t) + (Metric : METRIC with module Entry := Entry) : + S with module Entry := Entry and module Array := Array diff --git a/vendors/index/src/unix/index_unix.ml b/vendors/index/src/unix/index_unix.ml index 68376adefa61..36125198681d 100644 --- a/vendors/index/src/unix/index_unix.ml +++ b/vendors/index/src/unix/index_unix.ml @@ -289,19 +289,11 @@ module IO : Index.IO = struct Raw.Generation.set raw generation; v ~fan_size ~offset:0L ~version:current_version raw ) else - let () = Fmt.epr "HERE\n%!" in let offset = Raw.Offset.get raw in let version = Raw.Version.get raw in let fan_size = Raw.Fan.get_size raw in - let () = Fmt.epr "Got fan_size %Ld\n%!" fan_size in v ~fan_size ~offset ~version raw - let valid_fd t = - try - let _ = Unix.fstat t.raw.fd in - true - with Unix.Unix_error (Unix.EBADF, _, _) -> false - type lock = Unix.file_descr let unsafe_lock op f = @@ -323,12 +315,30 @@ module IO : Index.IO = struct Unix.close fd; raise e + exception Locked + + let err_rw_lock lock = + let ic = open_in lock in + let line = input_line ic in + close_in ic; + let pid = int_of_string line in + Fmt.epr + "Cannot lock %s: index is already opened in write mode by PID %d. \ + Current PID is %d.\n\ + %!" + lock pid (Unix.getpid ()); + raise Locked + let lock path = match unsafe_lock Unix.F_TLOCK path with | Some fd -> fd - | None -> failwith ("Lock didn't succeed: file " ^ path ^ " is present") + | None -> err_rw_lock path let unlock fd = Unix.close fd end module Make (K : Index.Key) (V : Index.Value) = Index.Make (K) (V) (IO) + +module Private = struct + module IO = IO +end diff --git a/vendors/index/src/unix/index_unix.mli b/vendors/index/src/unix/index_unix.mli index 6a58e56ebfee..532386af28d3 100644 --- a/vendors/index/src/unix/index_unix.mli +++ b/vendors/index/src/unix/index_unix.mli @@ -1,2 +1,7 @@ module Make (K : Index.Key) (V : Index.Value) : Index.S with type key = K.t and type value = V.t + +(** These modules should not be used. They are exposed purely for testing purposes. *) +module Private : sig + module IO : Index.IO +end -- GitLab From ead3ca1e8bb4e69034d216e116b8992148e6f7d2 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Wed, 4 Sep 2019 13:42:50 +0200 Subject: [PATCH 17/17] [irmin-pack] fix close --- vendors/irmin-pack/IO.ml | 8 -------- vendors/irmin-pack/IO.mli | 2 -- vendors/irmin-pack/dict.ml | 2 +- vendors/irmin-pack/irmin_pack.ml | 3 ++- vendors/irmin-pack/pack.ml | 16 +++++++++------- 5 files changed, 12 insertions(+), 19 deletions(-) diff --git a/vendors/irmin-pack/IO.ml b/vendors/irmin-pack/IO.ml index 937fc349c1a6..c3f5d3ff5fc7 100644 --- a/vendors/irmin-pack/IO.ml +++ b/vendors/irmin-pack/IO.ml @@ -46,8 +46,6 @@ module type S = sig val sync : t -> unit val close : t -> unit - - val is_valid : t -> bool end let ( ++ ) = Int64.add @@ -256,12 +254,6 @@ module Unix : S = struct v ~offset ~version raw let close t = Unix.close t.raw.fd - - let is_valid t = - try - let _ = Unix.fstat t.raw.fd in - true - with Unix.Unix_error (Unix.EBADF, _, _) -> false end let ( // ) = Filename.concat diff --git a/vendors/irmin-pack/IO.mli b/vendors/irmin-pack/IO.mli index 478e9d855a2c..cbeaf07b7f9d 100644 --- a/vendors/irmin-pack/IO.mli +++ b/vendors/irmin-pack/IO.mli @@ -42,8 +42,6 @@ module type S = sig val sync : t -> unit val close : t -> unit - - val is_valid : t -> bool end module Unix : S diff --git a/vendors/irmin-pack/dict.ml b/vendors/irmin-pack/dict.ml index 3f8e268ac0fa..72d6335a0fef 100644 --- a/vendors/irmin-pack/dict.ml +++ b/vendors/irmin-pack/dict.ml @@ -122,7 +122,7 @@ module Make (IO : IO.S) : S = struct Hashtbl.reset t.index ) let valid t = - if IO.is_valid t.io then ( + if t.counter <> 0 then ( t.counter <- t.counter + 1; true ) else false diff --git a/vendors/irmin-pack/irmin_pack.ml b/vendors/irmin-pack/irmin_pack.ml index 2f109e9233b0..9de9151861cd 100644 --- a/vendors/irmin-pack/irmin_pack.ml +++ b/vendors/irmin-pack/irmin_pack.ml @@ -175,7 +175,7 @@ module Atomic_write (K : Irmin.Type.S) (V : Irmin.Hash.S) = struct let watches = W.v () let valid t = - if IO.is_valid t.block then ( + if t.counter <> 0 then ( t.counter <- t.counter + 1; true ) else false @@ -429,6 +429,7 @@ struct { contents; node; commit; branch; config; index } let close t = + Index.close t.index; Contents.CA.close (contents_t t) >>= fun () -> Node.CA.close (snd (node_t t)) >>= fun () -> Commit.CA.close (snd (commit_t t)) >>= fun () -> Branch.close t.branch diff --git a/vendors/irmin-pack/pack.ml b/vendors/irmin-pack/pack.ml index fed2db70fdac..f567fe6d37af 100644 --- a/vendors/irmin-pack/pack.ml +++ b/vendors/irmin-pack/pack.ml @@ -147,7 +147,7 @@ struct Dict.clear t.dict let valid t = - if IO.is_valid t.block then ( + if t.counter <> 0 then ( t.counter <- t.counter + 1; true ) else false @@ -172,11 +172,8 @@ struct if t.counter = 0 then ( if not (IO.readonly t.block) then IO.sync t.block; IO.close t.block; - Index.close t.index; Dict.close t.dict ) - let valid t = IO.is_valid t.block - module Make (V : ELT with type hash := K.t) = struct module Tbl = Table (K) module Lru = Cache (K) @@ -205,6 +202,12 @@ struct let create = Lwt_mutex.create () + let valid t = + if t.counter <> 0 then ( + t.counter <- t.counter + 1; + true ) + else false + let unsafe_v_no_cache ~fresh ~readonly ~lru_size ~index root = let pack = v index ~fresh ~readonly root in let staging = Tbl.create 127 in @@ -215,8 +218,7 @@ struct ~index root = try let t = Hashtbl.find roots (root, readonly) in - if valid t.pack then ( - t.counter <- t.counter + 1; + if valid t then ( if fresh then clear t; t ) else ( @@ -353,7 +355,7 @@ struct let unsafe_close t = t.counter <- t.counter - 1; if t.counter = 0 then ( - Log.debug (fun l -> l "[pack] closing %s" (IO.name t.pack.block)); + Log.debug (fun l -> l "[pack] close %s" (IO.name t.pack.block)); Tbl.clear t.staging; ignore (Lru.clear t.lru); close t.pack ) -- GitLab