Merge branch 'main' into blocking-dummy-gc

mirage · Jun 26, 2022 · 3b6d981 · 3b6d981
2 parents b4e69c1 + adb1b6f
commit 3b6d981
Show file tree

Hide file tree

Showing 17 changed files with 221 additions and 51 deletions.
diff --git a/CHANGES.md b/CHANGES.md
@@ -2,9 +2,34 @@
 
 ### Added
 
+- **irmin**
+  - Add `Tree.seq` to `Tree`'s public API (#1923, @metanivek)
+
+### Changed
+
+- **irmin**
+  - Replaced `Tree.node_fn` type with more general `Tree.folder` type to
+    represent the different ways to use `Tree.fold` (#1918, @metanivek)
+
+### Fixed
+
+## 3.3.1 (2022-06-22)
+
+### Fixed
+
+- **irmin-pack**
+  - Fix topology irregularities on disk which may lead to post-gc crashes.
+    (#1925, @Ngoguey42, @icristescu)
+
+## 3.3.0 (2022-06-20)
+
+### Added
+
 - **irmin**
   - Add `Metrics` module to describe metric gathering in irmin.
     (#1817, @maiste)
+  - Add `Repo.config` to access config used to create repo
+    (#1886, @zshipko)
 
 - **irmin-unix**
   - Add `--plugin` flag to load Dynlink plugins that can register new

diff --git a/examples/dune b/examples/dune
@@ -8,7 +8,8 @@
   irmin_git_store
   custom_merge
   push
-  custom_graphql)
+  custom_graphql
+  fold)
  (libraries astring cohttp fmt git irmin irmin-git irmin-unix lwt lwt.unix)
  (preprocess
   (pps ppx_irmin)))
@@ -24,7 +25,8 @@
   push.exe
   irmin_git_store.exe
   custom_merge.exe
-  custom_graphql.exe))
+  custom_graphql.exe
+  fold.exe))
 
 (alias
  (name runtest)
@@ -37,4 +39,5 @@
   deploy.exe
   push.exe
   irmin_git_store.exe
-  custom_merge.exe))
+  custom_merge.exe
+  fold.exe))
diff --git a/examples/fold.ml b/examples/fold.ml
@@ -0,0 +1,100 @@
+(*
+ * Copyright (c) 2022 Tarides <contact@tarides.com>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+(* example of using tree fold *)
+
+open Lwt.Syntax
+module Store = Irmin_mem.KV.Make (Irmin.Contents.String)
+module Tree = Store.Tree
+
+let config = Irmin_mem.config ()
+
+let info =
+  let counter = ref 0L in
+  let inc () =
+    let c = !counter in
+    counter := Int64.add c 1L;
+    c
+  in
+  fun message () -> Store.Info.v ~author:"fold.exe" ~message (inc ())
+
+module Folder : sig
+  (* Not accumulating anything so use unit as accumulator type *)
+  val pre : (unit, Store.step list) Tree.folder
+  val post : (unit, Store.step list) Tree.folder
+  val node : (unit, Store.node) Tree.folder
+  val contents : (unit, Store.contents) Tree.folder
+  val tree : (unit, Store.tree) Tree.folder
+end = struct
+  let print_path newline path _ _ =
+    let format : ('a, Format.formatter, unit) format =
+      "Visit [%s]" ^^ if newline then "\n" else ""
+    in
+    Fmt.(pf stdout format (String.concat ";" path)) |> Lwt.return
+
+  let pre = print_path true
+  let post = print_path true
+  let node = print_path true
+
+  let contents path c acc =
+    let* () = print_path false path c acc in
+    Fmt.(pf stdout " = '%s'\n" c) |> Lwt.return
+
+  let tree path t acc =
+    let* () = print_path false path t acc in
+    let* k = Tree.kind t [] in
+    match k with
+    | Some k' ->
+        (match k' with
+        | `Node -> Fmt.(string stdout ", with `Node kind\n")
+        | `Contents -> Fmt.(string stdout ", with `Contents kind\n"))
+        |> Lwt.return
+    | None -> failwith "no kind"
+end
+
+let main =
+  let ps name = Fmt.(pf stdout "\n%s\n" name) in
+  ps "Demo of how tree folders visit nodes.";
+  let* repo = Store.Repo.v config in
+  let* main_b = Store.main repo in
+  let* () = Store.set_exn ~info:(info "add c1") main_b [ "c1" ] "c1" in
+  let* () = Store.set_exn ~info:(info "add c2") main_b [ "c2" ] "c2" in
+  let* () =
+    Store.set_exn ~info:(info "add n1/c1") main_b [ "n1"; "c1" ] "n1/c1"
+  in
+  let* () =
+    Store.set_exn ~info:(info "add n1/n1/c1") main_b [ "n1"; "n1"; "c1" ]
+      "n1/n1/c1"
+  in
+  let* () =
+    Store.set_exn ~info:(info "add n2/c1") main_b [ "n2"; "c1" ] "n2/c1"
+  in
+  let* t = Store.tree main_b in
+  (* let order = `Random (Random.State.make_self_init ()) in *)
+  let order = `Sorted in
+  ps "pre folder: preorder traversal of `Node kinds";
+  let* () = Tree.fold ~order ~pre:Folder.pre t () in
+  ps "post folder: postorder traversal of `Node kinds";
+  let* () = Tree.fold ~order ~post:Folder.post t () in
+  ps "node folder: visit all `Node kinds";
+  let* () = Tree.fold ~order ~node:Folder.node t () in
+  ps "contents folder: visit all `Contents kinds";
+  let* () = Tree.fold ~order ~contents:Folder.contents t () in
+  ps "tree folder: visit both `Node and `Contents kinds";
+  let* () = Tree.fold ~order ~tree:Folder.tree t () in
+  Lwt.return_unit
+
+let () = Lwt_main.run main
diff --git a/examples/plugin/plugin.t b/examples/plugin/plugin.t
@@ -1,9 +1,9 @@
   $ irmin set --plugin ./plugin.cmxs a/b/c 123
   $ echo 'plugin: plugin.cmxs' > irmin.yml # Set the plugin in config file
-  $ irmin set --root /tmp/irmin-plugin -s git -c int a/b/c 123
-  $ irmin get --root /tmp/irmin-plugin -s git -c int a/b/c
+  $ irmin set --root ./irmin-plugin -s git -c int a/b/c 123
+  $ irmin get --root ./irmin-plugin -s git -c int a/b/c
   123
-  $ irmin set --root /tmp/irmin-plugin -s git -c int a/b/c "AAA"
+  $ irmin set --root ./irmin-plugin -s git -c int a/b/c "AAA"
   ERROR: int_of_string
   [1]
 
diff --git a/src/irmin-git/backend.ml b/src/irmin-git/backend.ml
@@ -110,6 +110,7 @@ struct
       let+ b = Branch.v ~head ~bare g in
       { g; b; closed = ref false; config = (conf :> Irmin.config) }
 
+    let config t = t.config
     let close t = Branch.close t.b >|= fun () -> t.closed := true
   end
 

diff --git a/src/irmin-git/irmin_git.ml b/src/irmin-git/irmin_git.ml
@@ -307,6 +307,7 @@ struct
         let node_t t = t.nodes
         let commit_t t = t.commits
         let branch_t t = t.branch
+        let config t = t.config
 
         let batch t f =
           Contents.CA.batch t.contents @@ fun c ->

diff --git a/src/irmin-http/irmin_http.ml b/src/irmin-http/irmin_http.ml
@@ -532,6 +532,7 @@ module Client (Client : HTTP_CLIENT) (S : Irmin.S) = struct
       let commit_t t = t.commit
       let node_t t = t.node
       let contents_t t = t.contents
+      let config t = t.config
 
       let batch t f =
         Contents.X.batch t.contents @@ fun contents_t ->

diff --git a/src/irmin-pack/mem/irmin_pack_mem.ml b/src/irmin-pack/mem/irmin_pack_mem.ml
@@ -138,6 +138,7 @@ module Maker (Config : Irmin_pack.Conf.S) = struct
         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 config t = t.config
 
         let batch t f =
           Commit.Indexable.batch t.commit (fun commit ->

diff --git a/src/irmin-pack/unix/ext.ml b/src/irmin-pack/unix/ext.ml
@@ -155,6 +155,7 @@ module Maker (Config : Conf.S) = struct
         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 config t = t.config
 
         let batch t f =
           t.during_batch <- true;

diff --git a/src/irmin-unix/resolver.ml b/src/irmin-unix/resolver.ml
@@ -410,13 +410,10 @@ let config_term =
   let create root config_path (opts : (string * string) list list) =
     (root, config_path, opts)
   in
-  let spec = Conf.Spec.(join (v "unix") [ Irmin_http.Conf.spec ]) in
   let doc =
-    Seq.map (fun (Irmin.Backend.Conf.K x) -> Conf.name x) (Conf.Spec.keys spec)
-    |> List.of_seq
-    |> String.concat ~sep:", "
+    "Backend-specific options. See the output of `irmin options` for a list of \
+     options supported by the selected backend"
   in
-  let doc = "Backend-specific options: " ^ doc in
   let opts =
     Arg.info ~docv:"OPTIONS" ~docs:global_option_section ~doc
       [ "opt"; "options" ]

diff --git a/src/irmin/backend.ml b/src/irmin/backend.ml
@@ -94,6 +94,7 @@ module type S = sig
     val contents_t : t -> read Contents.t
     val node_t : t -> read Node.t
     val commit_t : t -> read Commit.t
+    val config : t -> Conf.t
 
     val batch :
       t ->

diff --git a/src/irmin/irmin.ml b/src/irmin/irmin.ml
@@ -113,6 +113,7 @@ module Maker_generic_key (Backend : Maker_generic_key_args) = struct
         let node_t t = t.nodes
         let commit_t t = t.commits
         let branch_t t = t.branch
+        let config t = t.config
 
         let batch t f =
           Contents.Backend.batch t.contents @@ fun c ->

diff --git a/src/irmin/store.ml b/src/irmin/store.ml
@@ -233,6 +233,7 @@ module Make (B : Backend.S) = struct
     type t = repo
 
     let v = B.Repo.v
+    let config = B.Repo.config
     let close = B.Repo.close
     let branch_t t = B.Repo.branch_t t
     let commit_t t = B.Repo.commit_t t

diff --git a/src/irmin/store_intf.ml b/src/irmin/store_intf.ml
@@ -106,6 +106,9 @@ module type S_generic_key = sig
     val v : Conf.t -> t Lwt.t
     (** [v config] connects to a repository in a backend-specific manner. *)
 
+    val config : t -> Conf.t
+    (** [config repo] is the configuration used to create [repo] *)
+
     include Closeable with type _ t := t
     (** @inline *)
 
@@ -429,8 +432,8 @@ module type S_generic_key = sig
         [r], if such a key exists and is indexed. *)
 
     val of_key : Repo.t -> kinded_key -> tree option Lwt.t
-    (** [of_key r h] is the the tree object in [r] having [h] as key, or [None]
-        is no such tree object exists. *)
+    (** [of_key r h] is the tree object in [r] having [h] as key, or [None] if
+        no such tree object exists. *)
 
     val shallow : Repo.t -> kinded_key -> tree
     (** [shallow r h] is the shallow tree object with the key [h]. No check is