diff --git a/CHANGES.md b/CHANGES.md index 12ef65e30d..dcee18cb86 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,13 @@ ## 4.0.0 +### Added + +- **irmin-lwt** + - New package providing a thin Lwt compatibility layer over Irmin 4's + direct-style API, so Irmin 3 consumers can migrate progressively. + Built on top of `lwt_eio`. See `doc/migration-from-irmin-3.md` for + the two-step migration path. + ### Changed - Convert to direct-style with Eio (#2149, @patricoferris, @ElectreAAS, @clecat, @art-w) diff --git a/doc/migration-from-irmin-3.md b/doc/migration-from-irmin-3.md new file mode 100644 index 0000000000..d836a19ff2 --- /dev/null +++ b/doc/migration-from-irmin-3.md @@ -0,0 +1,202 @@ +# Migrating from Irmin 3 (Lwt) to Irmin 4 (Eio) + +Irmin 4 swaps Lwt-based cooperative concurrency for direct-style Eio. The +core API change is straightforward on paper — every function that used +to return `'a Lwt.t` now returns `'a` directly — but rewriting a large +Irmin 3 codebase in one go is expensive. + +The **`irmin-lwt`** package provides a thin compatibility layer that +lets you keep the Irmin 3 Lwt-monadic style while the backend is already +Irmin 4. It is built on top of +[`lwt_eio`](https://github.com/ocaml-multicore/lwt_eio): every wrapped +operation crosses the Lwt/Eio bridge via `Lwt_eio.run_eio`. + +This document describes a two-step migration path: + +1. Move to `irmin-lwt` with minimal code changes. This unblocks Irmin 4 + adoption without rewriting every call site at once. +2. At your own pace, replace `irmin-lwt` calls with direct-style + `Irmin` calls. This can happen module by module. + +## Step 1: switch to `irmin-lwt` + +### Update the opam dependencies + +```diff + depends: [ +- "irmin" {>= "3.0"} +- "irmin-pack" {>= "3.0"} ++ "irmin" {>= "4.0.0"} ++ "irmin-pack" {>= "4.0.0"} ++ "irmin-lwt" {>= "4.0.0"} + "lwt" + ] +``` + +You can still depend on `lwt` directly. `irmin-lwt` is built on top of +it, not a replacement. + +### Instantiate the store through `Irmin_lwt.Make` + +```diff +-module Store = Irmin_pack_unix.KV (Irmin.Contents.String) ++module Store4 = Irmin_pack_unix.KV (Irmin.Contents.String) ++module Store = Irmin_lwt.Make (Store4) +``` + +`Store.t`, `Store.repo`, `Store.tree`, `Store.commit` and so on are all +re-exported unchanged from the underlying backend. The difference is +that `Store.Repo.v`, `Store.find`, `Store.set_exn`, `Store.merge_into`, +etc. now return `_ Lwt.t` instead of direct values. + +### Replace the entry point + +```diff +-let () = Lwt_main.run (main ()) ++let () = Irmin_lwt.run main +``` + +`Irmin_lwt.run` wraps `Eio_main.run` + `Lwt_eio.with_event_loop` + the +call to your `main`. It is the single line of Eio awareness a migrated +program needs at the top. + +If your program is already running inside an Eio event loop (for +example, you are writing a library that receives an `env` from its +caller), use `Irmin_lwt.run_with_env env main` instead. + +### Leave the rest alone + +Every other call site stays the same. `let*`, `>>=`, `Lwt.return`, +`Lwt.catch`, `Lwt.fail`, `Lwt.pick`, `Lwt.async` all work because +`irmin-lwt` returns `'a Lwt.t`. + +### A minimal before/after + +**Irmin 3 (Lwt):** + +```ocaml +open Lwt.Syntax +module Store = Irmin_mem.KV (Irmin.Contents.String) + +let info = Irmin_mem.Info.none + +let main () = + let* repo = Store.Repo.v (Irmin_mem.config ()) in + let* t = Store.main repo in + let* () = Store.set_exn t ~info [ "hello" ] "world" in + let* v = Store.find t [ "hello" ] in + Lwt.return (Option.value ~default:"(none)" v) + +let () = + let result = Lwt_main.run (main ()) in + print_endline result +``` + +**Migrated via `irmin-lwt`:** + +```ocaml +open Lwt.Syntax +module Store4 = Irmin_mem.KV.Make (Irmin.Contents.String) +module Store = Irmin_lwt.Make (Store4) + +let info message () = Store4.Info.v ~author:"app" ~message 0L + +let main () = + let* repo = Store.Repo.v (Irmin_mem.config ()) in + let* t = Store.main repo in + let* () = Store.set_exn t ~info:(info "seed") [ "hello" ] "world" in + let* v = Store.find t [ "hello" ] in + Lwt.return (Option.value ~default:"(none)" v) + +let () = + let result = Irmin_lwt.run main in + print_endline result +``` + +The diff is confined to: the opam file, the module instantiation, the +info constructor, and the entry point. The rest of `main` is byte-for- +byte identical. + +## Pitfalls not strictly related to `irmin-lwt` + +These are Irmin 3 → 4 breaking changes that `irmin-lwt` cannot hide, +because they are semantic rather than monadic: + +- **OCaml 5.1+ is required.** Irmin 4 uses effects; older compilers do + not support them. +- **Configuration renames.** Some `Irmin.Backend.Conf` keys were renamed + or dropped between 3.x and 4.x; check your `Irmin_pack.config` or + `Irmin_git.config` call site. +- **Removed APIs.** Functions deprecated in Irmin 3.x were dropped in 4. + Consult `CHANGES.md` for the exact list. +- **Info constructors.** `Irmin.Info.default` replaces the old + `Irmin_unix.Info`. `Store.Info.v ~author ~message timestamp` is the + canonical way to build a commit info. +- **Yield points.** Every `irmin-lwt` call crosses `Lwt_eio.run_eio`, + which is a scheduler yield. If your code assumed no Lwt yield could + happen between a sequence of Irmin calls, there is one now. This is + almost always invisible, but it is worth knowing for subtle + concurrency-sensitive code. + +## Step 2: drop `irmin-lwt` + +When a module is ready to go fully direct-style: + +1. Replace `Store = Irmin_lwt.Make (Store4)` with `Store = Store4` (or + inline the backend directly). +2. Remove the `Lwt.t` types from the local signatures. +3. Rewrite `let*` / `>>=` chains into plain sequencing (`;`) and `let`. +4. Drop `Lwt.return` wrappers. + +Because this is local to a single module, it can be done piecemeal. +Callers that are still `Lwt`-monadic can keep using the module through +a thin local wrapper, or the other way around if the module exports +direct-style only. + +Once no caller needs the Lwt wrapping, you can remove the `irmin-lwt` +dependency and switch the entry point back to `Eio_main.run`. + +## Scope of `irmin-lwt` + +The current release wraps: + +- Top-level `Store` operations: `Repo.v`/`close`/`heads`/`branches`/ + `config`/`export`, `main`, `of_branch`, `of_commit`, `empty`, `find`, + `find_all`, `mem`, `get`, `find_tree`, `get_tree`, `hash`, the + `set`/`set_tree`/`remove` families, `merge_into`, `last_modified`. +- `Tree` submodule: constructors and pure inspectors (`empty`, + `singleton`, `of_contents`, `of_node`, `v`, `pruned`, `is_empty`, + `destruct`, `hash`, `kinded_hash`, `key`, `shallow`, `clear`, + `of_concrete`, `pp`) are forwarded as-is; I/O-triggering operations + (`kind`, `diff`, `mem`, `find`, `find_all`, `find_tree`, `get`, + `get_all`, `get_tree`, `list`, `seq`, `length`, `add`, `add_tree`, + `update`, `update_tree`, `remove`, `mem_tree`, `stats`, `to_concrete`, + `find_key`, `of_key`, `of_hash`) and `fold` are Lwt-wrapped. `fold` + accepts Lwt-returning folders, same as in Irmin 3. +- `Commit` submodule: `v`, `of_key`, `of_hash` are Lwt-wrapped. Pure + accessors (`tree`, `parents`, `info`, `hash`, `key`, `pp`, + `pp_hash`) are forwarded. +- `Branch` submodule: all operations (`mem`, `find`, `get`, `set`, + `remove`, `list`, `watch`, `watch_all`). Watch callbacks are + Lwt-returning as in Irmin 3. +- `Head` submodule: `list`, `find`, `get`, `set`, `fast_forward`, + `test_and_set`, `merge`. +- Top-level `watch`, `watch_key`, `unwatch`. + +### Not wrapped yet + +- The `Sync` functor (remote git fetch/push/pull). If your code uses + `Irmin.Sync (S)`, call through `Lwt_eio.run_eio` manually for now. +- A few rarely-used helpers on `Repo` (`iter`, `breadth_first_traversal`, + `default_pred_*`). + +If you need something that is not wrapped, you can always drop into +Irmin 4 via `Lwt_eio.run_eio`: + +```ocaml +let tree' = + Lwt_eio.run_eio (fun () -> Store4.Some_unwrapped_op ... ) +``` + +File an issue with a concrete call site and we will extend the wrapper +accordingly. diff --git a/irmin-lwt.opam b/irmin-lwt.opam new file mode 100644 index 0000000000..4c19a1b299 --- /dev/null +++ b/irmin-lwt.opam @@ -0,0 +1,35 @@ +opam-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"] {dev} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] + +depends: [ + "ocaml" {>= "5.1.0"} + "dune" {>= "3.5.0"} + "irmin" {= version} + "irmin-pack" {= version} + "lwt" {>= "5.7.0"} + "lwt_eio" + "eio" {>= "1.0"} + "eio_main" {>= "1.0"} + "alcotest-lwt" {with-test & >= "1.8.0"} +] + +synopsis: "Lwt compatibility layer for Irmin 4" +description: """ +This package lets Irmin 3 (Lwt-based) consumers continue to use a monadic +Lwt.t API while the backend is Irmin 4 (direct-style Eio). It is a +transitional shim built on top of lwt_eio: new code should use Irmin +directly. +""" +x-maintenance-intent: [ "(latest)" ] diff --git a/src/irmin-lwt/dune b/src/irmin-lwt/dune new file mode 100644 index 0000000000..c148091378 --- /dev/null +++ b/src/irmin-lwt/dune @@ -0,0 +1,4 @@ +(library + (name irmin_lwt) + (public_name irmin-lwt) + (libraries irmin irmin-pack.io lwt lwt_eio eio_main)) diff --git a/src/irmin-lwt/irmin_lwt.ml b/src/irmin-lwt/irmin_lwt.ml new file mode 100644 index 0000000000..ad6cb0b6e5 --- /dev/null +++ b/src/irmin-lwt/irmin_lwt.ml @@ -0,0 +1,1563 @@ +(* Lwt compatibility layer for Irmin 4. + + Every wrapped operation threads its call through [Lwt_eio.run_eio] so + the direct-style Irmin 4 implementation executes on the Eio + scheduler while the caller remains in the Lwt monad. *) + +let run_eio f = Lwt_eio.run_eio f + +let run f = + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> + Lwt_eio.Promise.await_lwt (f ()) + +let run_with_env env f = + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> + Lwt_eio.Promise.await_lwt (f ()) + +module type Closeable = sig + type 'a t + + val close : 'a t -> unit Lwt.t +end + +module type S = sig + (** {1 Schema} *) + + module Schema : Irmin.Schema.S + + (** {1 Types} *) + + type repo + type t + type step = Schema.Path.step + type path = Schema.Path.t + type metadata = Schema.Metadata.t + type contents = Schema.Contents.t + type node + type tree + type commit + type branch = Schema.Branch.t + type slice + type info = Schema.Info.t + type hash = Schema.Hash.t + type contents_key + type node_key + type commit_key + type lca_error = [ `Max_depth_reached | `Too_many_lcas ] + type ff_error = [ `No_change | `Rejected | lca_error ] + + type write_error = + [ Irmin.Merge.conflict + | `Too_many_retries of int + | `Test_was of tree option ] + + type kinded_key = [ `Contents of contents_key | `Node of node_key ] + type watch + + (** {1 Type-level submodules} *) + + module Info : Irmin.Info.S with type t = info + module Hash : Irmin.Hash.S with type t = hash + module Path : Irmin.Path.S with type t = path and type step = step + module Metadata : Irmin.Metadata.S with type t = metadata + + module Backend : + Irmin.Backend.S + with module Schema = Schema + with type Slice.t = slice + and type Repo.t = repo + and type Contents.key = contents_key + and type Node.key = node_key + and type Commit.key = commit_key + + module Contents : sig + include Irmin.Contents.S with type t = contents + + val hash : contents -> hash + val of_key : repo -> contents_key -> contents option Lwt.t + val of_hash : repo -> hash -> contents option Lwt.t + end + + module History : Graph.Sig.P with type V.t = commit + + module Status : sig + type t = [ `Empty | `Branch of branch | `Commit of commit ] + + val t : repo -> t Irmin.Type.t + val pp : t Fmt.t + end + + type Irmin.remote += + | E of Backend.Remote.endpoint + (** Extends [Irmin.remote] with the endpoint type of [Backend]. *) + + (** {1 Repositories} *) + + module Repo : sig + type nonrec t = repo + + type elt = + [ `Commit of commit_key + | `Node of node_key + | `Contents of contents_key + | `Branch of branch ] + + val elt_t : elt Irmin.Type.t + val v : Irmin.Backend.Conf.t -> t Lwt.t + + include Closeable with type _ t := t + + val heads : t -> commit list Lwt.t + val branches : t -> branch list Lwt.t + val config : t -> Irmin.Backend.Conf.t + + val export : + ?full:bool -> + ?depth:int -> + ?min:commit list -> + ?max:[ `Head | `Max of commit list ] -> + t -> + slice Lwt.t + + val import : t -> slice -> (unit, [ `Msg of string ]) result Lwt.t + val default_pred_commit : t -> commit_key -> elt list Lwt.t + val default_pred_node : t -> node_key -> elt list Lwt.t + val default_pred_contents : t -> contents_key -> elt list Lwt.t + + val iter : + ?cache_size:int -> + min:elt list -> + max:elt list -> + ?edge:(elt -> elt -> unit Lwt.t) -> + ?branch:(branch -> unit Lwt.t) -> + ?commit:(commit_key -> unit Lwt.t) -> + ?node:(node_key -> unit Lwt.t) -> + ?contents:(contents_key -> unit Lwt.t) -> + ?skip_branch:(branch -> bool Lwt.t) -> + ?skip_commit:(commit_key -> bool Lwt.t) -> + ?skip_node:(node_key -> bool Lwt.t) -> + ?skip_contents:(contents_key -> bool Lwt.t) -> + ?pred_branch:(t -> branch -> elt list Lwt.t) -> + ?pred_commit:(t -> commit_key -> elt list Lwt.t) -> + ?pred_node:(t -> node_key -> elt list Lwt.t) -> + ?pred_contents:(t -> contents_key -> elt list Lwt.t) -> + ?rev:bool -> + t -> + unit Lwt.t + + val breadth_first_traversal : + ?cache_size:int -> + max:elt list -> + ?branch:(branch -> unit Lwt.t) -> + ?commit:(commit_key -> unit Lwt.t) -> + ?node:(node_key -> unit Lwt.t) -> + ?contents:(contents_key -> unit Lwt.t) -> + ?pred_branch:(t -> branch -> elt list Lwt.t) -> + ?pred_commit:(t -> commit_key -> elt list Lwt.t) -> + ?pred_node:(t -> node_key -> elt list Lwt.t) -> + ?pred_contents:(t -> contents_key -> elt list Lwt.t) -> + t -> + unit Lwt.t + end + + (** {1 Stores} *) + + val main : repo -> t Lwt.t + + val master : repo -> t Lwt.t + [@@ocaml.deprecated "Use `main` instead."] + (** Deprecated alias kept for Irmin 3 compatibility. Use {!main}. *) + + val of_branch : repo -> branch -> t Lwt.t + val of_commit : commit -> t Lwt.t + val empty : repo -> t Lwt.t + val repo : t -> repo + val tree : t -> tree Lwt.t + val status : t -> [ `Empty | `Branch of branch | `Commit of commit ] + + (** {2 Reads} *) + + val find : t -> path -> contents option Lwt.t + val find_all : t -> path -> (contents * metadata) option Lwt.t + val mem : t -> path -> bool Lwt.t + val mem_tree : t -> path -> bool Lwt.t + val get : t -> path -> contents Lwt.t + val get_all : t -> path -> (contents * metadata) Lwt.t + val find_tree : t -> path -> tree option Lwt.t + val get_tree : t -> path -> tree Lwt.t + val hash : t -> path -> hash option Lwt.t + val kind : t -> path -> [ `Contents | `Node ] option Lwt.t + val list : t -> path -> (step * tree) list Lwt.t + val key : t -> path -> kinded_key option Lwt.t + + (** {2 Writes} *) + + val set : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + contents -> + (unit, write_error) result Lwt.t + + val set_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + contents -> + unit Lwt.t + + val set_tree : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + tree -> + (unit, write_error) result Lwt.t + + val set_tree_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + tree -> + unit Lwt.t + + val remove : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + (unit, write_error) result Lwt.t + + val remove_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + unit Lwt.t + + val test_and_set : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + test:contents option -> + set:contents option -> + (unit, write_error) result Lwt.t + + val test_and_set_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + test:contents option -> + set:contents option -> + unit Lwt.t + + val test_and_set_tree : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + test:tree option -> + set:tree option -> + (unit, write_error) result Lwt.t + + val test_and_set_tree_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + test:tree option -> + set:tree option -> + unit Lwt.t + + val test_set_and_get : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + test:contents option -> + set:contents option -> + (commit option, write_error) result Lwt.t + + val test_set_and_get_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + test:contents option -> + set:contents option -> + commit option Lwt.t + + val test_set_and_get_tree : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + test:tree option -> + set:tree option -> + (commit option, write_error) result Lwt.t + + val test_set_and_get_tree_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + test:tree option -> + set:tree option -> + commit option Lwt.t + + val merge : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:contents option -> + t -> + path -> + contents option -> + (unit, write_error) result Lwt.t + + val merge_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:contents option -> + t -> + path -> + contents option -> + unit Lwt.t + + val merge_tree : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:tree option -> + t -> + path -> + tree option -> + (unit, write_error) result Lwt.t + + val merge_tree_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:tree option -> + t -> + path -> + tree option -> + unit Lwt.t + + val with_tree : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + ?strategy:[ `Set | `Test_and_set | `Merge ] -> + info:Info.f -> + t -> + path -> + (tree option -> tree option) -> + (unit, write_error) result Lwt.t + + val with_tree_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + ?strategy:[ `Set | `Test_and_set | `Merge ] -> + info:Info.f -> + t -> + path -> + (tree option -> tree option) -> + unit Lwt.t + + val clone : src:t -> dst:branch -> t Lwt.t + + (** {2 Merges and ancestors} *) + + type 'a merge = + info:Info.f -> + ?max_depth:int -> + ?n:int -> + 'a -> + (unit, Irmin.Merge.conflict) result Lwt.t + (** Lwt-wrapped abbreviation for merge-into-something functions. *) + + 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 + + val history : + ?depth:int -> ?min:commit list -> ?max:commit list -> t -> History.t Lwt.t + + val last_modified : ?depth:int -> ?n:int -> t -> path -> commit list Lwt.t + + (** {2 Backend converters} *) + + val of_backend_node : repo -> Backend.Node.value -> node + val to_backend_node : node -> Backend.Node.value Lwt.t + val to_backend_portable_node : node -> Backend.Node_portable.t Lwt.t + val to_backend_commit : commit -> Backend.Commit.value + + val of_backend_commit : + repo -> Backend.Commit.Key.t -> Backend.Commit.value -> commit + + val save_contents : + [> Irmin.Perms.write ] Backend.Contents.t -> contents -> contents_key Lwt.t + + val save_tree : + ?clear:bool -> + repo -> + [> Irmin.Perms.write ] Backend.Contents.t -> + [> Irmin.Perms.read_write ] Backend.Node.t -> + tree -> + kinded_key Lwt.t + + (** {1 Trees} *) + + module Tree : sig + type nonrec t = tree + type kinded_hash = [ `Contents of hash * metadata | `Node of hash ] + + type kinded_key = + [ `Contents of contents_key * metadata | `Node of node_key ] + + type elt = [ `Node of node | `Contents of contents * metadata ] + type marks + + type depth = + [ `Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int ] + + type stats + + val stats_t : stats Irmin.Type.t + + type concrete = + [ `Tree of (step * concrete) list | `Contents of contents * metadata ] + + type 'a force = [ `True | `False of path -> 'a -> 'a Lwt.t ] + type uniq = [ `False | `True | `Marks of marks ] + type ('a, 'b) folder = path -> 'b -> 'a -> 'a Lwt.t + + type error = + [ `Dangling_hash of hash | `Pruned_hash of hash | `Portable_value ] + + type 'a or_error = ('a, error) result + + exception Dangling_hash of { context : string; hash : hash } + exception Pruned_hash of { context : string; hash : hash } + exception Portable_value of { context : string } + + (** Operations on lazy tree contents. *) + module Contents : sig + type nonrec t + + val hash : ?cache:bool -> t -> hash + val key : t -> contents_key option + val force : t -> contents or_error Lwt.t + val force_exn : t -> contents Lwt.t + val clear : t -> unit + end + + val empty : unit -> t + val singleton : path -> ?metadata:metadata -> contents -> t + val of_contents : ?metadata:metadata -> contents -> t + val of_node : node -> t + val v : elt -> t + val pruned : kinded_hash -> t + val is_empty : t -> bool + val destruct : t -> [ `Node of node | `Contents of Contents.t * metadata ] + val hash : ?cache:bool -> t -> hash + val kinded_hash : ?cache:bool -> t -> kinded_hash + val key : t -> kinded_key option + val shallow : Repo.t -> kinded_key -> t + val clear : ?depth:int -> t -> unit + val pp : t Irmin.Type.pp + val kind : t -> path -> [ `Contents | `Node ] option Lwt.t + val diff : t -> t -> (path * (contents * metadata) Irmin.Diff.t) list Lwt.t + val mem : t -> path -> bool Lwt.t + val find_all : t -> path -> (contents * metadata) option Lwt.t + val length : t -> ?cache:bool -> path -> int Lwt.t + val find : t -> path -> contents option Lwt.t + val get_all : t -> path -> (contents * metadata) Lwt.t + val get : t -> path -> contents Lwt.t + + val list : + t -> + ?offset:int -> + ?length:int -> + ?cache:bool -> + path -> + (step * t) list Lwt.t + + val seq : + t -> + ?offset:int -> + ?length:int -> + ?cache:bool -> + path -> + (step * t) Seq.t Lwt.t + + val add : t -> path -> ?metadata:metadata -> contents -> t Lwt.t + + val update : + t -> + path -> + ?metadata:metadata -> + (contents option -> contents option) -> + t Lwt.t + + val remove : t -> path -> t Lwt.t + val mem_tree : t -> path -> bool Lwt.t + val find_tree : t -> path -> t option Lwt.t + val get_tree : t -> path -> t Lwt.t + val add_tree : t -> path -> t -> t Lwt.t + val update_tree : t -> path -> (t option -> t option) -> t Lwt.t + val of_concrete : concrete -> t + val stats : ?force:bool -> t -> stats Lwt.t + val to_concrete : t -> concrete Lwt.t + val find_key : Repo.t -> t -> kinded_key option Lwt.t + val of_key : Repo.t -> kinded_key -> t option Lwt.t + val of_hash : Repo.t -> kinded_hash -> t option Lwt.t + + (** {2 Fold} *) + + val empty_marks : unit -> marks + + val fold : + ?order:[ `Sorted | `Undefined | `Random of Random.State.t ] -> + ?force:'a force -> + ?cache:bool -> + ?uniq:uniq -> + ?pre:('a, step list) folder -> + ?post:('a, step list) folder -> + ?depth:depth -> + ?contents:('a, contents) folder -> + ?node:('a, node) folder -> + ?tree:('a, t) folder -> + t -> + 'a -> + 'a Lwt.t + + val merge : t Irmin.Merge.t + + type counters + + val counters : unit -> counters + val dump_counters : unit Fmt.t + val reset_counters : unit -> unit + + val inspect : + t -> + [ `Contents + | `Node of [ `Map | `Key | `Value | `Portable_dirty | `Pruned ] ] + + module Proof : sig + type 'a inode = { length : int; proofs : (int * 'a) list } + type 'a inode_extender = { length : int; segments : int list; proof : 'a } + + type tree = + | Contents of contents * metadata + | Blinded_contents of hash * metadata + | Node of (step * tree) list + | Blinded_node of hash + | Inode of inode_tree inode + | Extender of inode_tree inode_extender + + and inode_tree = + | Blinded_inode of hash + | Inode_values of (step * tree) list + | Inode_tree of inode_tree inode + | Inode_extender of inode_tree inode_extender + + type t + + val v : before:kinded_hash -> after:kinded_hash -> tree -> t + val before : t -> kinded_hash + val after : t -> kinded_hash + val state : t -> tree + + type irmin_tree + + val to_tree : t -> irmin_tree + end + with type irmin_tree := t + + type verifier_error = [ `Proof_mismatch of string ] + + val produce_proof : + Repo.t -> kinded_key -> (t -> (t * 'a) Lwt.t) -> (Proof.t * 'a) Lwt.t + + val verify_proof : + Proof.t -> (t -> (t * 'a) Lwt.t) -> (t * 'a, verifier_error) result Lwt.t + + val hash_of_proof_state : Proof.tree -> kinded_hash + end + + (** {1 Commits} *) + + module Commit : sig + type nonrec t = commit + type nonrec commit_key = commit_key + + val tree : t -> tree + val parents : t -> commit_key list + val info : t -> info + val hash : t -> hash + val key : t -> commit_key + val pp : t Fmt.t + val pp_hash : t Fmt.t + + val v : + ?clear:bool -> + Repo.t -> + info:info -> + parents:commit_key list -> + tree -> + t Lwt.t + + val of_key : Repo.t -> commit_key -> t option Lwt.t + val of_hash : Repo.t -> hash -> t option Lwt.t + end + + (** {1 Branches} *) + + module Branch : sig + type nonrec t = branch + + val mem : Repo.t -> t -> bool Lwt.t + val find : Repo.t -> t -> commit option Lwt.t + val get : Repo.t -> t -> commit Lwt.t + val set : Repo.t -> t -> commit -> unit Lwt.t + val remove : Repo.t -> t -> unit Lwt.t + val list : Repo.t -> t list Lwt.t + val pp : t Fmt.t + + val watch : + Repo.t -> + t -> + ?init:commit -> + (commit Irmin.Diff.t -> unit Lwt.t) -> + watch Lwt.t + + val watch_all : + Repo.t -> + ?init:(t * commit) list -> + (t -> commit Irmin.Diff.t -> unit Lwt.t) -> + watch Lwt.t + + include Irmin.Branch.S with type t := branch + end + + (** {1 Heads} *) + + 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, + [ `No_change | `Rejected | `Max_depth_reached | `Too_many_lcas ] ) + 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, Irmin.Merge.conflict) result Lwt.t + end + + (** {1 Watches} *) + + val watch : + t -> ?init:commit -> (commit Irmin.Diff.t -> unit Lwt.t) -> watch Lwt.t + + val watch_key : + t -> + path -> + ?init:commit -> + ((commit * tree) Irmin.Diff.t -> unit Lwt.t) -> + watch Lwt.t + + val unwatch : watch -> unit Lwt.t + + (** {1 Type descriptors} *) + + val step_t : step Irmin.Type.t + val path_t : path Irmin.Type.t + val metadata_t : metadata Irmin.Type.t + val contents_t : contents Irmin.Type.t + val node_t : node Irmin.Type.t + val tree_t : tree Irmin.Type.t + val hash_t : hash Irmin.Type.t + val branch_t : branch Irmin.Type.t + val slice_t : slice Irmin.Type.t + val info_t : info Irmin.Type.t + val lca_error_t : lca_error Irmin.Type.t + val ff_error_t : ff_error Irmin.Type.t + val contents_key_t : contents_key Irmin.Type.t + val node_key_t : node_key Irmin.Type.t + val commit_key_t : commit_key Irmin.Type.t + val write_error_t : write_error Irmin.Type.t + val commit_t : repo -> commit Irmin.Type.t +end + +module type S_simple = sig + type hash + + include + S + with type Schema.Hash.t = hash + and type hash := hash + and type contents_key = hash + and type node_key = hash + and type commit_key = hash +end + +module type KV = + S_simple + with type Schema.Path.step = string + and type Schema.Path.t = string list + and type Schema.Branch.t = string + +module type Maker = sig + type endpoint + + module Make (Schema : Irmin.Schema.S) : + S + with module Schema = Schema + and type Backend.Remote.endpoint = endpoint + and type contents_key = Schema.Hash.t + and type node_key = Schema.Hash.t + and type commit_key = Schema.Hash.t +end + +module type KV_maker = sig + type endpoint + type metadata + type info + type hash + + module Make (C : Irmin.Contents.S) : + S + with module Schema.Contents = C + and type Schema.Metadata.t = metadata + and type Schema.Hash.t = hash + and type Schema.Info.t = info + and type Schema.Path.step = string + and type Schema.Path.t = string list + and type Schema.Branch.t = string + and type Backend.Remote.endpoint = endpoint + and type contents_key = hash + and type node_key = hash + and type commit_key = hash +end + +module Make (S : Irmin.Generic_key.S) = struct + type repo = S.repo + type t = S.t + type step = S.step + type path = S.path + type metadata = S.metadata + type contents = S.contents + type node = S.node + type tree = S.tree + type commit = S.commit + type branch = S.branch + type slice = S.slice + type info = S.info + type hash = S.hash + type contents_key = S.contents_key + type node_key = S.node_key + type commit_key = S.commit_key + type lca_error = S.lca_error + type ff_error = S.ff_error + type write_error = S.write_error + type kinded_key = [ `Contents of contents_key | `Node of node_key ] + + (* Re-exports of the type-level modules of [S]. These are pure, + forwarded as-is. *) + module Schema = S.Schema + module Info = S.Info + module Hash = S.Hash + module Path = S.Path + module Metadata = S.Metadata + module Backend = S.Backend + module History = S.History + module Status = S.Status + + module Contents = struct + include (S.Contents : Irmin.Contents.S with type t = S.contents) + + let hash = S.Contents.hash + let of_key r k = run_eio (fun () -> S.Contents.of_key r k) + let of_hash r h = run_eio (fun () -> S.Contents.of_hash r h) + end + + module Repo = struct + type nonrec t = repo + type elt = S.Repo.elt + + let elt_t = S.Repo.elt_t + let v config = run_eio (fun () -> S.Repo.v config) + let close r = run_eio (fun () -> S.Repo.close r) + let heads r = run_eio (fun () -> S.Repo.heads r) + let branches r = run_eio (fun () -> S.Repo.branches r) + let config r = S.Repo.config r + + let export ?full ?depth ?min ?max r = + run_eio (fun () -> S.Repo.export ?full ?depth ?min ?max r) + + let import t s = run_eio (fun () -> S.Repo.import t s) + + (* Pure: no lazy loading. *) + let default_pred_commit t k = + run_eio (fun () -> S.Repo.default_pred_commit t k) + + let default_pred_node t k = run_eio (fun () -> S.Repo.default_pred_node t k) + + let default_pred_contents t k = + run_eio (fun () -> S.Repo.default_pred_contents t k) + + (* Helpers to bridge the Lwt-returning callbacks of [iter] and + [breadth_first_traversal] to the direct-style callbacks that the + underlying Irmin 4 function expects. *) + let lift_cb1 = function + | None -> None + | Some f -> Some (fun x -> Lwt_eio.Promise.await_lwt (f x)) + + let lift_cb2 = function + | None -> None + | Some f -> Some (fun x y -> Lwt_eio.Promise.await_lwt (f x y)) + + let iter ?cache_size ~min ~max ?edge ?branch ?commit ?node ?contents + ?skip_branch ?skip_commit ?skip_node ?skip_contents ?pred_branch + ?pred_commit ?pred_node ?pred_contents ?rev t = + let edge = lift_cb2 edge in + let branch = lift_cb1 branch in + let commit = lift_cb1 commit in + let node = lift_cb1 node in + let contents = lift_cb1 contents in + let skip_branch = lift_cb1 skip_branch in + let skip_commit = lift_cb1 skip_commit in + let skip_node = lift_cb1 skip_node in + let skip_contents = lift_cb1 skip_contents in + let pred_branch = lift_cb2 pred_branch in + let pred_commit = lift_cb2 pred_commit in + let pred_node = lift_cb2 pred_node in + let pred_contents = lift_cb2 pred_contents in + run_eio (fun () -> + S.Repo.iter ?cache_size ~min ~max ?edge ?branch ?commit ?node + ?contents ?skip_branch ?skip_commit ?skip_node ?skip_contents + ?pred_branch ?pred_commit ?pred_node ?pred_contents ?rev t) + + let breadth_first_traversal ?cache_size ~max ?branch ?commit ?node ?contents + ?pred_branch ?pred_commit ?pred_node ?pred_contents t = + let branch = lift_cb1 branch in + let commit = lift_cb1 commit in + let node = lift_cb1 node in + let contents = lift_cb1 contents in + let pred_branch = lift_cb2 pred_branch in + let pred_commit = lift_cb2 pred_commit in + let pred_node = lift_cb2 pred_node in + let pred_contents = lift_cb2 pred_contents in + run_eio (fun () -> + S.Repo.breadth_first_traversal ?cache_size ~max ?branch ?commit ?node + ?contents ?pred_branch ?pred_commit ?pred_node ?pred_contents t) + end + + let main r = run_eio (fun () -> S.main r) + let master r = run_eio (fun () -> S.main r) + let of_branch r b = run_eio (fun () -> S.of_branch r b) + let of_commit c = run_eio (fun () -> S.of_commit c) + let empty r = run_eio (fun () -> S.empty r) + + (* Pure accessors — no I/O, no wrapping needed. *) + let repo = S.repo + let status = S.status + + (* [tree] reads from the store handle. Lwt-wrapped to match Irmin 3. *) + let tree t = run_eio (fun () -> S.tree t) + let find t p = run_eio (fun () -> S.find t p) + let find_all t p = run_eio (fun () -> S.find_all t p) + let mem t p = run_eio (fun () -> S.mem t p) + let mem_tree t p = run_eio (fun () -> S.mem_tree t p) + let get t p = run_eio (fun () -> S.get t p) + let get_all t p = run_eio (fun () -> S.get_all t p) + let find_tree t p = run_eio (fun () -> S.find_tree t p) + let get_tree t p = run_eio (fun () -> S.get_tree t p) + let hash t p = run_eio (fun () -> S.hash t p) + let kind t p = run_eio (fun () -> S.kind t p) + let list t p = run_eio (fun () -> S.list t p) + let key t p = run_eio (fun () -> S.key t p) + + let set ?clear ?retries ?allow_empty ?parents ~info t p v = + run_eio (fun () -> S.set ?clear ?retries ?allow_empty ?parents ~info t p v) + + let set_exn ?clear ?retries ?allow_empty ?parents ~info t p v = + run_eio (fun () -> + S.set_exn ?clear ?retries ?allow_empty ?parents ~info t p v) + + let set_tree ?clear ?retries ?allow_empty ?parents ~info t p tr = + run_eio (fun () -> + S.set_tree ?clear ?retries ?allow_empty ?parents ~info t p tr) + + let set_tree_exn ?clear ?retries ?allow_empty ?parents ~info t p tr = + run_eio (fun () -> + S.set_tree_exn ?clear ?retries ?allow_empty ?parents ~info t p tr) + + let remove ?clear ?retries ?allow_empty ?parents ~info t p = + run_eio (fun () -> S.remove ?clear ?retries ?allow_empty ?parents ~info t p) + + let remove_exn ?clear ?retries ?allow_empty ?parents ~info t p = + run_eio (fun () -> + S.remove_exn ?clear ?retries ?allow_empty ?parents ~info t p) + + (* Irmin.Type.t descriptors derived by [@@deriving irmin] on [S]. *) + let step_t = S.step_t + let path_t = S.path_t + let metadata_t = S.metadata_t + let contents_t = S.contents_t + let node_t = S.node_t + let tree_t = S.tree_t + let hash_t = S.hash_t + let branch_t = S.branch_t + let slice_t = S.slice_t + let info_t = S.info_t + let lca_error_t = S.lca_error_t + let ff_error_t = S.ff_error_t + let contents_key_t = S.contents_key_t + let node_key_t = S.node_key_t + let commit_key_t = S.commit_key_t + let write_error_t = S.write_error_t + let commit_t = S.commit_t + + let test_and_set ?clear ?retries ?allow_empty ?parents ~info t p ~test ~set = + run_eio (fun () -> + S.test_and_set ?clear ?retries ?allow_empty ?parents ~info t p ~test + ~set) + + let test_and_set_exn ?clear ?retries ?allow_empty ?parents ~info t p ~test + ~set = + run_eio (fun () -> + S.test_and_set_exn ?clear ?retries ?allow_empty ?parents ~info t p ~test + ~set) + + let test_and_set_tree ?clear ?retries ?allow_empty ?parents ~info t p ~test + ~set = + run_eio (fun () -> + S.test_and_set_tree ?clear ?retries ?allow_empty ?parents ~info t p + ~test ~set) + + let test_and_set_tree_exn ?clear ?retries ?allow_empty ?parents ~info t p + ~test ~set = + run_eio (fun () -> + S.test_and_set_tree_exn ?clear ?retries ?allow_empty ?parents ~info t p + ~test ~set) + + let test_set_and_get ?clear ?retries ?allow_empty ?parents ~info t p ~test + ~set = + run_eio (fun () -> + S.test_set_and_get ?clear ?retries ?allow_empty ?parents ~info t p ~test + ~set) + + let test_set_and_get_exn ?clear ?retries ?allow_empty ?parents ~info t p ~test + ~set = + run_eio (fun () -> + S.test_set_and_get_exn ?clear ?retries ?allow_empty ?parents ~info t p + ~test ~set) + + let test_set_and_get_tree ?clear ?retries ?allow_empty ?parents ~info t p + ~test ~set = + run_eio (fun () -> + S.test_set_and_get_tree ?clear ?retries ?allow_empty ?parents ~info t p + ~test ~set) + + let test_set_and_get_tree_exn ?clear ?retries ?allow_empty ?parents ~info t p + ~test ~set = + run_eio (fun () -> + S.test_set_and_get_tree_exn ?clear ?retries ?allow_empty ?parents ~info + t p ~test ~set) + + let merge ?clear ?retries ?allow_empty ?parents ~info ~old t p v = + run_eio (fun () -> + S.merge ?clear ?retries ?allow_empty ?parents ~info ~old t p v) + + let merge_exn ?clear ?retries ?allow_empty ?parents ~info ~old t p v = + run_eio (fun () -> + S.merge_exn ?clear ?retries ?allow_empty ?parents ~info ~old t p v) + + let merge_tree ?clear ?retries ?allow_empty ?parents ~info ~old t p v = + run_eio (fun () -> + S.merge_tree ?clear ?retries ?allow_empty ?parents ~info ~old t p v) + + let merge_tree_exn ?clear ?retries ?allow_empty ?parents ~info ~old t p v = + run_eio (fun () -> + S.merge_tree_exn ?clear ?retries ?allow_empty ?parents ~info ~old t p v) + + let with_tree ?clear ?retries ?allow_empty ?parents ?strategy ~info t p f = + run_eio (fun () -> + S.with_tree ?clear ?retries ?allow_empty ?parents ?strategy ~info t p f) + + let with_tree_exn ?clear ?retries ?allow_empty ?parents ?strategy ~info t p f + = + run_eio (fun () -> + S.with_tree_exn ?clear ?retries ?allow_empty ?parents ?strategy ~info t + p f) + + let clone ~src ~dst = run_eio (fun () -> S.clone ~src ~dst) + + type 'a merge = + info:S.Info.f -> + ?max_depth:int -> + ?n:int -> + 'a -> + (unit, Irmin.Merge.conflict) result Lwt.t + + let merge_into ~into ~info ?max_depth ?n t = + run_eio (fun () -> S.merge_into ~into ~info ?max_depth ?n t) + + let merge_with_branch t ~info ?max_depth ?n b = + run_eio (fun () -> S.merge_with_branch t ~info ?max_depth ?n b) + + let merge_with_commit t ~info ?max_depth ?n c = + run_eio (fun () -> S.merge_with_commit t ~info ?max_depth ?n c) + + let lcas ?max_depth ?n t1 t2 = run_eio (fun () -> S.lcas ?max_depth ?n t1 t2) + + let lcas_with_branch t ?max_depth ?n b = + run_eio (fun () -> S.lcas_with_branch t ?max_depth ?n b) + + let lcas_with_commit t ?max_depth ?n c = + run_eio (fun () -> S.lcas_with_commit t ?max_depth ?n c) + + let history ?depth ?min ?max t = + run_eio (fun () -> S.history ?depth ?min ?max t) + + let last_modified ?depth ?n t p = + run_eio (fun () -> S.last_modified ?depth ?n t p) + + (* Backend converters. These are pure. *) + let of_backend_node = S.of_backend_node + let to_backend_node n = run_eio (fun () -> S.to_backend_node n) + + let to_backend_portable_node n = + run_eio (fun () -> S.to_backend_portable_node n) + + let to_backend_commit = S.to_backend_commit + let of_backend_commit = S.of_backend_commit + + (* Extend the top-level [Irmin.remote] the same way [S] does, so the + identifiers in [Irmin_lwt.Make(S).E] and [S.E] refer to remotes carrying + the same [endpoint] type. *) + type Irmin.remote += E of Backend.Remote.endpoint + + (* Saves. These do I/O. *) + let save_contents c v = run_eio (fun () -> S.save_contents c v) + let save_tree ?clear r c n t = run_eio (fun () -> S.save_tree ?clear r c n t) + + module Tree = struct + type nonrec t = tree + + (* Polymorphic variants: declared transparently here. They are + structurally identical to the upstream [S.Tree.X] versions, so + values flow through without coercion thanks to polymorphic-variant + subtyping. *) + type kinded_hash = [ `Contents of hash * metadata | `Node of hash ] + + type kinded_key = + [ `Contents of contents_key * metadata | `Node of node_key ] + + type elt = [ `Node of node | `Contents of contents * metadata ] + + type concrete = + [ `Tree of (step * concrete) list | `Contents of contents * metadata ] + + (* [stats] is a record. We keep it as an alias of [S.Tree.stats] so + it remains nominally compatible. Field access is exposed through + [stats_t] / [Irmin.Type] introspection. *) + type stats = S.Tree.stats + + let stats_t = S.Tree.stats_t + + type error = S.Tree.error + type 'a or_error = ('a, error) result + + exception Dangling_hash = S.Tree.Dangling_hash + exception Pruned_hash = S.Tree.Pruned_hash + exception Portable_value = S.Tree.Portable_value + + module Contents = struct + include ( + S.Tree.Contents : + module type of struct + include S.Tree.Contents + end + with type t = S.Tree.Contents.t) + + let force c = run_eio (fun () -> S.Tree.Contents.force c) + let force_exn c = run_eio (fun () -> S.Tree.Contents.force_exn c) + end + + (* Pure constructors and inspectors. *) + let empty = S.Tree.empty + let singleton = S.Tree.singleton + let of_contents = S.Tree.of_contents + let of_node = S.Tree.of_node + let v = S.Tree.v + let pruned = S.Tree.pruned + let is_empty = S.Tree.is_empty + let destruct = S.Tree.destruct + let hash = S.Tree.hash + let kinded_hash = S.Tree.kinded_hash + let key = S.Tree.key + let shallow = S.Tree.shallow + let clear = S.Tree.clear + let of_concrete = S.Tree.of_concrete + let pp = S.Tree.pp + + (* I/O-performing ops, wrapped. *) + let kind t p = run_eio (fun () -> S.Tree.kind t p) + let diff x y = run_eio (fun () -> S.Tree.diff x y) + let mem t p = run_eio (fun () -> S.Tree.mem t p) + let find_all t p = run_eio (fun () -> S.Tree.find_all t p) + let length t ?cache p = run_eio (fun () -> S.Tree.length t ?cache p) + let find t p = run_eio (fun () -> S.Tree.find t p) + let get_all t p = run_eio (fun () -> S.Tree.get_all t p) + let get t p = run_eio (fun () -> S.Tree.get t p) + + let list t ?offset ?length ?cache p = + run_eio (fun () -> S.Tree.list t ?offset ?length ?cache p) + + let seq t ?offset ?length ?cache p = + run_eio (fun () -> S.Tree.seq t ?offset ?length ?cache p) + + let add t p ?metadata c = run_eio (fun () -> S.Tree.add t p ?metadata c) + + let update t p ?metadata f = + run_eio (fun () -> S.Tree.update t p ?metadata f) + + let remove t p = run_eio (fun () -> S.Tree.remove t p) + let mem_tree t p = run_eio (fun () -> S.Tree.mem_tree t p) + let find_tree t p = run_eio (fun () -> S.Tree.find_tree t p) + let get_tree t p = run_eio (fun () -> S.Tree.get_tree t p) + let add_tree t p sub = run_eio (fun () -> S.Tree.add_tree t p sub) + let update_tree t p f = run_eio (fun () -> S.Tree.update_tree t p f) + let stats ?force t = run_eio (fun () -> S.Tree.stats ?force t) + let to_concrete t = run_eio (fun () -> S.Tree.to_concrete t) + let find_key r t = run_eio (fun () -> S.Tree.find_key r t) + let of_key r k = run_eio (fun () -> S.Tree.of_key r k) + let of_hash r h = run_eio (fun () -> S.Tree.of_hash r h) + + (* [fold] accepts Lwt-returning folders as Irmin 3 did; each folder is + bridged to direct style via [Lwt_eio.Promise.await_lwt] before being + handed to the underlying Irmin 4 [S.Tree.fold]. *) + type marks = S.Tree.marks + + let empty_marks = S.Tree.empty_marks + + type 'a force = [ `True | `False of path -> 'a -> 'a Lwt.t ] + type uniq = [ `False | `True | `Marks of marks ] + type ('a, 'b) folder = path -> 'b -> 'a -> 'a Lwt.t + type depth = S.Tree.depth + + let lift_folder = function + | None -> None + | Some (f : _ folder) -> + Some (fun path b acc -> Lwt_eio.Promise.await_lwt (f path b acc)) + + let lift_force = function + | None -> None + | Some `True -> Some `True + | Some (`False f) -> + Some (`False (fun path acc -> Lwt_eio.Promise.await_lwt (f path acc))) + + let fold ?order ?force ?cache ?uniq ?pre ?post ?depth ?contents ?node ?tree + t acc = + let force = lift_force force in + let pre = lift_folder pre in + let post = lift_folder post in + let contents = lift_folder contents in + let node = lift_folder node in + let tree = lift_folder tree in + run_eio (fun () -> + S.Tree.fold ?order ?force ?cache ?uniq ?pre ?post ?depth ?contents + ?node ?tree t acc) + + let merge = S.Tree.merge + + type counters = S.Tree.counters + + let counters = S.Tree.counters + let dump_counters = S.Tree.dump_counters + let reset_counters = S.Tree.reset_counters + let inspect = S.Tree.inspect + + module Proof = struct + include ( + S.Tree.Proof : + module type of struct + include S.Tree.Proof + end + with type tree := S.Tree.Proof.tree + and type t := S.Tree.Proof.t) + + type tree = S.Tree.Proof.tree = + | Contents of S.contents * S.metadata + | Blinded_contents of S.hash * S.metadata + | Node of (S.step * tree) list + | Blinded_node of S.hash + | Inode of inode_tree inode + | Extender of inode_tree inode_extender + + and inode_tree = S.Tree.Proof.inode_tree = + | Blinded_inode of S.hash + | Inode_values of (S.step * tree) list + | Inode_tree of inode_tree inode + | Inode_extender of inode_tree inode_extender + + type t = S.Tree.Proof.t + + let v = S.Tree.Proof.v + let before = S.Tree.Proof.before + let after = S.Tree.Proof.after + let state = S.Tree.Proof.state + let to_tree = S.Tree.Proof.to_tree + end + + type verifier_error = [ `Proof_mismatch of string ] + + let produce_proof repo key f = + let f' tree = Lwt_eio.Promise.await_lwt (f tree) in + run_eio (fun () -> S.Tree.produce_proof repo key f') + + let verify_proof proof f = + let f' tree = Lwt_eio.Promise.await_lwt (f tree) in + run_eio (fun () -> S.Tree.verify_proof proof f') + + let hash_of_proof_state = S.Tree.hash_of_proof_state + end + + module Commit = struct + type nonrec t = commit + type commit_key = S.commit_key + + (* Pure accessors. *) + let tree = S.Commit.tree + let parents = S.Commit.parents + let info = S.Commit.info + let hash = S.Commit.hash + let key = S.Commit.key + let pp = S.Commit.pp + let pp_hash = S.Commit.pp_hash + + (* I/O-performing. *) + let v ?clear r ~info ~parents tree = + run_eio (fun () -> S.Commit.v ?clear r ~info ~parents tree) + + let of_key r k = run_eio (fun () -> S.Commit.of_key r k) + let of_hash r h = run_eio (fun () -> S.Commit.of_hash r h) + end + + module Branch = struct + type nonrec t = branch + + let mem r b = run_eio (fun () -> S.Branch.mem r b) + let find r b = run_eio (fun () -> S.Branch.find r b) + let get r b = run_eio (fun () -> S.Branch.get r b) + let set r b c = run_eio (fun () -> S.Branch.set r b c) + let remove r b = run_eio (fun () -> S.Branch.remove r b) + let list r = run_eio (fun () -> S.Branch.list r) + let pp = S.Branch.pp + + let watch r b ?init lwt_cb = + let cb diff = Lwt_eio.Promise.await_lwt (lwt_cb diff) in + run_eio (fun () -> S.Branch.watch r b ?init cb) + + let watch_all r ?init lwt_cb = + let cb br diff = Lwt_eio.Promise.await_lwt (lwt_cb br diff) in + run_eio (fun () -> S.Branch.watch_all r ?init cb) + + let main = S.Branch.main + let is_valid = S.Branch.is_valid + let t = S.Branch.t + end + + module Head = struct + let list r = run_eio (fun () -> S.Head.list r) + let find t = run_eio (fun () -> S.Head.find t) + let get t = run_eio (fun () -> S.Head.get t) + let set t c = run_eio (fun () -> S.Head.set t c) + + let fast_forward t ?max_depth ?n c = + run_eio (fun () -> S.Head.fast_forward t ?max_depth ?n c) + + let test_and_set t ~test ~set = + run_eio (fun () -> S.Head.test_and_set t ~test ~set) + + let merge ~into ~info ?max_depth ?n c = + run_eio (fun () -> S.Head.merge ~into ~info ?max_depth ?n c) + end + + type watch = S.watch + (** Top-level watches. *) + + let watch t ?init lwt_cb = + let cb diff = Lwt_eio.Promise.await_lwt (lwt_cb diff) in + run_eio (fun () -> S.watch t ?init cb) + + let watch_key t path ?init lwt_cb = + let cb diff = Lwt_eio.Promise.await_lwt (lwt_cb diff) in + run_eio (fun () -> S.watch_key t path ?init cb) + + let unwatch w = run_eio (fun () -> S.unwatch w) +end + +(* Lwt wrappers for [irmin-pack-unix]-specific operations. + + [Pack.Make] takes an [Irmin_pack_io.S] (the full pack-unix store + signature) and returns a module that: + - [include]s [Make (S)] — every generic-key Lwt-wrapped operation is + available; + - additionally exposes Lwt-wrapped versions of the pack-unix + extensions: integrity check, GC, snapshots, split/reload/flush, + [create_one_commit_store]. *) +module Pack = struct + module Make (S : Irmin_pack_io.S) = struct + include Make (S) + + let integrity_check ?ppf ?heads ~auto_repair r = + run_eio (fun () -> S.integrity_check ?ppf ?heads ~auto_repair r) + + let integrity_check_inodes ?heads r = + run_eio (fun () -> S.integrity_check_inodes ?heads r) + + let traverse_pack_file kind conf = + run_eio (fun () -> S.traverse_pack_file kind conf) + + let test_traverse_pack_file kind conf = + run_eio (fun () -> S.test_traverse_pack_file kind conf) + + let split r = run_eio (fun () -> S.split r) + let is_split_allowed r = S.is_split_allowed r + let add_volume r = run_eio (fun () -> S.add_volume r) + let reload r = run_eio (fun () -> S.reload r) + let flush r = run_eio (fun () -> S.flush r) + + let create_one_commit_store ~domain_mgr r ck path = + run_eio (fun () -> S.create_one_commit_store ~domain_mgr r ck path) + + module Gc = struct + type process_state = S.Gc.process_state + type msg = S.Gc.msg + + let start_exn ~domain_mgr ?unlink r c = + run_eio (fun () -> S.Gc.start_exn ~domain_mgr ?unlink r c) + + let finalise_exn ?wait r = run_eio (fun () -> S.Gc.finalise_exn ?wait r) + + let run ~domain_mgr ?finished r c = + let finished = + Option.map + (fun lwt_f result -> Lwt_eio.Promise.await_lwt (lwt_f result)) + finished + in + run_eio (fun () -> S.Gc.run ~domain_mgr ?finished r c) + + let wait r = run_eio (fun () -> S.Gc.wait r) + let cancel r = run_eio (fun () -> S.Gc.cancel r) + let is_finished r = S.Gc.is_finished r + let behaviour r = S.Gc.behaviour r + let is_allowed r = S.Gc.is_allowed r + let latest_gc_target r = S.Gc.latest_gc_target r + end + + module Snapshot = struct + include S.Snapshot + + let export ?on_disk r f ~root_key = + run_eio (fun () -> S.Snapshot.export ?on_disk r f ~root_key) + end + end +end + +module Sync = struct + module type S = sig + type db + type commit + type status = [ `Empty | `Head of commit ] + type info + + val status_t : db -> status Irmin.Type.t + val pp_status : status Fmt.t + + val fetch : + db -> + ?depth:int -> + Irmin.remote -> + (status, [ `Msg of string ]) result Lwt.t + + val fetch_exn : db -> ?depth:int -> Irmin.remote -> status Lwt.t + + type pull_error = [ `Msg of string | Irmin.Merge.conflict ] + + val pp_pull_error : pull_error Fmt.t + + val pull : + db -> + ?depth:int -> + Irmin.remote -> + [ `Merge of unit -> info | `Set ] -> + (status, pull_error) result Lwt.t + + val pull_exn : + db -> + ?depth:int -> + Irmin.remote -> + [ `Merge of unit -> info | `Set ] -> + status Lwt.t + + type push_error = [ `Msg of string | `Detached_head ] + + val pp_push_error : push_error Fmt.t + + val push : + db -> ?depth:int -> Irmin.remote -> (status, push_error) result Lwt.t + + val push_exn : db -> ?depth:int -> Irmin.remote -> status Lwt.t + end + + module Make (X : Irmin.Generic_key.S) = struct + module S = Irmin.Sync.Make (X) + + type db = X.t + type commit = X.commit + type status = [ `Empty | `Head of commit ] + type info = X.info + + let status_t = S.status_t + let pp_status = S.pp_status + let fetch db ?depth r = run_eio (fun () -> S.fetch db ?depth r) + let fetch_exn db ?depth r = run_eio (fun () -> S.fetch_exn db ?depth r) + + type pull_error = S.pull_error + + let pp_pull_error = S.pp_pull_error + let pull db ?depth r s = run_eio (fun () -> S.pull db ?depth r s) + let pull_exn db ?depth r s = run_eio (fun () -> S.pull_exn db ?depth r s) + + type push_error = S.push_error + + let pp_push_error = S.pp_push_error + let push db ?depth r = run_eio (fun () -> S.push db ?depth r) + let push_exn db ?depth r = run_eio (fun () -> S.push_exn db ?depth r) + end +end + +let remote_store = Irmin.remote_store + +module Json_tree + (Store : Irmin.S with type Schema.Contents.t = Irmin.Contents.json) = +struct + module J = Irmin.Json_tree (Store) + include (J : Irmin.Contents.S with type t = Irmin.Contents.json) + + let to_concrete_tree = J.to_concrete_tree + let of_concrete_tree = J.of_concrete_tree + let get_tree tree path = run_eio (fun () -> J.get_tree tree path) + let set_tree tree path v = run_eio (fun () -> J.set_tree tree path v) + let get t path = run_eio (fun () -> J.get t path) + let set t path v ~info = run_eio (fun () -> J.set t path v ~info) +end + +module Dot (S : Irmin.Generic_key.S) = struct + module D = Irmin.Dot (S) + + type db = S.t + + let output_buffer db ?html ?depth ?full ~date buf = + run_eio (fun () -> D.output_buffer db ?html ?depth ?full ~date buf) +end diff --git a/src/irmin-lwt/irmin_lwt.mli b/src/irmin-lwt/irmin_lwt.mli new file mode 100644 index 0000000000..9cbe272a93 --- /dev/null +++ b/src/irmin-lwt/irmin_lwt.mli @@ -0,0 +1,1113 @@ +(** Lwt compatibility layer for Irmin 4. + + This package lets Irmin 3 (Lwt-based) consumers continue to use a monadic + [Lwt.t] API while the backend is Irmin 4 (direct-style Eio). It is a + transitional shim: new code should use [Irmin] directly. + + See [doc/migration-from-irmin-3.md] for a migration walkthrough. *) + +val run : (unit -> 'a Lwt.t) -> 'a +(** [run f] sets up the Eio runtime and the [lwt_eio] bridge, runs [f ()] to + completion, and returns its result. This is the drop-in replacement for + [Lwt_main.run] in Irmin 3 client code. + + Intended for top-level [let () = Irmin_lwt.run main] style usage in Irmin + 3-era programs being migrated to Irmin 4. *) + +val run_with_env : < clock : _ Eio.Time.clock ; .. > -> (unit -> 'a Lwt.t) -> 'a +(** [run_with_env env f] is like {!run} but reuses an existing Eio environment + instead of calling [Eio_main.run] internally. Useful when the client is + already inside an Eio event loop. *) + +(** Lwt-flavoured counterpart of the internal [Irmin.Closeable] trait: a single + [close] operation that releases the resources held by a handle. Used as + [include Closeable with type _ t := t] in [S.Repo] to mirror the Irmin 3 + [Repo] signature. *) +module type Closeable = sig + type 'a t + + val close : 'a t -> unit Lwt.t +end + +(** The Lwt-flavoured counterpart of [Irmin.Generic_key.S]. + + Every I/O-triggering operation of [Irmin.Generic_key.S] is replaced by a + version returning ['_ Lwt.t]; type-level submodules (Schema, Info, Hash, + Path, Metadata, Backend, Contents, History, Status) are kept so downstream + consumers can write [Irmin_lwt.S with module Schema = …] the same way they + would write [Irmin.Generic_key.S with module Schema = …]. + + See {!Make} for the functor that produces a module conforming to [S] from an + arbitrary [Irmin.Generic_key.S]. *) +module type S = sig + (** {1 Schema} *) + + module Schema : Irmin.Schema.S + + (** {1 Types} *) + + type repo + type t + type step = Schema.Path.step + type path = Schema.Path.t + type metadata = Schema.Metadata.t + type contents = Schema.Contents.t + type node + type tree + type commit + type branch = Schema.Branch.t + type slice + type info = Schema.Info.t + type hash = Schema.Hash.t + type contents_key + type node_key + type commit_key + type lca_error = [ `Max_depth_reached | `Too_many_lcas ] + type ff_error = [ `No_change | `Rejected | lca_error ] + + type write_error = + [ Irmin.Merge.conflict + | `Too_many_retries of int + | `Test_was of tree option ] + + type kinded_key = [ `Contents of contents_key | `Node of node_key ] + type watch + + (** {1 Type-level submodules} *) + + module Info : Irmin.Info.S with type t = info + module Hash : Irmin.Hash.S with type t = hash + module Path : Irmin.Path.S with type t = path and type step = step + module Metadata : Irmin.Metadata.S with type t = metadata + + module Backend : + Irmin.Backend.S + with module Schema = Schema + with type Slice.t = slice + and type Repo.t = repo + and type Contents.key = contents_key + and type Node.key = node_key + and type Commit.key = commit_key + + module Contents : sig + include Irmin.Contents.S with type t = contents + + val hash : contents -> hash + val of_key : repo -> contents_key -> contents option Lwt.t + val of_hash : repo -> hash -> contents option Lwt.t + end + + module History : Graph.Sig.P with type V.t = commit + + module Status : sig + type t = [ `Empty | `Branch of branch | `Commit of commit ] + + val t : repo -> t Irmin.Type.t + val pp : t Fmt.t + end + + type Irmin.remote += + | E of Backend.Remote.endpoint + (** Extends [Irmin.remote] with the endpoint type of [Backend]. *) + + (** {1 Repositories} *) + + module Repo : sig + type nonrec t = repo + + type elt = + [ `Commit of commit_key + | `Node of node_key + | `Contents of contents_key + | `Branch of branch ] + + val elt_t : elt Irmin.Type.t + val v : Irmin.Backend.Conf.t -> t Lwt.t + + include Closeable with type _ t := t + (** @inline *) + + val heads : t -> commit list Lwt.t + val branches : t -> branch list Lwt.t + val config : t -> Irmin.Backend.Conf.t + + val export : + ?full:bool -> + ?depth:int -> + ?min:commit list -> + ?max:[ `Head | `Max of commit list ] -> + t -> + slice Lwt.t + + val import : t -> slice -> (unit, [ `Msg of string ]) result Lwt.t + val default_pred_commit : t -> commit_key -> elt list Lwt.t + val default_pred_node : t -> node_key -> elt list Lwt.t + val default_pred_contents : t -> contents_key -> elt list Lwt.t + + val iter : + ?cache_size:int -> + min:elt list -> + max:elt list -> + ?edge:(elt -> elt -> unit Lwt.t) -> + ?branch:(branch -> unit Lwt.t) -> + ?commit:(commit_key -> unit Lwt.t) -> + ?node:(node_key -> unit Lwt.t) -> + ?contents:(contents_key -> unit Lwt.t) -> + ?skip_branch:(branch -> bool Lwt.t) -> + ?skip_commit:(commit_key -> bool Lwt.t) -> + ?skip_node:(node_key -> bool Lwt.t) -> + ?skip_contents:(contents_key -> bool Lwt.t) -> + ?pred_branch:(t -> branch -> elt list Lwt.t) -> + ?pred_commit:(t -> commit_key -> elt list Lwt.t) -> + ?pred_node:(t -> node_key -> elt list Lwt.t) -> + ?pred_contents:(t -> contents_key -> elt list Lwt.t) -> + ?rev:bool -> + t -> + unit Lwt.t + + val breadth_first_traversal : + ?cache_size:int -> + max:elt list -> + ?branch:(branch -> unit Lwt.t) -> + ?commit:(commit_key -> unit Lwt.t) -> + ?node:(node_key -> unit Lwt.t) -> + ?contents:(contents_key -> unit Lwt.t) -> + ?pred_branch:(t -> branch -> elt list Lwt.t) -> + ?pred_commit:(t -> commit_key -> elt list Lwt.t) -> + ?pred_node:(t -> node_key -> elt list Lwt.t) -> + ?pred_contents:(t -> contents_key -> elt list Lwt.t) -> + t -> + unit Lwt.t + end + + (** {1 Stores} *) + + val main : repo -> t Lwt.t + + val master : repo -> t Lwt.t + [@@ocaml.deprecated "Use `main` instead."] + (** Deprecated alias kept for Irmin 3 compatibility. Use {!main}. *) + + val of_branch : repo -> branch -> t Lwt.t + val of_commit : commit -> t Lwt.t + val empty : repo -> t Lwt.t + val repo : t -> repo + val tree : t -> tree Lwt.t + val status : t -> [ `Empty | `Branch of branch | `Commit of commit ] + + (** {2 Reads} *) + + val find : t -> path -> contents option Lwt.t + val find_all : t -> path -> (contents * metadata) option Lwt.t + val mem : t -> path -> bool Lwt.t + val mem_tree : t -> path -> bool Lwt.t + val get : t -> path -> contents Lwt.t + val get_all : t -> path -> (contents * metadata) Lwt.t + val find_tree : t -> path -> tree option Lwt.t + val get_tree : t -> path -> tree Lwt.t + val hash : t -> path -> hash option Lwt.t + val kind : t -> path -> [ `Contents | `Node ] option Lwt.t + val list : t -> path -> (step * tree) list Lwt.t + val key : t -> path -> kinded_key option Lwt.t + + (** {2 Writes} *) + + val set : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + contents -> + (unit, write_error) result Lwt.t + + val set_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + contents -> + unit Lwt.t + + val set_tree : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + tree -> + (unit, write_error) result Lwt.t + + val set_tree_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + tree -> + unit Lwt.t + + val remove : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + (unit, write_error) result Lwt.t + + val remove_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + unit Lwt.t + + val test_and_set : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + test:contents option -> + set:contents option -> + (unit, write_error) result Lwt.t + + val test_and_set_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + test:contents option -> + set:contents option -> + unit Lwt.t + + val test_and_set_tree : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + test:tree option -> + set:tree option -> + (unit, write_error) result Lwt.t + + val test_and_set_tree_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + test:tree option -> + set:tree option -> + unit Lwt.t + + val test_set_and_get : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + test:contents option -> + set:contents option -> + (commit option, write_error) result Lwt.t + + val test_set_and_get_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + test:contents option -> + set:contents option -> + commit option Lwt.t + + val test_set_and_get_tree : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + test:tree option -> + set:tree option -> + (commit option, write_error) result Lwt.t + + val test_set_and_get_tree_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + test:tree option -> + set:tree option -> + commit option Lwt.t + + val merge : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:contents option -> + t -> + path -> + contents option -> + (unit, write_error) result Lwt.t + + val merge_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:contents option -> + t -> + path -> + contents option -> + unit Lwt.t + + val merge_tree : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:tree option -> + t -> + path -> + tree option -> + (unit, write_error) result Lwt.t + + val merge_tree_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:tree option -> + t -> + path -> + tree option -> + unit Lwt.t + + val with_tree : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + ?strategy:[ `Set | `Test_and_set | `Merge ] -> + info:Info.f -> + t -> + path -> + (tree option -> tree option) -> + (unit, write_error) result Lwt.t + + val with_tree_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + ?strategy:[ `Set | `Test_and_set | `Merge ] -> + info:Info.f -> + t -> + path -> + (tree option -> tree option) -> + unit Lwt.t + + val clone : src:t -> dst:branch -> t Lwt.t + + (** {2 Merges and ancestors} *) + + type 'a merge = + info:Info.f -> + ?max_depth:int -> + ?n:int -> + 'a -> + (unit, Irmin.Merge.conflict) result Lwt.t + (** Lwt-wrapped abbreviation for merge-into-something functions. *) + + 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 + + val history : + ?depth:int -> ?min:commit list -> ?max:commit list -> t -> History.t Lwt.t + + val last_modified : ?depth:int -> ?n:int -> t -> path -> commit list Lwt.t + + (** {2 Backend converters} *) + + val of_backend_node : repo -> Backend.Node.value -> node + val to_backend_node : node -> Backend.Node.value Lwt.t + val to_backend_portable_node : node -> Backend.Node_portable.t Lwt.t + val to_backend_commit : commit -> Backend.Commit.value + + val of_backend_commit : + repo -> Backend.Commit.Key.t -> Backend.Commit.value -> commit + + val save_contents : + [> Irmin.Perms.write ] Backend.Contents.t -> contents -> contents_key Lwt.t + + val save_tree : + ?clear:bool -> + repo -> + [> Irmin.Perms.write ] Backend.Contents.t -> + [> Irmin.Perms.read_write ] Backend.Node.t -> + tree -> + kinded_key Lwt.t + + (** {1 Trees} *) + + module Tree : sig + type nonrec t = tree + type kinded_hash = [ `Contents of hash * metadata | `Node of hash ] + + type kinded_key = + [ `Contents of contents_key * metadata | `Node of node_key ] + + type elt = [ `Node of node | `Contents of contents * metadata ] + type marks + + type depth = + [ `Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int ] + + type stats + (** Tree statistics. The record fields ([nodes], [leafs], [skips], [depth], + [width]) cannot be exposed through the functor boundary, but the + [Irmin.Type.t] descriptor [stats_t] gives field access via [Irmin.Type] + introspection. *) + + val stats_t : stats Irmin.Type.t + + type concrete = + [ `Tree of (step * concrete) list | `Contents of contents * metadata ] + + type 'a force = [ `True | `False of path -> 'a -> 'a Lwt.t ] + type uniq = [ `False | `True | `Marks of marks ] + type ('a, 'b) folder = path -> 'b -> 'a -> 'a Lwt.t + + type error = + [ `Dangling_hash of hash | `Pruned_hash of hash | `Portable_value ] + (** Errors that can be raised when forcing a lazy tree value. *) + + type 'a or_error = ('a, error) result + + exception Dangling_hash of { context : string; hash : hash } + (** Raised by functions that can force lazy tree nodes but do not return an + explicit {!or_error}. *) + + exception Pruned_hash of { context : string; hash : hash } + (** Raised by functions that attempt to load {!pruned} tree nodes. *) + + exception Portable_value of { context : string } + (** Raised by functions that attempt to perform IO on a portable tree. *) + + (** Operations on lazy tree contents. *) + module Contents : sig + type nonrec t + + val hash : ?cache:bool -> t -> hash + val key : t -> contents_key option + val force : t -> contents or_error Lwt.t + val force_exn : t -> contents Lwt.t + val clear : t -> unit + end + + val empty : unit -> t + val singleton : path -> ?metadata:metadata -> contents -> t + val of_contents : ?metadata:metadata -> contents -> t + val of_node : node -> t + val v : elt -> t + val pruned : kinded_hash -> t + val is_empty : t -> bool + val destruct : t -> [ `Node of node | `Contents of Contents.t * metadata ] + val hash : ?cache:bool -> t -> hash + val kinded_hash : ?cache:bool -> t -> kinded_hash + val key : t -> kinded_key option + val shallow : Repo.t -> kinded_key -> t + val clear : ?depth:int -> t -> unit + val pp : t Irmin.Type.pp + val kind : t -> path -> [ `Contents | `Node ] option Lwt.t + val diff : t -> t -> (path * (contents * metadata) Irmin.Diff.t) list Lwt.t + val mem : t -> path -> bool Lwt.t + val find_all : t -> path -> (contents * metadata) option Lwt.t + val length : t -> ?cache:bool -> path -> int Lwt.t + val find : t -> path -> contents option Lwt.t + val get_all : t -> path -> (contents * metadata) Lwt.t + val get : t -> path -> contents Lwt.t + + val list : + t -> + ?offset:int -> + ?length:int -> + ?cache:bool -> + path -> + (step * t) list Lwt.t + + val seq : + t -> + ?offset:int -> + ?length:int -> + ?cache:bool -> + path -> + (step * t) Seq.t Lwt.t + + val add : t -> path -> ?metadata:metadata -> contents -> t Lwt.t + + val update : + t -> + path -> + ?metadata:metadata -> + (contents option -> contents option) -> + t Lwt.t + + val remove : t -> path -> t Lwt.t + val mem_tree : t -> path -> bool Lwt.t + val find_tree : t -> path -> t option Lwt.t + val get_tree : t -> path -> t Lwt.t + val add_tree : t -> path -> t -> t Lwt.t + val update_tree : t -> path -> (t option -> t option) -> t Lwt.t + val of_concrete : concrete -> t + val stats : ?force:bool -> t -> stats Lwt.t + val to_concrete : t -> concrete Lwt.t + val find_key : Repo.t -> t -> kinded_key option Lwt.t + val of_key : Repo.t -> kinded_key -> t option Lwt.t + val of_hash : Repo.t -> kinded_hash -> t option Lwt.t + + (** {2 Fold} *) + + val empty_marks : unit -> marks + + val fold : + ?order:[ `Sorted | `Undefined | `Random of Random.State.t ] -> + ?force:'a force -> + ?cache:bool -> + ?uniq:uniq -> + ?pre:('a, step list) folder -> + ?post:('a, step list) folder -> + ?depth:depth -> + ?contents:('a, contents) folder -> + ?node:('a, node) folder -> + ?tree:('a, t) folder -> + t -> + 'a -> + 'a Lwt.t + + (** {2 Merge} *) + + val merge : t Irmin.Merge.t + + (** {2 Performance counters and inspection} *) + + type counters + + val counters : unit -> counters + val dump_counters : unit Fmt.t + val reset_counters : unit -> unit + + val inspect : + t -> + [ `Contents + | `Node of [ `Map | `Key | `Value | `Portable_dirty | `Pruned ] ] + (** [inspect t] is similar to {!val-kind}, with extra state information + returned for nodes. Pure: no I/O. *) + + (** {2 Merkle proofs} *) + + (** [Tree.Proof] mirrors [Irmin.Proof.S] for the store's [contents], [hash], + [step] and [metadata]. *) + module Proof : sig + type 'a inode = { length : int; proofs : (int * 'a) list } + type 'a inode_extender = { length : int; segments : int list; proof : 'a } + + type tree = + | Contents of contents * metadata + | Blinded_contents of hash * metadata + | Node of (step * tree) list + | Blinded_node of hash + | Inode of inode_tree inode + | Extender of inode_tree inode_extender + + and inode_tree = + | Blinded_inode of hash + | Inode_values of (step * tree) list + | Inode_tree of inode_tree inode + | Inode_extender of inode_tree inode_extender + + type t + (** The type for Merkle proofs. *) + + val v : before:kinded_hash -> after:kinded_hash -> tree -> t + val before : t -> kinded_hash + val after : t -> kinded_hash + val state : t -> tree + + type irmin_tree + + val to_tree : t -> irmin_tree + end + with type irmin_tree := t + + type verifier_error = [ `Proof_mismatch of string ] + + val produce_proof : + Repo.t -> kinded_key -> (t -> (t * 'a) Lwt.t) -> (Proof.t * 'a) Lwt.t + + val verify_proof : + Proof.t -> (t -> (t * 'a) Lwt.t) -> (t * 'a, verifier_error) result Lwt.t + + val hash_of_proof_state : Proof.tree -> kinded_hash + end + + (** {1 Commits} *) + + module Commit : sig + type nonrec t = commit + type nonrec commit_key = commit_key + + val tree : t -> tree + val parents : t -> commit_key list + val info : t -> info + val hash : t -> hash + val key : t -> commit_key + val pp : t Fmt.t + val pp_hash : t Fmt.t + + val v : + ?clear:bool -> + Repo.t -> + info:info -> + parents:commit_key list -> + tree -> + t Lwt.t + + val of_key : Repo.t -> commit_key -> t option Lwt.t + val of_hash : Repo.t -> hash -> t option Lwt.t + end + + (** {1 Branches} *) + + module Branch : sig + type nonrec t = branch + + val mem : Repo.t -> t -> bool Lwt.t + val find : Repo.t -> t -> commit option Lwt.t + val get : Repo.t -> t -> commit Lwt.t + val set : Repo.t -> t -> commit -> unit Lwt.t + val remove : Repo.t -> t -> unit Lwt.t + val list : Repo.t -> t list Lwt.t + val pp : t Fmt.t + + val watch : + Repo.t -> + t -> + ?init:commit -> + (commit Irmin.Diff.t -> unit Lwt.t) -> + watch Lwt.t + + val watch_all : + Repo.t -> + ?init:(t * commit) list -> + (t -> commit Irmin.Diff.t -> unit Lwt.t) -> + watch Lwt.t + + include Irmin.Branch.S with type t := branch + (** @inline *) + end + + (** {1 Heads} *) + + 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, + [ `No_change | `Rejected | `Max_depth_reached | `Too_many_lcas ] ) + 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, Irmin.Merge.conflict) result Lwt.t + end + + (** {1 Watches} *) + + val watch : + t -> ?init:commit -> (commit Irmin.Diff.t -> unit Lwt.t) -> watch Lwt.t + + val watch_key : + t -> + path -> + ?init:commit -> + ((commit * tree) Irmin.Diff.t -> unit Lwt.t) -> + watch Lwt.t + + val unwatch : watch -> unit Lwt.t + + (** {1 Type descriptors} *) + + val step_t : step Irmin.Type.t + val path_t : path Irmin.Type.t + val metadata_t : metadata Irmin.Type.t + val contents_t : contents Irmin.Type.t + val node_t : node Irmin.Type.t + val tree_t : tree Irmin.Type.t + val hash_t : hash Irmin.Type.t + val branch_t : branch Irmin.Type.t + val slice_t : slice Irmin.Type.t + val info_t : info Irmin.Type.t + val lca_error_t : lca_error Irmin.Type.t + val ff_error_t : ff_error Irmin.Type.t + val contents_key_t : contents_key Irmin.Type.t + val node_key_t : node_key Irmin.Type.t + val commit_key_t : commit_key Irmin.Type.t + val write_error_t : write_error Irmin.Type.t + val commit_t : repo -> commit Irmin.Type.t +end + +(** {1 Convenience module types} + + Lwt-flavoured counterparts of [Irmin.S], [Irmin.KV], [Irmin.Maker], and + [Irmin.KV_maker]. They let downstream code declare interfaces and functor + parameters in the same shape as Irmin 3. *) + +(** Counterpart of [Irmin.S]: a store whose contents, node, and commit keys are + all the schema's hash type. *) +module type S_simple = sig + type hash + + include + S + with type Schema.Hash.t = hash + and type hash := hash + and type contents_key = hash + and type node_key = hash + and type commit_key = hash +end + +(** Counterpart of [Irmin.KV]: an [S_simple] with [string]-keyed paths and + branches. *) +module type KV = + S_simple + with type Schema.Path.step = string + and type Schema.Path.t = string list + and type Schema.Branch.t = string + +(** Counterpart of [Irmin.Maker]: the type-level signature of a + hash-keyed-store-producing functor parametrised by a [Schema]. *) +module type Maker = sig + type endpoint + + module Make (Schema : Irmin.Schema.S) : + S + with module Schema = Schema + and type Backend.Remote.endpoint = endpoint + and type contents_key = Schema.Hash.t + and type node_key = Schema.Hash.t + and type commit_key = Schema.Hash.t +end + +(** Counterpart of [Irmin.KV_maker]: the type-level signature of a hash-keyed + string-pathed-store-producing functor parametrised by [Contents]. *) +module type KV_maker = sig + type endpoint + type metadata + type info + type hash + + module Make (C : Irmin.Contents.S) : + S + with module Schema.Contents = C + and type Schema.Metadata.t = metadata + and type Schema.Hash.t = hash + and type Schema.Info.t = info + and type Schema.Path.step = string + and type Schema.Path.t = string list + and type Schema.Branch.t = string + and type Backend.Remote.endpoint = endpoint + and type contents_key = hash + and type node_key = hash + and type commit_key = hash +end + +module Make (S : Irmin.Generic_key.S) : + S + with module Schema = S.Schema + and type repo = S.repo + and type t = S.t + and type node = S.node + and type tree = S.tree + and type commit = S.commit + and type slice = S.slice + and type contents_key = S.contents_key + and type node_key = S.node_key + and type commit_key = S.commit_key + and type lca_error = S.lca_error + and type ff_error = S.ff_error + and type write_error = S.write_error + and type watch = S.watch + and module Info = S.Info + and module Hash = S.Hash + and module Path = S.Path + and module Metadata = S.Metadata + and module Backend = S.Backend + and module History = S.History + and type Repo.elt = S.Repo.elt + and type Tree.kinded_hash = S.Tree.kinded_hash + and type Tree.kinded_key = S.Tree.kinded_key + and type Tree.elt = S.Tree.elt + and type Tree.marks = S.Tree.marks + and type Tree.depth = S.Tree.depth + and type Tree.stats = S.Tree.stats + and type Tree.concrete = S.Tree.concrete + +(** Lwt wrappers for [irmin-pack-unix]-specific operations. + + [Pack.Make] takes an [Irmin_pack_io.S] (the full pack-unix store signature) + and returns a module that includes the result of the generic [Make] functor + plus Lwt-wrapped versions of the pack-unix extensions: integrity check, GC, + snapshots, split/reload/flush, [create_one_commit_store]. *) +module Pack : sig + module Make (S : Irmin_pack_io.S) : sig + include module type of Make (S) + + val integrity_check : + ?ppf:Format.formatter -> + ?heads:commit list -> + auto_repair:bool -> + repo -> + ( [> `Fixed of int | `No_error ], + [> `Cannot_fix of string | `Corrupted of int ] ) + result + Lwt.t + + val integrity_check_inodes : + ?heads:commit list -> + repo -> + ([> `No_error ], [> `Cannot_fix of string ]) result Lwt.t + + val traverse_pack_file : + [ `Reconstruct_index of [ `In_place | `Output of string ] + | `Check_index + | `Check_and_fix_index ] -> + Irmin.config -> + unit Lwt.t + + val test_traverse_pack_file : + [ `Reconstruct_index of [ `In_place | `Output of string ] + | `Check_index + | `Check_and_fix_index ] -> + Irmin.config -> + unit Lwt.t + + val split : repo -> unit Lwt.t + val is_split_allowed : repo -> bool + val add_volume : repo -> unit Lwt.t + val reload : repo -> unit Lwt.t + val flush : repo -> unit Lwt.t + + val create_one_commit_store : + domain_mgr:_ Eio.Domain_manager.t -> + repo -> + commit_key -> + Eio.Fs.dir_ty Eio.Path.t -> + unit Lwt.t + + module Gc : sig + type process_state = S.Gc.process_state + type msg = S.Gc.msg + + val start_exn : + domain_mgr:_ Eio.Domain_manager.t -> + ?unlink:bool -> + repo -> + commit_key -> + bool Lwt.t + + val finalise_exn : ?wait:bool -> repo -> process_state Lwt.t + + val run : + domain_mgr:_ Eio.Domain_manager.t -> + ?finished: + ((Irmin_pack_io.Stats.Latest_gc.stats, msg) result -> unit Lwt.t) -> + repo -> + commit_key -> + (bool, msg) result Lwt.t + + val wait : + repo -> (Irmin_pack_io.Stats.Latest_gc.stats option, msg) result Lwt.t + + val cancel : repo -> bool Lwt.t + val is_finished : repo -> bool + val behaviour : repo -> [ `Archive | `Delete ] + val is_allowed : repo -> bool + val latest_gc_target : repo -> commit_key option + end + + module Snapshot : sig + include module type of S.Snapshot + + val export : + ?on_disk:[ `Path of Eio.Fs.dir_ty Eio.Path.t ] -> + repo -> + (t -> unit) -> + root_key:Tree.kinded_key -> + int Lwt.t + end + end +end + +(** {1 Native Synchronisation} + + Lwt wrappers for [Irmin.Sync]. Mirrors the Irmin 3 API exactly. *) +module Sync : sig + module type S = sig + type db + type commit + type status = [ `Empty | `Head of commit ] + type info + + val status_t : db -> status Irmin.Type.t + val pp_status : status Fmt.t + + val fetch : + db -> + ?depth:int -> + Irmin.remote -> + (status, [ `Msg of string ]) result Lwt.t + + val fetch_exn : db -> ?depth:int -> Irmin.remote -> status Lwt.t + + type pull_error = [ `Msg of string | Irmin.Merge.conflict ] + + val pp_pull_error : pull_error Fmt.t + + val pull : + db -> + ?depth:int -> + Irmin.remote -> + [ `Merge of unit -> info | `Set ] -> + (status, pull_error) result Lwt.t + + val pull_exn : + db -> + ?depth:int -> + Irmin.remote -> + [ `Merge of unit -> info | `Set ] -> + status Lwt.t + + type push_error = [ `Msg of string | `Detached_head ] + + val pp_push_error : push_error Fmt.t + + val push : + db -> ?depth:int -> Irmin.remote -> (status, push_error) result Lwt.t + + val push_exn : db -> ?depth:int -> Irmin.remote -> status Lwt.t + end + + module Make (X : Irmin.Generic_key.S) : + S with type db = X.t and type commit = X.commit and type info = X.info +end + +val remote_store : + (module Irmin.Generic_key.S with type t = 'a) -> 'a -> Irmin.remote +(** [remote_store t] is the remote corresponding to the local store [t]. + Forwarding from [Irmin.remote_store]; pure (no Lwt). *) + +(** {1 JSON-as-tree projections} + + Lwt wrapper for [Irmin.Json_tree]. Extracts and projects JSON values onto a + tree or store at a given path. *) +module Json_tree : functor + (Store : Irmin.S with type Schema.Contents.t = Irmin.Contents.json) + -> sig + include Irmin.Contents.S with type t = Irmin.Contents.json + + val to_concrete_tree : t -> Store.Tree.concrete + val of_concrete_tree : Store.Tree.concrete -> t + val get_tree : Store.tree -> Store.path -> t Lwt.t + val set_tree : Store.tree -> Store.path -> t -> Store.tree Lwt.t + val get : Store.t -> Store.path -> t Lwt.t + + val set : + Store.t -> Store.path -> t -> info:(unit -> Store.info) -> unit Lwt.t +end + +(** {1 Graphviz output} + + Lwt wrapper for [Irmin.Dot]. *) +module Dot : functor (S : Irmin.Generic_key.S) -> sig + type db = S.t + + val output_buffer : + db -> + ?html:bool -> + ?depth:int -> + ?full:bool -> + date:(int64 -> string) -> + Buffer.t -> + unit Lwt.t +end diff --git a/test/irmin-lwt/dune b/test/irmin-lwt/dune new file mode 100644 index 0000000000..6b05b4dd79 --- /dev/null +++ b/test/irmin-lwt/dune @@ -0,0 +1,4 @@ +(test + (name test) + (package irmin-lwt) + (libraries alcotest alcotest-lwt irmin irmin.mem irmin-lwt)) diff --git a/test/irmin-lwt/test.ml b/test/irmin-lwt/test.ml new file mode 100644 index 0000000000..e1e09803e5 --- /dev/null +++ b/test/irmin-lwt/test.ml @@ -0,0 +1,251 @@ +(* Level-1 smoke test for irmin-lwt: exercise the minimal Repo/Store + lifecycle through the Lwt-wrapped API against the in-memory backend. *) + +module Backend = Irmin_mem.KV.Make (Irmin.Contents.String) +module Store = Irmin_lwt.Make (Backend) + +let info message () = Backend.Info.v ~author:"irmin-lwt-test" ~message 0L +let contents = Alcotest.option Alcotest.string + +let test_set_then_find _switch () = + let open Lwt.Syntax in + let* repo = Store.Repo.v (Irmin_mem.config ()) in + let* t = Store.main repo in + let* () = Store.set_exn t ~info:(info "set foo") [ "foo" ] "bar" in + let* v = Store.find t [ "foo" ] in + Alcotest.check contents "foo -> bar" (Some "bar") v; + let* () = Store.Repo.close repo in + Lwt.return_unit + +let test_remove _switch () = + let open Lwt.Syntax in + let* repo = Store.Repo.v (Irmin_mem.config ()) in + let* t = Store.main repo in + let* () = Store.set_exn t ~info:(info "set foo") [ "foo" ] "bar" in + let* () = Store.remove_exn t ~info:(info "remove foo") [ "foo" ] in + let* v = Store.find t [ "foo" ] in + Alcotest.check contents "foo is gone" None v; + let* () = Store.Repo.close repo in + Lwt.return_unit + +let test_missing_path _switch () = + let open Lwt.Syntax in + let* repo = Store.Repo.v (Irmin_mem.config ()) in + let* t = Store.main repo in + let* v = Store.find t [ "unset" ] in + Alcotest.check contents "missing path" None v; + let* () = Store.Repo.close repo in + Lwt.return_unit + +(* Level-2: a realistic workflow test that exercises branching, merging, + and history introspection — the idioms a typical Irmin 3 consumer + (e.g. Tezos' context) relies on — through the Lwt-wrapped API. *) + +let test_branch_merge_workflow _switch () = + let open Lwt.Syntax in + let* repo = Store.Repo.v (Irmin_mem.config ()) in + let* main = Store.main repo in + (* Seed the main branch. *) + let* () = Store.set_exn main ~info:(info "seed a") [ "a" ] "1" in + let* () = Store.set_exn main ~info:(info "seed b") [ "b" ] "2" in + (* Fork a feature branch from main and add a third entry. *) + let* () = + Store.set_exn main ~info:(info "fork point") [ "feature-flag" ] "yes" + in + let* feature = Store.of_branch repo "feature" in + let* () = Store.set_exn feature ~info:(info "feature: add c") [ "c" ] "3" in + (* Merge the feature branch back into main. *) + let* result = + Store.merge_into ~into:main ~info:(info "merge feature") feature + in + Alcotest.check + (Alcotest.result Alcotest.unit Alcotest.reject) + "merge succeeds" (Ok ()) result; + (* Main should now see all three entries. *) + let* a = Store.find main [ "a" ] in + let* b = Store.find main [ "b" ] in + let* c = Store.find main [ "c" ] in + Alcotest.check contents "a survived" (Some "1") a; + Alcotest.check contents "b survived" (Some "2") b; + Alcotest.check contents "c merged in" (Some "3") c; + (* [last_modified c] should return at least one commit (the one adding c). *) + let* history = Store.last_modified main [ "c" ] in + Alcotest.(check bool) "c has history" true (history <> []); + let* () = Store.Repo.close repo in + Lwt.return_unit + +(* Level-3: interactions between the Lwt monad and the lwt_eio bridge. + These are the subtle cases that can break real applications if the + wrapper does not forward Lwt's scheduling semantics correctly. *) + +let test_exception_caught_by_lwt _switch () = + (* [Store.get] raises [Invalid_argument] on a missing path. The + exception must propagate as a failed Lwt promise so that [Lwt.catch] + can handle it. *) + let open Lwt.Syntax in + let* repo = Store.Repo.v (Irmin_mem.config ()) in + let* t = Store.main repo in + let* caught = + Lwt.catch + (fun () -> + let* _ = Store.get t [ "nope" ] in + Lwt.return_false) + (fun _exn -> Lwt.return_true) + in + Alcotest.(check bool) "Lwt.catch caught the exception" true caught; + let* () = Store.Repo.close repo in + Lwt.return_unit + +let test_pause_interleaved _switch () = + (* [Lwt.pause] between two irmin-lwt calls must not break anything: the + scheduler ceding control and resuming should leave the store in the + expected state. *) + let open Lwt.Syntax in + let* repo = Store.Repo.v (Irmin_mem.config ()) in + let* t = Store.main repo in + let* () = Store.set_exn t ~info:(info "a") [ "x" ] "first" in + let* () = Lwt.pause () in + let* () = Store.set_exn t ~info:(info "b") [ "x" ] "second" in + let* v = Store.find t [ "x" ] in + Alcotest.check contents "last write wins" (Some "second") v; + let* () = Store.Repo.close repo in + Lwt.return_unit + +let test_many_concurrent_reads _switch () = + (* Dispatch several reads in parallel via [Lwt.all] and check they all + complete with the expected value. This exercises the lwt_eio bridge + under concurrent pressure from the Lwt side. *) + let open Lwt.Syntax in + let* repo = Store.Repo.v (Irmin_mem.config ()) in + let* t = Store.main repo in + let* () = Store.set_exn t ~info:(info "seed") [ "k" ] "v" in + let n = 50 in + let* results = Lwt.all (List.init n (fun _ -> Store.find t [ "k" ])) in + Alcotest.(check int) "all reads completed" n (List.length results); + Alcotest.(check bool) + "all reads returned the same value" true + (List.for_all (( = ) (Some "v")) results); + let* () = Store.Repo.close repo in + Lwt.return_unit + +(* Submodule tests: exercise the Tree, Commit, Branch and Head wrappers + that the MVP did not cover. These are the submodules a typical Irmin 3 + consumer (e.g. Tezos' context) uses heavily. *) + +let test_tree_build_and_read _switch () = + let open Lwt.Syntax in + let empty = Store.Tree.empty () in + let* tree = Store.Tree.add empty [ "a" ] "1" in + let* tree = Store.Tree.add tree [ "b"; "c" ] "2" in + let* v1 = Store.Tree.find tree [ "a" ] in + let* v2 = Store.Tree.find tree [ "b"; "c" ] in + let* missing = Store.Tree.find tree [ "nope" ] in + Alcotest.check contents "tree a" (Some "1") v1; + Alcotest.check contents "tree b/c" (Some "2") v2; + Alcotest.check contents "tree missing" None missing; + Alcotest.(check bool) "non-empty" false (Store.Tree.is_empty tree); + Lwt.return_unit + +let test_tree_fold _switch () = + (* Traverse a small tree with a Lwt-returning contents folder and + collect the encountered contents into a list. *) + let open Lwt.Syntax in + let empty = Store.Tree.empty () in + let* tree = Store.Tree.add empty [ "a" ] "1" in + let* tree = Store.Tree.add tree [ "b" ] "2" in + let* tree = Store.Tree.add tree [ "c" ] "3" in + let collect _path c acc = Lwt.return (c :: acc) in + let* seen = Store.Tree.fold ~contents:collect tree [] in + let sorted = List.sort compare seen in + Alcotest.(check (list string)) + "fold collected all contents" [ "1"; "2"; "3" ] sorted; + Lwt.return_unit + +let hash_to_string h = Irmin.Type.to_string Backend.Hash.t h + +let test_commit_and_branch _switch () = + (* Build a tree, commit it explicitly through [Commit.v], set a branch + to it through [Branch.set], then read it back via [Branch.find]. *) + let open Lwt.Syntax in + let* repo = Store.Repo.v (Irmin_mem.config ()) in + let tree = Store.Tree.empty () in + let* tree = Store.Tree.add tree [ "k" ] "v" in + let* c = + Store.Commit.v repo ~info:(info "explicit commit" ()) ~parents:[] tree + in + let* () = Store.Branch.set repo "topic" c in + let* c' = Store.Branch.find repo "topic" in + let* () = + match c' with + | None -> Alcotest.fail "branch lookup returned None" + | Some c' -> + Alcotest.(check string) + "same commit hash" + (hash_to_string (Store.Commit.hash c)) + (hash_to_string (Store.Commit.hash c')); + Lwt.return_unit + in + let* () = Store.Repo.close repo in + Lwt.return_unit + +let test_head_follows_writes _switch () = + (* After a write, [Head.find] should see a commit, and the returned + commit's tree should contain the new entry. Use a unique branch + name so other tests don't pollute the in-memory backend's shared + state. *) + let open Lwt.Syntax in + let* repo = Store.Repo.v (Irmin_mem.config ()) in + let* t = Store.of_branch repo "head-follows-writes" in + let* head0 = Store.Head.find t in + Alcotest.(check bool) "empty head initially" true (Option.is_none head0); + let* () = Store.set_exn t ~info:(info "create head") [ "k" ] "v" in + let* head1 = Store.Head.find t in + let* () = + match head1 with + | None -> Alcotest.fail "expected a head after a write" + | Some c -> + let* v = Store.Tree.find (Store.Commit.tree c) [ "k" ] in + Alcotest.check contents "head tree contains write" (Some "v") v; + Lwt.return_unit + in + let* () = Store.Repo.close repo in + Lwt.return_unit + +let () = + Irmin_lwt.run @@ fun () -> + Alcotest_lwt.run "irmin-lwt" + [ + ( "smoke", + [ + Alcotest_lwt.test_case "set then find" `Quick test_set_then_find; + Alcotest_lwt.test_case "remove" `Quick test_remove; + Alcotest_lwt.test_case "missing path" `Quick test_missing_path; + ] ); + ( "workflow", + [ + Alcotest_lwt.test_case "branch + merge + history" `Quick + test_branch_merge_workflow; + ] ); + ( "lwt-interaction", + [ + Alcotest_lwt.test_case "Lwt.catch catches an Irmin exception" `Quick + test_exception_caught_by_lwt; + Alcotest_lwt.test_case "Lwt.pause interleaves with Irmin ops" `Quick + test_pause_interleaved; + Alcotest_lwt.test_case "many concurrent reads via Lwt.all" `Quick + test_many_concurrent_reads; + ] ); + ( "tree", + [ + Alcotest_lwt.test_case "build and read" `Quick + test_tree_build_and_read; + Alcotest_lwt.test_case "fold with Lwt callback" `Quick test_tree_fold; + ] ); + ( "commit-branch-head", + [ + Alcotest_lwt.test_case "commit + branch round-trip" `Quick + test_commit_and_branch; + Alcotest_lwt.test_case "head follows writes" `Quick + test_head_follows_writes; + ] ); + ]