diff --git a/CHANGES.md b/CHANGES.md index 12ef65e30d..d4776f1ed0 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,12 @@ ## 4.0.0 +### Added + +- **irmin-lwt** + - New compatibility package exposing the Irmin 3 (Lwt) public API on top + of Irmin 4 (Eio), running operations through `Lwt_eio`. Lets consumers + of Irmin 3 upgrade to Irmin 4 without changing their application code. + ### Changed - Convert to direct-style with Eio (#2149, @patricoferris, @ElectreAAS, @clecat, @art-w) diff --git a/doc/irmin-lwt/dune b/doc/irmin-lwt/dune new file mode 100644 index 0000000000..fc3578dbb4 --- /dev/null +++ b/doc/irmin-lwt/dune @@ -0,0 +1,3 @@ +(documentation + (package irmin-lwt) + (mld_files index migration)) diff --git a/doc/irmin-lwt/index.mld b/doc/irmin-lwt/index.mld new file mode 100644 index 0000000000..9030135bc6 --- /dev/null +++ b/doc/irmin-lwt/index.mld @@ -0,0 +1,242 @@ +{0 [irmin-lwt]} + +The [irmin-lwt] package family provides a {b Lwt-flavoured API} on top +of Irmin 4. It is intended for applications that have not migrated from +[Lwt] to [Eio] but want to use the latest Irmin release. + +{e Release %%VERSION%% - %%HOMEPAGE%%} + +{1:big_warning Important: the main loop must be Eio} + +{b This is the central limitation of [irmin-lwt]. Read this before +adopting it.} + +[irmin-lwt] is not a self-contained Lwt library. Internally every +operation is a thin Lwt wrapper around Irmin 4's direct-style Eio +implementation, bridged through {{:https://github.com/ocaml-multicore/lwt_eio} +[lwt_eio]}. To use [irmin-lwt] you {b must run your program inside +[Eio_main.run]} and start a [lwt_eio] event loop: + +{[ +let () = + Eio_main.run @@ fun env -> + Eio.Switch.run @@ fun sw -> + Irmin.Backend.Watch.set_watch_switch sw; + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> + Lwt_main.run @@ fun () -> + (* your Lwt application code, freely calling Irmin_lwt.* APIs *) + ... +]} + +The structure is fixed: + +- {b [Eio_main.run]} is the outermost call. This sets up the Eio + scheduler. +- {b [Eio.Switch.run]} provides a switch needed by the Watch + infrastructure (see below). +- {b [Lwt_eio.with_event_loop]} runs a Lwt event loop {e inside} the + Eio scheduler, so Lwt promises and Eio fibers can interleave. +- {b [Lwt_main.run]} (or any normal Lwt entry point) starts your + application. + +You {b cannot} call [Irmin_lwt.*] from a program whose main loop is +plain [Lwt_main.run] without an enclosing Eio scheduler. There is no +way around it: every effectful Irmin operation eventually performs an +[Eio.*] call, and [Eio.*] requires an active scheduler. + +If your application cannot be restructured this way (for instance +because a host framework such as Cohttp or Mirage controls the main +loop, and that framework has not been adapted to Eio yet), [irmin-lwt] +is not the right tool. Stay on [Irmin 3] for now or migrate to [Eio] +end-to-end. + +{2 Why this constraint?} + +Irmin 4's body is direct-style: store reads, writes, GC, sync, watches +all use Eio primitives (mutexes, fibers, switches, IO). [irmin-lwt] +wraps the {e API} with [Lwt.t] return types, but the underlying calls +still need a running Eio scheduler. [lwt_eio] provides the bridge: +[Lwt_eio.run_eio] turns an Eio direct call into a [Lwt.t]; conversely +[Lwt_eio.Promise.await_lwt] turns a Lwt promise into a direct Eio +result. Both require a [Lwt_eio.with_event_loop] block to be active. + +The watch infrastructure has an additional requirement: [Irmin.Backend. +Watch.set_watch_switch] {b must} be called once with a live Eio switch +before any watch operation. If your application uses watches, do this +right after [Eio.Switch.run] and before [Lwt_eio.with_event_loop]. If +you forget, the first watch operation raises [Failure "Big Yikes"] +(yes, really -- it is a known upstream wart). + +{1 Packages} + +The package family lives under [src/irmin-lwt/]. Each backend is a +separate opam package; depend on the ones you need. + +{2 Core: [irmin-lwt]} + +The base shim. Exposes {!module:Irmin_lwt} as a Lwt-flavoured +re-export of the [Irmin] API: same module structure, same entry points +([Maker], [KV_maker], [Generic_key.S], [Schema], [Contents], [Hash], +etc.), but every effectful operation returns a [Lwt.t]. + +{[ +val Irmin_lwt.Repo.v : config -> Irmin_lwt.repo Lwt.t +val Irmin_lwt.set_exn : t -> path -> contents -> info:Info.f -> unit Lwt.t +(* etc. *) +]} + +{2 In-memory: [irmin-lwt-mem]} + +A Lwt-flavoured shim over Irmin 4's in-memory backend. The module +{!module:Irmin_lwt_mem} provides [Maker], [KV], and [config]: + +{[ +module S = Irmin_lwt_mem.KV.Make (Irmin_lwt.Contents.String) +let* repo = S.Repo.v (Irmin_lwt_mem.config ()) in +let* t = S.main repo in +let* () = S.set_exn t [ "k" ] "v" ~info:(fun () -> ...) in +... +]} + +{2 On-disk: [irmin-lwt-fs]} + +A Lwt shim over [irmin-fs.unix]. Stores trees and commits as ordinary +files in a directory. + +{[ +let config = + Irmin_lwt_fs.config + ~root:Eio.Path.(env#fs / "_build" / "data") + ~clock:env#clock +in +module S = Irmin_lwt_fs.KV.Make (Irmin_lwt.Contents.String) +let* repo = S.Repo.v config in +... +]} + +Note that the configuration takes Eio types ([Eio.Path.t], +[Eio.Time.clock]) directly. This is unavoidable -- the shim does not +hide Eio entirely. You obtain them from your [Eio_main.run] runner +(typically [Eio.Stdenv.fs env] and [env#clock]). + +{2 Pack: [irmin-lwt-pack]} + +A Lwt shim over [irmin-pack-unix], the high-performance on-disk +backend. Exposes the full surface: standard [Store.S] operations plus +[integrity_check], [Gc.run], [Snapshot.export], [stats], etc., all +[Lwt.t]-typed. + +{[ +module Conf = struct + let entries = 32 + let stable_hash = 256 + let contents_length_header = Some `Varint + let inode_child_order = `Seeded_hash + let forbid_empty_dir_persistence = true +end + +module Maker = Irmin_lwt_pack.Maker (Conf) +module S = Maker.Make (Irmin_lwt.Schema.KV (Irmin_lwt.Contents.String)) +]} + +{2 Chunk: [irmin-lwt-chunk]} + +A meta-backend that takes a Lwt-typed [Append_only.Maker] and produces +a Lwt-typed [Content_addressable.Maker] storing values cut into +fixed-size chunks. Useful for very large blobs. + +{[ +module CA = Irmin_lwt_chunk.Content_addressable (Irmin_lwt_mem.Append_only) +module S = + Irmin_lwt.KV_maker (CA) (Irmin_lwt_mem.Atomic_write).Make + (Irmin_lwt.Contents.String) +]} + +{2 Mergeable data structures: [irmin-lwt-containers]} + +Counter, Lww_register, Blob_log -- ready-to-use Lwt-typed CRDT-like +data structures, parameterised over an [Irmin_lwt.KV_maker]. Linked_log +is not yet ported. + +{[ +module C = Irmin_lwt_containers.Counter.Mem +let* repo = C.Store.Repo.v (Irmin_lwt_mem.config ()) in +let* t = C.Store.main repo in +let* () = C.inc ~by:5L ~path:[ "n" ] t in +let* v = C.read ~path:[ "n" ] t in (* v = 5L *) +]} + +{2 Git: [irmin-lwt-git]} + +A Lwt shim over [irmin-git.unix]. Provides [Mem] and [FS] backends +with [KV] / [Ref] convenience instantiations. Bidirectional +compatibility with on-disk Git repositories is preserved. + +{[ +module S = Irmin_lwt_git.Mem.KV (Irmin_lwt.Contents.String) +let* repo = S.Repo.v (Irmin_lwt_git.config "/some/path") in +... +let* git_commit_obj = S.git_commit repo head in +]} + +{2 Tezos: [irmin-lwt-tezos]} + +A Lwt shim providing the Tezos-specific Irmin schema (BLAKE2B+Base58 +hash, V1 pre-hashing for Node / Commit / Contents) on top of +[irmin-pack-unix]. {b On-disk data is wire-compatible with regular +[irmin-tezos] data.} + +{[ +let* repo = + Irmin_lwt_tezos.Repo.v + (Irmin_pack.Conf.init ~sw ~fs ~fresh:true Eio.Path.(fs / "tezos-data")) +in +... +]} + +{2 RPC client: [irmin-lwt-client]} + +A Lwt shim over [irmin-client.unix]. Connects to a running +[irmin-server] over TCP/TLS/Unix-socket/WebSocket and exposes a +Lwt-typed Store API. Useful when an Lwt application (e.g. an Ocsigen +service) needs to access an Irmin repository hosted on another +process. + +{[ +module Client = Irmin_lwt_client.Make (Irmin_lwt.Contents.String) +let* repo = Client.connect (Uri.of_string "tcp://localhost:9181") in +let* t = Client.main repo in +let* () = Client.set_exn t [ "k" ] "v" ~info:(fun () -> ...) in +... +]} + +{1 What is {b not} supported} + +[irmin-lwt] does not cover the full Irmin sister-package family. See +[src/irmin-lwt/LIMITATIONS.md] in the source tree for the canonical +list, but the headline items are: + +- {b [Of_backend]}: not exposed. Routing a hand-rolled Lwt-typed + [Backend.S] through Irmin 4 would force a per-operation + Lwt → Eio → Lwt round-trip and add ~400 lines of glue code for no + user we know of. Backend authors who need this entry point can + build their backend against [Irmin]'s direct-style [Backend.S] and + re-wrap with [Irmin_lwt.Wrap_store.Make]. +- {b [Generic_key.Maker] (functor)}: same rationale as [Of_backend]. + The {e module type} is exposed (so backends like [irmin-lwt-pack] + can declare their public signature against it); only the functor + implementation is gone. +- {b [irmin-graphql]}: the upstream package is already Lwt-typed and + bridges to an Eio store internally. A [irmin-lwt-graphql] would + duplicate the bridging. +- {b [irmin-mirage-git]}: the upstream package is {e already} + Lwt-typed in its public API ([Mirage_kv.RO] / [Mirage_kv.RW] are + Lwt). Lwt users should use it directly -- no shim needed. +- {b [irmin-cli]}: a binary, not a library. +- {b [irmin-server]}: standalone. Lwt apps consume it via + [irmin-lwt-client]; there is no need for a Lwt-typed server. + +{1 Migration guide} + +For applications moving from Irmin 3 (Lwt) to Irmin 4 via this shim, +see {{!page-migration} the migration guide}. diff --git a/doc/irmin-lwt/migration.mld b/doc/irmin-lwt/migration.mld new file mode 100644 index 0000000000..7998a9981b --- /dev/null +++ b/doc/irmin-lwt/migration.mld @@ -0,0 +1,251 @@ +{0 Migrating from Irmin 3 to Irmin 4 via [irmin-lwt]} + +This guide is for applications currently using {b Irmin 3} (the +Lwt-flavoured release on the [main] branch, latest [3.11.x]) that want +to upgrade to {b Irmin 4} {e without} migrating their own code to +[Eio]. The [irmin-lwt] package family is the bridge. + +{1 Prerequisites} + +{b Read the {{!page-index.big_warning} top-level warning} first.} You +{b must} restructure your application's main loop to be Eio-based, +even though your business logic stays in Lwt. There is no escape: the +Eio scheduler is required for [irmin-lwt] to function. + +If your main loop is controlled by a framework that has not been +ported to Eio yet (some web servers, some Mirage-based applications, +older Lwt scripts using [Lwt_main.run] without an Eio host), you +cannot use [irmin-lwt] today. Either stay on Irmin 3 or migrate the +host loop first. + +{1 Step 1 — restructure the main loop} + +Replace your top-level + +{[ +let () = Lwt_main.run (main ()) +]} + +with the standard [Eio_main.run] / [Lwt_eio.with_event_loop] / +[Lwt_main.run] sandwich: + +{[ +let () = + Eio_main.run @@ fun env -> + Eio.Switch.run @@ fun sw -> + Irmin.Backend.Watch.set_watch_switch sw; + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> + Lwt_main.run (main ()) +]} + +If your application uses framework-provided runners (cohttp-lwt-unix, +ocsigenserver, etc.) you typically wrap them too: + +{[ +let () = + Eio_main.run @@ fun env -> + Eio.Switch.run @@ fun sw -> + Irmin.Backend.Watch.set_watch_switch sw; + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> + Lwt_main.run @@ fun () -> + Cohttp_lwt_unix.Server.create ~mode:(`TCP (`Port 8080)) my_server +]} + +The [Eio.Stdenv.fs env] capability and [env#clock] are propagated +through closures to wherever you need them (typically when constructing +an [Irmin_lwt_fs] / [Irmin_lwt_pack] config). + +{1 Step 2 — change opam dependencies} + +In your [.opam] file (or [dune-project]'s [generate_opam_files]): + +{v +- "irmin" {>= "3.0" & < "4.0"} +- "irmin-pack" {>= "3.0" & < "4.0"} ++ "irmin-lwt" {>= "4.0"} ++ "irmin-lwt-pack" {>= "4.0"} ++ "lwt_eio" {>= "0.5.1"} ++ "eio_main" {>= "1.0"} +v} + +Replace each [irmin-X] dependency with its [irmin-lwt-X] counterpart +where one exists (see {{!page-index} the package overview}). For +[irmin-graphql] and [irmin-mirage-git], no shim is needed -- their +upstream versions are already Lwt-typed. + +{1 Step 3 — change module references} + +Replace [Irmin] with [Irmin_lwt] in your code: + +{[ +- module S = Irmin_mem.KV.Make (Irmin.Contents.String) ++ module S = Irmin_lwt_mem.KV.Make (Irmin_lwt.Contents.String) +]} + +Both module hierarchies have {b the same shape}: same module names, +same operation names, same record fields. The only differences are: + +- Effectful operations return [Lwt.t] in [irmin-lwt], same as + Irmin 3. (Irmin 4 native is direct-style.) +- A few configurations require Eio types directly ([Eio.Path.t], + [Eio.Time.clock], [Eio.Domain_manager.t]). These appear in + [Irmin_lwt_fs.config] and the advanced [Irmin_lwt_pack] surface + (GC, snapshots). + +In most cases your existing code compiles unchanged after the +[Irmin → Irmin_lwt] rename. + +{1 Step 4 — adjust configurations that take Eio types} + +Three places in [irmin-lwt] expose Eio types directly. Each needs a +small change in your config-building code. + +{2 [irmin-lwt-fs]} + +Irmin 3: + +{[ +let config = Irmin_fs.config "/path/to/store" +]} + +Irmin 4 via [irmin-lwt]: + +{[ +let config = + Irmin_lwt_fs.config + ~root:Eio.Path.(env#fs / "path" / "to" / "store") + ~clock:env#clock +]} + +You need access to [env]; pass it through your closures from +[Eio_main.run]. + +{2 [irmin-lwt-pack]} + +Irmin 3: + +{[ +let config = Irmin_pack.config ~fresh:true "/path/to/pack" +]} + +Irmin 4 via [irmin-lwt]: + +{[ +let config = + Irmin_pack.Conf.init ~sw ~fs ~fresh:true Eio.Path.(fs / path) +]} + +(Where [sw] is from [Eio.Switch.run] and [fs] is [Eio.Stdenv.fs env].) + +{2 [irmin-lwt-pack] advanced surface} + +Operations that explicitly take Eio capabilities: + +{[ +val Gc.start_exn : + domain_mgr:_ Eio.Domain_manager.t -> ... +val Gc.run : + domain_mgr:_ Eio.Domain_manager.t -> ... +val create_one_commit_store : + domain_mgr:_ Eio.Domain_manager.t -> + ... -> + Eio.Fs.dir_ty Eio.Path.t -> ... +]} + +Pass [Eio.Stdenv.domain_mgr env] and [Eio.Path.t] values through. + +{1 Step 5 — wire up the watch switch (only if you use watches)} + +If your application uses [Store.Watch.*] / [Store.Branch.watch], you +must call [Irmin.Backend.Watch.set_watch_switch] {b once} before any +watch operation: + +{[ +let () = + Eio_main.run @@ fun env -> + Eio.Switch.run @@ fun sw -> + Irmin.Backend.Watch.set_watch_switch sw; + (* ... rest of the runner ... *) +]} + +This is an upstream wart in Irmin 4 (the comment in [src/irmin/watch.ml] +literally reads "a terrible hack that will need fixed"). Until it is +fixed upstream, you set the switch yourself. Forgetting it produces a +[Failure "Big Yikes"] at the first watch. + +{1 Step 6 — replace dropped entry points} + +A few Irmin entry points have been intentionally not forwarded by +[irmin-lwt] (see {{!page-index} package overview} for rationale). If +you used them, here are the workarounds: + +{2 [Irmin.Of_backend]} + +If you had a hand-rolled [Backend.S] in Lwt: + +{[ +module M = Irmin.Of_backend (My_backend) +]} + +Choices: + ++ Port [My_backend] to Irmin 4's direct-style [Backend.S] (Eio-typed) + and apply [Irmin.Of_backend] there, then re-wrap to Lwt: +{[ +module M_eio = Irmin.Of_backend (My_backend_eio) +include Irmin_lwt.Wrap_store.Make + (My_lwt_schema) (My_eio_schema) (M_eio) +]} ++ Use a higher-level entry point ([Maker], [Generic_key.Maker], or + [Storage.Make]) if your backend can be expressed in those terms. + +{2 [Generic_key.Maker (X)] functor} + +Same options as above. The {e signature} [Generic_key.Maker] stays +exposed; backends like [Irmin_lwt_pack.Maker] satisfy it directly via +[Wrap_store.Make] without instantiating the [Generic_key.Maker] +functor. Mirror that pattern for your own keyed backend. + +{1 Step 7 — verify with the test harness} + +[irmin-lwt-test] (under [src/irmin-lwt/test]) is a port of [irmin-test] +patched to consume Lwt-typed stores. Application code that built test +suites on top of [Irmin_test.Suite.create] can usually keep them +unchanged after replacing [Irmin_test] with [Irmin_lwt_test.Irmin_test]. +The [test/irmin-lwt-mem/test.ml] file in this repository shows the +expected runner setup. + +{1 Performance and runtime cost} + +Each effectful Irmin call now goes through [Lwt_eio.run_eio] (Lwt → +Eio → Lwt). The bridge is cheap (one event-loop hop) but {e not free}. +For most applications it is invisible. For high-throughput inner loops +(e.g. millions of [find] calls per second), benchmark before and +after. + +The watch infrastructure pays an extra cost: each event is dispatched +on a fiber forked from the Eio switch you supplied to +[set_watch_switch]. If you have many watchers and high throughput, +expect noticeable overhead compared to plain Lwt watches in Irmin 3. + +{1 Common pitfalls} + +- {b Forgetting [Lwt_eio.with_event_loop]}: [Irmin_lwt] calls compile + but raise at runtime ("Eio: no scheduler running"). The error is + unmistakable; check your runner. +- {b Forgetting [set_watch_switch]}: see step 5. +- {b Mixing Lwt-typed and Eio-typed Irmin stores in the same + application}: technically possible, but they are separate [Repo.t] + values backed by separate state -- they do not see each other's + writes. Use one or the other for any given store, not both. +- {b Using [irmin-mirage-git] expecting it to be Eio-typed}: it is + still Lwt-typed in Irmin 4 (the [Mirage_kv] interface forces it). + No conversion needed. + +{1 What if you cannot adopt Eio at all?} + +Stay on Irmin 3.11.x. It is the last release of the Lwt-native series +and continues to receive critical fixes. The [irmin-lwt] family is for +applications that {e can} run an Eio scheduler at the top level even +if they prefer to keep their business logic in Lwt; it is not for +applications that must remain entirely Lwt-native. diff --git a/irmin-lwt-chunk.opam b/irmin-lwt-chunk.opam new file mode 100644 index 0000000000..10f8b756d8 --- /dev/null +++ b/irmin-lwt-chunk.opam @@ -0,0 +1,34 @@ +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-chunk" {= version} + "irmin-lwt" {= version} + "lwt" {>= "5.7.0"} + "lwt_eio" {>= "0.5.1"} +] + +synopsis: """ +Chunk meta-backend for irmin-lwt +""" +description: """ +A Lwt-flavoured shim over Irmin 4's irmin-chunk meta-backend. Wraps a +Lwt-typed Append_only.Maker into a Lwt-typed Content_addressable.Maker +that stores values cut into fixed-size chunks. Each operation forwards +to the irmin-chunk implementation through Lwt_eio. +""" +x-maintenance-intent: [ "(latest)" ] diff --git a/irmin-lwt-client.opam b/irmin-lwt-client.opam new file mode 100644 index 0000000000..8375f0ba9b --- /dev/null +++ b/irmin-lwt-client.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-lwt" {= version} + "irmin-client" {= version} + "lwt" {>= "5.7.0"} + "lwt_eio" {>= "0.5.1"} +] + +synopsis: """ +Lwt-flavoured RPC client for irmin-server +""" +description: """ +A Lwt-flavoured shim over Irmin 4's irmin-client. Connects to a remote +irmin-server and exposes a Lwt-typed Irmin store API. Useful for Lwt +applications that need to access an Irmin repository over the network +(typical case: an Ocsigen application talking to a centralised store). +""" +x-maintenance-intent: [ "(latest)" ] diff --git a/irmin-lwt-containers.opam b/irmin-lwt-containers.opam new file mode 100644 index 0000000000..055501700a --- /dev/null +++ b/irmin-lwt-containers.opam @@ -0,0 +1,38 @@ +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-lwt" {= version} + "irmin-lwt-mem" {= version} + "irmin-lwt-fs" {= version} + "lwt" {>= "5.7.0"} + "lwt_eio" {>= "0.5.1"} + "mtime" {>= "2.0.0"} +] + +synopsis: """ +Mergeable data structures for irmin-lwt +""" +description: """ +Lwt-flavoured port of the irmin-containers data structures (Counter, +Lww_register, Blob_log) on top of irmin-lwt. The merge logic is reused +from Irmin (Eio) by bridging through Lwt_eio. Linked_log is not yet +supported (its merge requires a Lwt-typed CAS handle that has not been +wired through the shim). +""" +x-maintenance-intent: [ "(latest)" ] diff --git a/irmin-lwt-fs.opam b/irmin-lwt-fs.opam new file mode 100644 index 0000000000..cd2643d83a --- /dev/null +++ b/irmin-lwt-fs.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-fs" {= version} + "irmin-lwt" {= version} + "lwt" {>= "5.7.0"} + "lwt_eio" {>= "0.5.1"} + "eio" {>= "1.0"} +] + +synopsis: """ +On-disk filesystem backend for irmin-lwt +""" +description: """ +A Lwt-flavoured shim over Irmin 4's irmin-fs backend (Unix +implementation). Each Lwt-typed operation forwards to its Irmin 4 +counterpart through Lwt_eio. Exposes a Maker / KV interface compatible +with Irmin 3's API for downstream consumers. +""" +x-maintenance-intent: [ "(latest)" ] diff --git a/irmin-lwt-git.opam b/irmin-lwt-git.opam new file mode 100644 index 0000000000..7c302ed895 --- /dev/null +++ b/irmin-lwt-git.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-git" {= version} + "irmin-lwt" {= version} + "lwt" {>= "5.7.0"} + "lwt_eio" {>= "0.5.1"} +] + +synopsis: """ +Lwt-flavoured Git backend for irmin-lwt +""" +description: """ +A Lwt-flavoured shim over Irmin 4's irmin-git backend (Unix +implementation). Exposes [Mem] and [FS] backends with [KV] / [Ref] +convenience instantiations producing Lwt-typed Irmin stores. Useful for +applications that want bi-directional Git compatibility while staying +on a Lwt scheduler. +""" +x-maintenance-intent: [ "(latest)" ] diff --git a/irmin-lwt-mem.opam b/irmin-lwt-mem.opam new file mode 100644 index 0000000000..09f0fb492a --- /dev/null +++ b/irmin-lwt-mem.opam @@ -0,0 +1,33 @@ +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-lwt" {= version} + "lwt" {>= "5.7.0"} + "lwt_eio" {>= "0.5.1"} +] + +synopsis: """ +In-memory backend for irmin-lwt +""" +description: """ +A thin Lwt-flavoured shim over Irmin 4's in-memory backend +([Irmin_mem]). Each Lwt-typed operation forwards to its Irmin 4 +counterpart through Lwt_eio. +""" +x-maintenance-intent: [ "(latest)" ] diff --git a/irmin-lwt-pack.opam b/irmin-lwt-pack.opam new file mode 100644 index 0000000000..1e34b4c441 --- /dev/null +++ b/irmin-lwt-pack.opam @@ -0,0 +1,34 @@ +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-pack" {= version} + "irmin-lwt" {= version} + "lwt" {>= "5.7.0"} + "lwt_eio" {>= "0.5.1"} +] + +synopsis: """ +On-disk pack backend for irmin-lwt +""" +description: """ +A Lwt-flavoured shim over Irmin 4's irmin-pack backend (Unix +implementation). Each Lwt-typed operation forwards to its Irmin 4 +counterpart through Lwt_eio. Exposes a Maker / KV interface compatible +with Irmin 3's API for downstream consumers (Tezos / Octez). +""" +x-maintenance-intent: [ "(latest)" ] diff --git a/irmin-lwt-test.opam b/irmin-lwt-test.opam new file mode 100644 index 0000000000..0c6d418055 --- /dev/null +++ b/irmin-lwt-test.opam @@ -0,0 +1,37 @@ +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-lwt" {= version} + "alcotest-lwt" {>= "1.8.0"} + "astring" + "fmt" + "jsonm" {>= "1.0.0"} + "logs" {>= "0.5.0"} + "lwt" {>= "5.7.0"} + "mtime" {>= "2.0.0"} +] + +synopsis: """ +Test harness for irmin-lwt +""" +description: """ +Generic test harness from Irmin 3 (Lwt), packaged on top of irmin-lwt +so that backend implementations targeting the irmin-lwt API can run +the same battery of tests. +""" +x-maintenance-intent: [ "(latest)" ] diff --git a/irmin-lwt-tezos.opam b/irmin-lwt-tezos.opam new file mode 100644 index 0000000000..e140821efa --- /dev/null +++ b/irmin-lwt-tezos.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-tezos" {= version} + "irmin-lwt" {= version} + "irmin-lwt-pack" {= version} + "lwt" {>= "5.7.0"} + "lwt_eio" {>= "0.5.1"} +] + +synopsis: """ +Lwt-flavoured Tezos schema and pack store +""" +description: """ +A Lwt shim exposing the Tezos-specific Irmin schema (Hash with +Base58 prefix, V1 pre-hashing for Node / Commit / Contents) on top of +[irmin-pack-unix], with a Lwt-typed Store API. Allows Lwt +applications to read / write Tezos-formatted data on disk. +""" +x-maintenance-intent: [ "(latest)" ] diff --git a/irmin-lwt.opam b/irmin-lwt.opam new file mode 100644 index 0000000000..2f30aa0c79 --- /dev/null +++ b/irmin-lwt.opam @@ -0,0 +1,34 @@ +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} + "lwt" {>= "5.7.0"} + "lwt_eio" {>= "0.5.1"} + "eio" {>= "1.0"} +] + +synopsis: """ +Lwt-flavoured compatibility layer for Irmin 4 (Eio) +""" +description: """ +irmin-lwt is a thin compatibility layer that exposes the Irmin 3 (Lwt) +public API on top of Irmin 4 (direct-style Eio). It allows consumers +that still use Irmin 3 to upgrade to Irmin 4 without changing their +application code, by running Eio operations through Lwt_eio. +""" +x-maintenance-intent: [ "(latest)" ] diff --git a/src/irmin-lwt/LIMITATIONS.md b/src/irmin-lwt/LIMITATIONS.md new file mode 100644 index 0000000000..0b619f0771 --- /dev/null +++ b/src/irmin-lwt/LIMITATIONS.md @@ -0,0 +1,155 @@ +# `irmin-lwt` — what is not supported + +`irmin-lwt` is a shim that exposes Irmin 3's Lwt-flavoured API on top of +Irmin 4's direct-style (Eio) implementation. Most of the public surface +of `Irmin` is preserved, but a few entry points are intentionally not +forwarded. This file is the canonical list. + +## Not exposed + +### `Of_backend` + +`Irmin.Of_backend (B : Backend.S)` lets a user supply a hand-rolled +`Backend.S` (Contents store, Node store, Commit store, Branch store, +Slice, Remote, Repo) and obtain a full Irmin store. + +`irmin-lwt` does **not** expose `Of_backend`. Routing a Lwt-typed +`Backend.S` through Irmin 4 would require an extensive Lwt → Eio adapter +for every sub-store (~400 lines of bridges with per-operation runtime +overhead). No application user of `irmin-lwt` needs this entry point — +in the wider Irmin codebase, only `irmin-git`, `irmin-client`, and +`irmin-pack-mem` use `Of_backend`, none of which are in the `irmin-lwt` +roadmap. + +If you really need to plug a custom backend into the Lwt API: + +- implement your backend against `Irmin`'s direct-style `Backend.S` + (Eio-typed) and apply `Irmin.Of_backend`, then wrap the resulting + `Generic_key.S` back to the Lwt surface using + `Irmin_lwt.Wrap_store.Make`; or +- use the higher-level supported entry points: `Maker` or + `Storage.Make`. + +### `Generic_key.Maker` (the functor) + +`Irmin.Generic_key.Maker (X)` takes four per-store sub-Makers +(`Contents_store`, `Node_store`, `Commit_store`, `Branch_store`) — each +a `Maker` parameterised by hash and value type — and produces a `Maker` +keyed by whatever the user-supplied sub-Makers want. Used by backends +with non-hash keys like `Pack_key.t`. + +`irmin-lwt` exposes the `Generic_key.Maker` **module type** (it is the +public contract that backends like `irmin-lwt-pack` declare against) +but not the **functor**. Routing user-supplied Lwt sub-Makers through +Irmin 4 forces every store operation through a Lwt → Eio → Lwt +round-trip. No application user needs the functor: in the wider Irmin +codebase only two test files invoke it directly, and `irmin-lwt-pack` +satisfies the signature by hand using `Wrap_store.Make`. + +Backend authors with custom keyed Lwt sub-Makers should: + +- implement against `Irmin`'s direct-style `Generic_key.Maker (X)` + (Eio-typed) and lift the result back to the Lwt surface with + `Wrap_store.Make`; or +- follow the `irmin-lwt-pack.Maker` pattern: write a hand-rolled + `Maker` that satisfies `Generic_key.Maker` and delegates to + `Wrap_store.Make` internally. + +### `Store.Make` and `Tree.Make` are gone + +The two implementation functors `Store.Make (B : Backend.S)` and +`Tree.Make (B : Backend.S)` (~4000 lines combined, verbatim from +Irmin 3 / `main`) used to live in `core/store.ml` and `core/tree.ml`. +Both have been deleted: with `Of_backend` and `Generic_key.Maker` +removed, neither functor had any consumer. All Lwt-typed stores now +flow through `Wrap_store.Make`, which delegates the tree machinery to +Irmin 4's `Tree` via `Inner.Tree`. The module **types** `Store.S`, +`Store.KV`, `Store.Maker`, `Store.KV_maker`, `Store.Generic_key.S`, +`Store.Json_tree` and `Tree.S` are still exposed. + +## Caveats / things that work but with constraints + +### `Watch.set_watch_switch` + +Irmin 4's watch infrastructure forks an Eio fiber to dispatch events, +and that fiber needs an Eio switch. `Irmin.Backend.Watch.set_watch_switch` +must be called once before any watch operation. Irmin itself does not +call it automatically (the comment in `watch.ml` reads *"a terrible +hack that will need fixed"*). If you use watches through `irmin-lwt`, +you must call this from your runner: + +```ocaml +Eio_main.run @@ fun env -> +Eio.Switch.run @@ fun sw -> +Irmin.Backend.Watch.set_watch_switch sw; +Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> +… +``` + +### Packages not yet ported to the Lwt shim + +The following Irmin sister packages are not currently shipped as +`irmin-lwt-*` shims. They are all bigger / more specialised than the +core backends and are deferred until a concrete user demands them. +None block application code: users who need them can call the Eio +counterpart directly from a Lwt program via `Lwt_eio.run_eio`, with +the trade-off that the backend store will not be the same `Repo.t` +the rest of the application uses. + +- **`irmin-graphql`** — already Lwt-typed (cohttp-lwt + graphql-lwt) + internally bridged to an Eio store via `Lwt_eio.run_eio`. To wrap + it on a Lwt-typed store would require exposing the underlying Eio + store of each `irmin-lwt-*` backend (the `Inner` parameter of + `Wrap_store.Make`), which the current `.mli` files seal. +- ~~**`irmin-git`**~~ — **shipped** as `irmin-lwt-git` (commit + `4160559c59`). +- **`irmin-mirage`** (core) — single helper module ([Info]); trivial + to port whenever needed. +- **`irmin-mirage-graphql`** — uses cohttp-lwt; would inherit from + whatever shape `irmin-graphql` ends up taking. +- **`irmin-mirage-git`** — interestingly, this is **still Lwt-typed + in its public API** (`connect : ... -> t Lwt.t`, `batch : ... -> + ('a Lwt.t) -> 'a Lwt.t`), because Mirage's `Mirage_kv.RO` / + `Mirage_kv.RW` types are defined in Lwt. Lwt users wanting a Mirage + Git store can use it directly today — no shim needed. +- ~~**`irmin-tezos`**~~ — **shipped** as `irmin-lwt-tezos` (commit + `52fdaf114f`). Note: the Tezos team is *not* on Eio; Tezos uses + `irmin-pack` directly. The Lwt shim preserves the V1 pre-hashing + end-to-end so on-disk data stays wire-compatible with regular + `irmin-tezos` data. +- **`irmin-cli`** — command-line utilities (binary, not a library used + from application code). Lwt vs Eio is irrelevant. +- ~~**`irmin-client`**~~ — **shipped** as `irmin-lwt-client` + (commit `0496a7c609`). The server (`irmin-server`) is standalone + and does not need a Lwt-flavoured shim — Lwt apps use + `irmin-lwt-client` to connect to an Eio server running on the + network. + +If you need any of these on the Lwt API, please open an issue. + +### `irmin-lwt-pack` advanced features + +The pack backend exposes the full `irmin-pack-unix` surface, with each +Eio-direct effectful operation bridged to `Lwt.t` via `Lwt_eio.run_eio`: + +- Integrity checks (`integrity_check`, `integrity_check_inodes`, + `traverse_pack_file`, `test_traverse_pack_file`) +- Chunking / lower layer / on-disk (`split`, `is_split_allowed`, + `add_volume`, `reload`, `flush`, `create_one_commit_store`) +- Statistics (`stats`) +- Garbage collection (`Gc.start_exn`, `finalise_exn`, `run`, `wait`, + `cancel`, `is_finished`, `behaviour`, `is_allowed`, + `latest_gc_target`) +- Snapshots (`Snapshot.export`, `Snapshot.Import.{v,save_elt,close}`) + +A few entry points unavoidably leak Eio types: those that take Eio +capabilities as arguments — `~domain_mgr:_ Eio.Domain_manager.t` (for +`Gc.start_exn`, `Gc.run`, `create_one_commit_store`) and +`Eio.Fs.dir_ty Eio.Path.t` (for `create_one_commit_store`, +`Snapshot.export ?on_disk`, `Snapshot.Import.v ?on_disk`). The shim +does not hide Eio entirely; Lwt callers must obtain these from their +top-level `Eio_main.run` runner (typically +`Eio.Stdenv.domain_mgr env` and `Eio.Stdenv.fs env`). + +The `Internal` sub-module of `Irmin_pack_unix.S` (unstable, used only +for inode tests) is deliberately not forwarded. diff --git a/src/irmin-lwt/chunk/dune b/src/irmin-lwt/chunk/dune new file mode 100644 index 0000000000..bb01f231e8 --- /dev/null +++ b/src/irmin-lwt/chunk/dune @@ -0,0 +1,4 @@ +(library + (name irmin_lwt_chunk) + (public_name irmin-lwt-chunk) + (libraries irmin irmin-chunk irmin-lwt lwt lwt_eio)) diff --git a/src/irmin-lwt/chunk/irmin_lwt_chunk.ml b/src/irmin-lwt/chunk/irmin_lwt_chunk.ml new file mode 100644 index 0000000000..cdf4a4da6e --- /dev/null +++ b/src/irmin-lwt/chunk/irmin_lwt_chunk.ml @@ -0,0 +1,56 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* Lwt-flavoured shim over Irmin 4's irmin-chunk meta-backend. *) + +let run = Lwt_eio.run_eio + +module Conf = Irmin_chunk.Conf + +let config = Irmin_chunk.config + +(* Bridge a Lwt-typed [Irmin_lwt.Append_only.Maker] to its Eio counterpart, + feed it through [Irmin_chunk.Content_addressable] (which produces an Eio + [Irmin.Content_addressable.Maker]), and bridge the result back to a + Lwt-typed [Irmin_lwt.Content_addressable.Maker]. *) +module Content_addressable (S : Irmin_lwt.Append_only.Maker) : + Irmin_lwt.Content_addressable.Maker = +functor + (H : Irmin_lwt.Hash.S) + (V : Irmin_lwt.Type.S) + -> + struct + (* Lift S to an Eio-typed Append_only.Maker. *) + module S_eio (K : Irmin_lwt.Type.S) (V : Irmin_lwt.Type.S) = + Irmin_lwt.Lwt_to_eio.Append_only (S) (K) (V) + + module Eio_CA = Irmin_chunk.Content_addressable (S_eio) + module M = Eio_CA (H) (V) + + type 'a t = 'a M.t + type key = M.key + type value = M.value + + let v c = run (fun () -> M.v c) + let mem t k = run (fun () -> M.mem t k) + let find t k = run (fun () -> M.find t k) + let add t v = run (fun () -> M.add t v) + let unsafe_add t k v = run (fun () -> M.unsafe_add t k v) + let close t = run (fun () -> M.close t) + + let batch t f = + run (fun () -> M.batch t (fun rw -> Lwt_eio.Promise.await_lwt (f rw))) + end diff --git a/src/irmin-lwt/chunk/irmin_lwt_chunk.mli b/src/irmin-lwt/chunk/irmin_lwt_chunk.mli new file mode 100644 index 0000000000..ea5d9f10fe --- /dev/null +++ b/src/irmin-lwt/chunk/irmin_lwt_chunk.mli @@ -0,0 +1,40 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Chunk meta-backend for [irmin-lwt]. + + Wraps a Lwt-typed [Append_only.Maker] into a Lwt-typed + [Content_addressable.Maker] that stores values cut into fixed-size chunks. + Internally bridges the user's Lwt Maker to its Eio counterpart, runs it + through [Irmin_chunk.Content_addressable], and bridges the resulting Eio + [Content_addressable.Maker] back to Lwt. *) + +module Conf = Irmin_chunk.Conf + +val config : + ?size:int -> + ?min_size:int -> + ?chunking:[ `Max | `Best_fit ] -> + Irmin_lwt.config -> + Irmin_lwt.config +(** [config ?size ?min_size ?chunking c] extends the configuration [c] with the + chunking parameters. See {!Irmin_chunk.config}. *) + +(** [Content_addressable (S)] is a Lwt-typed content-addressable store that + stores values cut into chunks into the underlying Lwt-typed append-only + store [S]. *) +module Content_addressable (S : Irmin_lwt.Append_only.Maker) : + Irmin_lwt.Content_addressable.Maker diff --git a/src/irmin-lwt/client/dune b/src/irmin-lwt/client/dune new file mode 100644 index 0000000000..61f8817a28 --- /dev/null +++ b/src/irmin-lwt/client/dune @@ -0,0 +1,11 @@ +(library + (name irmin_lwt_client) + (public_name irmin-lwt-client) + (libraries + irmin + irmin.mem + irmin-lwt + irmin-client + irmin-client.unix + lwt + lwt_eio)) diff --git a/src/irmin-lwt/client/irmin_lwt_client.ml b/src/irmin-lwt/client/irmin_lwt_client.ml new file mode 100644 index 0000000000..d2c8fc3702 --- /dev/null +++ b/src/irmin-lwt/client/irmin_lwt_client.ml @@ -0,0 +1,84 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* Lwt-flavoured shim over [Irmin_client_unix]. Takes a Lwt-typed + [Contents.S], synthesises an Eio-side reference store (using [Irmin_mem.KV] + purely as a Schema carrier — no actual local backing happens), feeds it to + [Irmin_client_unix.Make] to obtain an Eio-typed RPC client store, and + wraps the result back to [Irmin_lwt.Generic_key.S] via [Wrap_store.Make]. + Client-specific extras (connect / reconnect / dup / Batch / etc.) are + passed through. *) + +let run = Lwt_eio.run_eio + +module Error = Irmin_client_unix.Error + +let config = Irmin_client_unix.config + +module Make_codec (Codec : Irmin_server.Conn.Codec.S) (V : Irmin_lwt.Contents.S) = +struct + module V_eio = Irmin_lwt.Lwt_to_eio.Contents (V) + + (* Reference Eio Store: only used for its Schema by [Irmin_client_unix]. + The local mem backend never holds real data because the client routes + all ops over the wire. *) + module Reference = Irmin_mem.KV.Make (V_eio) + module Inner = Irmin_client_unix.Make_codec (Codec) (Reference) + + (* Lwt-typed Schema. Pure modules (Hash / Branch / Info / Path) are + reused directly from the Eio Schema. [Metadata = unit] (Metadata.None), + so we use the Lwt-side [Metadata.None] which has the same [t = unit]. *) + module Schema_lwt = struct + module Hash = Inner.Schema.Hash + module Branch = Inner.Schema.Branch + module Info = Inner.Schema.Info + module Path = Inner.Schema.Path + module Metadata = Irmin_lwt.Metadata.None + module Contents = V + end + + include Irmin_lwt.Wrap_store.Make (Schema_lwt) (Inner.Schema) (Inner) + + (* Pass-through client-specific surface. The functions are partly Eio + and partly Lwt upstream (Lwt because the network IO uses cohttp-lwt + / websocket-lwt). We keep the upstream shape, wrapping Eio-direct + ones in [Lwt.t] for caller convenience and leaving the already-Lwt + ones unchanged. *) + + let connect ?tls ?hostname uri = + run (fun () -> Inner.connect ?tls ?hostname uri) + + let reconnect = Inner.reconnect + let uri = Inner.uri + let close r = run (fun () -> Inner.close r) + let dup = Inner.dup + let ping r = run (fun () -> Inner.ping r) + let export ?depth r = run (fun () -> Inner.export ?depth r) + let import r s = run (fun () -> Inner.import r s) + + module Batch = struct + include Inner.Batch + + let apply ~info ?path s b = + run (fun () -> Inner.Batch.apply ~info ?path s b) + end +end + +module Make (V : Irmin_lwt.Contents.S) = + Make_codec (Irmin_server.Conn.Codec.Bin) (V) + +module Make_json (V : Irmin_lwt.Contents.S) = + Make_codec (Irmin_server.Conn.Codec.Json) (V) diff --git a/src/irmin-lwt/containers/dune b/src/irmin-lwt/containers/dune new file mode 100644 index 0000000000..02803279c9 --- /dev/null +++ b/src/irmin-lwt/containers/dune @@ -0,0 +1,14 @@ +(library + (name irmin_lwt_containers) + (public_name irmin-lwt-containers) + (libraries + irmin + irmin-lwt + irmin-lwt-mem + irmin-lwt-fs + lwt + lwt_eio + mtime + mtime.clock.os) + (preprocess + (pps ppx_irmin))) diff --git a/src/irmin-lwt/containers/irmin_lwt_containers.ml b/src/irmin-lwt/containers/irmin_lwt_containers.ml new file mode 100644 index 0000000000..2febd008df --- /dev/null +++ b/src/irmin-lwt/containers/irmin_lwt_containers.ml @@ -0,0 +1,232 @@ +(* + * Copyright (c) 2020 KC Sivaramakrishnan + * Copyright (c) 2020 Anirudh Sunder Raj + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* Lwt-flavoured port of irmin-containers (Counter / Lww_register / Blob_log) + on top of [irmin-lwt]. Each merge function is bridged from its Eio + counterpart in [Irmin.Merge] via [Irmin_lwt.Lwt_to_eio.merge_of_eio]; the + data-structure operations themselves use Lwt-typed [Store] ops directly. *) + +open Lwt.Syntax + +module Time = struct + module type S = sig + include Irmin_lwt.Type.S + + val now : unit -> t + end + + module Machine : S = struct + type t = Mtime.t + + let t = + Irmin_lwt.Type.map ~equal:Mtime.equal ~compare:Mtime.compare + Irmin_lwt.Type.int64 Mtime.of_uint64_ns Mtime.to_uint64_ns + + let now = Mtime_clock.now + end +end + +module Counter = struct + module type S = sig + module Store : Irmin_lwt.KV + + val inc : + ?by:int64 -> + ?info:Store.Info.f -> + path:Store.path -> + Store.t -> + unit Lwt.t + + val dec : + ?by:int64 -> + ?info:Store.Info.f -> + path:Store.path -> + Store.t -> + unit Lwt.t + + val read : path:Store.path -> Store.t -> int64 Lwt.t + end + + module Counter_contents : Irmin_lwt.Contents.S with type t = int64 = struct + type t = int64 + + let t = Irmin_lwt.Type.int64 + + let merge = + Irmin_lwt.Lwt_to_eio.merge_of_eio + Irmin.Type.(option int64) + Irmin.Merge.(option counter) + end + + module Make (Backend : Irmin_lwt.KV_maker) : S = struct + module Store = Backend.Make (Counter_contents) + + let empty_info = Store.Info.none + + let modify by info t path fn = + let* current = Store.find t path in + let v = match current with Some v -> v | None -> 0L in + Store.set_exn ~info t path (fn v by) + + let inc ?(by = 1L) ?(info = empty_info) ~path t = + modify by info t path Int64.add + + let dec ?(by = 1L) ?(info = empty_info) ~path t = + modify by info t path Int64.sub + + let read ~path t = + let+ v = Store.find t path in + match v with None -> 0L | Some v -> v + end + + module FS = Make (Irmin_lwt_fs.KV) + module Mem = Make (Irmin_lwt_mem.KV) +end + +module Lww_register = struct + module LWW (T : Time.S) (V : Irmin_lwt.Type.S) : + Irmin_lwt.Contents.S with type t = V.t * T.t = struct + type t = V.t * T.t [@@deriving irmin] + + (* The merge logic is identical to [Irmin_containers.Lww_register.LWW]; + we reproduce it here on the Lwt side because the type [t] is + parameterised over local [T] and [V] and cannot be lifted from a + prebuilt Eio module. The merge itself is pure (no I/O), so it is + wrapped to a Lwt [Merge.t] without a runtime bridge. *) + + let compare_t = Irmin.Type.(unstage (compare T.t)) + let compare_v = Irmin.Type.(unstage (compare V.t)) + + let compare (v1, t1) (v2, t2) = + let res = compare_t t1 t2 in + if res = 0 then compare_v v1 v2 else res + + let merge_eio ~old:_ v1 v2 = + let open Irmin.Merge in + if compare v1 v2 > 0 then ok v1 else ok v2 + + let merge = + Irmin_lwt.Lwt_to_eio.merge_of_eio (Irmin.Type.option t) + Irmin.Merge.(option (v t merge_eio)) + end + + module type S = sig + module Store : Irmin_lwt.KV + + type value + + val read : path:Store.path -> Store.t -> value option Lwt.t + + val write : + ?info:Store.Info.f -> path:Store.path -> Store.t -> value -> unit Lwt.t + end + + module Make + (Backend : Irmin_lwt.KV_maker) + (T : Time.S) + (V : Irmin_lwt.Type.S) : S with type value = V.t = struct + module Store = Backend.Make (LWW (T) (V)) + + let empty_info = Store.Info.none + + type value = V.t + + let read ~path t = + let+ x = Store.find t path in + match x with None -> None | Some (v, _) -> Some v + + let write ?(info = empty_info) ~path t v = + let timestamp = T.now () in + Store.set_exn ~info t path (v, timestamp) + end + + module FS (V : Irmin_lwt.Type.S) = Make (Irmin_lwt_fs.KV) (Time.Machine) (V) + module Mem (V : Irmin_lwt.Type.S) = Make (Irmin_lwt_mem.KV) (Time.Machine) (V) +end + +module Blob_log = struct + module Blob_log (T : Time.S) (V : Irmin_lwt.Type.S) : + Irmin_lwt.Contents.S with type t = (V.t * T.t) list = struct + type t = (V.t * T.t) list [@@deriving irmin] + + let compare_t = Irmin.Type.(unstage (compare T.t)) + let compare (_, t1) (_, t2) = compare_t t1 t2 + + let newer_than timestamp entries = + let rec util acc = function + | [] -> List.rev acc + | (_, x) :: _ when compare_t x timestamp <= 0 -> List.rev acc + | h :: t -> util (h :: acc) t + in + util [] entries + + let merge_eio ~old v1 v2 = + let open Irmin.Merge.Infix in + let ok = Irmin.Merge.ok in + old () >>=* fun old -> + let old = match old with None -> [] | Some o -> o in + let l1, l2 = + match old with + | [] -> (v1, v2) + | (_, t) :: _ -> (newer_than t v1, newer_than t v2) + in + let l3 = List.sort compare (List.rev_append l1 l2) in + ok (List.rev_append l3 old) + + let merge = + Irmin_lwt.Lwt_to_eio.merge_of_eio + Irmin.Type.(option t) + Irmin.Merge.(option (v t merge_eio)) + end + + module type S = sig + module Store : Irmin_lwt.KV + + type value + + val append : path:Store.path -> Store.t -> value -> unit Lwt.t + val read_all : path:Store.path -> Store.t -> value list Lwt.t + end + + module Make + (Backend : Irmin_lwt.KV_maker) + (T : Time.S) + (V : Irmin_lwt.Type.S) : S with type value = V.t = struct + module Store = Backend.Make (Blob_log (T) (V)) + + let empty_info = Store.Info.none + + type value = V.t + + let create_entry v = (v, T.now ()) + + let append ~path t v = + let* current = Store.find t path in + let entry = create_entry v in + match current with + | None -> Store.set_exn ~info:empty_info t path [ entry ] + | Some l -> Store.set_exn ~info:empty_info t path (entry :: l) + + let read_all ~path t = + let+ x = Store.find t path in + match x with None -> [] | Some l -> List.map (fun (v, _) -> v) l + end + + module FS (V : Irmin_lwt.Type.S) = Make (Irmin_lwt_fs.KV) (Time.Machine) (V) + module Mem (V : Irmin_lwt.Type.S) = Make (Irmin_lwt_mem.KV) (Time.Machine) (V) +end diff --git a/src/irmin-lwt/core/append_only.ml b/src/irmin-lwt/core/append_only.ml new file mode 100644 index 0000000000..3a08f97487 --- /dev/null +++ b/src/irmin-lwt/core/append_only.ml @@ -0,0 +1 @@ +include Append_only_intf diff --git a/src/irmin-lwt/core/append_only.mli b/src/irmin-lwt/core/append_only.mli new file mode 100644 index 0000000000..0356a7e819 --- /dev/null +++ b/src/irmin-lwt/core/append_only.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Append_only_intf.Sigs +(** @inline *) diff --git a/src/irmin-lwt/core/append_only_intf.ml b/src/irmin-lwt/core/append_only_intf.ml new file mode 100644 index 0000000000..b5d318d4aa --- /dev/null +++ b/src/irmin-lwt/core/append_only_intf.ml @@ -0,0 +1,51 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import +open Store_properties + +module type S = sig + (** {1 Append-only stores} + + Append-only stores are store where it is possible to read and add new + values. *) + + include Read_only.S + (** @inline *) + + val add : [> write ] t -> key -> value -> unit Lwt.t + (** Write the contents of a value to the store. *) + + include Closeable with type 'a t := 'a t + (** @inline *) + + include Batch with type 'a t := 'a t + (** @inline *) +end + +module Append_only_is_a_read_only (X : S) : Read_only.S = X + +module type Maker = functor (K : Type.S) (V : Type.S) -> sig + include S with type key = K.t and type value = V.t + + include Of_config with type 'a t := 'a t + (** @inline *) +end + +module type Sigs = sig + module type S = S + module type Maker = Maker +end diff --git a/src/irmin-lwt/core/atomic_write.ml b/src/irmin-lwt/core/atomic_write.ml new file mode 100644 index 0000000000..7bf9b0db10 --- /dev/null +++ b/src/irmin-lwt/core/atomic_write.ml @@ -0,0 +1,61 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import +include Atomic_write_intf + +module Check_closed_store (AW : S) = struct + type t = { closed : bool ref; t : AW.t } + type key = AW.key + type value = AW.value + type watch = AW.watch + + let make_closeable t = { closed = ref false; t } + + let get_if_open_exn t = + if !(t.closed) then raise Store_properties.Closed else t.t + + let mem t k = (get_if_open_exn t |> AW.mem) k + let find t k = (get_if_open_exn t |> AW.find) k + let set t k v = (get_if_open_exn t |> AW.set) k v + + let test_and_set t k ~test ~set = + (get_if_open_exn t |> AW.test_and_set) k ~test ~set + + let remove t k = (get_if_open_exn t |> AW.remove) k + let list t = get_if_open_exn t |> AW.list + let watch t ?init f = (get_if_open_exn t |> AW.watch) ?init f + let watch_key t k ?init f = (get_if_open_exn t |> AW.watch_key) k ?init f + let unwatch t w = (get_if_open_exn t |> AW.unwatch) w + + let close t = + if !(t.closed) then Lwt.return_unit + else ( + t.closed := true; + AW.close t.t) + + let clear t = get_if_open_exn t |> AW.clear +end + +module Check_closed (Make_atomic_write : Maker) (K : Type.S) (V : Type.S) = +struct + module AW = Make_atomic_write (K) (V) + include Check_closed_store (AW) + + let v conf = + let+ t = AW.v conf in + { closed = ref false; t } +end diff --git a/src/irmin-lwt/core/atomic_write.mli b/src/irmin-lwt/core/atomic_write.mli new file mode 100644 index 0000000000..f42c7e8c8f --- /dev/null +++ b/src/irmin-lwt/core/atomic_write.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Atomic_write_intf.Sigs +(** @inline *) diff --git a/src/irmin-lwt/core/atomic_write_intf.ml b/src/irmin-lwt/core/atomic_write_intf.ml new file mode 100644 index 0000000000..15f506c225 --- /dev/null +++ b/src/irmin-lwt/core/atomic_write_intf.ml @@ -0,0 +1,110 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Store_properties + +type 'a diff = 'a Diff.t + +module type S = sig + (** {1 Atomic write stores} + + Atomic-write stores are stores where it is possible to read, update and + remove elements, with atomically guarantees. *) + + type t + (** The type for atomic-write backend stores. *) + + include Read_only.S with type _ t := t + (** @inline *) + + val set : t -> key -> value -> unit Lwt.t + (** [set t k v] replaces the contents of [k] by [v] in [t]. If [k] is not + already defined in [t], create a fresh binding. Raise [Invalid_argument] + if [k] is the {{!Irmin.Path.S.empty} empty path}. *) + + val test_and_set : + t -> key -> test:value option -> set:value option -> bool Lwt.t + (** [test_and_set t key ~test ~set] sets [key] to [set] only if the current + value of [key] is [test] and in that case returns [true]. If the current + value of [key] is different, it returns [false]. [None] means that the + value does not have to exist or is removed. + + {b Note:} The operation is guaranteed to be atomic. *) + + val remove : t -> key -> unit Lwt.t + (** [remove t k] remove the key [k] in [t]. *) + + val list : t -> key list Lwt.t + (** [list t] it the list of keys in [t]. *) + + type watch + (** The type of watch handlers. *) + + val watch : + t -> + ?init:(key * value) list -> + (key -> value diff -> unit Lwt.t) -> + watch Lwt.t + (** [watch t ?init f] adds [f] to the list of [t]'s watch handlers and returns + the watch handler to be used with {!unwatch}. [init] is the optional + initial values. It is more efficient to use {!watch_key} to watch only a + single given key.*) + + val watch_key : + t -> key -> ?init:value -> (value diff -> unit Lwt.t) -> watch Lwt.t + (** [watch_key t k ?init f] adds [f] to the list of [t]'s watch handlers for + the key [k] and returns the watch handler to be used with {!unwatch}. + [init] is the optional initial value of the key. *) + + val unwatch : t -> watch -> unit Lwt.t + (** [unwatch t w] removes [w] from [t]'s watch handlers. *) + + include Clearable with type _ t := t + (** @inline *) + + include Closeable with type _ t := t + (** @inline *) +end + +module type Maker = functor (K : Type.S) (V : Type.S) -> sig + include S with type key = K.t and type value = V.t + + include Of_config with type _ t := t + (** @inline *) +end + +module type Sigs = sig + module type S = S + module type Maker = Maker + + module Check_closed_store (AW : S) : sig + include + S + with type key = AW.key + and type value = AW.value + and type watch = AW.watch + + val make_closeable : AW.t -> t + (** [make_closeable t] returns a version of [t] that raises {!Irmin.Closed} + if an operation is performed when it is already closed. *) + + val get_if_open_exn : t -> AW.t + (** [get_if_open_exn t] returns the store (without close checks) if it is + open; otherwise raises {!Irmin.Closed} *) + end + + module Check_closed (M : Maker) : Maker +end diff --git a/src/irmin-lwt/core/backend.ml b/src/irmin-lwt/core/backend.ml new file mode 100644 index 0000000000..4b9f981b7f --- /dev/null +++ b/src/irmin-lwt/core/backend.ml @@ -0,0 +1,119 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Store_properties + +open struct + module type Node_portable = Node.Portable.S + module type Commit_portable = Commit.Portable.S +end + +(** [S] is what a backend must define in order to be made an irmin store. *) +module type S = sig + module Schema : Schema.S + (** A store schema, meant to be provided by the user. *) + + module Hash : Hash.S with type t = Schema.Hash.t + (** Hashing implementation. *) + + (** A contents store. *) + module Contents : + Contents.Store with type hash = Hash.t and type value = Schema.Contents.t + + (** A node store. *) + module Node : + Node.Store + with type hash = Hash.t + and type Val.contents_key = Contents.key + and module Path = Schema.Path + and module Metadata = Schema.Metadata + + (** A node abstraction that is portable from different repos. Similar to + [Node.Val]. *) + module Node_portable : + Node_portable + with type node := Node.value + and type hash := Hash.t + and type metadata := Schema.Metadata.t + and type step := Schema.Path.step + + (** A commit store. *) + module Commit : + Commit.Store + with type hash = Hash.t + and type Val.node_key = Node.key + and module Info = Schema.Info + + (** A commit abstraction that is portable from different repos. Similar to + [Commit.Val]. *) + module Commit_portable : + Commit_portable + with type commit := Commit.value + and type hash := Hash.t + and module Info = Schema.Info + + (** A branch store. *) + module Branch : + Branch.Store with type key = Schema.Branch.t and type value = Commit.key + + (** A slice abstraction. *) + module Slice : + Slice.S + with type contents = Contents.hash * Contents.value + and type node = Node.hash * Node.value + and type commit = Commit.hash * Commit.value + + (** A repo abstraction. *) + module Repo : sig + type t + + (** Repo opening and closing functions *) + + include Of_config with type _ t := t + (** @inline *) + + include Closeable with type _ t := t + (** @inline *) + + (** Getters from repo to backend store in ro mode *) + + val contents_t : t -> read Contents.t + val node_t : t -> read Node.t + val commit_t : t -> read Commit.t + val config : t -> Conf.t + + val batch : + t -> + (read_write Contents.t -> + read_write Node.t -> + read_write Commit.t -> + 'a Lwt.t) -> + 'a Lwt.t + (** A getter from repo to backend stores in rw mode. *) + + val branch_t : t -> Branch.t + (** A branch store getter from repo *) + end + + (** URI-based low-level remote synchronisation. *) + module Remote : sig + include Remote.S with type commit = Commit.key and type branch = Branch.key + + val v : Repo.t -> t Lwt.t + end +end diff --git a/src/irmin-lwt/core/branch.ml b/src/irmin-lwt/core/branch.ml new file mode 100644 index 0000000000..da5576af5d --- /dev/null +++ b/src/irmin-lwt/core/branch.ml @@ -0,0 +1,36 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Branch_intf + +module String = struct + type t = string + + let t = Type.string + let main = "main" + + let is_valid s = + let ok = ref true in + let n = String.length s in + let i = ref 0 in + while !i < n do + (match s.[!i] with + | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '-' | '_' | '.' | '/' -> () + | _ -> ok := false); + incr i + done; + !ok +end diff --git a/src/irmin-lwt/core/branch.mli b/src/irmin-lwt/core/branch.mli new file mode 100644 index 0000000000..cb6bbce144 --- /dev/null +++ b/src/irmin-lwt/core/branch.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** User-defined branches. *) + +include Branch_intf.Sigs +(** @inline *) diff --git a/src/irmin-lwt/core/branch_intf.ml b/src/irmin-lwt/core/branch_intf.ml new file mode 100644 index 0000000000..bc84047cdf --- /dev/null +++ b/src/irmin-lwt/core/branch_intf.ml @@ -0,0 +1,63 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + (** {1 Signature for Branches} *) + + type t [@@deriving irmin] + (** The type for branches. *) + + val main : t + (** The name of the main branch. *) + + val is_valid : t -> bool + (** Check if the branch is valid. *) +end + +module Irmin_key = Key + +module type Store = sig + (** {1 Branch Store} *) + + include Atomic_write.S + + module Key : S with type t = key + (** Base functions on keys. *) + + module Val : Irmin_key.S with type t = value + (** Base functions on values. *) +end + +module type Sigs = sig + (** {1 Branches} *) + + module type S = S + (** The signature for branches. Irmin branches are similar to Git branches: + they are used to associated user-defined names to head commits. Branches + have a default value: the {{!Branch.S.main} main} branch. *) + + module String : S with type t = string + (** [String] is an implementation of {{!Branch.S} S} where branches are + strings. The [main] branch is ["main"]. Valid branch names contain only + alpha-numeric characters, [-], [_], [.], and [/]. *) + + module type Store = Store + (** [Store] specifies the signature for branch stores. + + A {i branch store} is a mutable and reactive key / value store, where keys + are branch names created by users and values are keys are head commmits. + *) +end diff --git a/src/irmin-lwt/core/commit.ml b/src/irmin-lwt/core/commit.ml new file mode 100644 index 0000000000..3805577e8a --- /dev/null +++ b/src/irmin-lwt/core/commit.ml @@ -0,0 +1,700 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Commit_intf +open Merge.Infix + +let src = Logs.Src.create "irmin.commit" ~doc:"Irmin commits" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Maker_generic_key (I : Info.S) = struct + module Info = I + + module Make + (H : Type.S) + (N : Key.S with type hash = H.t) + (C : Key.S with type hash = H.t) = + struct + module Info = I + + type hash = H.t [@@deriving irmin ~compare] + type node_key = N.t [@@deriving irmin ~compare] + type commit_key = C.t [@@deriving irmin] + + type t = { node : node_key; parents : commit_key list; info : Info.t } + [@@deriving irmin] + + type t_not_prefixed = t [@@deriving irmin] + + let pre_hash = Type.(unstage (pre_hash t)) + + (* Manually add a prefix to default commits, in order to prevent hash + collision between contents and commits (see + https://github.com/mirage/irmin/issues/1304). + If we only prefix the prehash of contents, (suppose the prefix is "B"), + then we can have a collision with the prehash of a commit (the prehash of + a commit starts with the hash of the root and can start with a "B" - the + prefix of the contents is not enough to prevent the collision). *) + let pre_hash_prefixed x f = + f "C"; + pre_hash x f + + let t = Type.(like t ~pre_hash:pre_hash_prefixed) + let parents t = t.parents + let node t = t.node + let info t = t.info + let compare_commit_key x y = compare_hash (C.to_hash x) (C.to_hash y) + + let v ~info ~node ~parents = + let parents = List.fast_sort compare_commit_key parents in + { node; parents; info } + + module Portable = struct + module Info = I + + type commit = t + + type t = { node : hash; parents : hash list; info : Info.t } + [@@deriving irmin] + + type t_not_prefixed = t [@@deriving irmin] + + let pre_hash = Type.(unstage (pre_hash t)) + + let pre_hash_prefixed x f = + f "C"; + pre_hash x f + + let t = Type.(like t ~pre_hash:pre_hash_prefixed) + + type commit_key = H.t [@@deriving irmin] + type node_key = H.t [@@deriving irmin] + type hash = H.t [@@deriving irmin] + + let parents t = t.parents + let node t = t.node + let info t = t.info + + let v ~info ~node ~parents = + let parents = List.fast_sort compare_hash parents in + { node; parents; info } + + let of_commit : commit -> t = + fun { node; parents; info } -> + let node = N.to_hash node in + let parents = List.map C.to_hash parents in + { node; parents; info } + end + end + + module Make_v2 + (H : Type.S) + (N : Key.S with type hash = H.t) + (C : Key.S with type hash = H.t) = + struct + include Make (H) (N) (C) + + let t = t_not_prefixed_t + + module Portable = struct + include Portable + + let t = t_not_prefixed_t + end + end +end + +module Maker (Info : Info.S) = struct + include Maker_generic_key (Info) + + module Make (H : Type.S) = struct + module Key = Key.Of_hash (H) + include Make (H) (Key) (Key) + end +end + +module Store_generic_key + (I : Info.S) + (N : Node.Store) + (S : Indexable.S) + (H : Hash.S with type t = S.hash) + (V : + S_generic_key + with type node_key = N.Key.t + and type commit_key = S.Key.t + and type t = S.value + and module Info := I) = +struct + module Node = N + module Val = V + module Key = S.Key + module Hash = Hash.Typed (H) (V) + module Info = I + + type 'a t = 'a N.t * 'a S.t + type key = Key.t [@@deriving irmin ~equal] + type value = S.value + type hash = S.hash + + let add (_, t) = S.add t + let unsafe_add (_, t) = S.unsafe_add t + let mem (_, t) = S.mem t + let index (_, t) = S.index t + let find (_, t) = S.find t + let batch (n, s) f = N.batch n (fun n -> S.batch s (fun s -> f (n, s))) + + let close (n, s) = + let* () = N.close n in + let+ () = S.close s in + () + + let merge_node (t, _) = Merge.f (N.merge t) + let pp_key = Type.pp Key.t + let err_not_found k = Fmt.kstr invalid_arg "Commit.get: %a not found" pp_key k + + let get (_, t) k = + S.find t k >>= function None -> err_not_found k | Some v -> Lwt.return v + + let empty_if_none (n, _) = function + | None -> N.add n (N.Val.empty ()) + | Some node -> Lwt.return node + + let equal_key = Type.(unstage (equal Key.t)) + let equal_opt_keys = Type.(unstage (equal (option Key.t))) + + let merge_commit info t ~old k1 k2 = + [%log.debug "Commit.merge %a %a" pp_key k1 pp_key k2]; + let* v1 = get t k1 in + let* v2 = get t k2 in + if List.mem ~equal:equal_key k1 (Val.parents v2) then Merge.ok k2 + else if List.mem ~equal:equal_key k2 (Val.parents v1) then Merge.ok k1 + else + (* If we get an error while looking the the lca, then we + assume that there is no common ancestor. Maybe we want to + expose this to the user in a more structured way. But maybe + that's too much low-level details. *) + let* old = + old () >>= function + | Error (`Conflict msg) -> + [%log.debug "old: conflict %s" msg]; + Lwt.return_none + | Ok o -> Lwt.return o + in + if equal_opt_keys old (Some k1) then Merge.ok k2 + else if equal_opt_keys old (Some k2) then Merge.ok k1 + else + let old () = + match old with + | None -> Merge.ok None + | Some old -> + let* vold = get t old in + Merge.ok (Some (Some (Val.node vold))) + in + merge_node t ~old (Some (Val.node v1)) (Some (Val.node v2)) + >>=* fun node -> + let* node = empty_if_none t node in + let parents = [ k1; k2 ] in + let commit = Val.v ~node ~parents ~info:(info ()) in + let* key = add t commit in + Merge.ok key + + let merge t ~info = Merge.(option (v Key.t (merge_commit info t))) +end + +module Generic_key = struct + module type S = S_generic_key + module type Maker = Maker_generic_key + + module Maker = Maker_generic_key + module Store = Store_generic_key + include Maker (Info.Default) +end + +module Portable = struct + module Of_commit (X : S) = struct + include X + + let of_commit t = t + end + + module type S = Portable +end + +module Store + (I : Info.S) + (N : Node.Store) + (S : Content_addressable.S with type key = N.key) + (H : Hash.S with type t = S.key) + (V : S with type hash = S.key and type t = S.value and module Info := I) = +struct + include + Store_generic_key (I) (N) (Indexable.Of_content_addressable (H) (S)) (H) (V) + + module Val = struct + include Val + + type hash = H.t [@@deriving irmin] + end +end + +module History (S : Store) = struct + type commit_key = S.Key.t [@@deriving irmin] + type node_key = S.Val.node_key [@@deriving irmin] + type v = S.Val.t [@@deriving irmin] + type info = S.Info.t [@@deriving irmin] + type 'a t = 'a S.t + + let merge t ~info = + let f ~old c1 c2 = + let somify = Merge.map_promise (fun x -> Some x) in + let merge = S.merge t ~info in + Merge.f merge ~old:(somify old) (Some c1) (Some c2) >>=* function + | None -> Merge.conflict "History.merge" + | Some x -> Merge.ok x + in + Merge.v S.Key.t f + + let v t ~node ~parents ~info = + let commit = S.Val.v ~node ~parents ~info in + let+ hash = S.add t commit in + (hash, commit) + + let pp_key = Type.pp S.Key.t + + let parents t c = + [%log.debug "parents %a" pp_key c]; + S.find t c >|= function None -> [] | Some c -> S.Val.parents c + + module U = struct + type t = unit [@@deriving irmin] + end + + module Graph = Object_graph.Make (U) (S.Node.Key) (S.Key) (U) + + let edges t = + [%log.debug "edges"]; + [ `Node (S.Val.node t) ] @ List.map (fun k -> `Commit k) (S.Val.parents t) + + let closure t ~min ~max = + [%log.debug "closure"]; + let pred = function + | `Commit k -> ( S.find t k >|= function Some r -> edges r | None -> []) + | _ -> Lwt.return_nil + in + let min = List.map (fun k -> `Commit k) min in + let max = List.map (fun k -> `Commit k) max in + let+ g = Graph.closure ~pred ~min ~max () in + List.fold_left + (fun acc -> function `Commit k -> k :: acc | _ -> acc) + [] (Graph.vertex g) + + let ignore_lwt _ = Lwt.return_unit + + let iter t ~min ~max ?(commit = ignore_lwt) ?edge + ?(skip = fun _ -> Lwt.return_false) ?(rev = true) () = + let max = List.map (fun x -> `Commit x) max in + let min = List.map (fun x -> `Commit x) min in + let node = function `Commit x -> commit x | _ -> assert false in + let skip = function `Commit x -> skip x | _ -> assert false in + let pred = function + | `Commit k -> parents t k >|= List.map (fun x -> `Commit x) + | _ -> assert false + in + let edge = + Option.map + (fun edge n pred -> + match (n, pred) with + | `Commit src, `Commit dst -> edge src dst + | _ -> assert false) + edge + in + Graph.iter ~pred ~min ~max ~node ?edge ~skip ~rev () + + module K = struct + type t = S.Key.t + + let compare = Type.(unstage (compare S.Key.t)) + let hash k = S.Hash.short_hash (S.Key.to_hash k) + let equal = Type.(unstage (equal S.Key.t)) + end + + module KSet = Set.Make (K) + module KHashtbl = Hashtbl.Make (K) + + let read_parents t commit = + S.find t commit >|= function + | None -> KSet.empty + | Some c -> KSet.of_list (S.Val.parents c) + + let equal_keys = Type.(unstage (equal S.Key.t)) + let str_key k = String.sub (Type.to_string S.Key.t k) 0 4 + let pp_key = Fmt.of_to_string str_key + + let pp_keys ppf keys = + let keys = KSet.elements keys in + Fmt.pf ppf "[%a]" Fmt.(list ~sep:(any " ") pp_key) keys + + let str_keys = Fmt.to_to_string pp_keys + let lca_calls = ref 0 + + let rec unqueue todo seen = + if Queue.is_empty todo then None + else + let ((_, commit) as pop) = Queue.pop todo in + if KSet.mem commit seen then unqueue todo seen else Some pop + + (* Traverse the graph of commits using a breadth first search + strategy. Start by visiting the commits in [init] and stops + either when [check] returns [`Stop] or when all the ancestors of + [init] have been visited. *) + let traverse_bfs t ~f ~pp:_ ~check ~init ~return = + let todo = Queue.create () in + let add_todo d x = Queue.add (d, x) todo in + KSet.iter (add_todo 0) init; + let rec aux seen = + match check () with + | (`Too_many_lcas | `Max_depth_reached) as x -> Lwt.return (Error x) + | `Stop -> return () + | `Continue -> ( + match unqueue todo seen with + | None -> return () + | Some (depth, commit) -> + (* Log.debug "lca %d: %s.%d %a" + !lca_calls (pp_key commit) depth force (pp ()); *) + let seen = KSet.add commit seen in + let* parents = read_parents t commit in + let () = f depth commit parents in + let parents = KSet.diff parents seen in + KSet.iter (add_todo (depth + 1)) parents; + aux seen) + in + aux KSet.empty + + (* Initially the first node is marked as [Seen1] and the second as [Seen2]. + Marks are updated as the search progresses, and may change. *) + type mark = + | Seen1 (* reachable from the first commit *) + | Seen2 (* reachable from the second commit *) + | SeenBoth (* reachable from both, but below an LCA *) + | LCA + + (* reachable from both; candidate for the answer set *) + + let _pp_mark = function + | Seen1 -> "seen1" + | Seen2 -> "seen2" + | SeenBoth -> "seenBoth" + | LCA -> "LCA" + + (* Exploration state *) + type state = { + marks : mark KHashtbl.t; + (* marks of commits already explored *) + parents : KSet.t KHashtbl.t; + (* parents of commits already explored *) + layers : (int, KSet.t) Hashtbl.t; + (* layers of commit, sorted by depth *) + c1 : S.key; + (* initial state 1 *) + c2 : S.key; + (* initial state 2 *) + mutable depth : int; + (* the current exploration depth *) + mutable lcas : int; + (* number of commit marked with LCA *) + mutable complete : bool; (* is the exploration complete? *) + } + + let pp_state t = + lazy + (let pp m = + KHashtbl.fold + (fun k v acc -> if v = m then str_key k :: acc else acc) + t.marks [] + |> String.concat " " + in + Fmt.str "d: %d, seen1: %s, seen2: %s, seenboth: %s, lcas: %s (%d) %s" + t.depth (pp Seen1) (pp Seen2) (pp SeenBoth) (pp LCA) t.lcas + (String.concat " | " + (Hashtbl.fold + (fun d ks acc -> Fmt.str "(%d: %s)" d (str_keys ks) :: acc) + t.layers []))) + + let get_mark_exn t elt = KHashtbl.find t.marks elt + let get_mark t elt = try Some (get_mark_exn t elt) with Not_found -> None + let set_mark t elt mark = KHashtbl.replace t.marks elt mark + let get_layer t d = try Hashtbl.find t.layers d with Not_found -> KSet.empty + + let add_to_layer t d k = + Hashtbl.replace t.layers d (KSet.add k (get_layer t d)) + + let add_parent t c p = KHashtbl.add t.parents c p + + let get_parent t c = + try KHashtbl.find t.parents c with Not_found -> KSet.empty + + let incr_lcas t = t.lcas <- t.lcas + 1 + let decr_lcas t = t.lcas <- t.lcas - 1 + + let both_seen t k = + match get_mark t k with + | None | Some Seen1 | Some Seen2 -> false + | _ -> true + + let empty_state c1 c2 = + let t = + { + marks = KHashtbl.create 10; + parents = KHashtbl.create 10; + layers = Hashtbl.create 10; + c1; + c2; + depth = 0; + lcas = 0; + complete = false; + } + in + set_mark t c1 Seen1; + set_mark t c2 Seen2; + t + + (* update the parent mark and keep the number of lcas up-to-date. *) + let update_mark t mark commit = + let new_mark = + match (mark, get_mark t commit) with + | Seen1, Some Seen1 | Seen1, None -> Seen1 + | Seen2, Some Seen2 | Seen2, None -> Seen2 + | SeenBoth, Some LCA -> + decr_lcas t; + SeenBoth + | SeenBoth, _ -> SeenBoth + | Seen1, Some Seen2 | Seen2, Some Seen1 -> + incr_lcas t; + LCA + | _, Some LCA -> LCA + | _ -> SeenBoth + in + (* check for fast-forwards *) + let is_init () = equal_keys commit t.c1 || equal_keys commit t.c2 in + let is_shared () = new_mark = SeenBoth || new_mark = LCA in + if is_shared () && is_init () then ( + [%log.debug "fast-forward"]; + t.complete <- true); + set_mark t commit new_mark; + new_mark + + (* update the ancestors which have already been visisted. *) + let update_ancestors_marks t mark commit = + let todo = Queue.create () in + Queue.add commit todo; + let rec loop mark = + if Queue.is_empty todo then () + else + let a = Queue.pop todo in + let old_mark = get_mark t a in + let mark = update_mark t mark a in + let () = + match old_mark with + | Some (SeenBoth | LCA) -> () (* Can't be an LCA lower down *) + | Some old when old = mark -> () (* No change *) + | _ -> KSet.iter (fun x -> Queue.push x todo) (get_parent t a) + in + loop (if mark = LCA then SeenBoth else mark) + in + loop mark + + (* We are looking for LCAs, doing a breadth-first-search from the two starting commits. + This is called each time we visit a new commit. *) + let update_parents t depth commit parents = + add_parent t commit parents; + add_to_layer t depth commit; + if depth <> t.depth then ( + assert (depth = t.depth + 1); + + (* before starting to explore a new layer, check if we really + have some work to do, ie. do we still have a commit seen only + by one node? *) + let layer = get_layer t t.depth in + let complete = KSet.for_all (both_seen t) layer in + if complete then t.complete <- true else t.depth <- depth); + let mark = get_mark_exn t commit in + KSet.iter (update_ancestors_marks t mark) parents + + let lcas t = + KHashtbl.fold (fun k v acc -> if v = LCA then k :: acc else acc) t.marks [] + + let check ~max_depth ~n t = + if t.depth > max_depth then `Max_depth_reached + else if t.lcas > n then `Too_many_lcas + else if t.lcas = n || t.complete then `Stop + else `Continue + + let lcas t ?(max_depth = max_int) ?(n = max_int) c1 c2 = + incr lca_calls; + if max_depth < 0 then Lwt.return (Error `Max_depth_reached) + else if n <= 0 then Lwt.return (Error `Too_many_lcas) + else if equal_keys c1 c2 then Lwt.return (Ok [ c1 ]) + else + let init = KSet.of_list [ c1; c2 ] in + let s = empty_state c1 c2 in + let check () = check ~max_depth ~n s in + let pp () = pp_state s in + let return () = Lwt.return (Ok (lcas s)) in + let t0 = Sys.time () in + Lwt.finalize + (fun () -> + traverse_bfs t ~f:(update_parents s) ~pp ~check ~init ~return) + (fun () -> + let t1 = Sys.time () -. t0 in + [%log.debug "lcas %d: depth=%d time=%.4fs" !lca_calls s.depth t1]; + Lwt.return_unit) + + let rec three_way_merge t ~info ?max_depth ?n c1 c2 = + [%log.debug "3-way merge between %a and %a" pp_key c1 pp_key c2]; + if equal_keys c1 c2 then Merge.ok c1 + else + let* lcas = lcas t ?max_depth ?n c1 c2 in + let old () = + match lcas with + | Error `Too_many_lcas -> Merge.conflict "Too many lcas" + | Error `Max_depth_reached -> Merge.conflict "Max depth reached" + | Ok [] -> Merge.ok None (* no common ancestor *) + | Ok (old :: olds) -> + let rec aux acc = function + | [] -> Merge.ok (Some acc) + | old :: olds -> + three_way_merge t ~info acc old >>=* fun acc -> aux acc olds + in + aux old olds + in + let merge = + merge t ~info + |> Merge.with_conflict (fun msg -> + Fmt.str "Recursive merging of common ancestors: %s" msg) + |> Merge.f + in + merge ~old c1 c2 + + let lca_aux t ~info ?max_depth ?n c1 c2 = + if equal_keys c1 c2 then Merge.ok (Some c1) + else + lcas t ?max_depth ?n c1 c2 >>= function + | Error `Too_many_lcas -> Merge.conflict "Too many lcas" + | Error `Max_depth_reached -> Merge.conflict "Max depth reached" + | Ok [] -> Merge.ok None (* no common ancestor *) + | Ok [ x ] -> Merge.ok (Some x) + | Ok (c :: cs) -> + let rec aux acc = function + | [] -> Merge.ok (Some acc) + | c :: cs -> ( + three_way_merge t ~info ?max_depth ?n acc c >>= function + | Error (`Conflict _) -> Merge.ok None + | Ok acc -> aux acc cs) + in + aux c cs + + let rec lca t ~info ?max_depth ?n = function + | [] -> Merge.conflict "History.lca: empty" + | [ c ] -> Merge.ok (Some c) + | c1 :: c2 :: cs -> ( + lca_aux t ~info ?max_depth ?n c1 c2 >>=* function + | None -> Merge.ok None + | Some c -> lca t ~info ?max_depth ?n (c :: cs)) +end + +module V1 = struct + module Info = struct + include Info.Default + + let t : t Type.t = + let open Type in + record "info" (fun date author message -> v ~author ~message date) + |+ field "date" int64 (fun t -> date t) + |+ field "author" (string_of `Int64) (fun t -> author t) + |+ field "message" (string_of `Int64) (fun t -> message t) + |> sealr + end + + module Make (Hash : Hash.S) (C : Generic_key.S with module Info := Info) = + struct + module K (K : Type.S) = struct + let h = Type.string_of `Int64 + + type t = K.t [@@deriving irmin ~pre_hash ~to_bin_string ~of_bin_string] + + let size_of = Type.Size.using to_bin_string (Type.Size.t h) + + let encode_bin = + let encode_bin = Type.(unstage (encode_bin h)) in + fun e k -> encode_bin (to_bin_string e) k + + let decode_bin = + let decode_bin = Type.(unstage (decode_bin h)) in + fun buf pos_ref -> + let v = decode_bin buf pos_ref in + match of_bin_string v with + | Ok v -> v + | Error (`Msg e) -> Fmt.failwith "decode_bin: %s" e + + (* Manually box hashes in V1 commits with length headers: *) + let pre_hash = + let hash_length_header : string = + let b = Bytes.create 8 in + Bytes.set_int64_be b 0 (Int64.of_int Hash.hash_size); + Bytes.unsafe_to_string b + in + fun x f -> + f hash_length_header; + pre_hash x f + + let t = Type.like K.t ~bin:(encode_bin, decode_bin, size_of) ~pre_hash + end + + module Node_key = K (struct + type t = C.node_key [@@deriving irmin] + end) + + module Commit_key = K (struct + type t = C.commit_key [@@deriving irmin] + end) + + type node_key = Node_key.t [@@deriving irmin] + type commit_key = Commit_key.t [@@deriving irmin] + type t = { parents : commit_key list; c : C.t } + + module Info = Info + + let import c = { c; parents = C.parents c } + let export t = t.c + let node t = C.node t.c + let parents t = t.parents + let info t = C.info t.c + let v ~info ~node ~parents = { parents; c = C.v ~node ~parents ~info } + let make = v + + let t : t Type.t = + let open Type in + record "commit" (fun node parents info -> make ~info ~node ~parents) + |+ field "node" Node_key.t node + |+ field "parents" (list ~len:`Int64 Commit_key.t) parents + |+ field "info" Info.t info + |> sealr + end +end + +include Maker (Info.Default) diff --git a/src/irmin-lwt/core/commit.mli b/src/irmin-lwt/core/commit.mli new file mode 100644 index 0000000000..0bd9361dc3 --- /dev/null +++ b/src/irmin-lwt/core/commit.mli @@ -0,0 +1,27 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Commit values represent the store history. + + Every commit contains a list of predecessor commits, and the collection of + commits form an acyclic directed graph. + + Every commit also can contain an optional key, pointing to a + {{!Backend.Commit.Store} node} value. See the {{!Backend.Node.Store} Node} + signature for more details on node values. *) + +include Commit_intf.Sigs +(** @inline *) diff --git a/src/irmin-lwt/core/commit_intf.ml b/src/irmin-lwt/core/commit_intf.ml new file mode 100644 index 0000000000..80aceed7e8 --- /dev/null +++ b/src/irmin-lwt/core/commit_intf.ml @@ -0,0 +1,333 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type S_generic_key = sig + (** {1 Commit values} *) + + type t [@@deriving irmin] + (** The type for commit values. *) + + type node_key [@@deriving irmin] + (** Type for node keys. *) + + type commit_key [@@deriving irmin] + (** Type for commit keys. *) + + module Info : Info.S + (** The type for commit info. *) + + val v : info:Info.t -> node:node_key -> parents:commit_key list -> t + (** Create a commit. *) + + val node : t -> node_key + (** The underlying node key. *) + + val parents : t -> commit_key list + (** The commit parents. *) + + val info : t -> Info.t + (** The commit info. *) +end + +module type S = sig + type hash [@@deriving irmin] + + (** @inline *) + include S_generic_key with type node_key = hash and type commit_key = hash +end + +module type Portable = sig + include S + + type commit + + val of_commit : commit -> t +end + +open struct + module S_is_a_generic_key (X : S) : S_generic_key = X +end + +module type Maker_generic_key = sig + module Info : Info.S + + module Make + (H : Type.S) + (N : Key.S with type hash = H.t) + (C : Key.S with type hash = H.t) : sig + include + S_generic_key + with type node_key = N.t + and type commit_key = C.t + and module Info = Info + + module Portable : + Portable with type commit := t and type hash := H.t and module Info = Info + end + + module Make_v2 + (H : Type.S) + (N : Key.S with type hash = H.t) + (C : Key.S with type hash = H.t) : sig + include + S_generic_key + with type node_key = N.t + and type commit_key = C.t + and module Info = Info + + module Portable : + Portable with type commit := t and type hash := H.t and module Info = Info + end +end + +module type Maker = sig + module Info : Info.S + module Make (H : Type.S) : S with type hash = H.t and module Info = Info +end + +module type Store = sig + (** {1 Commit Store} *) + + include Indexable.S + + module Info : Info.S + (** Commit info. *) + + (** [Val] provides functions for commit values. *) + module Val : + S_generic_key + with type t = value + and type commit_key = key + and module Info := Info + + module Hash : Hash.Typed with type t = hash and type value = value + + module Node : Node.Store with type key = Val.node_key + (** [Node] is the underlying node store. *) + + val merge : [> read_write ] t -> info:Info.f -> key option Merge.t + (** [merge] is the 3-way merge function for commit keys. *) +end + +module type History = sig + (** {1 Commit History} *) + + type 'a t + (** The type for store handles. *) + + type node_key [@@deriving irmin] + (** The type for node keys. *) + + type commit_key [@@deriving irmin] + (** The type for commit keys. *) + + type v [@@deriving irmin] + (** The type for commit objects. *) + + type info [@@deriving irmin] + (** The type for commit info. *) + + val v : + [> write ] t -> + node:node_key -> + parents:commit_key list -> + info:info -> + (commit_key * v) Lwt.t + (** Create a new commit. *) + + val parents : [> read ] t -> commit_key -> commit_key list Lwt.t + (** Get the commit parents. + + Commits form a append-only, fully functional, partial-order + data-structure: every commit carries the list of its immediate + predecessors. *) + + val merge : [> read_write ] t -> info:(unit -> info) -> commit_key Merge.t + (** [merge t] is the 3-way merge function for commit. *) + + val lcas : + [> read ] t -> + ?max_depth:int -> + ?n:int -> + commit_key -> + commit_key -> + (commit_key list, [ `Max_depth_reached | `Too_many_lcas ]) result Lwt.t + (** Find the lowest common ancestors + {{:http://en.wikipedia.org/wiki/Lowest_common_ancestor} lca} between two + commits. *) + + val lca : + [> read_write ] t -> + info:(unit -> info) -> + ?max_depth:int -> + ?n:int -> + commit_key list -> + (commit_key option, Merge.conflict) result Lwt.t + (** Compute the lowest common ancestors ancestor of a list of commits by + recursively calling {!lcas} and merging the results. + + If one of the merges results in a conflict, or if a call to {!lcas} + returns either [Error `Max_depth_reached] or [Error `Too_many_lcas] then + the function returns the same error. *) + + val three_way_merge : + [> read_write ] t -> + info:(unit -> info) -> + ?max_depth:int -> + ?n:int -> + commit_key -> + commit_key -> + (commit_key, Merge.conflict) result Lwt.t + (** Compute the {!lcas} of the two commit and 3-way merge the result. *) + + val closure : + [> read ] t -> + min:commit_key list -> + max:commit_key list -> + commit_key list Lwt.t + (** Same as {{!Node.Graph.closure} Node.Graph.closure} but for the history + graph. *) + + val iter : + [> read ] t -> + min:commit_key list -> + max:commit_key list -> + ?commit:(commit_key -> unit Lwt.t) -> + ?edge:(commit_key -> commit_key -> unit Lwt.t) -> + ?skip:(commit_key -> bool Lwt.t) -> + ?rev:bool -> + unit -> + unit Lwt.t + (** Same as {{!Node.Graph.iter} Node.Graph.iter} but for traversing the + history graph. *) +end + +module type Sigs = sig + module type S = S + module type Maker = Maker + + (** [Maker] provides a simple implementation of commit values, parameterized + by commit info. *) + module Maker (I : Info.S) : Maker with module Info = I + + (** [Generic_key] generalises the concept of "commit" to one that supports + object keys that are not strictly equal to hashes. *) + module Generic_key : sig + module type S = S_generic_key + module type Maker = Maker_generic_key + + module Maker (I : Info.S) : Maker with module Info = I + + module Store + (I : Info.S) + (N : Node.Store) + (S : Indexable.S) + (H : Hash.S with type t = S.hash) + (V : + S + with type node_key = N.key + and type commit_key = S.key + and type t = S.value + and module Info := I) : + Store + with type 'a t = 'a N.t * 'a S.t + and type key = S.key + and type value = S.value + and module Info = I + and type hash = S.hash + and module Val = V + + include Maker with module Info = Info.Default + end + + (** V1 serialisation. *) + module V1 : sig + module Info : Info.S with type t = Info.Default.t + (** Serialisation format for V1 info. *) + + module Make + (Hash : Hash.S) + (C : Generic_key.S with module Info := Info) : sig + include + Generic_key.S + with module Info = Info + and type node_key = C.node_key + and type commit_key = C.commit_key + + val import : C.t -> t + val export : t -> C.t + end + end + + module Portable : sig + (** Portable form of a commit implementation that can be constructed from a + concrete representation and used in computing hashes. Conceptually, a + [Commit.Portable.t] is a [Commit.t] in which all internal keys have been + replaced with the hashes of the values they point to. + + As with {!Node.Portable}, computations over portable values must commute + with those over [t]s. *) + + (** A node implementation with hashes for keys is trivially portable: *) + module Of_commit (S : S) : + Portable + with type commit := S.t + and type t = S.t + and type hash = S.hash + and module Info = S.Info + + module type S = Portable + end + + module type Store = Store + (** [Store] specifies the signature for commit stores. *) + + (** [Store] creates a new commit store. *) + module Store + (I : Info.S) + (N : Node.Store) + (S : Content_addressable.S with type key = N.key) + (H : Hash.S with type t = S.key) + (V : S with type hash = S.key and type t = S.value and module Info := I) : + Store + with type 'a t = 'a N.t * 'a S.t + and type key = S.key + and type hash = S.key + and type value = S.value + and module Info = I + and module Val = V + + module type History = History + (** [History] specifies the signature for commit history. The history is + represented as a partial-order of commits and basic functions to search + through that history are provided. + + Every commit can point to an entry point in a node graph, where + user-defined contents are stored. *) + + (** Build a commit history. *) + module History (C : Store) : + History + with type 'a t = 'a C.t + and type v = C.Val.t + and type node_key = C.Node.key + and type commit_key = C.key + and type info = C.Info.t + + include Maker with module Info = Info.Default +end diff --git a/src/irmin-lwt/core/conf.ml b/src/irmin-lwt/core/conf.ml new file mode 100644 index 0000000000..8ed94f78a6 --- /dev/null +++ b/src/irmin-lwt/core/conf.ml @@ -0,0 +1 @@ +include Irmin.Backend.Conf diff --git a/src/irmin-lwt/core/conf.mli b/src/irmin-lwt/core/conf.mli new file mode 100644 index 0000000000..ac41a864c1 --- /dev/null +++ b/src/irmin-lwt/core/conf.mli @@ -0,0 +1,23 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Backend configuration. + + [Irmin_lwt.Conf] is a transparent re-export of [Irmin.Backend.Conf]: config + values constructed here can be passed without conversion to any Irmin 4 + backend used through {!Lwt_to_eio}. *) + +include module type of Irmin.Backend.Conf diff --git a/src/irmin-lwt/core/content_addressable.ml b/src/irmin-lwt/core/content_addressable.ml new file mode 100644 index 0000000000..aa7b506b5c --- /dev/null +++ b/src/irmin-lwt/core/content_addressable.ml @@ -0,0 +1,84 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Content_addressable_intf + +module Make (AO : Append_only.Maker) (K : Hash.S) (V : Type.S) = struct + include AO (K) (V) + open Lwt.Infix + module H = Hash.Typed (K) (V) + + let hash = H.hash + let pp_key = Type.pp K.t + let equal_hash = Type.(unstage (equal K.t)) + + let find t k = + find t k >>= function + | None -> Lwt.return_none + | Some v as r -> + let k' = hash v in + if equal_hash k k' then Lwt.return r + else + Fmt.kstr Lwt.fail_invalid_arg "corrupted value: got %a, expecting %a" + pp_key k' pp_key k + + let unsafe_add t k v = add t k v + + let add t v = + let k = hash v in + add t k v >|= fun () -> k +end + +module Check_closed (CA : Maker) (K : Hash.S) (V : Type.S) = struct + module S = CA (K) (V) + + type 'a t = { closed : bool ref; t : 'a S.t } + type key = S.key + type value = S.value + + let check_not_closed t = if !(t.closed) then raise Store_properties.Closed + + let mem t k = + check_not_closed t; + S.mem t.t k + + let find t k = + check_not_closed t; + S.find t.t k + + let add t v = + check_not_closed t; + S.add t.t v + + let unsafe_add t k v = + check_not_closed t; + S.unsafe_add t.t k v + + let batch t f = + check_not_closed t; + S.batch t.t (fun w -> f { t = w; closed = t.closed }) + + let v conf = + let+ t = S.v conf in + { closed = ref false; t } + + let close t = + if !(t.closed) then Lwt.return_unit + else ( + t.closed := true; + S.close t.t) +end diff --git a/src/irmin-lwt/core/content_addressable.mli b/src/irmin-lwt/core/content_addressable.mli new file mode 100644 index 0000000000..ed9b4cc43d --- /dev/null +++ b/src/irmin-lwt/core/content_addressable.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Content_addressable_intf.Sigs +(** @inline *) diff --git a/src/irmin-lwt/core/content_addressable_intf.ml b/src/irmin-lwt/core/content_addressable_intf.ml new file mode 100644 index 0000000000..1c0fe4a1e4 --- /dev/null +++ b/src/irmin-lwt/core/content_addressable_intf.ml @@ -0,0 +1,69 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import +open Store_properties + +module type S = sig + (** A {i content-addressable} store is an indexed read-write store in which + values are keyed directly by their hashes. *) + + include Read_only.S + (** @inline *) + + val add : [> write ] t -> value -> key Lwt.t + (** Write the contents of a value to the store. It's the responsibility of the + content-addressable store to generate a consistent key. *) + + val unsafe_add : [> write ] t -> key -> value -> unit Lwt.t + (** Same as {!add} but allows specifying the key directly. The backend might + choose to discard that key and/or can be corrupt if the key scheme is not + consistent. *) + + include Closeable with type 'a t := 'a t + (** @inline *) + + include Batch with type 'a t := 'a t + (** @inline *) +end + +module type Maker = functor (Hash : Hash.S) (Value : Type.S) -> sig + include S with type value = Value.t and type key = Hash.t + + include Of_config with type 'a t := 'a t + (** @inline *) +end + +module type Sigs = sig + module type S = S + module type Maker = Maker + + module Make + (Append_only_maker : Append_only.Maker) + (Hash : Hash.S) + (Value : Type.S) : sig + include + S + with type 'a t = 'a Append_only_maker(Hash)(Value).t + and type value = Value.t + and type key = Hash.t + + include Of_config with type 'a t := 'a t + (** @inline *) + end + + module Check_closed (M : Maker) : Maker +end diff --git a/src/irmin-lwt/core/contents.ml b/src/irmin-lwt/core/contents.ml new file mode 100644 index 0000000000..9cc3126f99 --- /dev/null +++ b/src/irmin-lwt/core/contents.ml @@ -0,0 +1,251 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Contents_intf + +let lexeme e x = ignore (Jsonm.encode e (`Lexeme x)) + +let rec encode_json e = function + | `Null -> lexeme e `Null + | `Bool b -> lexeme e (`Bool b) + | `String s -> lexeme e (`String s) + | `Float f -> lexeme e (`Float f) + | `A a -> + lexeme e `As; + List.iter (encode_json e) a; + lexeme e `Ae + | `O o -> + lexeme e `Os; + List.iter + (fun (k, v) -> + lexeme e (`Name k); + encode_json e v) + o; + lexeme e `Oe + +let decode_json d = + let decode d = + match Jsonm.decode d with + | `Lexeme l -> l + | `Error e -> failwith (Fmt.str "%a" Jsonm.pp_error e) + | _ -> failwith "invalid JSON encoding" + in + let rec unwrap v d = + match v with + | `Os -> obj [] d + | `As -> arr [] d + | (`Null | `Bool _ | `String _ | `Float _) as v -> v + | _ -> failwith "invalid JSON value" + and arr vs d = + match decode d with + | `Ae -> `A (List.rev vs) + | v -> + let v = unwrap v d in + arr (v :: vs) d + and obj ms d = + match decode d with + | `Oe -> `O (List.rev ms) + | `Name k -> + let v = unwrap (decode d) d in + obj ((k, v) :: ms) d + | _ -> failwith "invalid JSON object" + in + try Ok (unwrap (decode d) d) with Failure msg -> Error (`Msg msg) + +type json = + [ `Null + | `Bool of bool + | `String of string + | `Float of float + | `O of (string * json) list + | `A of json list ] +[@@deriving irmin] + +module Json_value = struct + type t = json [@@deriving irmin] + + let pp fmt x = + let buffer = Buffer.create 32 in + let encoder = Jsonm.encoder (`Buffer buffer) in + encode_json encoder x; + ignore @@ Jsonm.encode encoder `End; + let s = Buffer.contents buffer in + Fmt.pf fmt "%s" s + + let of_string s = + let decoder = Jsonm.decoder (`String s) in + match decode_json decoder with Ok obj -> Ok obj | Error _ as err -> err + + let equal_bool = Type.(unstage (equal bool)) + let equal_float = Type.(unstage (equal float)) + + let rec equal a b = + match (a, b) with + | `Null, `Null -> true + | `Bool a, `Bool b -> equal_bool a b + | `String a, `String b -> String.equal a b + | `Float a, `Float b -> equal_float a b + | `A a, `A b -> ( + try List.for_all2 (fun a' b' -> equal a' b') a b + with Invalid_argument _ -> false) + | `O a, `O b -> ( + let compare_fst (a, _) (b, _) = compare a b in + try + List.for_all2 + (fun (k, v) (k', v') -> k = k' && equal v v') + (List.sort compare_fst a) (List.sort compare_fst b) + with Invalid_argument _ -> false) + | _, _ -> false + + let t = Type.like ~equal ~pp ~of_string t + + let rec merge_object ~old x y = + let open Merge.Infix in + let m = + Merge.(alist Type.string t (fun _key -> option (v t merge_value))) + in + Merge.(f m ~old x y) >>=* fun x -> Merge.ok (`O x) + + and merge_float ~old x y = + let open Merge.Infix in + Merge.(f float ~old x y) >>=* fun f -> Merge.ok (`Float f) + + and merge_string ~old x y = + let open Merge.Infix in + Merge.(f string ~old x y) >>=* fun s -> Merge.ok (`String s) + + and merge_bool ~old x y = + let open Merge.Infix in + Merge.(f bool ~old x y) >>=* fun b -> Merge.ok (`Bool b) + + and merge_array ~old x y = + let open Merge.Infix in + Merge.(f (Merge.idempotent (Type.list t)) ~old x y) >>=* fun x -> + Merge.ok (`A x) + + and merge_value ~old x y = + let open Merge.Infix in + old () >>=* fun old -> + match (old, x, y) with + | Some `Null, _, _ -> merge_value ~old:(fun () -> Merge.ok None) x y + | None, `Null, `Null -> Merge.ok `Null + | Some (`Float old), `Float a, `Float b -> + merge_float ~old:(fun () -> Merge.ok (Some old)) a b + | None, `Float a, `Float b -> merge_float ~old:(fun () -> Merge.ok None) a b + | Some (`String old), `String a, `String b -> + merge_string ~old:(fun () -> Merge.ok (Some old)) a b + | None, `String a, `String b -> + merge_string ~old:(fun () -> Merge.ok None) a b + | Some (`Bool old), `Bool a, `Bool b -> + merge_bool ~old:(fun () -> Merge.ok (Some old)) a b + | None, `Bool a, `Bool b -> merge_bool ~old:(fun () -> Merge.ok None) a b + | Some (`A old), `A a, `A b -> + merge_array ~old:(fun () -> Merge.ok (Some old)) a b + | None, `A a, `A b -> merge_array ~old:(fun () -> Merge.ok None) a b + | Some (`O old), `O a, `O b -> + merge_object ~old:(fun () -> Merge.ok (Some old)) a b + | None, `O a, `O b -> merge_object ~old:(fun () -> Merge.ok None) a b + | _, _, _ -> Merge.conflict "Conflicting JSON datatypes" + + let merge_json = Merge.(v t merge_value) + let merge = Merge.(option merge_json) +end + +module Json = struct + type t = (string * json) list [@@deriving irmin] + + let pp fmt x = + let buffer = Buffer.create 32 in + let encoder = Jsonm.encoder (`Buffer buffer) in + encode_json encoder (`O x); + ignore @@ Jsonm.encode encoder `End; + let s = Buffer.contents buffer in + Fmt.pf fmt "%s" s + + let of_string s = + let decoder = Jsonm.decoder (`String s) in + match decode_json decoder with + | Ok (`O obj) -> Ok obj + | Ok _ -> Error (`Msg "Irmin JSON values must be objects") + | Error _ as err -> err + + let equal a b = Json_value.equal (`O a) (`O b) + let t = Type.like ~equal ~pp ~of_string t + + let merge = + Merge.(option (alist Type.string Json_value.t (fun _ -> Json_value.merge))) +end + +module String_v2 = struct + type t = string [@@deriving irmin] + + let merge = Merge.idempotent Type.(option string) +end + +module String = struct + type t = string [@@deriving irmin] + + let pre_hash = Type.(unstage (pre_hash t)) + + (* Manually add a prefix to default contents, in order to prevent hash + collision between contents and nodes or commits (see + https://github.com/mirage/irmin/issues/1304). *) + let pre_hash_prefixed x f = + f "B"; + pre_hash x f + + let t = Type.(like t ~pre_hash:pre_hash_prefixed) + let merge = Merge.idempotent Type.(option string) +end + +module Store_indexable + (S : Indexable.S) + (H : Hash.S with type t = S.hash) + (C : S with type t = S.value) = +struct + module Val = C + module Hash = Hash.Typed (H) (C) + include S + + let read_opt t = function None -> Lwt.return_none | Some k -> find t k + + let add_opt t = function + | None -> Lwt.return_none + | Some v -> add t v >>= Lwt.return_some + + let merge t = + Merge.like_lwt Type.(option Key.t) Val.merge (read_opt t) (add_opt t) +end + +module Store + (S : Content_addressable.S) + (H : Hash.S with type t = S.key) + (C : S with type t = S.value) = + Store_indexable (Indexable.Of_content_addressable (H) (S)) (H) (C) + +module V1 = struct + module String = struct + include String + + let t = Type.(boxed (string_of `Int64)) + + type nonrec t = t [@@deriving irmin ~encode_bin ~decode_bin ~pre_hash] + + let size_of = Type.Size.t t + let t = Type.like t ~bin:(encode_bin, decode_bin, size_of) ~pre_hash + end +end diff --git a/src/irmin-lwt/core/contents.mli b/src/irmin-lwt/core/contents.mli new file mode 100644 index 0000000000..2863917273 --- /dev/null +++ b/src/irmin-lwt/core/contents.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Values. *) + +include Contents_intf.Sigs +(** @inline *) diff --git a/src/irmin-lwt/core/contents_intf.ml b/src/irmin-lwt/core/contents_intf.ml new file mode 100644 index 0000000000..3c79b7df34 --- /dev/null +++ b/src/irmin-lwt/core/contents_intf.ml @@ -0,0 +1,108 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type S = sig + (** {1 Signature for store contents} *) + + type t [@@deriving irmin] + (** The type for user-defined contents. *) + + val merge : t option Merge.t + (** Merge function. Evaluates to [`Conflict msg] if the values cannot be + merged properly. The arguments of the merge function can take [None] to + mean that the key does not exists for either the least-common ancestor or + one of the two merging points. The merge function returns [None] when the + key's value should be deleted. *) +end + +module type Store = sig + include Indexable.S + + val merge : [> read_write ] t -> key option Merge.t + (** [merge t] lifts the merge functions defined on contents values to contents + key. The merge function will: {e (i)} read the values associated with the + given keys, {e (ii)} use the merge function defined on values and + {e (iii)} write the resulting values into the store to get the resulting + key. See {!val-S.merge}. + + If any of these operations fail, return [`Conflict]. *) + + module Val : S with type t = value + module Hash : Hash.Typed with type t = hash and type value = value +end + +module type Sigs = sig + module type S = S + + module String : S with type t = string + (** Contents of type [string], with the {{!Irmin.Merge.default} default} 3-way + merge strategy: assume that update operations are idempotent and conflict + iff values are modified concurrently. *) + + module String_v2 : S with type t = string + (** Similar to [String] above, but the hash computation is compatible with + versions older than irmin.3.0 *) + + type json = + [ `Null + | `Bool of bool + | `String of string + | `Float of float + | `O of (string * json) list + | `A of json list ] + + module Json : S with type t = (string * json) list + (** [Json] contents are associations from strings to [json] values stored as + JSON encoded strings. If the same JSON key has been modified concurrently + with different values then the [merge] function conflicts. *) + + module Json_value : S with type t = json + (** [Json_value] allows any kind of json value to be stored, not only objects. + *) + + module V1 : sig + module String : S with type t = string + (** Same as {!String} but use v1 serialisation format. *) + end + + module type Store = Store + (** Contents store. *) + + (** [Store] creates a contents store. *) + module Store + (S : Content_addressable.S) + (H : Hash.S with type t = S.key) + (C : S with type t = S.value) : + Store + with type 'a t = 'a S.t + and type key = H.t + and type hash = H.t + and type value = C.t + + (** [Store_indexable] is like {!Store} but uses an indexable store as a + backend (rather than a content-addressable one). *) + module Store_indexable + (S : Indexable.S) + (H : Hash.S with type t = S.hash) + (C : S with type t = S.value) : + Store + with type 'a t = 'a S.t + and type key = S.key + and type value = S.value + and type hash = S.hash +end diff --git a/src/irmin-lwt/core/diff.ml b/src/irmin-lwt/core/diff.ml new file mode 100644 index 0000000000..89a39f908a --- /dev/null +++ b/src/irmin-lwt/core/diff.ml @@ -0,0 +1 @@ +include Irmin.Diff diff --git a/src/irmin-lwt/core/dot.ml b/src/irmin-lwt/core/dot.ml new file mode 100644 index 0000000000..4be8bd91d0 --- /dev/null +++ b/src/irmin-lwt/core/dot.ml @@ -0,0 +1,226 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Printf +open Astring + +let src = Logs.Src.create "irmin.dot" ~doc:"Irmin dot graph output" + +module Log = (val Logs.src_log src : Logs.LOG) + +module type S = sig + type db + + val output_buffer : + db -> + ?html:bool -> + ?depth:int -> + ?full:bool -> + date:(int64 -> string) -> + Buffer.t -> + unit Lwt.t +end + +exception Utf8_failure + +let is_valid_utf8 str = + try + Uutf.String.fold_utf_8 + (fun _ _ -> function `Malformed _ -> raise Utf8_failure | _ -> ()) + () str; + true + with Utf8_failure -> false + +module Make (S : Store.Generic_key.S) = struct + type db = S.t + + module Branch = S.Backend.Branch + module Contents = S.Backend.Contents + module Node = S.Backend.Node + module Commit = S.Backend.Commit + module Slice = S.Backend.Slice + + module Graph = + Object_graph.Make (Contents.Hash) (Node.Hash) (Commit.Hash) (Branch.Key) + + module Info = S.Info + + let pp_author = Type.pp Info.author_t + let pp_message = Type.pp Info.message_t + + let fprintf (t : db) ?depth ?(html = false) ?full ~date name = + [%log.debug + "depth=%s html=%b full=%s" + (match depth with None -> "" | Some d -> string_of_int d) + html + (match full with None -> "" | Some b -> string_of_bool b)]; + let* slice = S.Repo.export ?full ?depth (S.repo t) in + let vertex = Hashtbl.create 102 in + let add_vertex v l = Hashtbl.add vertex v l in + let mem_vertex v = Hashtbl.mem vertex v in + let edges = ref [] in + let add_edge v1 l v2 = + if mem_vertex v1 && mem_vertex v2 then edges := (v1, l, v2) :: !edges + in + let string_of_hash t k = + let s = Type.to_string t k in + if String.length s <= 8 then s else String.with_range s ~len:8 + in + let string_of_contents s = + let s = + if String.length s <= 10 then s else String.with_range s ~len:10 + in + let s = if is_valid_utf8 s then s else "" in + s + in + let label_of_node k _ = + let s = + (if html then + sprintf "
%s
" + else fun x -> x) + (string_of_hash Node.Hash.t k) + in + `Label s + in + let label_of_step l = + let l = Type.to_string S.Path.step_t l in + let s = + (if html then sprintf "
%s
" else fun x -> x) + (string_of_contents l) + in + `Label s + in + let label_of_commit k c = + let k = string_of_hash Commit.Hash.t k in + let o = Commit.Val.info c in + let s = + if html then + let message = Fmt.to_to_string pp_message (Info.message o) in + Fmt.str + "
\n\ + \
%s
\n\ + \
%a
\n\ + \
%s
\n\ + \ 
%s
\n\ + \
 
\n\ +
" + k pp_author (Info.author o) + (date (Info.date o)) + (String.Ascii.escape message) + else sprintf "%s" k + in + `Label s + in + let label_of_contents k v = + let k = string_of_hash Contents.Hash.t k in + let s = + if html then + sprintf + "
\n\ + \
%s
\n\ + \
 
\n\ +
" + k + else + let v = string_of_contents (Type.to_string Contents.Val.t v) in + sprintf "%s (%s)" k (String.Ascii.escape_string v) + in + `Label s + in + let label_of_tag t = + let s = + if html then + sprintf "
%s
" (Type.to_string Branch.Key.t t) + else Type.to_string Branch.Key.t t + in + `Label s + in + let contents = ref [] in + let nodes = ref [] in + let commits = ref [] in + let* () = + Slice.iter slice (function + | `Contents c -> + contents := c :: !contents; + Lwt.return_unit + | `Node n -> + nodes := n :: !nodes; + Lwt.return_unit + | `Commit c -> + commits := c :: !commits; + Lwt.return_unit) + in + List.iter + (fun (k, c) -> + add_vertex (`Contents k) [ `Shape `Box; label_of_contents k c ]) + !contents; + List.iter + (fun (k, t) -> + add_vertex (`Node k) [ `Shape `Box; `Style `Dotted; label_of_node k t ]) + !nodes; + List.iter + (fun (k, r) -> + add_vertex (`Commit k) + [ `Shape `Box; `Style `Bold; label_of_commit k r ]) + !commits; + List.iter + (fun (k, t) -> + List.iter + (fun (l, v) -> + match v with + | `Contents (v, _meta) -> + let v = Contents.Key.to_hash v in + add_edge (`Node k) + [ `Style `Dotted; label_of_step l ] + (`Contents v) + | `Node n -> + let n = Node.Key.to_hash n in + add_edge (`Node k) [ `Style `Solid; label_of_step l ] (`Node n)) + (Node.Val.list t)) + !nodes; + List.iter + (fun (k, r) -> + List.iter + (fun c -> + let c = Commit.Key.to_hash c in + add_edge (`Commit k) [ `Style `Bold ] (`Commit c)) + (Commit.Val.parents r); + let node_hash = Commit.Val.node r |> Node.Key.to_hash in + add_edge (`Commit k) [ `Style `Dashed ] (`Node node_hash)) + !commits; + let branch_t = S.Backend.Repo.branch_t (S.repo t) in + let* bs = Branch.list branch_t in + let+ () = + Lwt_list.iter_s + (fun r -> + Branch.find branch_t r >|= function + | None -> () + | Some k -> + let k = Commit.Key.to_hash k in + add_vertex (`Branch r) + [ `Shape `Plaintext; label_of_tag r; `Style `Filled ]; + add_edge (`Branch r) [ `Style `Bold ] (`Commit k)) + bs + in + let vertex = Hashtbl.fold (fun k v acc -> (k, v) :: acc) vertex [] in + fun ppf -> Graph.output ppf vertex !edges name + + let output_buffer t ?html ?depth ?full ~date buf = + let+ fprintf = fprintf t ?depth ?full ?html ~date "graph" in + let ppf = Format.formatter_of_buffer buf in + fprintf ppf +end diff --git a/src/irmin-lwt/core/dot.mli b/src/irmin-lwt/core/dot.mli new file mode 100644 index 0000000000..aa8f903461 --- /dev/null +++ b/src/irmin-lwt/core/dot.mli @@ -0,0 +1,45 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Store dumps. *) + +module type S = sig + (** {1 Dot Export} *) + + type db + + val output_buffer : + db -> + ?html:bool -> + ?depth:int -> + ?full:bool -> + date:(int64 -> string) -> + Buffer.t -> + unit Lwt.t + (** [output_buffer t ?html ?depth ?full buf] outputs the Graphviz + representation of [t] in the buffer [buf]. + + [html] (default is false) enables HTML labels. + + [depth] is used to limit the depth of the commit history. [None] here + means no limitation. + + If [full] is set (default is not) the full graph, including the commits, + nodes and contents, is exported, otherwise it is the commit history graph + only. *) +end + +module Make (S : Store.Generic_key.S) : S with type db = S.t diff --git a/src/irmin-lwt/core/dune b/src/irmin-lwt/core/dune new file mode 100644 index 0000000000..eba49f725b --- /dev/null +++ b/src/irmin-lwt/core/dune @@ -0,0 +1,8 @@ +(library + (name irmin_lwt) + (public_name irmin-lwt) + (libraries irmin lwt lwt_eio) + (flags + (:standard -w -69)) + (preprocess + (pps ppx_irmin.internal -- --lib "Type"))) diff --git a/src/irmin-lwt/core/export_for_backends.ml b/src/irmin-lwt/core/export_for_backends.ml new file mode 100644 index 0000000000..6f1b909c9f --- /dev/null +++ b/src/irmin-lwt/core/export_for_backends.ml @@ -0,0 +1 @@ +include Irmin.Export_for_backends diff --git a/src/irmin-lwt/core/hash.ml b/src/irmin-lwt/core/hash.ml new file mode 100644 index 0000000000..5236a732bf --- /dev/null +++ b/src/irmin-lwt/core/hash.ml @@ -0,0 +1 @@ +include Irmin.Hash diff --git a/src/irmin-lwt/core/import.ml b/src/irmin-lwt/core/import.ml new file mode 100644 index 0000000000..814f31812a --- /dev/null +++ b/src/irmin-lwt/core/import.ml @@ -0,0 +1,164 @@ +(* + * Copyright (c) 2019-2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* Extensions to the default namespace, opened throughout the Irmin codebase. *) + +type read = Perms.read +type write = Perms.write +type read_write = Perms.read_write + +(** {2 Lwt syntax} *) + +include Lwt.Syntax + +let ( >>= ) = Lwt.Infix.( >>= ) +let ( >|= ) = Lwt.Infix.( >|= ) + +(** {2 Dependency extensions} *) + +module Option = struct + include Option + (** @closed *) + + let of_result = function Ok x -> Some x | Error _ -> None + let might f = function Some x -> f x | None -> Ok () +end + +module List = struct + include List + (** @closed *) + + let rec is_longer_than : type a. int -> a list -> bool = + fun len l -> + if len < 0 then true + else match l with [] -> false | _ :: tl -> is_longer_than (len - 1) tl + + let map f l = + let rec aux acc = function + | [] -> acc [] + | h :: t -> (aux [@tailcall]) (fun t' -> acc (f h :: t')) t + in + aux (fun x -> x) l + + let concat l = + let rec aux acc curr l = + match (curr, l) with + | [], [] -> List.rev acc + | [], [ l ] -> List.rev_append acc l + | [], h :: t -> (aux [@tailcall]) acc h t + | h :: t, l -> (aux [@tailcall]) (h :: acc) t l + in + aux [] [] l + + (* For compatibility with versions older than ocaml.4.11.0 *) + let concat_map f l = + let rec aux f acc = function + | [] -> rev acc + | x :: l -> + let xs = f x in + aux f (rev_append xs acc) l + in + aux f [] l + + let rec mem : type a. equal:(a -> a -> bool) -> a -> a t -> bool = + fun ~equal y -> function + | [] -> false + | x :: xs -> equal x y || mem ~equal y xs + + let rec rev_append_map : type a b. (a -> b) -> a list -> b list -> b list = + fun f xs ys -> + match xs with [] -> ys | x :: xs -> rev_append_map f xs (f x :: ys) + + let insert_exn : type a. a list -> int -> a -> a list = + fun l idx v -> + (* [list_insert l 0 v] is [v :: l] *) + assert (idx >= 0); + let rec aux l i acc = + if i = 0 then List.rev_append acc (v :: l) + else + match l with + | [] -> failwith "list_insert: input list too short" + | hd :: tl -> aux tl (i - 1) (hd :: acc) + in + aux l idx [] +end + +module Mtime = struct + include Mtime + + let span_to_s span = Mtime.Span.to_float_ns span *. 1e-9 + let span_to_us span = Mtime.Span.to_float_ns span *. 1e-3 +end + +module Seq = struct + include Seq + (** @closed *) + + let rec drop : type a. int -> a t -> a t = + fun n l () -> + match l () with + | l' when n = 0 -> l' + | Nil -> Nil + | Cons (_, l') -> drop (n - 1) l' () + + let exists : type a. (a -> bool) -> a Seq.t -> bool = + fun f s -> + let rec aux s = + match s () with Seq.Nil -> false | Seq.Cons (v, s) -> f v || aux s + in + aux s + + let rec take : type a. int -> a t -> a t = + fun n l () -> + if n = 0 then Nil + else match l () with Nil -> Nil | Cons (x, l') -> Cons (x, take (n - 1) l') + + let for_all : type a. (a -> bool) -> a Seq.t -> bool = + fun f s -> + let rec aux s = + match s () with Seq.Nil -> true | Seq.Cons (v, s) -> f v && aux s + in + aux s + + (* For compatibility with versions older than ocaml.4.11.0 *) + let rec append seq1 seq2 () = + match seq1 () with + | Nil -> seq2 () + | Cons (x, next) -> Cons (x, append next seq2) + + (* Since 4.14 *) + let rec for_all2 f xs ys = + match xs () with + | Nil -> true + | Cons (x, xs) -> ( + match ys () with + | Nil -> true + | Cons (y, ys) -> f x y && for_all2 f xs ys) +end + +let shuffle state arr = + let rec aux n = + if n > 1 then ( + let k = Random.State.int state (n + 1) in + let temp = arr.(n) in + arr.(n) <- arr.(k); + arr.(k) <- temp; + aux (n - 1)) + in + let len = Array.length arr in + aux (len - 1); + () diff --git a/src/irmin-lwt/core/indexable.ml b/src/irmin-lwt/core/indexable.ml new file mode 100644 index 0000000000..5f833bea85 --- /dev/null +++ b/src/irmin-lwt/core/indexable.ml @@ -0,0 +1,83 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Indexable_intf + +module Maker_concrete_key2_of_1 (X : Maker_concrete_key1) = struct + type ('h, _) key = 'h X.key + + module Key (H : Hash.S) (_ : Type.S) = X.Key (H) + module Make = X.Make +end + +module Of_content_addressable (Key : Type.S) (S : Content_addressable.S) = +struct + include S + + type hash = key + type key = Key.t + + module Key = struct + include Key + + type nonrec hash = hash + + let to_hash x = x + end + + let index _ h = Lwt.return_some h + let unsafe_add t h v = unsafe_add t h v >|= fun () -> h +end + +module Check_closed_store (CA : S) = struct + module Key = CA.Key + + type 'a t = { closed : bool ref; t : 'a CA.t } + type value = CA.value + type key = CA.key + type hash = CA.hash + + let make_closeable t = { closed = ref false; t } + + let get_if_open_exn t = + if !(t.closed) then raise Store_properties.Closed else t.t + + let mem t k = (get_if_open_exn t |> CA.mem) k + let index t h = (get_if_open_exn t |> CA.index) h + let find t k = (get_if_open_exn t |> CA.find) k + let add t v = (get_if_open_exn t |> CA.add) v + let unsafe_add t k v = (get_if_open_exn t |> CA.unsafe_add) k v + + let batch t f = + (get_if_open_exn t |> CA.batch) (fun w -> f { t = w; closed = t.closed }) + + let close t = + if !(t.closed) then Lwt.return_unit + else ( + t.closed := true; + CA.close t.t) +end + +module Check_closed (M : Maker) (Hash : Hash.S) (Value : Type.S) = struct + module CA = M (Hash) (Value) + include Check_closed_store (CA) + + let v conf = + let+ t = CA.v conf in + { closed = ref false; t } +end diff --git a/src/irmin-lwt/core/indexable.mli b/src/irmin-lwt/core/indexable.mli new file mode 100644 index 0000000000..df5168c32a --- /dev/null +++ b/src/irmin-lwt/core/indexable.mli @@ -0,0 +1,19 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Indexable_intf.Sigs +(** @inline *) diff --git a/src/irmin-lwt/core/indexable_intf.ml b/src/irmin-lwt/core/indexable_intf.ml new file mode 100644 index 0000000000..e7c084e8a2 --- /dev/null +++ b/src/irmin-lwt/core/indexable_intf.ml @@ -0,0 +1,149 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Store_properties + +module type S_without_key_impl = sig + include Read_only.S + (** @inline *) + + type hash + (** The type of hashes of [value]. *) + + val add : [> write ] t -> value -> key Lwt.t + (** Write the contents of a value to the store, and obtain its key. *) + + val unsafe_add : [> write ] t -> hash -> value -> key Lwt.t + (** Same as {!add} but allows specifying the value's hash directly. The + backend might choose to discard that hash and/or can be corrupt if the + hash is not consistent. *) + + val index : [> read ] t -> hash -> key option Lwt.t + (** Indexing maps the hash of a value to a corresponding key of that value in + the store. For stores that are addressed by hashes directly, this is + typically [fun _t h -> Lwt.return (Key.of_hash h)]; for stores with more + complex addressing schemes, [index] may attempt a lookup operation in the + store. + + In general, indexing is best-effort and reveals no information about the + membership of the value in the store. In particular: + + - [index t hash = Some key] doesn't guarantee [mem t key]: the value with + hash [hash] may still be absent from the store; + + - [index t hash = None] doesn't guarantee that there is no [key] such that + [mem t key] and [Key.to_hash key = hash]: the value may still be present + in the store under a key that is not indexed. *) + + include Batch with type 'a t := 'a t + (** @inline *) +end + +module type S = sig + (** An {i indexable} store is a read-write store in which values can be added + and later found via their keys. + + Keys are not necessarily portable between different stores, so each store + provides an {!val-index} mechanism to find keys by the hashes of the + values they reference. *) + + include S_without_key_impl (* @inline *) + module Key : Key.S with type t = key and type hash = hash +end + +module type Maker = functor (Hash : Hash.S) (Value : Type.S) -> sig + include S with type value = Value.t and type hash = Hash.t + + include Of_config with type 'a t := 'a t + (** @inline *) +end + +(** A {!Maker_concrete_key} is an indexable store in which the key type is + uniquely determined by the hash type and is stated up-front. *) +module type Maker_concrete_key1 = sig + type 'h key + + module Key : functor (Hash : Hash.S) -> + Key.S with type t = Hash.t key and type hash = Hash.t + + module Make : functor (Hash : Hash.S) (Value : Type.S) -> sig + include + S + with type value = Value.t + and type hash = Hash.t + and type key = Hash.t key + + include Of_config with type 'a t := 'a t + (** @inline *) + end +end + +(** Like {!Maker_concrete_key1}, but the key type may also depend on type of the + value that it references. *) +module type Maker_concrete_key2 = sig + type ('h, 'v) key + + module Key : functor (Hash : Hash.S) (Value : Type.S) -> + Key.S with type t = (Hash.t, Value.t) key and type hash = Hash.t + + module Make : functor (Hash : Hash.S) (Value : Type.S) -> sig + include + S + with type value = Value.t + and type hash = Hash.t + and type key = (Hash.t, Value.t) key + + include Of_config with type 'a t := 'a t + (** @inline *) + end +end + +module type Sigs = sig + module type S = S + module type S_without_key_impl = S_without_key_impl + module type Maker = Maker + module type Maker_concrete_key1 = Maker_concrete_key1 + module type Maker_concrete_key2 = Maker_concrete_key2 + + module Maker_concrete_key2_of_1 (X : Maker_concrete_key1) : + Maker_concrete_key2 with type ('h, _) key = 'h X.key + + module Of_content_addressable + (Key : Type.S) + (S : Content_addressable.S with type key = Key.t) : + S + with type 'a t = 'a S.t + and type key = Key.t + and type hash = Key.t + and type value = S.value + + module Check_closed_store (CA : S) : sig + include + S with type key = CA.key and type hash = CA.hash and type value = CA.value + + val make_closeable : 'a CA.t -> 'a t + (** [make_closeable t] returns a version of [t] that raises {!Irmin.Closed} + if an operation is performed when it is already closed. *) + + val get_if_open_exn : 'a t -> 'a CA.t + (** [get_if_open_exn t] returns the store (without close checks) if it is + open; otherwise raises {!Irmin.Closed} *) + end + + module Check_closed (M : Maker) : Maker +end diff --git a/src/irmin-lwt/core/info.ml b/src/irmin-lwt/core/info.ml new file mode 100644 index 0000000000..aed7cf81b1 --- /dev/null +++ b/src/irmin-lwt/core/info.ml @@ -0,0 +1 @@ +include Irmin.Info diff --git a/src/irmin-lwt/core/irmin_lwt.ml b/src/irmin-lwt/core/irmin_lwt.ml new file mode 100644 index 0000000000..b8133cef3c --- /dev/null +++ b/src/irmin-lwt/core/irmin_lwt.ml @@ -0,0 +1,138 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +module Type = Repr +module Metrics = Metrics +module Diff = Diff +module Read_only = Read_only +module Append_only = Append_only +module Indexable = Indexable +module Content_addressable = Content_addressable +module Atomic_write = Atomic_write +module Contents = Contents +module Merge = Merge +module Branch = Branch +module Node = Node +module Commit = Commit +module Info = Info +module Schema = Schema +module Dot = Dot.Make +module Hash = Hash +module Path = Path +module Perms = Perms +module Key = Key +module Irmin_node = Node + +exception Closed = Store_properties.Closed + +(* [Generic_key.Maker] (a functor producing a [Generic_key.S] from four + per-store sub-Makers) is intentionally not exposed: the only way to route + it through Irmin 4 is to bridge each user-supplied Lwt sub-Maker to its + Eio counterpart, which forces every operation through a Lwt -> Eio -> Lwt + round-trip. The functor was unused in [irmin-lwt]'s own surface (backends + like [irmin-lwt-pack] implement the [Generic_key.Maker] signature + directly via [Wrap_store.Make]). The module type [Generic_key.Maker] + stays exposed because backends use it as their public signature; only + the functor implementation is gone. See LIMITATIONS.md. *) + +module Maker (CA : Content_addressable.Maker) (AW : Atomic_write.Maker) = struct + type endpoint = unit + type ('h, _) contents_key = 'h + type 'h node_key = 'h + type 'h commit_key = 'h + + module Make (S : Schema.S) = Maker_v2.Make (CA) (AW) (S) +end + +module KV_maker (CA : Content_addressable.Maker) (AW : Atomic_write.Maker) = +struct + type metadata = unit + type hash = Schema.default_hash + type info = Info.default + + module Maker = Maker (CA) (AW) + include Maker + module Make (C : Contents.S) = Maker.Make (Schema.KV (C)) +end + +(* [Of_backend] is intentionally not exposed: routing a Lwt-typed [Backend.S] + through Irmin 4 (Eio) would require ~400 lines of sub-store bridges with + per-op overhead, and no application user of [irmin-lwt] needs the entry + point. See [irmin_lwt.mli] for the rationale and the recommended + workaround for users who do need a custom backend. *) + +module type Tree = Tree.S +module type S = Store.S + +type config = Conf.t +type 'a diff = 'a Diff.t + +module type Maker = Store.Maker +module type KV = Store.KV +module type KV_maker = Store.KV_maker + +module Generic_key = struct + include Store.Generic_key +end + +module Backend = struct + module Conf = Conf + module Slice = Slice + module Remote = Remote + + module type S = Backend.S + + module Watch = Watch + module Lock = Lock + module Lru = Lru +end + +let version = Irmin.version + +module Sync = Sync + +type remote = Remote.t = .. + +let remote_store (type t) (module M : Generic_key.S with type t = t) (t : t) = + let module X : Store.Generic_key.S with type t = t = M in + Sync.remote_store (module X) t + +module Metadata = Metadata +module Json_tree = Store.Json_tree +module Export_for_backends = Export_for_backends +module Storage = Storage + +module Of_storage (M : Storage.Make) (H : Hash.S) (V : Contents.S) = struct + module CA = Storage.Content_addressable (M) + module AW = Storage.Atomic_write (M) + module Maker = Maker (CA) (AW) + + include Maker.Make (struct + module Hash = H + module Contents = V + module Info = Info.Default + module Metadata = Metadata.None + module Path = Path.String_list + module Branch = Branch.String + module Node = Node.Make (Hash) (Path) (Metadata) + module Commit = Commit.Make (Hash) + end) +end + +(* Shim helpers exposed for downstream backend packages. *) +module Lwt_to_eio = Lwt_to_eio +module Wrap_store = Wrap_store diff --git a/src/irmin-lwt/core/irmin_lwt.mli b/src/irmin-lwt/core/irmin_lwt.mli new file mode 100644 index 0000000000..15a4f7a49a --- /dev/null +++ b/src/irmin-lwt/core/irmin_lwt.mli @@ -0,0 +1,542 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** The {!Irmin} module provides a common interface and types used by all + backends. + + The prinicipal concept is the {i store} (see {!S}), which provides access to + persistently stored values, commits and branches. *) + +val version : string +(** The version of the library. *) + +(** {1:stores Stores} + + An Irmin store is a branch-consistent store where keys are lists of steps. + + An example is a Git repository where keys are filenames, {e i.e.} lists of + ['/']-separated strings. More complex examples are structured values, where + steps might contain first-class field accessors and array offsets. + + Irmin provides the following features: + + - Support for fast clones, branches and merges, in a fashion very similar to + Git. + - Efficient staging areas for fast, transient, in-memory operations. + - Fast {{!Sync} synchronization} primitives between remote stores, using + native backend protocols (as the Git protocol) when available. *) + +exception Closed +(** The exception raised when any operation is attempted on a closed store, + except for {!S.close}, which is idempotent. *) + +(** Irmin stores. *) +module type S = sig + include Store.S + (** @inline *) +end + +(** {2 Schema} *) + +module Type = Repr +(** Dynamic types for Irmin values, supplied by + {{:https://github.com/mirage/repr} [Repr]}. These values can be derived from + type definitions via [[@@deriving irmin]] (see the + {{:https://github.com/mirage/irmin/blob/main/README_PPX.md} documentation + for [ppx_irmin]})*) + +module Hash = Hash +(** Hashing functions. + + [Hash] provides user-defined hash functions to digest serialized contents. + Some {{!backend} backends} might be parameterized by such hash functions, + others might work with a fixed one (for instance, the Git format uses only + {{!Hash.SHA1} SHA1}). + + A {{!Hash.SHA1} SHA1} implementation is available to pass to the backends. +*) + +module Branch = Branch + +module Info = Info +(** Commit info are used to keep track of the origin of write operations in the + stores. [Info] models the metadata associated with commit objects in Git. *) + +module Node = Node +module Commit = Commit + +module Metadata = Metadata +(** [Metadata] defines metadata that is attached to contents but stored in + nodes. For instance, the Git backend uses this to indicate the type of file + (normal, executable or symlink). *) + +module Path = Path +(** Store paths. + + An Irmin {{!Irmin.S} store} binds {{!Path.S.t} paths} to user-defined + {{!Contents.S} contents}. Paths are composed by basic elements, that we call + {{!Path.S.step} steps}. The following [Path] module provides functions to + manipulate steps and paths. *) + +module Contents = Contents +(** [Contents] specifies how user-defined contents need to be {e serializable} + and {e mergeable}. + + The user needs to provide: + + - a type [t] to be used as store contents. + - a value type for [t] (built using the {{!Irmin.Type} Irmin.Type} + combinators). + - a 3-way [merge] function, to handle conflicts between multiple versions of + the same contents. + + Default implementations for {{!Contents.String} idempotent string} and + {{!Contents.Json} JSON} contents are provided. *) + +module Schema = Schema +(** Store schemas *) + +(** {2 Common Stores} *) + +(** [KV] is similar to {!S} but chooses sensible implementations for path and + branch. *) +module type KV = sig + include Store.KV + (** @inline *) +end + +module Json_tree : Store.Json_tree + +(** {2 Creating Stores} *) + +(** [Maker] is the signature exposed by any backend providing {!S} + implementations. {!Maker.Make} is parameterised by {!Schema.S}. It does not + use any native synchronization primitives. *) +module type Maker = sig + include Store.Maker + (** @inline *) +end + +(** [KV_maker] is like {!Maker} but where everything except the contents is + replaced by sensible default implementations. {!KV_maker.Make} is + parameterised by {!Contents.S} *) +module type KV_maker = sig + include Store.KV_maker + (** @inline *) +end + +(** {2 Generic Key Stores} *) + +module Key = Key + +(** "Generic key" stores are Irmin stores in which the backend may not be keyed + directly by the hashes of stored values. See {!Key} for more details. *) +module Generic_key : sig + include module type of Store.Generic_key + (** @inline *) +end + +(** {3 [Generic_key.Maker] functor is not exposed in [irmin-lwt]} + + [Irmin.Generic_key.Maker (X)] takes four per-store sub-Makers (one for each + of [Contents_store], [Node_store], [Commit_store], [Branch_store]) and + produces a [Maker] keyed by whatever the user-supplied sub-Makers want — + used by backends with non-hash keys like [Pack_key.t]. + + [irmin-lwt] does not expose this functor. The only way to route + user-supplied Lwt sub-Makers through Irmin 4 is to bridge each one to its + Eio counterpart, which forces every store operation through a Lwt -> Eio -> + Lwt round-trip. No application user of [irmin-lwt] needs the functor: in the + wider Irmin codebase, only two test files invoke it directly, and backends + like [irmin-lwt-pack] implement the [Generic_key.Maker] {b signature} by + hand using {!Wrap_store.Make} rather than instantiating the functor. + + The {b module type} [Generic_key.Maker] above is still exposed: it is the + public signature that backends like [irmin-lwt-pack] satisfy. Only the + functor implementation is removed. + + Backend authors with custom keyed Lwt sub-Makers should: + + - implement their backend against [Irmin]'s direct-style + [Generic_key.Maker (X)] (Eio-typed) and apply {!Wrap_store.Make} to lift + the result back to the Lwt surface; or + - follow the pattern used by [irmin-lwt-pack.Maker]: write a hand-rolled + [Maker] that satisfies [Generic_key.Maker] and delegates to + [Wrap_store.Make] internally. *) + +(** {1 Backends} + + A backend is an implementation exposing either a concrete implementation of + {!S} or a functor providing {!S} once applied. *) + +type config = Conf.t +(** The type for backend-specific configuration values. + + Every backend has different configuration options, which are kept abstract + to the user. *) + +(** {2 Low-level Stores} *) + +(** An Irmin backend is built from a number of lower-level stores, each + implementing fewer operations, such as + {{!Content_addressable.Store} content-addressable} and + {{!Atomic_write.Store} atomic-write} stores. *) + +module Read_only = Read_only +(** Read-only backend backends. *) + +module Append_only = Append_only +(** Append-only backend backends. *) + +module Indexable = Indexable +(** Indexable backend backends. *) + +module Content_addressable = Content_addressable +(** Content-addressable backends. *) + +module Atomic_write = Atomic_write +(** Atomic-write stores. *) + +(** [Maker] uses the same type for all internal keys and store all the values in + the same store. *) +module Maker (CA : Content_addressable.Maker) (AW : Atomic_write.Maker) : + Maker with type endpoint = unit + +(** [KV_maker] is like {!module-Maker} but uses sensible default implementations + for everything except the contents type. *) +module KV_maker (CA : Content_addressable.Maker) (AW : Atomic_write.Maker) : + KV_maker + with type endpoint = unit + and type metadata = unit + and type info = Info.default + +(** {2 Backend} *) + +(** [Backend] defines functions only useful for creating new backends. If you + are just using the library (and not developing a new backend), you should + not use this module. *) +module Backend : sig + module Conf : module type of Conf + (** Backend configuration. + + A backend configuration is a set of {{!keys} keys} mapping to typed + values. Backends define their own keys. *) + + module Watch = Watch + module Lock = Lock + module Lru = Lru + module Slice = Slice + module Remote = Remote + + module type S = Backend.S + (** The modules that define a complete Irmin backend. *) +end + +(** {3 [Of_backend] is not supported in [irmin-lwt]} + + Irmin's [Of_backend] takes a hand-rolled [Backend.S] (Contents store, Node + store, Commit store, Branch store, Slice, Remote, Repo) and produces a full + store. The [irmin-lwt] shim does not expose [Of_backend]: routing a + user-supplied Lwt-typed [Backend.S] through Irmin 4 would require an + extensive Lwt -> Eio adapter for every sub-store (~400 lines of bridges that + exist nowhere else and pay a runtime cost on every operation), and no + application user of [irmin-lwt] needs this entry point — only three internal + Irmin packages ([irmin-git], [irmin-client], [irmin-pack-mem]) use it, none + of which are in the [irmin-lwt] roadmap. + + Users wanting to expose a custom backend on the Lwt API should: + + - implement their backend against [Irmin]'s direct-style [Backend.S] + (Eio-typed) and apply [Irmin.Of_backend] there, then wrap the resulting + [Generic_key.S] back to the Lwt surface using [Wrap_store.Make]; or + - use the higher-level [Maker] / [Generic_key.Maker] / [Storage.Make] entry + points below, which are supported. *) + +(** {2 Storage} *) + +module Storage = Storage +(** [Storage] provides {!Storage.Make} for defining a custom storage layer that + can be used to create Irmin stores. Unlike {!Backend.S}, an implementation + of {!Storage.Make} is only concerned with storing and retrieving keys and + values. It can be used to create stores for {!Backend.S} through something + like {!Storage.Content_addressable} or, primarily, with {!Of_storage} to + automatically construct an Irmin store. *) + +(** [Of_storage] uses a custom storage layer and chosen hash and contents type + to create a key-value store. *) +module Of_storage (M : Storage.Make) (H : Hash.S) (V : Contents.S) : + KV with type hash = H.t and module Schema.Contents = V + +(** {2 Helpers} *) + +module Perms = Perms + +module Export_for_backends = Export_for_backends +(** Helper module containing useful top-level types for defining Irmin backends. + This module is relatively unstable. *) + +(** {1 Advanced} *) + +(** {2 Custom Merge Operators} *) + +module Merge = Merge +(** [Merge] provides functions to build custom 3-way merge operators for various + user-defined contents. *) + +module Diff = Diff +(** Differences between values. *) + +type 'a diff = 'a Diff.t +(** The type for representing differences betwen values. *) + +(** {3 Example} *) + +(** The complete code for the following can be found in + [examples/custom_merge.ml]. + + We will demonstrate the use of custom merge operators by defining mergeable + debug log files. We first define a log entry as a pair of a timestamp and a + message, using the combinator exposed by {!Irmin.Type}: + + {[ + open Lwt.Infix + open Astring + + let time = ref 0L + let failure fmt = Fmt.kstr failwith fmt + + (* A log entry *) + module Entry : sig + include Irmin.Type.S + + val v : string -> t + val timestamp : t -> int64 + end = struct + type t = { timestamp : int64; message : string } [@@deriving irmin] + + let compare x y = Int64.compare x.timestamp y.timestamp + + let v message = + time := Int64.add 1L !time; + { timestamp = !time; message } + + let timestamp t = t.timestamp + + let pp ppf { timestamp; message } = + Fmt.pf ppf "%04Ld: %s" timestamp message + + let of_string str = + match String.cut ~sep:": " str with + | None -> Error (`Msg ("invalid entry: " ^ str)) + | Some (x, message) -> ( + try Ok { timestamp = Int64.of_string x; message } + with Failure e -> Error (`Msg e)) + + let t = Irmin.Type.like ~pp ~of_string ~compare t + end + ]} + + A log file is a list of entries (one per line), ordered by decreasing order + of timestamps. The 3-way [merge] operator for log files concatenates and + sorts the new entries and prepend them to the common ancestor's ones. + + {[ + (* A log file *) + module Log : sig + include Irmin.Contents.S + + val add : t -> Entry.t -> t + val empty : t + end = struct + type t = Entry.t list [@@deriving irmin] + + let empty = [] + let pp_entry = Irmin.Type.pp Entry.t + let lines ppf l = List.iter (Fmt.pf ppf "%a\n" pp_entry) (List.rev l) + + let of_string str = + let lines = String.cuts ~empty:false ~sep:"\n" str in + try + List.fold_left + (fun acc l -> + match Irmin.Type.of_string Entry.t l with + | Ok x -> x :: acc + | Error (`Msg e) -> failwith e) + [] lines + |> fun l -> Ok l + with Failure e -> Error (`Msg e) + + let t = Irmin.Type.like ~pp:lines ~of_string t + let timestamp = function [] -> 0L | e :: _ -> Entry.timestamp e + + let newer_than timestamp file = + let rec aux acc = function + | [] -> List.rev acc + | h :: _ when Entry.timestamp h <= timestamp -> List.rev acc + | h :: t -> aux (h :: acc) t + in + aux [] file + + let merge ~old t1 t2 = + let open Irmin.Merge.Infix in + old () >>=* fun old -> + let old = match old with None -> [] | Some o -> o in + let ts = timestamp old in + let t1 = newer_than ts t1 in + let t2 = newer_than ts t2 in + let t3 = + List.sort (Irmin.Type.compare Entry.t) (List.rev_append t1 t2) + in + Irmin.Merge.ok (List.rev_append t3 old) + + let merge = Irmin.Merge.(option (v t merge)) + let add t e = e :: t + end + ]} + + {b Note:} The serialisation primitives used in that example are not very + efficient in this case as they parse the file every time. For real usage, + you would write buffered versions of [Log.pp] and [Log.of_string]. + + To persist the log file on disk, we need to choose a backend. We show here + how to use the on-disk [Git] backend on Unix. + + {[ + (* Build an Irmin store containing log files. *) + module Store = Irmin_unix.Git.FS.KV (Log) + + (* Set-up the local configuration of the Git repository. *) + let config = Irmin_git.config ~bare:true Config.root + + (* Convenient alias for the info function for commit messages *) + let info = Irmin_unix.info + ]} + + We can now define a toy example to use our mergeable log files. + + {[ + let log_file = [ "local"; "debug" ] + + let all_logs t = + Store.find t log_file >|= function None -> Log.empty | Some l -> l + + (** Persist a new entry in the log. Pretty inefficient as it reads/writes + the whole file every time. *) + let log t fmt = + Printf.ksprintf + (fun message -> + all_logs t >>= fun logs -> + let logs = Log.add logs (Entry.v message) in + Store.set_exn t ~info:(info "Adding a new entry") log_file logs) + fmt + + let print_logs name t = + all_logs t >|= fun logs -> + Fmt.pr "-----------\n%s:\n-----------\n%a%!" name (Irmin.Type.pp Log.t) + logs + + let main () = + Config.init (); + Store.Repo.v config >>= fun repo -> + Store.main repo >>= fun t -> + (* populate the log with some random messages *) + Lwt_list.iter_s + (fun msg -> log t "This is my %s " msg) + [ "first"; "second"; "third" ] + >>= fun () -> + Printf.printf "%s\n\n" what; + print_logs "lca" t >>= fun () -> + Store.clone ~src:t ~dst:"test" >>= fun x -> + log x "Adding new stuff to x" >>= fun () -> + log x "Adding more stuff to x" >>= fun () -> + log x "More. Stuff. To x." >>= fun () -> + print_logs "branch 1" x >>= fun () -> + log t "I can add stuff on t also" >>= fun () -> + log t "Yes. On t!" >>= fun () -> + print_logs "branch 2" t >>= fun () -> + Store.merge_into ~info:(info "Merging x into t") x ~into:t >>= function + | Ok () -> print_logs "merge" t + | Error _ -> failwith "conflict!" + + let () = Lwt_main.run (main ()) + ]} *) + +(** {2 Synchronization} *) + +type remote = Remote.t = .. +(** The type for remote stores. *) + +val remote_store : (module Generic_key.S with type t = 'a) -> 'a -> remote +(** [remote_store t] is the remote corresponding to the local store [t]. + Synchronization is done by importing and exporting store + {{!BC.slice} slices}, so this is usually much slower than native + synchronization using {!Store.remote} but it works for all backends. *) + +module Sync = Sync +(** Remote synchronisation. *) + +(** {3 Example} *) + +(** A simple synchronization example, using the {{!Irmin_unix.Git} Git} backend + and the {!Sync} helpers. The code clones a fresh repository if the + repository does not exist locally, otherwise it performs a fetch: in this + case, only the missing contents are downloaded. + + The complete code for the following can be found in [examples/sync.ml]. + + {[ + open Lwt.Infix + module S = Irmin_unix.Git.FS.KV (Irmin.Contents.String) + module Sync = Irmin.Sync (S) + + let config = Irmin_git.config "/tmp/test" + + let upstream = + if Array.length Sys.argv = 2 then + Uri.of_string (Store.remote Sys.argv.(1)) + else ( + Printf.eprintf "Usage: sync [uri]\n%!"; + exit 1) + + let test () = + S.Repo.v config >>= S.main >>= fun t -> + Sync.pull_exn t upstream `Set >>= fun () -> + S.get t [ "README.md" ] >|= fun r -> Printf.printf "%s\n%!" r + + let () = Lwt_main.run (test ()) + ]} *) + +(** {1 Helpers} *) + +(** [Dot] provides functions to export a store to the Graphviz `dot` format. *) +module Dot (S : Generic_key.S) : Dot.S with type db = S.t + +module Metrics = Metrics +(** Type agnostics mechanisms to manipulate metrics. *) + +(** {1 Shim helpers} + + Exposed for downstream packages that wrap an Irmin 4 backend in a Lwt-typed + surface (for instance [irmin-lwt-mem], [irmin-lwt-pack]). *) + +module Lwt_to_eio = Lwt_to_eio +(** Adapter functors from Lwt-typed signatures to Irmin 4's Eio-typed + counterparts (and back, for [merge_of_eio]). *) + +module Wrap_store = Wrap_store +(** [Wrap_store.Make (S) (Schema_eio) (Inner)] takes an Eio-typed + [Generic_key.S] [Inner] whose schema is the Eio-bridged version of the + user's Lwt-typed [Schema.S] and produces the Lwt-typed [Store.S] surface. *) diff --git a/src/irmin-lwt/core/key.ml b/src/irmin-lwt/core/key.ml new file mode 100644 index 0000000000..942c555853 --- /dev/null +++ b/src/irmin-lwt/core/key.ml @@ -0,0 +1 @@ +include Irmin.Key diff --git a/src/irmin-lwt/core/lock.ml b/src/irmin-lwt/core/lock.ml new file mode 100644 index 0000000000..6cd3f5a0ab --- /dev/null +++ b/src/irmin-lwt/core/lock.ml @@ -0,0 +1,66 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type S = sig + type key + type t + + val v : unit -> t + val with_lock : t -> key -> (unit -> 'a Lwt.t) -> 'a Lwt.t + val stats : t -> int +end + +module Make (K : Type.S) = struct + module K = struct + type t = K.t + + let hash = Hashtbl.hash + let equal = Type.(unstage (equal K.t)) + end + + module KHashtbl = Hashtbl.Make (K) + + type key = K.t + type t = { global : Lwt_mutex.t; locks : Lwt_mutex.t KHashtbl.t } + + let v () = { global = Lwt_mutex.create (); locks = KHashtbl.create 1024 } + let stats t = KHashtbl.length t.locks + + let lock t key () = + let lock = + try KHashtbl.find t.locks key + with Not_found -> + let lock = Lwt_mutex.create () in + KHashtbl.add t.locks key lock; + lock + in + Lwt.return lock + + let unlock t key () = + let () = + if KHashtbl.mem t.locks key then + let lock = KHashtbl.find t.locks key in + if Lwt_mutex.is_empty lock then KHashtbl.remove t.locks key + in + Lwt.return_unit + + let with_lock t k fn = + let* lock = Lwt_mutex.with_lock t.global (lock t k) in + let* r = Lwt_mutex.with_lock lock fn in + Lwt_mutex.with_lock t.global (unlock t k) >>= fun () -> Lwt.return r +end diff --git a/src/irmin-lwt/core/lock.mli b/src/irmin-lwt/core/lock.mli new file mode 100644 index 0000000000..718b6db22b --- /dev/null +++ b/src/irmin-lwt/core/lock.mli @@ -0,0 +1,37 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** {1 Process locking helpers} *) + +module type S = sig + type t + (** The type for lock manager. *) + + type key + (** The type for key to be locked. *) + + val v : unit -> t + (** Create a lock manager. *) + + val with_lock : t -> key -> (unit -> 'a Lwt.t) -> 'a Lwt.t + (** [with_lock t k f] executes [f ()] while holding the exclusive lock + associated to the key [k]. *) + + val stats : t -> int +end + +(** Create a lock manager implementation. *) +module Make (K : Type.S) : S with type key = K.t diff --git a/src/irmin-lwt/core/lru.ml b/src/irmin-lwt/core/lru.ml new file mode 100644 index 0000000000..79fb7f7edc --- /dev/null +++ b/src/irmin-lwt/core/lru.ml @@ -0,0 +1,155 @@ +(* + Copyright (c) 2016 David Kaloper Meršinjak + Copyright (c) 2013-2022 Thomas Gazagnaire + + Permission to use, copy, modify, and/or distribute this software for any + purpose with or without fee is hereby granted, provided that the above + copyright notice and this permission notice appear in all copies. + + THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) + +(* Extracted from https://github.com/pqwy/lru *) + +module Make (H : Hashtbl.HashedType) = struct + module HT = Hashtbl.Make (H) + + module Q = struct + type 'a node = { + value : 'a; + mutable next : 'a node option; + mutable prev : 'a node option; + } + + type 'a t = { + mutable first : 'a node option; + mutable last : 'a node option; + } + + let detach t n = + let np = n.prev and nn = n.next in + (match np with + | None -> t.first <- nn + | Some x -> + x.next <- nn; + n.prev <- None); + match nn with + | None -> t.last <- np + | Some x -> + x.prev <- np; + n.next <- None + + let append t n = + let on = Some n in + match t.last with + | Some x as l -> + x.next <- on; + t.last <- on; + n.prev <- l + | None -> + t.first <- on; + t.last <- on + + let node x = { value = x; prev = None; next = None } + let create () = { first = None; last = None } + + let iter t f = + let rec aux f = function + | Some n -> + let next = n.next in + f n.value; + aux f next + | _ -> () + in + aux f t.first + + let clear t = + t.first <- None; + t.last <- None + end + + type key = HT.key + + type 'a t = { + ht : (key * 'a) Q.node HT.t; + q : (key * 'a) Q.t; + mutable cap : cap; + mutable w : int; + } + + and cap = Uncapped | Capped of int + + let weight t = t.w + + let create cap = + let cap, ht_cap = + if cap < 0 then (Uncapped, 65536) else (Capped cap, cap) + in + { cap; w = 0; ht = HT.create ht_cap; q = Q.create () } + + let drop t = + match t.q.first with + | None -> None + | Some ({ Q.value = k, v; _ } as n) -> + t.w <- t.w - 1; + HT.remove t.ht k; + Q.detach t.q n; + Some v + + let remove t k = + try + let n = HT.find t.ht k in + t.w <- t.w - 1; + HT.remove t.ht k; + Q.detach t.q n + with Not_found -> () + + let add t k v = + let add t k v = + remove t k; + let n = Q.node (k, v) in + t.w <- t.w + 1; + HT.add t.ht k n; + Q.append t.q n + in + match t.cap with + | Capped c when c = 0 -> () + | Uncapped -> add t k v + | Capped c -> + add t k v; + if weight t > c then + let _ = drop t in + () + + let promote t k = + try + let n = HT.find t.ht k in + Q.( + detach t.q n; + append t.q n) + with Not_found -> () + + let find t k = + let v = HT.find t.ht k in + promote t k; + snd v.value + + let mem t k = + match HT.mem t.ht k with + | false -> false + | true -> + promote t k; + true + + let iter t f = Q.iter t.q (fun (k, v) -> f k v) + + let clear t = + t.w <- 0; + HT.clear t.ht; + Q.clear t.q +end diff --git a/src/irmin-lwt/core/lru.mli b/src/irmin-lwt/core/lru.mli new file mode 100644 index 0000000000..f3ea5736eb --- /dev/null +++ b/src/irmin-lwt/core/lru.mli @@ -0,0 +1,28 @@ +(* + Copyright (c) 2016 David Kaloper Meršinjak + + Permission to use, copy, modify, and/or distribute this software for any + purpose with or without fee is hereby granted, provided that the above + copyright notice and this permission notice appear in all copies. + + THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) + +(* Extracted from https://github.com/pqwy/lru *) + +module Make (H : Hashtbl.HashedType) : sig + type 'a t + + val create : int -> 'a t + val add : 'a t -> H.t -> 'a -> unit + val find : 'a t -> H.t -> 'a + val mem : 'a t -> H.t -> bool + val clear : 'a t -> unit + val iter : 'a t -> (H.t -> 'a -> unit) -> unit + val drop : 'a t -> 'a option +end diff --git a/src/irmin-lwt/core/lwt_to_eio.ml b/src/irmin-lwt/core/lwt_to_eio.ml new file mode 100644 index 0000000000..0a4b86dc6e --- /dev/null +++ b/src/irmin-lwt/core/lwt_to_eio.ml @@ -0,0 +1,313 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Adapter functors: take a Lwt-typed backend Maker (Content_addressable or + Atomic_write), produce the Irmin 4 (Eio-typed) counterpart by bridging each + operation through {!Lwt_eio.Promise.await_lwt}. Used to feed user-supplied + Lwt backends into Irmin 4 functors like {!Irmin.Maker}. *) + +let await = Lwt_eio.Promise.await_lwt + +(* Alias the outer [Schema] module so the local [Schema] functor below + doesn't shadow it when later definitions need to reference its module + types (e.g. [Schema_extended] referring to [Schema.S]). *) +module Schema_intf = Schema + +(* Same trick for [Atomic_write]: we define a local functor of that name below, + so we keep an alias for the outer module's [.S] signature. *) +module Atomic_write_intf = Atomic_write + +(** Bridge an Irmin 4 (Eio-typed) merge function into our Lwt-typed {!Merge.t}. + Takes the type descriptor explicitly because [Merge.f] only exposes the + merge function, not its underlying type. *) +let merge_of_eio (type_desc : 'a Type.t) (m : 'a Irmin.Merge.t) : 'a Merge.t = + let f ~old a b = + Lwt_eio.run_eio (fun () -> + let old_eio () = await (old ()) in + Irmin.Merge.f m ~old:old_eio a b) + in + Merge.v type_desc f + +(** Reverse bridge: take our Lwt-typed merge function and produce an Irmin 4 + (Eio-typed) one. Used when the user provides a custom [Contents.S] or + [Metadata.S] whose merge needs to be passed to Irmin's functors. *) +let merge_to_eio (type_desc : 'a Type.t) (m : 'a Merge.t) : 'a Irmin.Merge.t = + let f ~old a b = + let old_lwt () = Lwt_eio.run_eio (fun () -> old ()) in + await (Merge.f m ~old:old_lwt a b) + in + Irmin.Merge.v type_desc f + +(** Lift a Lwt-typed [Metadata.S] to its Irmin 4 counterpart by bridging the + [merge] field through {!merge_to_eio}. Used when feeding a user's Schema + into Irmin.Maker which expects an Irmin.Schema.S. *) +module Metadata (M : Metadata.S) : Irmin.Metadata.S with type t = M.t = struct + type t = M.t + + let t = M.t + let default = M.default + let merge = merge_to_eio M.t M.merge +end + +(** Same idea for [Contents.S]. *) +module Contents (C : Contents.S) : Irmin.Contents.S with type t = C.t = struct + type t = C.t + + let t = C.t + let merge = merge_to_eio Type.(option C.t) C.merge +end + +(** Reverse direction: lift an Irmin 4 (Eio-typed) [Indexable.S] into our + Lwt-typed counterpart by bridging each I/O operation through + {!Lwt_eio.run_eio}. The [v] / [batch] operations are not in [S] (they come + from [Of_config] / the backend's [Repo]), so they are not part of the + adapter; the user is expected to wrap them at their call site. *) +module Indexable_of_eio (M : Irmin.Indexable.S) : + Indexable.S + with type 'a t = 'a M.t + and type key = M.key + and type hash = M.hash + and type value = M.value + and module Key = M.Key = struct + type 'a t = 'a M.t + type key = M.key + type hash = M.hash + type value = M.value + + module Key = M.Key + + let mem t k = Lwt_eio.run_eio (fun () -> M.mem t k) + let find t k = Lwt_eio.run_eio (fun () -> M.find t k) + let add t v = Lwt_eio.run_eio (fun () -> M.add t v) + let unsafe_add t h v = Lwt_eio.run_eio (fun () -> M.unsafe_add t h v) + let index t h = Lwt_eio.run_eio (fun () -> M.index t h) + let close t = Lwt_eio.run_eio (fun () -> M.close t) + let batch t f = Lwt_eio.run_eio (fun () -> M.batch t (fun rw -> await (f rw))) +end + +(** Eio -> Lwt adapter for [Atomic_write.S]. Used to wrap + [Inner.Backend.Branch]. *) +module Atomic_write_of_eio (M : Irmin.Atomic_write.S) : + Atomic_write.S + with type t = M.t + and type key = M.key + and type value = M.value + and type watch = M.watch = struct + type t = M.t + type key = M.key + type value = M.value + type watch = M.watch + + let mem t k = Lwt_eio.run_eio (fun () -> M.mem t k) + let find t k = Lwt_eio.run_eio (fun () -> M.find t k) + let set t k v = Lwt_eio.run_eio (fun () -> M.set t k v) + + let test_and_set t k ~test ~set = + Lwt_eio.run_eio (fun () -> M.test_and_set t k ~test ~set) + + let remove t k = Lwt_eio.run_eio (fun () -> M.remove t k) + let list t = Lwt_eio.run_eio (fun () -> M.list t) + + let watch t ?init f = + Lwt_eio.run_eio (fun () -> M.watch t ?init (fun k d -> await (f k d))) + + let watch_key t k ?init f = + Lwt_eio.run_eio (fun () -> M.watch_key t k ?init (fun d -> await (f d))) + + let unwatch t w = Lwt_eio.run_eio (fun () -> M.unwatch t w) + let close t = Lwt_eio.run_eio (fun () -> M.close t) + let clear t = Lwt_eio.run_eio (fun () -> M.clear t) +end + +(** Lift a Lwt-typed [Schema.S] to [Irmin.Schema.S] by bridging Metadata and + Contents and re-exporting the rest unchanged (Hash / Branch / Info / Path + are pure types). *) +module Schema (S : Schema.S) : + Irmin.Schema.S + with module Hash = S.Hash + and module Branch = S.Branch + and module Info = S.Info + and module Path = S.Path + and type Metadata.t = S.Metadata.t + and type Contents.t = S.Contents.t = struct + module Hash = S.Hash + module Branch = S.Branch + module Info = S.Info + module Path = S.Path + module Metadata = Metadata (S.Metadata) + module Contents = Contents (S.Contents) +end + +(** Like {!Schema} but produces an [Irmin.Schema.Extended] by adding the [Node] + and [Commit] sub-functors that backends like [Irmin_pack_unix.Maker] + require. *) +module Schema_extended (S : Schema_intf.S) : + Irmin.Schema.Extended + with module Hash = S.Hash + and module Branch = S.Branch + and module Info = S.Info + and module Path = S.Path + and type Metadata.t = S.Metadata.t + and type Contents.t = S.Contents.t = struct + include Schema (S) + + module Node + (Contents_key : Irmin.Key.S with type hash = Hash.t) + (Node_key : Irmin.Key.S with type hash = Hash.t) = + Irmin.Node.Generic_key.Make (Hash) (Path) (Metadata) (Contents_key) + (Node_key) + + module Commit + (Node_key : Irmin.Key.S with type hash = Hash.t) + (Commit_key : Irmin.Key.S with type hash = Hash.t) = + struct + module Inner_maker = Irmin.Commit.Generic_key.Maker (Info) + include Inner_maker.Make (Hash) (Node_key) (Commit_key) + end +end + +module Content_addressable + (M : Content_addressable.Maker) + (H : Irmin.Hash.S) + (V : Irmin.Type.S) = +struct + module Lwt_M = M (H) (V) + + type 'a t = 'a Lwt_M.t + type key = Lwt_M.key + type value = Lwt_M.value + + let v c = await (Lwt_M.v c) + let mem t k = await (Lwt_M.mem t k) + let find t k = await (Lwt_M.find t k) + let add t v = await (Lwt_M.add t v) + let unsafe_add t h v = await (Lwt_M.unsafe_add t h v) + let close t = await (Lwt_M.close t) + + let batch t f = + await (Lwt_M.batch t (fun rw -> Lwt_eio.run_eio (fun () -> f rw))) +end + +module Append_only (M : Append_only.Maker) (K : Irmin.Type.S) (V : Irmin.Type.S) = +struct + module Lwt_M = M (K) (V) + + type 'a t = 'a Lwt_M.t + type key = K.t + type value = V.t + + let v c = await (Lwt_M.v c) + let mem t k = await (Lwt_M.mem t k) + let find t k = await (Lwt_M.find t k) + let add t k v = await (Lwt_M.add t k v) + let close t = await (Lwt_M.close t) + + let batch t f = + await (Lwt_M.batch t (fun rw -> Lwt_eio.run_eio (fun () -> f rw))) +end + +module Atomic_write + (M : Atomic_write.Maker) + (K : Irmin.Type.S) + (V : Irmin.Type.S) = +struct + module Lwt_M = M (K) (V) + + type t = Lwt_M.t + type key = Lwt_M.key + type value = Lwt_M.value + type watch = Lwt_M.watch + + let v c = await (Lwt_M.v c) + let mem t k = await (Lwt_M.mem t k) + let find t k = await (Lwt_M.find t k) + let set t k v = await (Lwt_M.set t k v) + let test_and_set t k ~test ~set = await (Lwt_M.test_and_set t k ~test ~set) + let remove t k = await (Lwt_M.remove t k) + let list t = await (Lwt_M.list t) + + let watch t ?init f = + await (Lwt_M.watch t ?init (fun k d -> Lwt_eio.run_eio (fun () -> f k d))) + + let watch_key t k ?init f = + await (Lwt_M.watch_key t k ?init (fun d -> Lwt_eio.run_eio (fun () -> f d))) + + let unwatch t w = await (Lwt_M.unwatch t w) + let close t = await (Lwt_M.close t) + let clear t = await (Lwt_M.clear t) +end + +(** Lift a Lwt-typed [Indexable.S] to its Irmin 4 (Eio-typed) counterpart. + Mirror of {!Indexable_of_eio}, going the opposite direction: each I/O + operation is awaited via {!Lwt_eio.Promise.await_lwt}. + + Used when feeding a user-supplied Lwt [Backend.S] into [Irmin.Of_backend]: + the user's [Contents] / [Node] / [Commit] sub-stores are Lwt-typed + [Indexable.S] and need to look like [Irmin.Indexable.S] to Irmin 4. *) +module Indexable_to_eio (M : Indexable.S) : + Irmin.Indexable.S + with type 'a t = 'a M.t + and type key = M.key + and type hash = M.hash + and type value = M.value + and module Key = M.Key = struct + type 'a t = 'a M.t + type key = M.key + type hash = M.hash + type value = M.value + + module Key = M.Key + + let mem t k = await (M.mem t k) + let find t k = await (M.find t k) + let add t v = await (M.add t v) + let unsafe_add t h v = await (M.unsafe_add t h v) + let index t h = await (M.index t h) + let close t = await (M.close t) + let batch t f = await (M.batch t (fun rw -> Lwt_eio.run_eio (fun () -> f rw))) +end + +(** Lift a Lwt-typed [Atomic_write.S] to its Irmin 4 (Eio-typed) counterpart. + Mirror of {!Atomic_write_of_eio}. Used to bridge a user's [Branch] sub-store + when feeding a Lwt [Backend.S] into [Irmin.Of_backend]. *) +module Atomic_write_to_eio (M : Atomic_write_intf.S) : + Irmin.Atomic_write.S + with type t = M.t + and type key = M.key + and type value = M.value + and type watch = M.watch = struct + type t = M.t + type key = M.key + type value = M.value + type watch = M.watch + + let mem t k = await (M.mem t k) + let find t k = await (M.find t k) + let set t k v = await (M.set t k v) + let test_and_set t k ~test ~set = await (M.test_and_set t k ~test ~set) + let remove t k = await (M.remove t k) + let list t = await (M.list t) + + let watch t ?init f = + await (M.watch t ?init (fun k d -> Lwt_eio.run_eio (fun () -> f k d))) + + let watch_key t k ?init f = + await (M.watch_key t k ?init (fun d -> Lwt_eio.run_eio (fun () -> f d))) + + let unwatch t w = await (M.unwatch t w) + let close t = await (M.close t) + let clear t = await (M.clear t) +end diff --git a/src/irmin-lwt/core/maker_v2.ml b/src/irmin-lwt/core/maker_v2.ml new file mode 100644 index 0000000000..55cbac8846 --- /dev/null +++ b/src/irmin-lwt/core/maker_v2.ml @@ -0,0 +1,40 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Lwt-typed [Store.S] built on top of Irmin 4 (Eio). + + [Make (CA) (AW) (S)] builds an inner [Irmin.Generic_key.S] by feeding + Lwt-to-Eio adapted backend Makers and the bridged Schema into [Irmin.Maker], + and then delegates the bulk of the wrap to {!Wrap_store.Make}. *) + +module Make + (CA : Content_addressable.Maker) + (AW : Atomic_write.Maker) + (S : Schema.S) = +struct + module CA_eio (H : Irmin.Hash.S) (V : Irmin.Type.S) = + Lwt_to_eio.Content_addressable (CA) (H) (V) + + module AW_eio (K : Irmin.Type.S) (V : Irmin.Type.S) = + Lwt_to_eio.Atomic_write (AW) (K) (V) + + (* Bridge the user's Lwt-typed schema into an Irmin 4-compatible one + (Metadata.merge and Contents.merge are converted from Lwt to Eio). *) + module Schema_eio = Lwt_to_eio.Schema (S) + module Inner_maker = Irmin.Maker (CA_eio) (AW_eio) + module Inner = Inner_maker.Make (Schema_eio) + include Wrap_store.Make (S) (Schema_eio) (Inner) +end diff --git a/src/irmin-lwt/core/merge.ml b/src/irmin-lwt/core/merge.ml new file mode 100644 index 0000000000..67435d80e9 --- /dev/null +++ b/src/irmin-lwt/core/merge.ml @@ -0,0 +1,421 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Printf + +let src = Logs.Src.create "irmin.merge" ~doc:"Irmin merging" + +module Log = (val Logs.src_log src : Logs.LOG) + +type conflict = [ `Conflict of string ] +type 'a promise = unit -> ('a option, conflict) result Lwt.t + +let promise t : 'a promise = fun () -> Lwt.return (Ok (Some t)) + +let memo fn = + let r = ref None in + fun () -> + match !r with + | Some x -> x + | None -> + let* x = fn () in + r := Some (Lwt.return x); + Lwt.return x + +type 'a f = old:'a promise -> 'a -> 'a -> ('a, conflict) result Lwt.t +type 'a t = 'a Type.t * 'a f + +let v t f = (t, f) +let f (x : 'a t) = snd x + +let conflict fmt = + ksprintf + (fun msg -> + [%log.debug "conflict: %s" msg]; + Lwt.return (Error (`Conflict msg))) + fmt + +let bind x f = x >>= function Error e -> Lwt.return (Error e) | Ok x -> f x +let map f x = x >|= function Error _ as x -> x | Ok x -> Ok (f x) + +let map_promise f t () = + t () >|= function + | Error _ as x -> x + | Ok None -> Ok None + | Ok (Some a) -> Ok (Some (f a)) + +let bind_promise t f () = + t () >>= function + | Error e -> Lwt.return (Error e) + | Ok None -> Lwt.return (Ok None) + | Ok (Some a) -> f a () + +let ok x = Lwt.return (Ok x) + +module Infix = struct + let ( >>=* ) = bind + let ( >|=* ) x f = map f x + let ( >>=? ) = bind_promise + let ( >|=? ) x f = map_promise f x +end + +open Infix + +let default (type a) (t : a Type.t) : a t = + let pp = Type.pp t and equal = Type.(unstage (equal t)) in + ( t, + fun ~old t1 t2 -> + let open Infix in + [%log.debug "default %a | %a" pp t1 pp t2]; + old () >>=* function + | None -> conflict "default: add/add and no common ancestor" + | Some old -> + [%log.debug "default old=%a" pp t1]; + if equal old t1 && equal t1 t2 then ok t1 + else if equal old t1 then ok t2 + else if equal old t2 then ok t1 + else conflict "default" ) + +let idempotent dt = + let equal = Type.(unstage (equal dt)) in + let default = default dt in + let f ~old x y = if equal x y then ok x else f default ~old x y in + v dt f + +let seq = function + | [] -> invalid_arg "nothing to merge" + | (t, _) :: _ as ts -> + ( t, + fun ~old v1 v2 -> + Lwt_list.fold_left_s + (fun acc (_, merge) -> + match acc with Ok x -> ok x | Error _ -> merge ~old v1 v2) + (Error (`Conflict "nothing to merge")) + ts ) + +let option (type a) ((a, t) : a t) : a option t = + let pp_a = Type.pp a and equal = Type.(unstage (equal a)) in + let dt = Type.option a in + let pp = Type.pp dt in + ( dt, + fun ~old t1 t2 -> + [%log.debug "some %a | %a" pp t1 pp t2]; + f (default Type.(option a)) ~old t1 t2 >>= function + | Ok x -> ok x + | Error _ -> ( + match (t1, t2) with + | None, None -> ok None + | Some v1, Some v2 -> + let open Infix in + let old () = + old () >>=* function + | None -> ok None + | Some o -> + [%log.debug "option old=%a" pp o]; + ok o + in + t ~old v1 v2 >|=* fun x -> Some x + | Some x, None | None, Some x -> ( + let open Infix in + old () >>=* function + | None | Some None -> ok (Some x) + | Some (Some o) -> + [%log.debug "option old=%a" pp_a o]; + if equal x o then ok (Some x) else conflict "option: add/del") + ) ) + +let pair (da, a) (db, b) = + let dt = Type.pair da db in + let pp = Type.pp dt in + ( dt, + fun ~old x y -> + [%log.debug "pair %a | %a" pp x pp y]; + (snd (default dt)) ~old x y >>= function + | Ok x -> ok x + | Error _ -> + let (a1, b1), (a2, b2) = (x, y) in + let o1 = map_promise fst old in + let o2 = map_promise snd old in + a ~old:o1 a1 a2 >>=* fun a3 -> + b ~old:o2 b1 b2 >|=* fun b3 -> (a3, b3) ) + +let triple (da, a) (db, b) (dc, c) = + let dt = Type.triple da db dc in + let pp = Type.pp dt in + ( dt, + fun ~old x y -> + [%log.debug "triple %a | %a" pp x pp y]; + (snd (default dt)) ~old x y >>= function + | Ok x -> ok x + | Error _ -> + let (a1, b1, c1), (a2, b2, c2) = (x, y) in + let o1 = map_promise (fun (x, _, _) -> x) old in + let o2 = map_promise (fun (_, x, _) -> x) old in + let o3 = map_promise (fun (_, _, x) -> x) old in + a ~old:o1 a1 a2 >>=* fun a3 -> + b ~old:o2 b1 b2 >>=* fun b3 -> + c ~old:o3 c1 c2 >|=* fun c3 -> (a3, b3, c3) ) + +exception C of string + +let merge_elt merge_v old key vs = + let v1, v2 = + match vs with + | `Left v -> (Some v, None) + | `Right v -> (None, Some v) + | `Both (v1, v2) -> (Some v1, Some v2) + in + let old () = old key in + merge_v key ~old v1 v2 >>= function + | Error (`Conflict msg) -> Lwt.fail (C msg) + | Ok x -> Lwt.return x + +(* assume l1 and l2 are key-sorted *) +let alist_iter2 compare_k f l1 l2 = + let rec aux l1 l2 = + match (l1, l2) with + | [], t -> List.iter (fun (key, v) -> f key (`Right v)) t + | t, [] -> List.iter (fun (key, v) -> f key (`Left v)) t + | (k1, v1) :: t1, (k2, v2) :: t2 -> ( + match compare_k k1 k2 with + | 0 -> + f k1 (`Both (v1, v2)); + aux t1 t2 + | x -> + if x < 0 then ( + f k1 (`Left v1); + aux t1 l2) + else ( + f k2 (`Right v2); + aux l1 t2)) + in + aux l1 l2 + +(* assume l1 and l2 are key-sorted *) +let alist_iter2_lwt compare_k f l1 l2 = + let l3 = ref [] in + alist_iter2 compare_k (fun left right -> l3 := f left right :: !l3) l1 l2; + Lwt_list.iter_p Fun.id (List.rev !l3) + +(* DO NOT assume l1 and l2 are key-sorted *) +let alist_merge_lwt compare_k f l1 l2 = + let open Lwt in + let l3 = ref [] in + let sort l = List.sort (fun (x, _) (y, _) -> compare_k x y) l in + let l1 = sort l1 in + let l2 = sort l2 in + let f key data = + f key data >>= function + | None -> return_unit + | Some v -> + l3 := (key, v) :: !l3; + return_unit + in + alist_iter2_lwt compare_k f l1 l2 >>= fun () -> return !l3 + +let alist dx dy merge_v = + let pair = Type.pair dx dy in + let compare_pair = Type.unstage (Type.compare pair) in + let compare_dx = Type.(unstage (compare dx)) in + let dt = Type.list pair in + ( dt, + fun ~old x y -> + let pp = Type.pp dt in + [%log.debug "alist %a | %a" pp x pp y]; + let sort = List.sort compare_pair in + let x = sort x in + let y = sort y in + let old k = + let open Infix in + old () >|=* function + | None -> Some None (* no parent = parent with empty value *) + | Some old -> + let old = try Some (List.assoc k old) with Not_found -> None in + Some old + in + let merge_v k = f (merge_v k) in + Lwt.catch + (fun () -> + alist_merge_lwt compare_dx (merge_elt merge_v old) x y >>= ok) + (function C msg -> conflict "%s" msg | e -> Lwt.fail e) ) + +module MultiSet (K : sig + include Set.OrderedType + + val t : t Type.t +end) = +struct + module M = Map.Make (K) + + let of_alist l = List.fold_left (fun map (k, v) -> M.add k v map) M.empty l + let t = Type.map Type.(list (pair K.t int64)) of_alist M.bindings + + let merge ~old m1 m2 = + let get k m = try M.find k m with Not_found -> 0L in + let set k v m = match v with 0L -> M.remove k m | _ -> M.add k v m in + let add k v m = set k (Int64.add v @@ get k m) m in + let keys = ref M.empty in + old () >|=* fun old -> + let old = + match old with + | None -> M.empty (* no parent = parent with empty value *) + | Some o -> o + in + M.iter (fun k v -> keys := add k (Int64.neg v) !keys) old; + M.iter (fun k v -> keys := add k v !keys) m1; + M.iter (fun k v -> keys := add k v !keys) m2; + !keys + + let merge = (t, merge) +end + +module Set (K : sig + include Set.OrderedType + + val t : t Type.t +end) = +struct + module S = Set.Make (K) + + let of_list l = List.fold_left (fun set elt -> S.add elt set) S.empty l + let t = Type.(map @@ list K.t) of_list S.elements + let pp = Type.pp t + + let merge ~old x y = + [%log.debug "merge %a %a" pp x pp y]; + old () >|=* fun old -> + let old = match old with None -> S.empty | Some o -> o in + let ( ++ ) = S.union and ( -- ) = S.diff in + let to_add = x -- old ++ (y -- old) in + let to_del = old -- x ++ (old -- y) in + old -- to_del ++ to_add + + let merge = (t, merge) +end + +module Map (K : sig + include Map.OrderedType + + val t : t Type.t +end) = +struct + module M = Map.Make (K) + + let of_alist l = List.fold_left (fun map (k, v) -> M.add k v map) M.empty l + let t x = Type.map Type.(list @@ pair K.t x) of_alist M.bindings + let iter2 f t1 t2 = alist_iter2 K.compare f (M.bindings t1) (M.bindings t2) + + let iter2 f m1 m2 = + let m3 = ref [] in + iter2 (fun key data -> m3 := f key data :: !m3) m1 m2; + Lwt_list.iter_p (fun b -> b >>= fun () -> Lwt.return_unit) (List.rev !m3) + + let merge_maps f m1 m2 = + let l3 = ref [] in + let f key data = + f key data >|= function None -> () | Some v -> l3 := (key, v) :: !l3 + in + iter2 f m1 m2 >>= fun () -> + let m3 = of_alist !l3 in + Lwt.return m3 + + let merge dv (merge_v : K.t -> 'a option t) = + let pp ppf m = Type.(pp (list (pair K.t dv))) ppf @@ M.bindings m in + let merge_v k = f (merge_v k) in + ( t dv, + fun ~old m1 m2 -> + [%log.debug "assoc %a | %a" pp m1 pp m2]; + Lwt.catch + (fun () -> + let old key = + old () >>=* function + | None -> ok None + | Some old -> + [%log.debug "assoc old=%a" pp old]; + let old = + try Some (M.find key old) with Not_found -> None + in + ok (Some old) + in + merge_maps (merge_elt merge_v old) m1 m2 >>= ok) + (function C msg -> conflict "%s" msg | e -> Lwt.fail e) ) +end + +let like da t a_to_b b_to_a = + let pp = Type.pp da in + let merge ~old a1 a2 = + [%log.debug "biject %a | %a" pp a1 pp a2]; + try + let b1 = a_to_b a1 in + let b2 = a_to_b a2 in + let old = memo (map_promise a_to_b old) in + (f t) ~old b1 b2 >|=* b_to_a + with Not_found -> conflict "biject" + in + seq [ default da; (da, merge) ] + +let like_lwt (type a b) da (t : b t) (a_to_b : a -> b Lwt.t) + (b_to_a : b -> a Lwt.t) : a t = + let pp = Type.pp da in + let merge ~old a1 a2 = + [%log.debug "biject' %a | %a" pp a1 pp a2]; + try + let* b1 = a_to_b a1 in + let* b2 = a_to_b a2 in + let old = + memo (fun () -> + bind (old ()) @@ function + | None -> ok None + | Some a -> + let+ b = a_to_b a in + Ok (Some b)) + in + bind ((f t) ~old b1 b2) @@ fun b3 -> b_to_a b3 >>= ok + with Not_found -> conflict "biject'" + in + seq [ default da; (da, merge) ] + +let unit = default Type.unit +let bool = default Type.bool +let char = default Type.char +let int32 = default Type.int32 +let int64 = default Type.int64 +let float = default Type.float +let string = default Type.string + +type counter = int64 + +let counter = + ( Type.int64, + fun ~old x y -> + old () >|=* fun old -> + let old = match old with None -> 0L | Some o -> o in + let ( + ) = Int64.add and ( - ) = Int64.sub in + x + y - old ) + +let with_conflict rewrite (d, f) = + let f ~old x y = + f ~old x y >>= function + | Error (`Conflict msg) -> conflict "%s" (rewrite msg) + | Ok x -> ok x + in + (d, f) + +let conflict_t = + Type.(map string) (fun x -> `Conflict x) (function `Conflict x -> x) + +type nonrec 'a result = ('a, conflict) result [@@deriving irmin] diff --git a/src/irmin-lwt/core/merge.mli b/src/irmin-lwt/core/merge.mli new file mode 100644 index 0000000000..8200af325a --- /dev/null +++ b/src/irmin-lwt/core/merge.mli @@ -0,0 +1,229 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Merge operators. *) + +type conflict = [ `Conflict of string ] [@@deriving irmin] +(** The type for merge errors. *) + +val ok : 'a -> ('a, conflict) result Lwt.t +(** Return [Ok x]. *) + +val conflict : ('a, unit, string, ('b, conflict) result Lwt.t) format4 -> 'a +(** Return [Error (Conflict str)]. *) + +val bind : + ('a, 'b) result Lwt.t -> + ('a -> ('c, 'b) result Lwt.t) -> + ('c, 'b) result Lwt.t +(** [bind r f] is the merge result which behaves as of the application of the + function [f] to the return value of [r]. If [r] fails, [bind r f] also + fails, with the same conflict. *) + +val map : ('a -> 'c) -> ('a, 'b) result Lwt.t -> ('c, 'b) result Lwt.t +(** [map f m] maps the result of a merge. This is the same as + [bind m (fun x -> ok (f x))]. *) + +(** {1 Merge Combinators} *) + +type 'a promise = unit -> ('a option, conflict) result Lwt.t +(** An ['a] promise is a function which, when called, will eventually return a + value type of ['a]. A promise is an optional, lazy and non-blocking value. +*) + +val promise : 'a -> 'a promise +(** [promise a] is the promise containing [a]. *) + +val map_promise : ('a -> 'b) -> 'a promise -> 'b promise +(** [map_promise f a] is the promise containing [f] applied to what is promised + by [a]. *) + +val bind_promise : 'a promise -> ('a -> 'b promise) -> 'b promise +(** [bind_promise a f] is the promise returned by [f] applied to what is + promised by [a]. *) + +type 'a f = old:'a promise -> 'a -> 'a -> ('a, conflict) result Lwt.t +(** Signature of a merge function. [old] is the value of the least-common + ancestor. + + {v + /----> t1 ----\ + ----> old |--> result + \----> t2 ----/ + v} *) + +type 'a t +(** The type for merge combinators. *) + +val v : 'a Type.t -> 'a f -> 'a t +(** [v dt f] create a merge combinator. *) + +val f : 'a t -> 'a f +(** [f m] is [m]'s merge function. *) + +val seq : 'a t list -> 'a t +(** Call the merge functions in sequence. Stop as soon as one is {e not} + returning a conflict. *) + +val like : 'a Type.t -> 'b t -> ('a -> 'b) -> ('b -> 'a) -> 'a t +(** Use the merge function defined in another domain. If the converting + functions raise any exception the merge is a conflict. *) + +val with_conflict : (string -> string) -> 'a t -> 'a t +(** [with_conflict f m] is [m] with the conflict error message modified by [f]. +*) + +val like_lwt : 'a Type.t -> 'b t -> ('a -> 'b Lwt.t) -> ('b -> 'a Lwt.t) -> 'a t +(** Same as {{!Merge.biject} biject} but with blocking domain converting + functions. *) + +(** {1 Basic Merges} *) + +val default : 'a Type.t -> 'a t +(** [default t] is the default merge function for values of type [t]. This is a + simple merge function which supports changes in one branch at a time: + + - if [t1=old] then the result of the merge is [OK t2]; + - if [t2=old] then return [OK t1]; + - otherwise the result is [Conflict]. *) + +val idempotent : 'a Type.t -> 'a t +(** [idempotent t] is the default merge function for values of type [t] using + idempotent operations. It follows the same rules as the {!default} merge + function but also adds: + + - if [t1=t2] then the result of the merge is [OK t1]. *) + +val unit : unit t +(** [unit] is the default merge function for unit values. *) + +val bool : bool t +(** [bool] is the default merge function for booleans. *) + +val char : char t +(** [char] is the default merge function for characters. *) + +val int32 : int32 t +(** [int32] is the default merge function for 32-bits integers. *) + +val int64 : int64 t +(** [int64] the default merge function for 64-bit integers. *) + +val float : float t +(** [float] is the default merge function for floating point numbers. *) + +val string : string t +(** The default string merge function. Do not do anything clever, just compare + the strings using the [default] merge function. *) + +val option : 'a t -> 'a option t +(** Lift a merge function to optional values of the same type. If all the + provided values are inhabited, then call the provided merge function, + otherwise use the same behavior as {!default}. *) + +val pair : 'a t -> 'b t -> ('a * 'b) t +(** Lift merge functions to pairs of elements. *) + +val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t +(** Lift merge functions to triples of elements. *) + +(** {1 Counters and Multisets} *) + +type counter = int64 +(** The type for counter values. It is expected that the only valid operations + on counters are {e increment} and {e decrement}. The following merge + functions ensure that the counter semantics are preserved: {e i.e.} it + ensures that the number of increments and decrements is preserved. *) + +val counter : counter t +(** The merge function for mergeable counters. *) + +(** Multi-sets. *) +module MultiSet (K : sig + include Set.OrderedType + + val t : t Type.t +end) : sig + val merge : counter Map.Make(K).t t +end + +(** {1 Maps and Association Lists} *) + +(** We consider the only valid operations for maps and association lists to be: + + - Adding a new bindings to the map. + - Removing a binding from the map. + - Replacing an existing binding with a different value. + - {e Trying to add an already existing binding is a no-op}. + + We thus assume that no operation on maps is modifying the {e key} names. So + the following merge functions ensures that {e (i)} new bindings are + preserved {e (ii)} removed bindings stay removed and {e (iii)} modified + bindings are merged using the merge function of values. + + {b Note:} We only consider sets of bindings, instead of multisets. + Application developers should take care of concurrent addition and removal + of similar bindings themselves, by using the appropriate + {{!Merge.MSet} multi-sets}. *) + +(** Lift merge functions to sets. *) +module Set (E : sig + include Set.OrderedType + + val t : t Type.t +end) : sig + val merge : Set.Make(E).t t +end + +val alist : 'a Type.t -> 'b Type.t -> ('a -> 'b option t) -> ('a * 'b) list t +(** Lift the merge functions to association lists. *) + +(** Lift the merge functions to maps. *) + +module Map (K : sig + include Map.OrderedType + + val t : t Type.t +end) : sig + val merge : 'a Type.t -> (K.t -> 'a option t) -> 'a Map.Make(K).t t +end + +(** Infix operators for manipulating merge results and {!promise}s. + + [open Irmin.Merge.Infix] at the top of your file to use them. *) +module Infix : sig + (** {1 Merge Result Combinators} *) + + val ( >>=* ) : + ('a, conflict) result Lwt.t -> + ('a -> ('b, conflict) result Lwt.t) -> + ('b, conflict) result Lwt.t + (** [>>=*] is {!bind}. *) + + val ( >|=* ) : + ('a, conflict) result Lwt.t -> ('a -> 'b) -> ('b, conflict) result Lwt.t + (** [>|=*] is {!map}. *) + + (** {1 Promise Combinators} + + This is useful to manipulate lca results. *) + + val ( >>=? ) : 'a promise -> ('a -> 'b promise) -> 'b promise + (** [>>=?] is {!bind_promise}. *) + + val ( >|=? ) : 'a promise -> ('a -> 'b) -> 'b promise + (** [>|=?] is {!map_promise}. *) +end diff --git a/src/irmin-lwt/core/metadata.ml b/src/irmin-lwt/core/metadata.ml new file mode 100644 index 0000000000..a0a8c25055 --- /dev/null +++ b/src/irmin-lwt/core/metadata.ml @@ -0,0 +1,24 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Metadata_intf + +module None = struct + type t = unit [@@deriving irmin] + + let default = () + let merge = Merge.v t (fun ~old:_ () () -> Merge.ok ()) +end diff --git a/src/irmin-lwt/core/metadata.mli b/src/irmin-lwt/core/metadata.mli new file mode 100644 index 0000000000..c8808836a3 --- /dev/null +++ b/src/irmin-lwt/core/metadata.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Metadata_intf.Sigs +(** @inline *) diff --git a/src/irmin-lwt/core/metadata_intf.ml b/src/irmin-lwt/core/metadata_intf.ml new file mode 100644 index 0000000000..3ecacde227 --- /dev/null +++ b/src/irmin-lwt/core/metadata_intf.ml @@ -0,0 +1,31 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Node metadata. *) + +module type S = sig + include Type.Defaultable + + val merge : t Merge.t + (** [merge] is the merge function for metadata. *) +end + +module type Sigs = sig + module type S = S + + module None : S with type t = unit + (** A metadata definition for systems that don't use metadata. *) +end diff --git a/src/irmin-lwt/core/metrics.ml b/src/irmin-lwt/core/metrics.ml new file mode 100644 index 0000000000..c9075996c9 --- /dev/null +++ b/src/irmin-lwt/core/metrics.ml @@ -0,0 +1 @@ +include Irmin.Metrics diff --git a/src/irmin-lwt/core/node.ml b/src/irmin-lwt/core/node.ml new file mode 100644 index 0000000000..8ade40e835 --- /dev/null +++ b/src/irmin-lwt/core/node.ml @@ -0,0 +1,788 @@ +(* + * Copyright (c) 2013 Louis Gesbert + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Node_intf + +let src = Logs.Src.create "irmin.node" ~doc:"Irmin trees/nodes" + +module Log = (val Logs.src_log src : Logs.LOG) + +(* Add [merge] to a [Core] implementation. *) +module Of_core (S : Core) = struct + include S + (* Merges *) + + let all_contents t = + let kvs = S.list t in + List.fold_left + (fun acc -> function k, `Contents c -> (k, c) :: acc | _ -> acc) + [] kvs + + let all_succ t = + let kvs = S.list t in + List.fold_left + (fun acc -> function k, `Node n -> (k, n) :: acc | _ -> acc) + [] kvs + + (* [Merge.alist] expects us to return an option. [C.merge] does + that, but we need to consider the metadata too... *) + let merge_metadata merge_contents = + (* This gets us [C.t option, S.Val.Metadata.t]. We want [(C.t * + S.Val.Metadata.t) option]. *) + let explode = function + | None -> (None, S.Metadata.default) + | Some (c, m) -> (Some c, m) + in + let implode = function None, _ -> None | Some c, m -> Some (c, m) in + Merge.like [%typ: (S.contents_key * S.metadata) option] + (Merge.pair merge_contents S.Metadata.merge) + explode implode + + let merge_contents merge_key = + Merge.alist S.step_t (Type.pair S.contents_key_t S.metadata_t) (fun _step -> + merge_metadata merge_key) + + let merge_node merge_key = + Merge.alist S.step_t S.node_key_t (fun _step -> merge_key) + + (* FIXME: this is very broken; do the same thing as [Tree.merge] + instead. *) + let merge ~contents ~node = + let explode t = (all_contents t, all_succ t) in + let implode (contents, succ) = + let xs = List.rev_map (fun (s, c) -> (s, `Contents c)) contents in + let ys = List.rev_map (fun (s, n) -> (s, `Node n)) succ in + S.of_list (xs @ ys) + in + let merge = Merge.pair (merge_contents contents) (merge_node node) in + Merge.like S.t merge explode implode +end + +module Irmin_hash = Hash + +(* A [Make] implementation providing the subset of [S] that can be implemented + over abstract [key] types. *) +module Make_core + (Hash : Hash.S) + (Path : sig + type step [@@deriving irmin] + end) + (Metadata : Metadata.S) + (Contents_key : Key.S with type hash = Hash.t) + (Node_key : Key.S with type hash = Hash.t) = +struct + module Metadata = Metadata + + type contents_key = Contents_key.t [@@deriving irmin] + type node_key = Node_key.t [@@deriving irmin] + type step = Path.step [@@deriving irmin] + type metadata = Metadata.t [@@deriving irmin ~equal] + type hash = Hash.t [@@deriving irmin] + + type 'key contents_entry = { name : Path.step; contents : 'key } + [@@deriving irmin] + + type 'key contents_m_entry = { + metadata : Metadata.t; + name : Path.step; + contents : 'key; + } + [@@deriving irmin] + + module StepMap = Map.Make (struct + type t = Path.step [@@deriving irmin ~compare] + end) + + type 'h node_entry = { name : Path.step; node : 'h } [@@deriving irmin] + + type entry = + | Node of node_key node_entry + | Contents of contents_key contents_entry + | Contents_m of contents_key contents_m_entry + (* Invariant: the [_hash] cases are only externally reachable via + [Portable.of_node]. *) + | Node_hash of Hash.t node_entry + | Contents_hash of Hash.t contents_entry + | Contents_m_hash of Hash.t contents_m_entry + [@@deriving irmin] + + type t = entry StepMap.t + type value = [ `Contents of contents_key * metadata | `Node of node_key ] + + type weak_value = [ `Contents of hash * metadata | `Node of hash ] + [@@deriving irmin] + + (* FIXME: special-case the default metadata in the default signature? *) + let value_t = + let open Type in + variant "value" (fun n c x -> function + | `Node h -> n h + | `Contents (h, m) -> + if equal_metadata m Metadata.default then c h else x (h, m)) + |~ case1 "node" node_key_t (fun k -> `Node k) + |~ case1 "contents" contents_key_t (fun h -> + `Contents (h, Metadata.default)) + |~ case1 "contents-x" (pair contents_key_t Metadata.t) (fun (h, m) -> + `Contents (h, m)) + |> sealv + + let to_entry (k, (v : value)) = + match v with + | `Node h -> Node { name = k; node = h } + | `Contents (h, m) -> + if equal_metadata m Metadata.default then + Contents { name = k; contents = h } + else Contents_m { metadata = m; name = k; contents = h } + + let inspect_nonportable_entry_exn : entry -> step * value = function + | Node n -> (n.name, `Node n.node) + | Contents c -> (c.name, `Contents (c.contents, Metadata.default)) + | Contents_m c -> (c.name, `Contents (c.contents, c.metadata)) + | Node_hash _ | Contents_hash _ | Contents_m_hash _ -> + (* Not reachable after [Portable.of_node]. See invariant on {!entry}. *) + assert false + + let step_of_entry : entry -> step = function + | Node { name; _ } + | Node_hash { name; _ } + | Contents { name; _ } + | Contents_m { name; _ } + | Contents_hash { name; _ } + | Contents_m_hash { name; _ } -> + name + + let weak_of_entry : entry -> step * weak_value = function + | Node n -> (n.name, `Node (Node_key.to_hash n.node)) + | Node_hash n -> (n.name, `Node n.node) + | Contents c -> + (c.name, `Contents (Contents_key.to_hash c.contents, Metadata.default)) + | Contents_m c -> + (c.name, `Contents (Contents_key.to_hash c.contents, c.metadata)) + | Contents_hash c -> (c.name, `Contents (c.contents, Metadata.default)) + | Contents_m_hash c -> (c.name, `Contents (c.contents, c.metadata)) + + let of_seq l = + Seq.fold_left + (fun acc x -> StepMap.add (fst x) (to_entry x) acc) + StepMap.empty l + + let of_list l = of_seq (List.to_seq l) + + let seq_entries ~offset ?length (t : t) = + let take seq = match length with None -> seq | Some n -> Seq.take n seq in + StepMap.to_seq t |> Seq.drop offset |> take + + let seq ?(offset = 0) ?length ?cache:_ (t : t) = + seq_entries ~offset ?length t + |> Seq.map (fun (_, e) -> inspect_nonportable_entry_exn e) + + let list ?offset ?length ?cache:_ t = List.of_seq (seq ?offset ?length t) + let find_entry ?cache:_ (t : t) s = StepMap.find_opt s t + + let find ?cache (t : t) s = + Option.map + (fun e -> snd (inspect_nonportable_entry_exn e)) + (find_entry ?cache t s) + + let empty = Fun.const StepMap.empty + let is_empty e = StepMap.is_empty e + let length e = StepMap.cardinal e + let clear _ = () + let equal_entry_opt = Type.(unstage (equal (option entry_t))) + + let add_entry t k e = + StepMap.update k + (fun e' -> if equal_entry_opt (Some e) e' then e' else Some e) + t + + let add t k v = + let e = to_entry (k, v) in + add_entry t k e + + let remove t k = StepMap.remove k t + + let of_entries es = + List.to_seq es |> Seq.map (fun e -> (step_of_entry e, e)) |> StepMap.of_seq + + let entries e = List.rev_map (fun (_, e) -> e) (StepMap.bindings e) + + module Hash_preimage = struct + type entry = + | Node_hash of Hash.t node_entry + | Contents_hash of Hash.t contents_entry + | Contents_m_hash of Hash.t contents_m_entry + [@@deriving irmin] + + type t = entry list [@@deriving irmin ~pre_hash] + type t_not_prefixed = t [@@deriving irmin ~pre_hash] + + let pre_hash = Type.(unstage (pre_hash t)) + + (* Manually add a prefix to default nodes, in order to prevent hash + collision between contents and nodes (see + https://github.com/mirage/irmin/issues/1304). + + Prefixing the contents is not enough to prevent the collision: the + prehash of a node starts with the number of its children, which can + coincide with the prefix of the content's prehash. *) + let pre_hash x f = + f "N"; + pre_hash x f + end + + let pre_hash pre_hash t f = + let entries : Hash_preimage.t = + StepMap.to_seq t + |> Seq.map (fun (_, v) -> + match v with + (* Weaken keys to hashes *) + | Node { name; node } -> + Hash_preimage.Node_hash { name; node = Node_key.to_hash node } + | Contents { name; contents } -> + Contents_hash { name; contents = Contents_key.to_hash contents } + | Contents_m { metadata; name; contents } -> + Contents_m_hash + { metadata; name; contents = Contents_key.to_hash contents } + | Node_hash { name; node } -> Node_hash { name; node } + | Contents_hash { name; contents } -> Contents_hash { name; contents } + | Contents_m_hash { metadata; name; contents } -> + Contents_m_hash { metadata; name; contents }) + |> Seq.fold_left (fun xs x -> x :: xs) [] + in + pre_hash entries f + + let t = + let pre_hash = pre_hash Hash_preimage.pre_hash in + Type.map ~pre_hash Type.(list entry_t) of_entries entries + + let t_not_prefixed = + let pre_hash = pre_hash Hash_preimage.pre_hash_t_not_prefixed in + Type.map ~pre_hash Type.(list entry_t) of_entries entries + + let with_handler _ t = t + + let head_entries t = + let l = seq_entries ~offset:0 t |> List.of_seq in + `Node l + + let head t = + let (`Node l) = head_entries t in + let l = List.map (fun (_, e) -> inspect_nonportable_entry_exn e) l in + `Node l + + module Ht = + Irmin_hash.Typed + (Hash) + (struct + type nonrec t = t [@@deriving irmin] + end) + + let hash_exn ?force:_ = Ht.hash +end + +module Portable = struct + module Of_core (X : sig + type hash + + include + Core + with type hash := hash + and type contents_key = hash + and type node_key = hash + end) = + struct + include X + + let of_node t = t + + type proof = + [ `Blinded of hash + | `Values of (step * value) list + | `Inode of int * (int * proof) list ] + [@@deriving irmin] + + let to_proof (t : t) : proof = `Values (seq t |> List.of_seq) + + let of_proof ~depth (t : proof) = + assert (depth = 0); + match t with + | `Blinded _ | `Inode _ -> None + | `Values e -> Some (of_list e) + end + + module Of_node (X : S) = struct + include Of_core (X) + include X + end + + module type S = Portable +end + +module Make_generic_key + (Hash : Hash.S) + (Path : sig + type step [@@deriving irmin] + end) + (Metadata : Metadata.S) + (Contents_key : Key.S with type hash = Hash.t) + (Node_key : Key.S with type hash = Hash.t) = +struct + module Core = Make_core (Hash) (Path) (Metadata) (Contents_key) (Node_key) + include Core + include Of_core (Core) + + module Portable = struct + module Core = struct + include Core + + type contents_key = hash [@@deriving irmin] + type node_key = hash [@@deriving irmin] + type value = weak_value [@@deriving irmin] + + let to_entry name = function + | `Node node -> Node_hash { name; node } + | `Contents (contents, metadata) -> + if equal_metadata metadata Metadata.default then + Contents_hash { name; contents } + else Contents_m_hash { name; contents; metadata } + + let of_seq s = + Seq.fold_left + (fun acc (name, v) -> StepMap.add name (to_entry name v) acc) + StepMap.empty s + + let of_list s = of_seq (List.to_seq s) + + let add t name v = + let entry = to_entry name v in + add_entry t name entry + + let find ?cache t s = + Option.map (fun e -> snd (weak_of_entry e)) (find_entry ?cache t s) + + let seq ?(offset = 0) ?length ?cache:_ (t : t) = + seq_entries ~offset ?length t |> Seq.map (fun (_, e) -> weak_of_entry e) + + let list ?offset ?length ?cache t = + List.of_seq (seq ?offset ?length ?cache t) + + let head t = + let (`Node l) = head_entries t in + let l = List.map (fun (_, e) -> weak_of_entry e) l in + `Node l + end + + include Of_core (Core) + include Portable.Of_core (Core) + end + + exception Dangling_hash of { context : string; hash : hash } + + type nonrec hash = hash [@@deriving irmin ~pp] + + let () = + Printexc.register_printer (function + | Dangling_hash { context; hash } -> + Some (Fmt.str "%s: encountered dangling hash %a" context pp_hash hash) + | _ -> None) +end + +module Make_generic_key_v2 + (Hash : Hash.S) + (Path : sig + type step [@@deriving irmin] + end) + (Metadata : Metadata.S) + (Contents_key : Key.S with type hash = Hash.t) + (Node_key : Key.S with type hash = Hash.t) = +struct + include Make_generic_key (Hash) (Path) (Metadata) (Contents_key) (Node_key) + + let t = t_not_prefixed + + module Portable = struct + include Portable + + let t = t_not_prefixed + end +end + +module Make + (Hash : Hash.S) + (Path : sig + type step [@@deriving irmin] + end) + (Metadata : Metadata.S) = +struct + module Key = Key.Of_hash (Hash) + include Make_generic_key (Hash) (Path) (Metadata) (Key) (Key) +end + +module Store_generic_key + (C : Contents.Store) + (S : Indexable.S) + (H : Hash.S with type t = S.hash) + (V : + S_generic_key + with type t = S.value + and type contents_key = C.Key.t + and type node_key = S.Key.t) + (M : Metadata.S with type t = V.metadata) + (P : Path.S with type step = V.step) = +struct + module Val = struct + include V + + type hash = H.t + end + + module Contents = C + module Key = S.Key + module Hash = Hash.Typed (H) (Val) + module Path = P + module Metadata = M + + type 'a t = 'a C.t * 'a S.t + type value = S.value + type key = Key.t + type hash = Hash.t + + let mem (_, t) = S.mem t + let find (_, t) = S.find t + let add (_, t) = S.add t + let unsafe_add (_, t) = S.unsafe_add t + let index (_, t) h = S.index t h + let batch (c, s) f = C.batch c (fun n -> S.batch s (fun s -> f (n, s))) + + let close (c, s) = + let* () = C.close c in + let+ () = S.close s in + () + + let rec merge t = + let merge_key = + Merge.v [%typ: Key.t option] (fun ~old x y -> + Merge.(f (merge t)) ~old x y) + in + let merge = Val.merge ~contents:C.(merge (fst t)) ~node:merge_key in + let read = function + | None -> Lwt.return (Val.empty ()) + | Some k -> ( find t k >|= function None -> Val.empty () | Some v -> v) + in + let add v = + if Val.is_empty v then Lwt.return_none else add t v >>= Lwt.return_some + in + Merge.like_lwt [%typ: Key.t option] merge read add +end + +module Generic_key = struct + module type S = S_generic_key + module type Maker = Maker_generic_key + module type Core = Core + + module Make = Make_generic_key + module Store = Store_generic_key + module Make_v2 = Make_generic_key_v2 +end + +module Store + (C : Contents.Store) + (S : Content_addressable.S with type key = C.key) + (H : Hash.S with type t = S.key) + (V : S with type t = S.value and type hash = S.key) + (M : Metadata.S with type t = V.metadata) + (P : Path.S with type step = V.step) = +struct + module S = Indexable.Of_content_addressable (H) (S) + include Store_generic_key (C) (S) (H) (V) (M) (P) +end + +module Graph (S : Store) = struct + module Path = S.Path + module Contents_key = S.Contents.Key + module Metadata = S.Metadata + + type step = Path.step [@@deriving irmin] + type metadata = Metadata.t [@@deriving irmin] + type contents_key = Contents_key.t [@@deriving irmin] + type node_key = S.Key.t [@@deriving irmin] + type path = Path.t [@@deriving irmin] + type 'a t = 'a S.t + type value = [ `Contents of contents_key * metadata | `Node of node_key ] + + let empty t = S.add t (S.Val.empty ()) + + let list t n = + [%log.debug "steps"]; + S.find t n >|= function None -> [] | Some n -> S.Val.list n + + module U = struct + type t = unit [@@deriving irmin] + end + + module Graph = Object_graph.Make (Contents_key) (S.Key) (U) (U) + + let edges t = + List.rev_map + (function _, `Node n -> `Node n | _, `Contents (c, _) -> `Contents c) + (S.Val.list t) + + let pp_key = Type.pp S.Key.t + let pp_keys = Fmt.(Dump.list pp_key) + let pp_path = Type.pp S.Path.t + let equal_val = Type.(unstage (equal S.Val.t)) + + let pred t = function + | `Node k -> ( S.find t k >|= function None -> [] | Some v -> edges v) + | _ -> Lwt.return_nil + + let closure t ~min ~max = + [%log.debug "closure min=%a max=%a" pp_keys min pp_keys max]; + let min = List.rev_map (fun x -> `Node x) min in + let max = List.rev_map (fun x -> `Node x) max in + let+ g = Graph.closure ~pred:(pred t) ~min ~max () in + List.fold_left + (fun acc -> function `Node x -> x :: acc | _ -> acc) + [] (Graph.vertex g) + + let ignore_lwt _ = Lwt.return_unit + + let iter t ~min ~max ?(node = ignore_lwt) ?(contents = ignore_lwt) ?edge + ?(skip_node = fun _ -> Lwt.return_false) + ?(skip_contents = fun _ -> Lwt.return_false) ?(rev = true) () = + let min = List.rev_map (fun x -> `Node x) min in + let max = List.rev_map (fun x -> `Node x) max in + let node = function + | `Node x -> node x + | `Contents c -> contents c + | `Branch _ | `Commit _ -> Lwt.return_unit + in + let edge = + Option.map + (fun edge n pred -> + match (n, pred) with + | `Node src, `Node dst -> edge src dst + | _ -> Lwt.return_unit) + edge + in + let skip = function + | `Node x -> skip_node x + | `Contents c -> skip_contents c + | _ -> Lwt.return_false + in + Graph.iter ~pred:(pred t) ~min ~max ~node ?edge ~skip ~rev () + + let v t xs = S.add t (S.Val.of_list xs) + + let find_step t node step = + [%log.debug "contents %a" pp_key node]; + S.find t node >|= function None -> None | Some n -> S.Val.find n step + + let find t node path = + [%log.debug "read_node_exn %a %a" pp_key node pp_path path]; + let rec aux node path = + match Path.decons path with + | None -> Lwt.return_some (`Node node) + | Some (h, tl) -> ( + find_step t node h >>= function + | (None | Some (`Contents _)) as x -> Lwt.return x + | Some (`Node node) -> aux node tl) + in + aux node path + + let err_empty_path () = invalid_arg "Irmin.node: empty path" + + let map_one t node f label = + [%log.debug "map_one %a" Type.(pp Path.step_t) label]; + let old_key = S.Val.find node label in + let* old_node = + match old_key with + | None | Some (`Contents _) -> Lwt.return (S.Val.empty ()) + | Some (`Node k) -> ( + S.find t k >|= function None -> S.Val.empty () | Some v -> v) + in + let* new_node = f old_node in + if equal_val old_node new_node then Lwt.return node + else if S.Val.is_empty new_node then + let node = S.Val.remove node label in + if S.Val.is_empty node then Lwt.return (S.Val.empty ()) + else Lwt.return node + else + let+ k = S.add t new_node in + S.Val.add node label (`Node k) + + let map t node path f = + [%log.debug "map %a %a" pp_key node pp_path path]; + let rec aux node path = + match Path.decons path with + | None -> Lwt.return (f node) + | Some (h, tl) -> map_one t node (fun node -> aux node tl) h + in + let* node = + S.find t node >|= function None -> S.Val.empty () | Some n -> n + in + aux node path >>= S.add t + + let add t node path n = + [%log.debug "add %a %a" pp_key node pp_path path]; + match Path.rdecons path with + | Some (path, file) -> map t node path (fun node -> S.Val.add node file n) + | None -> ( + match n with + | `Node n -> Lwt.return n + | `Contents _ -> failwith "TODO: Node.add") + + let rdecons_exn path = + match Path.rdecons path with + | Some (l, t) -> (l, t) + | None -> err_empty_path () + + let remove t node path = + let path, file = rdecons_exn path in + map t node path (fun node -> S.Val.remove node file) + + let value_t = S.Val.value_t +end + +module V1 (N : Generic_key.S with type step = string) = struct + module K (H : Type.S) = struct + let h = Type.string_of `Int64 + + type t = H.t [@@deriving irmin ~to_bin_string ~of_bin_string] + + let size_of = Type.Size.using to_bin_string (Type.Size.t h) + + let encode_bin = + let encode_bin = Type.(unstage (encode_bin h)) in + fun e k -> encode_bin (to_bin_string e) k + + let decode_bin = + let decode_bin = Type.(unstage (decode_bin h)) in + fun buf pos_ref -> + let v = decode_bin buf pos_ref in + match of_bin_string v with + | Ok v -> v + | Error (`Msg e) -> Fmt.failwith "decode_bin: %s" e + + let t = Type.like t ~bin:(encode_bin, decode_bin, size_of) + end + + module Node_key = K (struct + type t = N.node_key + + let t = N.node_key_t + end) + + module Contents_key = K (struct + type t = N.contents_key + + let t = N.contents_key_t + end) + + module Metadata = N.Metadata + + type step = N.step + type node_key = Node_key.t [@@deriving irmin] + type contents_key = Contents_key.t [@@deriving irmin] + type metadata = N.metadata [@@deriving irmin] + type hash = N.hash [@@deriving irmin] + type value = N.value + type t = { n : N.t; entries : (step * value) list } + + exception Dangling_hash = N.Dangling_hash + + let import n = { n; entries = N.list n } + let export t = t.n + let with_handler _ t = t + let hash_exn ?force t = N.hash_exn ?force t.n + let head t = N.head t.n + + let of_seq entries = + let n = N.of_seq entries in + let entries = List.of_seq entries in + { n; entries } + + let of_list entries = + let n = N.of_list entries in + { n; entries } + + let seq ?(offset = 0) ?length ?cache:_ t = + let take seq = match length with None -> seq | Some n -> Seq.take n seq in + List.to_seq t.entries |> Seq.drop offset |> take + + let list ?offset ?length ?cache t = List.of_seq (seq ?offset ?length ?cache t) + let empty () = { n = N.empty (); entries = [] } + let is_empty t = t.entries = [] + let length e = N.length e.n + let clear _ = () + let find ?cache t k = N.find ?cache t.n k + + let add t k v = + let n = N.add t.n k v in + if t.n == n then t else { n; entries = N.list n } + + let remove t k = + let n = N.remove t.n k in + if t.n == n then t else { n; entries = N.list n } + + let v1_step = Type.string_of `Int64 + let step_to_bin_string = Type.(unstage (to_bin_string v1_step)) + let step_of_bin_string = Type.(unstage (of_bin_string v1_step)) + + let step_t : step Type.t = + let to_string p = step_to_bin_string p in + let of_string s = + step_of_bin_string s |> function + | Ok x -> x + | Error (`Msg e) -> Fmt.failwith "Step.of_string: %s" e + in + Type.(map (string_of `Int64)) of_string to_string + + let is_default = Type.(unstage (equal N.metadata_t)) Metadata.default + + let value_t = + let open Type in + record "node" (fun contents metadata node -> + match (contents, metadata, node) with + | Some c, None, None -> `Contents (c, Metadata.default) + | Some c, Some m, None -> `Contents (c, m) + | None, None, Some n -> `Node n + | _ -> failwith "invalid node") + |+ field "contents" (option Contents_key.t) (function + | `Contents (x, _) -> Some x + | _ -> None) + |+ field "metadata" (option metadata_t) (function + | `Contents (_, x) when not (is_default x) -> Some x + | _ -> None) + |+ field "node" (option Node_key.t) (function + | `Node n -> Some n + | _ -> None) + |> sealr + + let t : t Type.t = + Type.map Type.(list ~len:`Int64 (pair step_t value_t)) of_list list + + let merge ~contents ~node = + let merge = N.merge ~contents ~node in + let f ~old x y = + let old = Merge.map_promise (fun old -> old.n) old in + let+ r = Merge.f merge ~old x.n y.n in + match r with Ok r -> Ok (import r) | Error e -> Error e + in + Merge.v t f +end diff --git a/src/irmin-lwt/core/node.mli b/src/irmin-lwt/core/node.mli new file mode 100644 index 0000000000..8cbe4350b1 --- /dev/null +++ b/src/irmin-lwt/core/node.mli @@ -0,0 +1,27 @@ +(* + * Copyright (c) 2013 Louis Gesbert + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** [Node] provides functions to describe the graph-like structured values. + + The node blocks form a labeled directed acyclic graph, labeled by + {{!Path.S.step} steps}: a list of steps defines a unique path from one node + to an other. + + Each node can point to user-defined {{!Contents.S} contents} values. *) + +include Node_intf.Sigs +(** @inline *) diff --git a/src/irmin-lwt/core/node_intf.ml b/src/irmin-lwt/core/node_intf.ml new file mode 100644 index 0000000000..d59e3e3288 --- /dev/null +++ b/src/irmin-lwt/core/node_intf.ml @@ -0,0 +1,478 @@ +(* + * Copyright (c) 2013 Louis Gesbert + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +module type Core = sig + (** {1 Node values} *) + + type t [@@deriving irmin] + (** The type for node values. *) + + type metadata [@@deriving irmin] + (** The type for node metadata. *) + + type contents_key [@@deriving irmin] + (** The type for contents keys. *) + + type node_key [@@deriving irmin] + (** The type for node keys. *) + + type step [@@deriving irmin] + (** The type for steps between nodes. *) + + type value = [ `Node of node_key | `Contents of contents_key * metadata ] + [@@deriving irmin] + (** The type for either (node) keys or (contents) keys combined with their + metadata. *) + + type hash [@@deriving irmin] + (** The type of hashes of values. *) + + val of_list : (step * value) list -> t + (** [of_list l] is the node [n] such that [list n = l]. *) + + val list : + ?offset:int -> ?length:int -> ?cache:bool -> t -> (step * value) list + (** [list t] is the contents of [t]. [offset] and [length] are used to + paginate results. *) + + val of_seq : (step * value) Seq.t -> t + (** [of_seq s] is the node [n] such that [seq n = s]. *) + + val seq : + ?offset:int -> ?length:int -> ?cache:bool -> t -> (step * value) Seq.t + (** [seq t] is the contents of [t]. [offset] and [length] are used to paginate + results. + + See {!caching} for an explanation of the [cache] parameter *) + + val empty : unit -> t + (** [empty ()] is the empty node. *) + + val is_empty : t -> bool + (** [is_empty t] is true iff [t] is {!empty}. *) + + val length : t -> int + (** [length t] is the number of entries in [t]. *) + + val hash_exn : ?force:bool -> t -> hash + (** [hash_exn t] is the hash of [t]. + + Another way of computing it is [Hash.Typed(Hash)(Node).hash t] which + computes the pre-hash of [t] before hashing it using [Hash]. [hash_exn] + might be faster because the it may be optimised (e.g. it may use caching). + + [hash_exn t] is [hash_exn ~force:true t] which is not expected to raise an + exception. [hash_exn ~force:false t] will raise [Not_found] if the hash + requires IOs to be computed. *) + + val clear : t -> unit + (** Cleanup internal caches. *) + + val find : ?cache:bool -> t -> step -> value option + (** [find t s] is the value associated with [s] in [t]. + + A node can point to user-defined {{!contents_key} contents}. The edge + between the node and the contents is labeled by a {!step}. + + See {!caching} for an explanation of the [cache] parameter *) + + val add : t -> step -> value -> t + (** [add t s v] is the node where [find t v] is [Some s] but is similar to [t] + otherwise. *) + + val remove : t -> step -> t + (** [remove t s] is the node where [find t s] is [None] but is similar to [t] + otherwise. *) + + module Metadata : Metadata.S with type t = metadata + (** Metadata functions. *) + + (** {2:caching caching} + + [cache] regulates the caching behaviour regarding the node's internal data + which may be lazily loaded from the backend, depending on the node + implementation. + + [cache] defaults to [true] which may greatly reduce the IOs and the + runtime but may also increase the memory consumption. + + [cache = false] doesn't replace a call to [clear], it only prevents the + storing of new data, it doesn't discard the existing one. *) + + (** {1 Recursive Nodes} *) + + (** Some [Node] implementations (like [irmin-pack]'s inodes) can represent a + node as a set of nodes. One operation on such "high-level" node + corresponds to a sequence of recursive calls to the underlying + "lower-level" nodes. Note: theses [effects] are not in the Lwt monad on + purpose (so [Tree.hash] and [Tree.equal] are not in the Lwt monad as + well). *) + + type read_effect := expected_depth:int -> node_key -> t option + (** The type for read effects. *) + + val with_handler : (read_effect -> read_effect) -> t -> t + (** [with_handler f] replace the current effect handler [h] by [f h]. [f h] + will be called for all the recursive read effects that are required by + recursive operations on nodes. .*) + + type head := + [ `Node of (step * value) list | `Inode of int * (int * hash) list ] + [@@deriving irmin] + + val head : t -> head + (** Reveal the shallow internal structure of the node. + + Only hashes and not keys are revealed in the [`Inode] case, this is + because these inodes might not be keyed yet. *) +end + +module type S_generic_key = sig + include Core + (** @inline *) + + (** {2 merging} *) + + val merge : + contents:contents_key option Merge.t -> + node:node_key option Merge.t -> + t Merge.t + (** [merge] is the merge function for nodes. *) + + exception Dangling_hash of { context : string; hash : hash } +end + +module type S = sig + type hash + + (** @inline *) + include + S_generic_key + with type hash := hash + and type contents_key = hash + and type node_key = hash +end + +module type Portable = sig + type hash + + (** @inline *) + include + Core + with type hash := hash + and type contents_key = hash + and type node_key = hash + + type node + + val of_node : node -> t + + (** {2 merging} *) + + val merge : + contents:contents_key option Merge.t -> + node:node_key option Merge.t -> + t Merge.t + (** [merge] is the merge function for nodes. *) + + (** {1 Proofs} *) + + type proof = + [ `Blinded of hash + | `Values of (step * value) list + | `Inode of int * (int * proof) list ] + [@@deriving irmin] + (** The type for proof trees. *) + + val to_proof : t -> proof + + val of_proof : depth:int -> proof -> t option + (** [of_proof ~depth p] is [None] if [p] is corrupted or incompatible with + [depth]. It is [Some t] when [t] is a node if the operation succeeded. + + [hash_exn t] never raises [Not_found] *) +end + +open struct + module S_is_a_generic_key (X : S) : S_generic_key = X +end + +module type Maker_generic_key = functor + (Hash : Hash.S) + (Path : sig + type step [@@deriving irmin] + end) + (Metadata : Metadata.S) + (Contents_key : Key.S with type hash = Hash.t) + (Node_key : Key.S with type hash = Hash.t) + -> sig + include + S_generic_key + with type metadata = Metadata.t + and type step = Path.step + and type hash = Hash.t + and type contents_key = Contents_key.t + and type node_key = Node_key.t + + module Portable : + Portable + with type node := t + and type step := step + and type metadata := metadata + and type hash := hash +end + +module type Store = sig + include Indexable.S + + module Path : Path.S + (** [Path] provides base functions on node paths. *) + + val merge : [> read_write ] t -> key option Merge.t + (** [merge] is the 3-way merge function for nodes keys. *) + + module Metadata : Metadata.S + (** [Metadata] provides base functions for node metadata. *) + + (** [Val] provides base functions for node values. *) + module Val : + S_generic_key + with type t = value + and type hash = hash + and type node_key = key + and type metadata = Metadata.t + and type step = Path.step + + module Hash : Hash.Typed with type t = hash and type value = value + + module Contents : Contents.Store with type key = Val.contents_key + (** [Contents] is the underlying contents store. *) +end + +module type Graph = sig + (** {1 Node Graphs} *) + + type 'a t + (** The type for store handles. *) + + type metadata [@@deriving irmin] + (** The type for node metadata. *) + + type contents_key [@@deriving irmin] + (** The type of user-defined contents. *) + + type node_key [@@deriving irmin] + (** The type for node values. *) + + type step [@@deriving irmin] + (** The type of steps. A step is used to pass from one node to another. *) + + type path [@@deriving irmin] + (** The type of store paths. A path is composed of {{!step} steps}. *) + + type value = [ `Node of node_key | `Contents of contents_key * metadata ] + [@@deriving irmin] + (** The type for store values. *) + + val empty : [> write ] t -> node_key Lwt.t + (** The empty node. *) + + val v : [> write ] t -> (step * value) list -> node_key Lwt.t + (** [v t n] is a new node containing [n]. *) + + val list : [> read ] t -> node_key -> (step * value) list Lwt.t + (** [list t n] is the contents of the node [n]. *) + + val find : [> read ] t -> node_key -> path -> value option Lwt.t + (** [find t n p] is the contents of the path [p] starting form [n]. *) + + val add : [> read_write ] t -> node_key -> path -> value -> node_key Lwt.t + (** [add t n p v] is the node [x] such that [find t x p] is [Some v] and it + behaves the same [n] for other operations. *) + + val remove : [> read_write ] t -> node_key -> path -> node_key Lwt.t + (** [remove t n path] is the node [x] such that [find t x] is [None] and it + behhaves then same as [n] for other operations. *) + + val closure : + [> read ] t -> min:node_key list -> max:node_key list -> node_key list Lwt.t + (** [closure t min max] is the unordered list of nodes [n] reachable from a + node of [max] along a path which: (i) either contains no [min] or (ii) it + ends with a [min]. + + {b Note:} Both [min] and [max] are subsets of [n]. *) + + val iter : + [> read ] t -> + min:node_key list -> + max:node_key list -> + ?node:(node_key -> unit Lwt.t) -> + ?contents:(contents_key -> unit Lwt.t) -> + ?edge:(node_key -> node_key -> unit Lwt.t) -> + ?skip_node:(node_key -> bool Lwt.t) -> + ?skip_contents:(contents_key -> bool Lwt.t) -> + ?rev:bool -> + unit -> + unit Lwt.t + (** [iter t min max node edge skip rev ()] iterates in topological order over + the closure of [t]. + + It applies the following functions while traversing the graph: [node] on + the nodes; [edge n predecessor_of_n] on the directed edges; [skip_node n] + to not include a node [n], its predecessors and the outgoing edges of [n] + and [skip_contents c] to not include content [c]. + + If [rev] is true (the default) then the graph is traversed in the reverse + order: [node n] is applied only after it was applied on all its + predecessors; [edge n p] is applied after [node n]. Note that [edge n p] + is applied even if [p] is skipped. *) +end + +module type Sigs = sig + module type S = S + + (** [Make] provides a simple node implementation, parameterized by hash, path + and metadata implementations. The contents and node values are addressed + directly by their hash. *) + module Make + (Hash : Hash.S) + (Path : sig + type step [@@deriving irmin] + end) + (Metadata : Metadata.S) : + S + with type hash = Hash.t + and type metadata = Metadata.t + and type step = Path.step + + (** [Generic_key] generalises the concept of "node" to one that supports + object keys that are not strictly equal to hashes. *) + module Generic_key : sig + module type S = S_generic_key + module type Maker = Maker_generic_key + module type Core = Core + + module Make : Maker + + module Make_v2 : Maker + (** [Make_v2] provides a similar implementation as [Make] but the hash + computation is compatible with versions older than irmin.3.0 *) + + module Store + (C : Contents.Store) + (S : Indexable.S) + (H : Hash.S with type t = S.hash) + (V : + S + with type t = S.value + and type hash = H.t + and type contents_key = C.key + and type node_key = S.key) + (M : Metadata.S with type t = V.metadata) + (P : Path.S with type step = V.step) : + Store + with type 'a t = 'a C.t * 'a S.t + and type key = S.key + and type hash = S.hash + and type value = S.value + and module Path = P + and module Metadata = M + and module Val = V + end + + (** v1 serialisation *) + module V1 (N : Generic_key.S with type step = string) : sig + include + Generic_key.S + with type contents_key = N.contents_key + and type node_key = N.node_key + and type step = N.step + and type metadata = N.metadata + + val import : N.t -> t + val export : t -> N.t + end + + module Portable : sig + (** Portable form of a node implementation that can be constructed from a + concrete representation and used in computing hashes. Conceptually, a + [Node.Portable.t] is a [Node.t] in which all internal keys have been + replaced with the hashes of the values they point to. + + Computations over [Portable.t] values must commute with those over [t]s, + as in the following diagram: + + {[ + ┌────────┐ ┌─────────┐ of_node ┌────────────────┐ + │ Key │ │ Node │ ─────────> │ Node.Portable │ + └────────┘ └─────────┘ └────────────────┘ + │ │ add/remove │ │ + to_hash └───────────> (+) add/remove │ + │ ┌──────────────┼──────────────────────> (+) + v │ v v + ┌────────┐ ┌─────────┐ ┌────────────────┐ + │ Hash │ │ Node' │ ─────────> │ Node.Portable' │ + └────────┘ └─────────┘ of_node └────────────────┘ + ]} *) + + (** A node implementation with hashes for keys is trivially portable: *) + module Of_node (S : S) : + Portable + with type node := S.t + and type t = S.t + and type step = S.step + and type metadata = S.metadata + and type hash = S.hash + + module type S = Portable + end + + module type Store = Store + (** [Store] specifies the signature for node stores. *) + + (** [Store] creates node stores. *) + module Store + (C : Contents.Store) + (S : Content_addressable.S with type key = C.key) + (H : Hash.S with type t = S.key) + (V : S with type t = S.value and type hash = S.key) + (M : Metadata.S with type t = V.metadata) + (P : Path.S with type step = V.step) : + Store + with type 'a t = 'a C.t * 'a S.t + and type key = S.key + and type value = S.value + and type hash = H.t + and module Path = P + and module Metadata = M + and module Val = V + + module type Graph = Graph + (** [Graph] specifies the signature for node graphs. A node graph is a + deterministic DAG, labeled by steps. *) + + module Graph (N : Store) : + Graph + with type 'a t = 'a N.t + and type contents_key = N.Contents.key + and type node_key = N.key + and type metadata = N.Metadata.t + and type step = N.Path.step + and type path = N.Path.t +end diff --git a/src/irmin-lwt/core/object_graph.ml b/src/irmin-lwt/core/object_graph.ml new file mode 100644 index 0000000000..bb47a16371 --- /dev/null +++ b/src/irmin-lwt/core/object_graph.ml @@ -0,0 +1,291 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Object_graph_intf + +let src = Logs.Src.create "irmin.graph" ~doc:"Irmin graph support" + +module Log = (val Logs.src_log src : Logs.LOG) + +let list_partition_map f t = + let rec aux fst snd = function + | [] -> (List.rev fst, List.rev snd) + | h :: t -> ( + match f h with + | `Fst x -> aux (x :: fst) snd t + | `Snd x -> aux fst (x :: snd) t) + in + aux [] [] t + +module Make + (Contents_key : Type.S) + (Node_key : Type.S) + (Commit_key : Type.S) + (Branch : Type.S) = +struct + module X = struct + type t = + [ `Contents of Contents_key.t + | `Node of Node_key.t + | `Commit of Commit_key.t + | `Branch of Branch.t ] + [@@deriving irmin] + + let equal = Type.(unstage (equal t)) + let compare = Type.(unstage (compare t)) + let hash_contents = Type.(unstage (short_hash Contents_key.t)) + let hash_commit = Type.(unstage (short_hash Commit_key.t)) + let hash_node = Type.(unstage (short_hash Node_key.t)) + let hash_branch = Type.(unstage (short_hash Branch.t)) + + (* we are using cryptographic hashes here, so the first bytes + are good enough to be used as short hashes. *) + let hash (t : t) : int = + match t with + | `Contents c -> hash_contents c + | `Node n -> hash_node n + | `Commit c -> hash_commit c + | `Branch b -> hash_branch b + end + + module G = Graph.Imperative.Digraph.ConcreteBidirectional (X) + module GO = Graph.Oper.I (G) + module Topological = Graph.Topological.Make (G) + + module Table : sig + type t + + val create : int option -> t + val add : t -> X.t -> int -> unit + val mem : t -> X.t -> bool + end = struct + module Lru = Lru.Make (X) + module Tbl = Hashtbl.Make (X) + + type t = L of int Lru.t | T of int Tbl.t + + let create = function + | None -> T (Tbl.create 1024) + | Some n -> L (Lru.create n) + + let add t k v = match t with L t -> Lru.add t k v | T t -> Tbl.add t k v + let mem t k = match t with L t -> Lru.mem t k | T t -> Tbl.mem t k + end + + module Set = Set.Make (X) + include G + include GO + + type dump = vertex list * (vertex * vertex) list + + (* XXX: for the binary format, we can use offsets in the vertex list + to save space. *) + module Dump = struct + type t = X.t list * (X.t * X.t) list [@@deriving irmin] + end + + let vertex g = G.fold_vertex (fun k set -> k :: set) g [] + let edges g = G.fold_edges (fun k1 k2 list -> (k1, k2) :: list) g [] + let pp_vertices = Fmt.Dump.list (Type.pp X.t) + let pp_depth ppf d = if d <> max_int then Fmt.pf ppf "depth=%d,@ " d + + type action = Visit of (X.t * int) | Treat of X.t + + let iter ?cache_size ?(depth = max_int) ~pred ~min ~max ~node ?edge ~skip ~rev + () = + [%log.debug + "@[<2>iter:@ %arev=%b,@ min=%a,@ max=%a@, cache=%a@]" pp_depth depth rev + pp_vertices min pp_vertices max + Fmt.(Dump.option int) + cache_size]; + let marks = Table.create cache_size in + let mark key level = Table.add marks key level in + let todo = Stack.create () in + (* if a branch is in [min], add the commit it is pointing to too. *) + let* min = + Lwt_list.fold_left_s + (fun acc -> function + | `Branch _ as x -> pred x >|= fun c -> (x :: c) @ acc + | x -> Lwt.return (x :: acc)) + [] min + in + let min = Set.of_list min in + let has_mark key = Table.mem marks key in + List.iter (fun k -> Stack.push (Visit (k, 0)) todo) max; + let treat key = + [%log.debug "TREAT %a" Type.(pp X.t) key]; + node key >>= fun () -> + if not (Set.mem key min) then + (* the edge function is optional to prevent an unnecessary computation + of the preds .*) + match edge with + | None -> Lwt.return_unit + | Some edge -> + let* keys = pred key in + Lwt_list.iter_p (fun k -> edge key k) keys + else Lwt.return_unit + in + let visit_predecessors ~filter_history key level = + let+ keys = pred key in + (*if a commit is in [min] cut the history but still visit + its nodes. *) + List.iter + (function + | `Commit _ when filter_history -> () + | k -> Stack.push (Visit (k, level + 1)) todo) + keys + in + let visit key level = + if level >= depth then Lwt.return_unit + else if has_mark key then Lwt.return_unit + else + skip key >>= function + | true -> Lwt.return_unit + | false -> + let+ () = + [%log.debug "VISIT %a %d" Type.(pp X.t) key level]; + mark key level; + if rev then Stack.push (Treat key) todo; + match key with + | `Commit _ -> + visit_predecessors ~filter_history:(Set.mem key min) key level + | _ -> + if Set.mem key min then Lwt.return_unit + else visit_predecessors ~filter_history:false key level + in + if not rev then Stack.push (Treat key) todo + in + let rec pop () = + match Stack.pop todo with + | exception Stack.Empty -> Lwt.return_unit + | Treat key -> treat key >>= pop + | Visit (key, level) -> visit key level >>= pop + in + pop () + + let breadth_first_traversal ?cache_size ~pred ~max ~node () = + let marks = Table.create cache_size in + let mark key level = Table.add marks key level in + let todo = Queue.create () in + let has_mark key = Table.mem marks key in + List.iter (fun k -> Queue.push (Visit (k, 0)) todo) max; + let treat key = + [%log.debug "TREAT %a" Type.(pp X.t) key]; + node key + in + let visit_predecessors key level = + let+ keys = pred key in + List.iter (fun k -> Queue.push (Visit (k, level + 1)) todo) keys + in + let visit key level = + if has_mark key then Lwt.return_unit + else ( + [%log.debug "VISIT %a" Type.(pp X.t) key]; + mark key level; + treat key >>= fun () -> visit_predecessors key level) + in + let rec pop () = + match Queue.pop todo with + | exception Queue.Empty -> Lwt.return_unit + | Treat _ -> + Fmt.failwith "in bfs always treat the node as soon as its visited" + | Visit (key, level) -> visit key level >>= pop + in + pop () + + let closure ?(depth = max_int) ~pred ~min ~max () = + let g = G.create ~size:1024 () in + List.iter (G.add_vertex g) max; + let node key = + if not (G.mem_vertex g key) then G.add_vertex g key else (); + Lwt.return_unit + in + let edge node pred = + G.add_edge g pred node; + Lwt.return_unit + in + let skip _ = Lwt.return_false in + iter ~depth ~pred ~min ~max ~node ~edge ~skip ~rev:false () >|= fun () -> g + + let min g = + G.fold_vertex + (fun v acc -> if G.in_degree g v = 0 then v :: acc else acc) + g [] + + let max g = + G.fold_vertex + (fun v acc -> if G.out_degree g v = 0 then v :: acc else acc) + g [] + + let vertex_attributes = ref (fun _ -> []) + let edge_attributes = ref (fun _ -> []) + let graph_name = ref None + + module Dot = Graph.Graphviz.Dot (struct + include G + + let edge_attributes k = !edge_attributes k + let default_edge_attributes _ = [] + + let vertex_name k = + let str t v = "\"" ^ Type.to_string t v ^ "\"" in + match k with + | `Node n -> str Node_key.t n + | `Commit c -> str Commit_key.t c + | `Contents c -> str Contents_key.t c + | `Branch b -> str Branch.t b + + let vertex_attributes k = !vertex_attributes k + let default_vertex_attributes _ = [] + let get_subgraph _ = None + + let graph_attributes _ = + match !graph_name with None -> [] | Some n -> [ `Label n ] + end) + + let export t = (vertex t, edges t) + + let import (vs, es) = + let g = G.create ~size:(List.length vs) () in + List.iter (G.add_vertex g) vs; + List.iter (fun (v1, v2) -> G.add_edge g v1 v2) es; + g + + let output ppf vertex edges name = + [%log.debug "output %s" name]; + let g = G.create ~size:(List.length vertex) () in + List.iter (fun (v, _) -> G.add_vertex g v) vertex; + List.iter (fun (v1, _, v2) -> G.add_edge g v1 v2) edges; + let eattrs (v1, v2) = + try + let l = List.filter (fun (x, _, y) -> x = v1 && y = v2) edges in + let l = List.fold_left (fun acc (_, l, _) -> l @ acc) [] l in + let labels, others = + list_partition_map (function `Label l -> `Fst l | x -> `Snd x) l + in + match labels with + | [] -> others + | [ l ] -> `Label l :: others + | _ -> `Label (String.concat "," labels) :: others + with Not_found -> [] + in + let vattrs v = try List.assoc v vertex with Not_found -> [] in + vertex_attributes := vattrs; + edge_attributes := eattrs; + graph_name := Some name; + Dot.fprint_graph ppf g +end diff --git a/src/irmin-lwt/core/object_graph.mli b/src/irmin-lwt/core/object_graph.mli new file mode 100644 index 0000000000..a16412aaa2 --- /dev/null +++ b/src/irmin-lwt/core/object_graph.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Graphs. *) + +include Object_graph_intf.Sigs +(** @inline *) diff --git a/src/irmin-lwt/core/object_graph_intf.ml b/src/irmin-lwt/core/object_graph_intf.ml new file mode 100644 index 0000000000..063c3bbe0b --- /dev/null +++ b/src/irmin-lwt/core/object_graph_intf.ml @@ -0,0 +1,139 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + include Graph.Sig.I + (** Directed graph *) + + include Graph.Oper.S with type g := t + (** Basic operations. *) + + (** Topological traversal *) + module Topological : sig + val fold : (vertex -> 'a -> 'a) -> t -> 'a -> 'a + end + + val vertex : t -> vertex list + (** Get all the vertices. *) + + val edges : t -> (vertex * vertex) list + (** Get all the relations. *) + + val closure : + ?depth:int -> + pred:(vertex -> vertex list Lwt.t) -> + min:vertex list -> + max:vertex list -> + unit -> + t Lwt.t + (** [closure depth pred min max ()] creates the transitive closure graph of + [max] using the predecessor relation [pred]. The graph is bounded by the + [min] nodes and by [depth]. + + {b Note:} Both [min] and [max] are subsets of [n]. *) + + val iter : + ?cache_size:int -> + ?depth:int -> + pred:(vertex -> vertex list Lwt.t) -> + min:vertex list -> + max:vertex list -> + node:(vertex -> unit Lwt.t) -> + ?edge:(vertex -> vertex -> unit Lwt.t) -> + skip:(vertex -> bool Lwt.t) -> + rev:bool -> + unit -> + unit Lwt.t + (** [iter depth min max node edge skip rev ()] iterates in topological order + over the closure graph starting with the [max] nodes and bounded by the + [min] nodes and by [depth]. + + It applies three functions while traversing the graph: [node] on the + nodes; [edge n predecessor_of_n] on the directed edges and [skip n] to not + include a node [n], its predecessors and the outgoing edges of [n]. + + If [rev] is true (the default) then the graph is traversed in the reverse + order: [node n] is applied only after it was applied on all its + predecessors; [edge n p] is applied after [node n]. Note that [edge n p] + is applied even if [p] is skipped. + + [cache_size] is the size of the LRU cache used to store nodes already + seen. If [None] (by default) every traversed nodes is stored (and thus no + entries are never removed from the LRU). *) + + val breadth_first_traversal : + ?cache_size:int -> + pred:(vertex -> vertex list Lwt.t) -> + max:vertex list -> + node:(vertex -> unit Lwt.t) -> + unit -> + unit Lwt.t + (** [breadth_first_traversal ?cache_size pred max node ()] traverses the + closure graph in breadth-first order starting with the [max] nodes. It + applies [node] on the nodes of the graph while traversing it. *) + + val output : + Format.formatter -> + (vertex * Graph.Graphviz.DotAttributes.vertex list) list -> + (vertex * Graph.Graphviz.DotAttributes.edge list * vertex) list -> + string -> + unit + (** [output ppf vertex edges name] create aand dumps the graph contents on + [ppf]. The graph is defined by its [vertex] and [edges]. [name] is the + name of the output graph.*) + + val min : t -> vertex list + (** Compute the minimum vertex. *) + + val max : t -> vertex list + (** Compute the maximun vertex. *) + + type dump = vertex list * (vertex * vertex) list + (** Expose the graph internals. *) + + val export : t -> dump + (** Expose the graph as a pair of vertices and edges. *) + + val import : dump -> t + (** Import a graph. *) + + module Dump : Type.S with type t = dump + (** The base functions over graph internals. *) +end + +module type HASH = sig + include Type.S + + val short_hash : t -> int +end + +module type Sigs = sig + module type S = S + module type HASH = HASH + + (** Build a graph. *) + module Make + (Contents_key : Type.S) + (Node_key : Type.S) + (Commit_key : Type.S) + (Branch : Type.S) : + S + with type V.t = + [ `Contents of Contents_key.t + | `Node of Node_key.t + | `Commit of Commit_key.t + | `Branch of Branch.t ] +end diff --git a/src/irmin-lwt/core/path.ml b/src/irmin-lwt/core/path.ml new file mode 100644 index 0000000000..2d021997e3 --- /dev/null +++ b/src/irmin-lwt/core/path.ml @@ -0,0 +1 @@ +include Irmin.Path diff --git a/src/irmin-lwt/core/perms.ml b/src/irmin-lwt/core/perms.ml new file mode 100644 index 0000000000..9f4bb7b944 --- /dev/null +++ b/src/irmin-lwt/core/perms.ml @@ -0,0 +1 @@ +include Irmin.Perms diff --git a/src/irmin-lwt/core/proof.ml b/src/irmin-lwt/core/proof.ml new file mode 100644 index 0000000000..a82dd20c10 --- /dev/null +++ b/src/irmin-lwt/core/proof.ml @@ -0,0 +1,276 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Proof_intf + +module Make + (C : Type.S) + (H : Type.S) + (S : sig + type step [@@deriving irmin] + end) + (M : Type.S) = +struct + type contents = C.t [@@deriving irmin] + type hash = H.t [@@deriving irmin] + type step = S.step [@@deriving irmin] + type metadata = M.t [@@deriving irmin] + + type kinded_hash = [ `Contents of hash * metadata | `Node of hash ] + [@@deriving irmin] + + type 'a inode = { length : int; proofs : (int * 'a) list } [@@deriving irmin] + + type 'a inode_extender = { length : int; segments : int list; proof : 'a } + [@@deriving irmin] + + 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 + [@@deriving irmin] + + 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 + [@@deriving irmin] + + type elt = + | Contents of contents + | Node of (step * kinded_hash) list + | Inode of hash inode + | Inode_extender of hash inode_extender + [@@deriving irmin] + + type stream = elt Seq.t [@@deriving irmin] + + type t = { before : kinded_hash; after : kinded_hash; state : tree } + [@@deriving irmin] + + let before t = t.before + let after t = t.after + let state t = t.state + let v ~before ~after state = { after; before; state } +end + +exception Bad_proof of { context : string } + +let bad_proof_exn context = raise (Bad_proof { context }) + +module Env + (B : Backend.S) + (P : + S + with type contents := B.Contents.Val.t + and type hash := B.Hash.t + and type step := B.Node.Val.step + and type metadata := B.Node.Val.metadata) = +struct + module H = B.Hash + + module Hashes = struct + include Hashtbl.Make (struct + type t = H.t + + let hash = H.short_hash + let equal = Type.(unstage (equal H.t)) + end) + + let of_list l = of_seq (List.to_seq l) + let to_list t = List.of_seq (to_seq t) + let t elt_t = Type.map [%typ: (H.t * elt) list] of_list to_list + end + + type mode = Produce | Serialise | Deserialise | Consume [@@deriving irmin] + + module Set = struct + type produce = { + nodes : B.Node.Val.t Hashes.t; + contents : B.Contents.Val.t Hashes.t; + } + [@@deriving irmin] + + type deserialise = { + nodes : B.Node_portable.t Hashes.t; + contents : B.Contents.Val.t Hashes.t; + } + [@@deriving irmin] + + type t = + | Produce of produce + | Serialise of produce + | Deserialise of deserialise + | Consume of deserialise + [@@deriving irmin] + + let producer () = + Produce { contents = Hashes.create 13; nodes = Hashes.create 13 } + + let deserialiser () = + Deserialise { contents = Hashes.create 13; nodes = Hashes.create 13 } + end + + type v = Empty | Set of Set.t [@@deriving irmin] + type t = v ref + + let t = Type.map v_t ref ( ! ) + let empty () : t = ref Empty + let is_empty t = !t = Empty + let copy ~into t = into := !t + + type hash = H.t [@@deriving irmin ~equal ~pp] + + let set_mode t mode = + match (!t, mode) with + | Empty, Produce -> t := Set Set.(producer ()) + | Empty, Deserialise -> t := Set Set.(deserialiser ()) + | Set (Produce set), Serialise -> t := Set Set.(Serialise set) + | Set (Deserialise set), Consume -> t := Set Set.(Consume set) + | _ -> assert false + + let with_consume f = + let t = ref Empty in + set_mode t Deserialise; + let stop_deserialise () = set_mode t Consume in + let+ res = f t ~stop_deserialise in + t := Empty; + res + + let with_produce f = + let t = ref Empty in + set_mode t Produce; + let start_serialise () = set_mode t Serialise in + let+ res = f t ~start_serialise in + t := Empty; + res + + module Contents_hash = Hash.Typed (H) (B.Contents.Val) + + let find_contents t h = + match !t with + | Empty -> None + | Set (Produce set) -> + (* Sharing of contents is not strictly needed during this phase. It + could be disabled. *) + Hashes.find_opt set.contents h + | Set (Serialise set) -> + (* This is needed in order to differenciate between blinded contents + from others. *) + Hashes.find_opt set.contents h + | Set (Deserialise _) -> + (* This phase only fills the env, it should search for anything *) + assert false + | Set (Consume set) -> + (* Use the Env to feed the values during consume *) + Hashes.find_opt set.contents h + + let add_contents_from_store t h v = + match !t with + | Empty -> () + | Set (Produce set) -> + (* Registering in [set] for traversal during [Serialise]. *) + assert (not (Hashes.mem set.contents h)); + Hashes.add set.contents h v + | Set (Serialise _) -> + (* There shouldn't be new contents during this phase *) + assert false + | Set (Deserialise _) -> + (* This phase has no repo pointer *) + assert false + | Set (Consume _) -> + (* This phase has no repo pointer *) + assert false + + let add_contents_from_proof t h v = + match !t with + | Set (Deserialise set) -> + (* Using [replace] because there could be several instances of this + contents in the proof, we will not share as this is not strictly + needed. *) + Hashes.replace set.contents h v + | Empty -> + (* Happens during [hash_of_proof_state] *) + () + | _ -> assert false + + let find_node t h = + match !t with + | Empty -> None + | Set (Produce set) -> + (* This is needed in order to achieve sharing on inode's pointers. In + other words, each node present in the [before] tree should have a + single [P.Node.Val.t] representative that will witness all the lazy + inode loadings. *) + Hashes.find_opt set.nodes h + | Set (Serialise set) -> + (* This is needed in order to follow loaded paths in the [before] + tree. *) + Hashes.find_opt set.nodes h + | Set (Deserialise _) -> + (* This phase only fills the env, it should search for anything *) + assert false + | Set (Consume _) -> + (* This phase looks for portable nodes *) + None + + let find_pnode t h = + match !t with + | Set (Consume set) -> + (* [set] has been filled during deserialise. Using it to provide values + during consume. *) + Hashes.find_opt set.nodes h + | _ -> None + + let add_node_from_store t h v = + match !t with + | Empty -> v + | Set (Produce set) -> + (* Registering in [set] for sharing during [Produce] and traversal + during [Serialise]. This assertion is guarenteed because + [add_node_from_store] is guarded by a call to [find_node] in tree. *) + assert (not (Hashes.mem set.nodes h)); + Hashes.add set.nodes h v; + v + | Set (Serialise _) -> + (* There shouldn't be new nodes during this phase *) + assert false + | Set (Deserialise _) -> + (* This phase has no repo pointer *) + assert false + | Set (Consume _) -> + (* This phase has no repo pointer *) + assert false + + let add_pnode_from_proof t h v = + match !t with + | Set (Deserialise set) -> + (* Using [replace] because there could be several instances of this + node in the proof, we will not share as this is not strictly + needed. + All the occurences of this node in the proof are expected to have + the same blinded/visible coverage (i.e. the same node proof). *) + Hashes.replace set.nodes h v + | Empty -> + (* Happens during [hash_of_proof_state] *) + () + | _ -> assert false +end diff --git a/src/irmin-lwt/core/proof.mli b/src/irmin-lwt/core/proof.mli new file mode 100644 index 0000000000..d2f22b543f --- /dev/null +++ b/src/irmin-lwt/core/proof.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Proof_intf.Proof diff --git a/src/irmin-lwt/core/proof_intf.ml b/src/irmin-lwt/core/proof_intf.ml new file mode 100644 index 0000000000..527b3966f4 --- /dev/null +++ b/src/irmin-lwt/core/proof_intf.ml @@ -0,0 +1,281 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + (** Proofs are compact representations of trees which can be shared between + peers. + + This is expected to be used as follows: + + - A first peer runs a function [f] over a tree [t]. While performing this + computation, it records: the hash of [t] (called [before] below), the + hash of [f t] (called [after] below) and a subset of [t] which is needed + to replay [f] without any access to the first peer's storage. Once done, + all these informations are packed into a proof of type [t] that is sent + to the second peer. + + - The second peer generates an initial tree [t'] from [p] and computes + [f t']. Once done, it compares [t']'s hash and [f t']'s hash to [before] + and [after]. If they match, they know that the result state [f t'] is a + valid context state, without having to have access to the full storage + of the first peer. *) + + type contents + type hash + type step + type metadata + + type kinded_hash = [ `Contents of hash * metadata | `Node of hash ] + [@@deriving irmin] + + type 'a inode = { length : int; proofs : (int * 'a) list } [@@deriving irmin] + (** The type for (internal) inode proofs. + + These proofs encode large directories into a tree-like structure. + + Invariants are dependent on the backend. + + [length] is the total number of entries in the children of the inode. It's + the size of the "flattened" version of that inode. [length] can be used to + prove the correctness of operations such as [Tree.length] and + [Tree.list ~offset ~length] in an efficient way. + + [proofs] contains the children proofs. It is a sparse list of ['a] values. + These values are associated to their index in the list, and the list is + kept sorted in increasing order of indices. ['a] can be a concrete proof + or a hash of that proof. + + {e For [irmin-pack]}: [proofs] have a length of at most [Conf.entries] + entries. For binary trees, this boolean index is a step of the left-right + sequence / decision proof corresponding to the path in that binary tree. + *) + + type 'a inode_extender = { length : int; segments : int list; proof : 'a } + [@@deriving irmin] + (** The type for inode extenders. + + An extender is a compact representation of a sequence of [inode] which + contain only one child. As for inodes, the ['a] parameter can be a + concrete proof or a hash of that proof. + + If an inode proof contains singleton children [i_0, ..., i_n] such as: + [{length=l; proofs = [ (i_0, {proofs = ... { proofs = [ (i_n, p) ] }})]}], + then it is compressed into the inode extender + [{length=l; segment = [i_0;..;i_n]; proof=p}] sharing the same length [l] + and final proof [p]. *) + + (** The type for compressed and partial Merkle tree proofs. + + Tree proofs do not provide any guarantee with the ordering of + computations. For instance, if two effects commute, they won't be + distinguishable by this kind of proof. + + [Value v] proves that a value [v] exists in the store. + + [Blinded_value h] proves a value with hash [h] exists in the store. + + [Node ls] proves that a a "flat" node containing the list of files [ls] + exists in the store. {e For [irmin-pack]}: the length of [ls] is at most + [Conf.stable_hash]; + + [Blinded_node h] proves that a node with hash [h] exists in the store. + + [Inode i] proves that an inode [i] exists in the store. + + [Extender e] proves that an inode extender [e] exist in the store. *) + 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 + [@@deriving irmin] + + (** The type for inode trees. It is a subset of [tree], limited to nodes. + + [Blinded_inode h] proves that an inode with hash [h] exists in the store. + + [Inode_values ls] is simliar to trees' [Node]. + + [Inode_tree i] is similar to tree's [Inode]. + + [Inode_extender e] is similar to trees' [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 + [@@deriving irmin] + + type t [@@deriving irmin] + (** The type for Merkle proofs. + + A proof [p] proves that the state advanced from [before p] to [after p]. + [state p]'s hash is [before p], and [state p] contains the minimal + information for the computation to reach [after p]. *) + + val v : before:kinded_hash -> after:kinded_hash -> tree -> t + (** [v ~before ~after p] proves that the state advanced from [before] to + [after]. [p]'s hash is [before], and [p] contains the minimal information + for the computation to reach [after]. *) + + val before : t -> kinded_hash + (** [before t] it the state's hash at the beginning of the computation. *) + + val after : t -> kinded_hash + (** [after t] is the state's hash at the end of the computation. *) + + val state : t -> tree + (** [state t] is a subset of the initial state needed to prove that the proven + computation could run without performing any I/O. *) +end + +(** Environment that tracks side effects during the production/consumption of + proofs. + + {1 The Merkle Proof Construction Algorithm} + + This description stands for [Set] proofs and assumes that the large nodes + are represented by the backend as a tree structure (i.e. inodes). + + There are 4 distinct phases when working with Irmin's merkle proofs: + [Produce | Serialise | Deserialise | Consume]. + + {2 [Produce]} + + This phase runs the [f] function provided by the Irmin user. It builds an + [after] tree from a [before] tree that has been setup with an [Env] that + records every backend reads into two hash tables. + + During the next phase (i.e. [Serialise]) the cleared [before] tree will be + traversed from root to stems only following the paths that are referenced in + [Env]. + + In practice [Env] doesn't exactly record the reads, it keeps track of all + the [hash -> backend node] and [hash -> backend contents] mappings that are + directly output of the backend stores through [P.Node.find] and + [P.Contents.find]. This is obviously enough to remember the contents, the + nodes and the inodes tips, but the inner inodes are not directly referenced + in the hash tables. + + The inner inodes are in fact referenced in their inode tip which is itself + referenced in [Env]'s hash tables. Since an inode shares its lazy pointers + with the inodes derived from it, even the inner inodes that are loaded from + the derived tips will be available from the original inode tip. + + {2 [Serialise]} + + In this phase, the [Env] contains everything necessary for the computation + of a Merkle proof from a cleared [before]. The [Env] now affects + [Node.cached_value] and [Contents.cached_value] allowing for the discovery + of the cached closure. + + {2 [Deserialise]} + + In this phase the [Env] is filled by recursively destructing the proof and + filling it before the [Consume] phase. + + {2 [Consume]} + + In this last phase the [Env] is again made accessible through + [Node.cached_pvalue] and [Contents.cached_pvalue], making it possible for + the user to reference by [hash] everything that was contained in the proof. + + {1 Nodes and Portable Nodes} + + While the [Produce] phase must be connected to the backend to records reads, + the [Consume] phase must be disconnected from the backend. + + [Produce] manipulates backend nodes of type [Backend.Node.Val.t] (the ones + enriched with backend keys) + + [Consume] is restricted to manipulating nodes of type + [Backend.Node_portable.t]. *) +module type Env = sig + type mode = Produce | Serialise | Deserialise | Consume + type t [@@deriving irmin] + type hash + type node + type pnode + type contents + + val is_empty : t -> bool + val empty : unit -> t + val copy : into:t -> t -> unit + + (** {2 Modes} *) + + val set_mode : t -> mode -> unit + + val with_produce : + (t -> start_serialise:(unit -> unit) -> 'a Lwt.t) -> 'a Lwt.t + + val with_consume : + (t -> stop_deserialise:(unit -> unit) -> 'a Lwt.t) -> 'a Lwt.t + + (** {2 Interactions With [Tree]} *) + + val add_contents_from_store : t -> hash -> contents -> unit + + val add_node_from_store : t -> hash -> node -> node + (** [add_node_from_store] returns a [node] and not [unit] because [Env] may + take the opportunity to wrap the input node in [Node.Val.with_handler]. *) + + val add_contents_from_proof : t -> hash -> contents -> unit + val add_pnode_from_proof : t -> hash -> pnode -> unit + val find_contents : t -> hash -> contents option + val find_node : t -> hash -> node option + val find_pnode : t -> hash -> pnode option +end + +module type Proof = sig + module type S = S + module type Env = Env + + exception Bad_proof of { context : string } + + val bad_proof_exn : string -> 'a + + module Make + (C : Type.S) + (H : Hash.S) + (P : sig + type step [@@deriving irmin] + end) + (M : Type.S) : sig + include + S + with type contents := C.t + and type hash := H.t + and type step := P.step + and type metadata := M.t + end + + module Env + (B : Backend.S) + (P : + S + with type contents := B.Contents.Val.t + and type hash := B.Hash.t + and type step := B.Node.Val.step + and type metadata := B.Node.Val.metadata) : + Env + with type hash := B.Hash.t + and type contents := B.Contents.Val.t + and type node := B.Node.Val.t + and type pnode := B.Node_portable.t +end diff --git a/src/irmin-lwt/core/read_only.ml b/src/irmin-lwt/core/read_only.ml new file mode 100644 index 0000000000..d1765fa4b0 --- /dev/null +++ b/src/irmin-lwt/core/read_only.ml @@ -0,0 +1 @@ +include Read_only_intf diff --git a/src/irmin-lwt/core/read_only.mli b/src/irmin-lwt/core/read_only.mli new file mode 100644 index 0000000000..0096f050cf --- /dev/null +++ b/src/irmin-lwt/core/read_only.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Read_only_intf.Sigs +(** @inline *) diff --git a/src/irmin-lwt/core/read_only_intf.ml b/src/irmin-lwt/core/read_only_intf.ml new file mode 100644 index 0000000000..6191822305 --- /dev/null +++ b/src/irmin-lwt/core/read_only_intf.ml @@ -0,0 +1,57 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import +open Store_properties + +module type S = sig + (** {1 Read-only stores} + + Read-only stores are store where it is only possible to read existing + values. *) + + type -'a t + (** The type for stores. The ['a] phantom type carries information about the + store mutability. *) + + type key + (** The type for keys. *) + + type value + (** The type for raw values. *) + + val mem : [> read ] t -> key -> bool Lwt.t + (** [mem t k] is true iff [k] is present in [t]. *) + + val find : [> read ] t -> key -> value option Lwt.t + (** [find t k] is [Some v] if [k] is associated to [v] in [t] and [None] is + [k] is not present in [t]. *) + + include Closeable with type 'a t := 'a t + (** @inline *) +end + +module type Maker = functor (Key : Type.S) (Value : Type.S) -> sig + include S with type key = Key.t and type value = Value.t + + include Of_config with type 'a t := 'a t + (** @inline *) +end + +module type Sigs = sig + module type S = S + module type Maker = Maker +end diff --git a/src/irmin-lwt/core/remote.ml b/src/irmin-lwt/core/remote.ml new file mode 100644 index 0000000000..b4d2247985 --- /dev/null +++ b/src/irmin-lwt/core/remote.ml @@ -0,0 +1,33 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Remote_intf + +module None (H : Type.S) (R : Type.S) = struct + type t = unit + + let v _ = Lwt.return_unit + + type endpoint = unit + type commit = H.t + type branch = R.t + + let fetch () ?depth:_ _ _br = + Lwt.return (Error (`Msg "fetch operation is not available")) + + let push () ?depth:_ _ _br = + Lwt.return (Error (`Msg "push operation is not available")) +end diff --git a/src/irmin-lwt/core/remote.mli b/src/irmin-lwt/core/remote.mli new file mode 100644 index 0000000000..8475355546 --- /dev/null +++ b/src/irmin-lwt/core/remote.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Remote stores. *) + +include Remote_intf.Sigs +(** @inline *) diff --git a/src/irmin-lwt/core/remote_intf.ml b/src/irmin-lwt/core/remote_intf.ml new file mode 100644 index 0000000000..1bf89ff43c --- /dev/null +++ b/src/irmin-lwt/core/remote_intf.ml @@ -0,0 +1,71 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* Aliased to [Irmin.remote] so that constructors added by Irmin 4 (notably + [Backend.E of endpoint] inside Inner) are visible at our shim's type. *) +type t = Irmin.remote = .. + +module type S = sig + (** {1 Remote synchronization} *) + + type t + (** The type for store handles. *) + + type commit + (** The type for store heads. *) + + type branch + (** The type for branch IDs. *) + + type endpoint + (** The type for sync endpoints. *) + + val fetch : + t -> + ?depth:int -> + endpoint -> + branch -> + (commit option, [ `Msg of string ]) result Lwt.t + (** [fetch t uri] fetches the contents of the remote store located at [uri] + into the local store [t]. Return the head of the remote branch with the + same name, which is now in the local store. [No_head] means no such branch + exists. *) + + val push : + t -> + ?depth:int -> + endpoint -> + branch -> + (unit, [ `Msg of string | `Detached_head ]) result Lwt.t + (** [push t uri] pushes the contents of the local store [t] into the remote + store located at [uri]. *) +end + +module type Sigs = sig + module type S = S + + type nonrec t = t = .. + + (** Provides stub implementations of the {!S} that always returns [Error] when + push/pull operations are attempted. *) + module None (H : Type.S) (R : Type.S) : sig + include + S with type commit = H.t and type branch = R.t and type endpoint = unit + + val v : 'a -> t Lwt.t + (** Create a remote store handle. *) + end +end diff --git a/src/irmin-lwt/core/schema.ml b/src/irmin-lwt/core/schema.ml new file mode 100644 index 0000000000..6b4c178a57 --- /dev/null +++ b/src/irmin-lwt/core/schema.ml @@ -0,0 +1,73 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * Copyright (c) 2020-2021 Craig Ferguson + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + module Hash : Hash.S + module Branch : Branch.S + module Info : Info.S + module Metadata : Metadata.S + module Path : Path.S + module Contents : Contents.S +end + +module type Extended = sig + include S + + module Node + (Contents_key : Key.S with type hash = Hash.t) + (Node_key : Key.S with type hash = Hash.t) : + Node.Generic_key.S + with type metadata = Metadata.t + and type step = Path.step + and type hash = Hash.t + and type contents_key = Contents_key.t + and type node_key = Node_key.t + + module Commit + (Node_key : Key.S with type hash = Hash.t) + (Commit_key : Key.S with type hash = Hash.t) : + Commit.Generic_key.S + with module Info := Info + and type node_key = Node_key.t + and type commit_key = Commit_key.t +end + +open struct + module Extended_is_a_schema (X : Extended) : S = X +end + +type default_hash = Hash.BLAKE2B.t + +module type KV = + Extended + with type Hash.t = default_hash + and type Branch.t = string + and type Info.t = Info.default + and type Metadata.t = unit + and type Path.step = string + and type Path.t = string list + +module KV (C : Contents.S) : KV with module Contents = C = struct + module Hash = Hash.BLAKE2B + module Info = Info.Default + module Branch = Branch.String + module Path = Path.String_list + module Metadata = Metadata.None + module Contents = C + module Node = Node.Generic_key.Make (Hash) (Path) (Metadata) + module Commit = Commit.Generic_key.Make (Hash) +end diff --git a/src/irmin-lwt/core/slice.ml b/src/irmin-lwt/core/slice.ml new file mode 100644 index 0000000000..9f3e7580a8 --- /dev/null +++ b/src/irmin-lwt/core/slice.ml @@ -0,0 +1,58 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Slice_intf + +module Make + (Contents : Contents.Store) + (Node : Node.Store) + (Commit : Commit.Store) = +struct + type contents = Contents.Hash.t * Contents.Val.t [@@deriving irmin] + type node = Node.Hash.t * Node.Val.t [@@deriving irmin] + type commit = Commit.Hash.t * Commit.Val.t [@@deriving irmin] + + type value = [ `Contents of contents | `Node of node | `Commit of commit ] + [@@deriving irmin] + + type t = { + mutable contents : contents list; + mutable nodes : node list; + mutable commits : commit list; + } + [@@deriving irmin] + + let empty () = Lwt.return { contents = []; nodes = []; commits = [] } + + let add t = function + | `Contents c -> + t.contents <- c :: t.contents; + Lwt.return_unit + | `Node n -> + t.nodes <- n :: t.nodes; + Lwt.return_unit + | `Commit c -> + t.commits <- c :: t.commits; + Lwt.return_unit + + let iter t f = + Lwt.join + [ + Lwt_list.iter_p (fun c -> f (`Contents c)) t.contents; + Lwt_list.iter_p (fun n -> f (`Node n)) t.nodes; + Lwt_list.iter_p (fun c -> f (`Commit c)) t.commits; + ] +end diff --git a/src/irmin-lwt/core/slice.mli b/src/irmin-lwt/core/slice.mli new file mode 100644 index 0000000000..2d673d6275 --- /dev/null +++ b/src/irmin-lwt/core/slice.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Slice_intf.Sigs +(** @inline *) diff --git a/src/irmin-lwt/core/slice_intf.ml b/src/irmin-lwt/core/slice_intf.ml new file mode 100644 index 0000000000..fc71483f35 --- /dev/null +++ b/src/irmin-lwt/core/slice_intf.ml @@ -0,0 +1,56 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + (** {1 Slices} *) + + type t [@@deriving irmin] + (** The type for slices. *) + + type contents [@@deriving irmin] + (** The type for exported contents. *) + + type node [@@deriving irmin] + (** The type for exported nodes. *) + + type commit [@@deriving irmin] + (** The type for exported commits. *) + + type value = [ `Contents of contents | `Node of node | `Commit of commit ] + [@@deriving irmin] + (** The type for exported values. *) + + val empty : unit -> t Lwt.t + (** Create a new empty slice. *) + + val add : t -> value -> unit Lwt.t + (** [add t v] adds [v] to [t]. *) + + val iter : t -> (value -> unit Lwt.t) -> unit Lwt.t + (** [iter t f] calls [f] on all values of [t]. *) +end + +module type Sigs = sig + module type S = S + (** The signature for slices. *) + + (** Build simple slices. *) + module Make (C : Contents.Store) (N : Node.Store) (H : Commit.Store) : + S + with type contents = C.hash * C.value + and type node = N.hash * N.value + and type commit = H.hash * H.value +end diff --git a/src/irmin-lwt/core/storage.ml b/src/irmin-lwt/core/storage.ml new file mode 100644 index 0000000000..037d7ddb3b --- /dev/null +++ b/src/irmin-lwt/core/storage.ml @@ -0,0 +1,146 @@ +(* + * Copyright (c) 2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import +include Storage_intf + +module Read_only (M : Make) = +functor + (K : Type.S) + (V : Type.S) + -> + struct + module S = M (K) (V) + + type 'a t = S.t + type key = S.key + type value = S.value + + let v = S.v + let mem = S.mem + let find = S.find + let close = S.close + end + +module Content_addressable (M : Make) : Content_addressable.Maker = +functor + (H : Hash.S) + (V : Type.S) + -> + struct + include Read_only (M) (H) (V) + module H = Hash.Typed (H) (V) + + let batch = S.batch + + let add t value = + let key = H.hash value in + let+ () = S.set t key value in + key + + let equal_hash = Type.(equal H.t |> unstage) + let pp_hash = Type.(pp H.t) + + let unsafe_add t k v = + let+ hash' = add t v in + if equal_hash k hash' then () + else + Fmt.failwith + "[unsafe_append] %a is not a valid key. Expecting %a instead.\n" + pp_hash k pp_hash hash' + end + +module Append_only (M : Make) : Append_only.Maker = +functor + (Key : Type.S) + (Value : Type.S) + -> + struct + include Read_only (M) (Key) (Value) + + let batch = S.batch + let add = S.set + end + +module Atomic_write (M : Make) : Atomic_write.Maker = +functor + (Key : Type.S) + (Value : Type.S) + -> + struct + module S = M (Key) (Value) + module W = Watch.Make (Key) (Value) + module L = Lock.Make (Key) + + type t = { t : S.t; w : W.t; l : L.t } + type key = S.key + type value = S.value + type watch = W.watch + + let watches = W.v () + let lock = L.v () + + let v config = + let* t = S.v config in + Lwt.return { t; w = watches; l = lock } + + let find { t; _ } = S.find t + let mem { t; _ } = S.mem t + + module Internal = struct + let set t w key value = + let* () = S.set t key value in + W.notify w key (Some value) + + let remove t w key = + let* () = S.remove t key in + W.notify w key None + end + + let list { t; _ } = S.keys t + + let set { t; l; w } key value = + L.with_lock l key @@ fun () -> Internal.set t w key value + + let remove { t; l; w } key = + L.with_lock l key @@ fun () -> Internal.remove t w key + + let test_and_set = + let value_equal = Type.(unstage (equal (option Value.t))) in + fun { t; l; w } key ~test ~set:set_value -> + L.with_lock l key @@ fun () -> + let* v = S.find t key in + if value_equal v test then + let* () = + match set_value with + | Some set_value -> Internal.set t w key set_value + | None -> Internal.remove t w key + in + Lwt.return_true + else Lwt.return_false + + let watch_key { w; _ } key = W.watch_key w key + let watch { w; _ } = W.watch w + let unwatch { w; _ } = W.unwatch w + + let clear { t; w; _ } = + let* () = W.clear w in + S.clear t + + let close { t; w; _ } = + let* () = W.clear w in + S.close t + end diff --git a/src/irmin-lwt/core/storage.mli b/src/irmin-lwt/core/storage.mli new file mode 100644 index 0000000000..aa45644aba --- /dev/null +++ b/src/irmin-lwt/core/storage.mli @@ -0,0 +1,23 @@ +(* + * Copyright (c) 2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Storage_intf.Sigs +(** @inline *) + +module Read_only (M : Make) : Read_only.Maker +module Content_addressable (M : Make) : Content_addressable.Maker +module Append_only (M : Make) : Append_only.Maker +module Atomic_write (M : Make) : Atomic_write.Maker diff --git a/src/irmin-lwt/core/storage_intf.ml b/src/irmin-lwt/core/storage_intf.ml new file mode 100644 index 0000000000..144622abc5 --- /dev/null +++ b/src/irmin-lwt/core/storage_intf.ml @@ -0,0 +1,64 @@ +(* + * Copyright (c) 2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + type t + type key + type value + + val v : Conf.t -> t Lwt.t + (** [v config] initialises a storage layer, with the configuration [config]. + *) + + val mem : t -> key -> bool Lwt.t + (** [mem t k] is true iff [k] is present in [t]. *) + + val find : t -> key -> value option Lwt.t + (** [find t k] is [Some v] if [k] is associated to [v] in [t] and [None] is + [k] is not present in [t]. *) + + val keys : t -> key list Lwt.t + (** [keys t] it the list of keys in [t]. *) + + val set : t -> key -> value -> unit Lwt.t + (** [set t k v] sets the contents of [k] to [v] in [t]. *) + + val remove : t -> key -> unit Lwt.t + (** [remove t k] removes the key [k] in [t]. *) + + val batch : t -> (t -> 'a Lwt.t) -> 'a Lwt.t + (** [batch t f] applies the operations in [f] in a batch. The exact guarantees + depend on the implementation. *) + + val clear : t -> unit Lwt.t + (** [clear t] clears the storage. This operation is expected to be slow. *) + + val close : t -> unit Lwt.t + (** [close t] frees up all the resources associated with [t]. *) +end + +module type Make = functor (Key : Type.S) (Value : Type.S) -> + S with type key = Key.t and type value = Value.t + +module type Sigs = sig + module type S = S + (** [S] is a storage layer that can be used to build Irmin stores. *) + + module type Make = Make + (** [Make] parameterizes a storage layer over a key [Key] and a value [Value]. + This is the signature to implement when building custom storage for Irmin. + *) +end diff --git a/src/irmin-lwt/core/store.ml b/src/irmin-lwt/core/store.ml new file mode 100644 index 0000000000..65707565e9 --- /dev/null +++ b/src/irmin-lwt/core/store.ml @@ -0,0 +1,90 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Store module types + [Json_tree] helper. + + The implementation functor [Store.Make (B : Backend.S)] (~1300 lines, + verbatim from [main]) used to live here, alongside [Json_tree] and the + [Remote.t Store] constructor. [Store.Make] has been removed: all backends in + [irmin-lwt] now go through [Wrap_store.Make] (which delegates to Irmin 4's + [Of_backend] internally). [Of_backend] and [Generic_key.Maker] -- the only + consumers of [Store.Make] -- are also no longer exposed (see + LIMITATIONS.md). [Json_tree] is kept because it operates on any [Store.S] + regardless of how it was built. *) + +open! Import +include Store_intf + +module Generic_key = struct + module type S = S_generic_key + module type KV = KV_generic_key + module type Maker = Maker_generic_key + module type KV_maker = KV_maker_generic_key +end + +module Json_tree (Store : S with type Schema.Contents.t = Contents.json) = +struct + include Contents.Json_value + + type json = Contents.json + + let to_concrete_tree j : Store.Tree.concrete = + let rec obj j acc = + match j with + | [] -> `Tree acc + | (k, v) :: l -> ( + match Type.of_string Store.Path.step_t k with + | Ok key -> obj l ((key, node v []) :: acc) + | _ -> obj l acc) + and node j acc = + match j with + | `O j -> obj j acc + | _ -> `Contents (j, Store.Metadata.default) + in + node j [] + + let of_concrete_tree c : json = + let step = Type.to_string Store.Path.step_t in + let rec tree t acc = + match t with + | [] -> `O acc + | (k, v) :: l -> tree l ((step k, contents v []) :: acc) + and contents t acc = + match t with `Contents (c, _) -> c | `Tree c -> tree c acc + in + contents c [] + + let set_tree (tree : Store.tree) key j : Store.tree Lwt.t = + let c = to_concrete_tree j in + let c = Store.Tree.of_concrete c in + Store.Tree.add_tree tree key c + + let get_tree (tree : Store.tree) key = + let* t = Store.Tree.get_tree tree key in + let+ c = Store.Tree.to_concrete t in + of_concrete_tree c + + let set t key j ~info = + set_tree (Store.Tree.empty ()) Store.Path.empty j >>= function + | tree -> Store.set_tree_exn ~info t key tree + + let get t key = + let* tree = Store.get_tree t key in + get_tree tree Store.Path.empty +end + +type Remote.t += + | Store : (module Generic_key.S with type t = 'a) * 'a -> Remote.t diff --git a/src/irmin-lwt/core/store.mli b/src/irmin-lwt/core/store.mli new file mode 100644 index 0000000000..a79f53b712 --- /dev/null +++ b/src/irmin-lwt/core/store.mli @@ -0,0 +1,21 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Branch-consistent stores: read-write store with support fork/merge + operations. *) + +include Store_intf.Sigs +(** @inline *) diff --git a/src/irmin-lwt/core/store_intf.ml b/src/irmin-lwt/core/store_intf.ml new file mode 100644 index 0000000000..34ca56b18e --- /dev/null +++ b/src/irmin-lwt/core/store_intf.ml @@ -0,0 +1,1243 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +open Store_properties + +module type S_generic_key = sig + (** {1 Irmin stores} + + Irmin stores are tree-like read-write stores with extended capabilities. + They allow an application (or a collection of applications) to work with + multiple local states, which can be forked and merged programmatically, + without having to rely on a global state. In a way very similar to version + control systems, Irmin local states are called {i branches}. + + There are two kinds of store in Irmin: the ones based on + {{!of_branch} persistent} named branches and the ones based + {{!of_commit} temporary} detached heads. These exist relative to a local, + larger (and shared) store, and have some (shared) contents. This is + exactly the same as usual version control systems, that the informed user + can see as an implicit purely functional data-structure. *) + + module Schema : Schema.S + + type repo + (** The type for Irmin repositories. *) + + type t + (** The type for Irmin stores. *) + + type step = Schema.Path.step [@@deriving irmin] + (** The type for {!type-key} steps. *) + + type path = Schema.Path.t [@@deriving irmin] + (** The type for store keys. A key is a sequence of {!step}s. *) + + type metadata = Schema.Metadata.t [@@deriving irmin] + (** The type for store metadata. *) + + type contents = Schema.Contents.t [@@deriving irmin] + (** The type for store contents. *) + + type node [@@deriving irmin] + (** The type for store nodes. *) + + type tree [@@deriving irmin] + (** The type for store trees. *) + + type hash = Schema.Hash.t [@@deriving irmin] + (** The type for object hashes. *) + + type commit + (** Type for [`Commit] identifiers. Similar to Git's commit SHA1s. *) + + val commit_t : repo -> commit Type.t + (** [commit_t r] is the value type for {!commit}. *) + + type branch = Schema.Branch.t [@@deriving irmin] + (** Type for persistent branch names. Branches usually share a common global + namespace and it's the user's responsibility to avoid name clashes. *) + + type slice [@@deriving irmin] + (** Type for store slices. *) + + type info = Schema.Info.t [@@deriving irmin] + (** The type for commit info. *) + + type lca_error = [ `Max_depth_reached | `Too_many_lcas ] [@@deriving irmin] + (** The type for errors associated with functions computing least common + ancestors *) + + type ff_error = [ `No_change | `Rejected | lca_error ] [@@deriving irmin] + (** The type for errors for {!Head.fast_forward}. *) + + module Info : sig + include Info.S with type t = info + (** @inline *) + + val pp : t Fmt.t + [@@ocaml.toplevel_printer] + (** [pp] is a pretty-printer for info. *) + end + + type contents_key [@@deriving irmin] + type node_key [@@deriving irmin] + type commit_key [@@deriving irmin] + + (** Repositories. *) + module Repo : sig + (** {1 Repositories} + + A repository contains a set of branches. *) + + type t = repo + (** The type of repository handles. *) + + val v : Conf.t -> t Lwt.t + (** [v config] connects to a repository in a backend-specific manner. *) + + val config : t -> Conf.t + (** [config repo] is the configuration used to create [repo] *) + + include Closeable with type _ t := t + (** @inline *) + + val heads : t -> commit list Lwt.t + (** [heads] is {!Head.list}. *) + + val branches : t -> branch list Lwt.t + (** [branches] is {!Branch.list}. *) + + val export : + ?full:bool -> + ?depth:int -> + ?min:commit list -> + ?max:[ `Head | `Max of commit list ] -> + t -> + slice Lwt.t + (** [export t ~full ~depth ~min ~max] exports the store slice between [min] + and [max], using at most [depth] history depth (starting from the max). + + If [max] is `Head (also the default value), use the current [heads]. If + [min] is not specified, use an unbound past (but can still be limited by + [depth]). + + [depth] is used to limit the depth of the commit history. [None] here + means no limitation. + + If [full] is set (default is true), the full graph, including the + commits, nodes and contents, is exported, otherwise it is the commit + history graph only. *) + + val import : t -> slice -> (unit, [ `Msg of string ]) result Lwt.t + (** [import t s] imports the contents of the slice [s] in [t]. Does not + modify branches. *) + + type elt = + [ `Commit of commit_key + | `Node of node_key + | `Contents of contents_key + | `Branch of branch ] + [@@deriving irmin] + (** The type for elements iterated over by {!iter}. *) + + 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 + (** [iter t] iterates in topological order over the closure graph of [t]. If + [rev] is set (by default it is) the traversal is done in reverse order. + + [skip_branch], [skip_commit], [skip_node] and [skip_contents] allow the + traversal to be stopped when the corresponding objects are traversed. By + default no objects are skipped. + + The [branch], [commit], [node] and [contents] functions are called + whenever the corresponding objects are traversed. By default these + functions do nothing. These functions are not called on skipped objects. + + [pred_branch], [pred_commit], [pred_node] and [pred_contents] implicitly + define the graph underlying the traversal. By default they exactly match + the underlying Merkle graph of the repository [t]. These functions can + be used to traverse a slightly modified version of that graph, for + instance by modifying [pred_contents] to implicitly link structured + contents with other objects in the graph. + + The traversed objects are all included between [min] (included) and + [max] (included), following the Merkle graph order. Moreover, the [min] + boundary is extended as follows: + + - contents and node objects in [min] stop the traversal; their + predecessors are not traversed. + - commit objects in [min] stop the traversal for their commit + predecessors, but their sub-node are still traversed. This allows + users to define an inclusive range of commit to iterate over. + - branch objects in [min] implicitly add to [min] the commit they are + pointing to; this allow users to define the iteration between two + branches. + + [cache_size] is the size of the LRU used to store traversed objects. If + an entry is evicted from the LRU, it can be traversed multiple times by + {!Repo.iter}. When [cache_size] is [None] (the default), no entries is + ever evicted from the cache; hence every object is only traversed once, + at the cost of having to store all the traversed objects in memory. *) + + 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 + + val empty : repo -> t Lwt.t + (** [empty repo] is a temporary, empty store. Becomes a normal temporary store + after the first update. *) + + val main : repo -> t Lwt.t + (** [main r] is a persistent store based on [r]'s main branch. This operation + is cheap, can be repeated multiple times. *) + + val of_branch : repo -> branch -> t Lwt.t + (** [of_branch r name] is a persistent store based on the branch [name]. + Similar to {!main}, but use [name] instead of {!Irmin.Branch.S.main}. *) + + val of_commit : commit -> t Lwt.t + (** [of_commit c] is a temporary store, based on the commit [c]. + + Temporary stores do not have stable names: instead they can be addressed + using the hash of the current commit. Temporary stores are similar to + Git's detached heads. In a temporary store, all the operations are + performed relative to the current head and update operations can modify + the current head: the current stores's head will automatically become the + new head obtained after performing the update. *) + + val repo : t -> repo + (** [repo t] is the repository containing [t]. *) + + val tree : t -> tree Lwt.t + (** [tree t] is [t]'s current tree. Contents is not allowed at the root of the + tree. *) + + module Status : sig + type t = [ `Empty | `Branch of branch | `Commit of commit ] + (** The type for store status. *) + + val t : repo -> t Type.t + (** [t] is the value type for {!type-t}. *) + + val pp : t Fmt.t + [@@ocaml.toplevel_printer] + (** [pp] is the pretty-printer for store status. *) + end + + val status : t -> Status.t + (** [status t] is [t]'s status. It can either be a branch, a commit or empty. + *) + + (** Managing the store's heads. *) + module Head : sig + val list : repo -> commit list Lwt.t + (** [list t] is the list of all the heads in local store. Similar to + [git rev-list --all]. *) + + val find : t -> commit option Lwt.t + (** [find t] is the current head of the store [t]. This works for both + persistent and temporary branches. In the case of a persistent branch, + this involves getting the the head associated with the branch, so this + may block. In the case of a temporary store, it simply returns the + current head. Returns [None] if the store has no contents. Similar to + [git rev-parse HEAD]. *) + + val get : t -> commit Lwt.t + (** Same as {!find} but raise [Invalid_argument] if the store does not have + any contents. *) + + val set : t -> commit -> unit Lwt.t + (** [set t h] updates [t]'s contents with the contents of the commit [h]. + Can cause data loss as it discards the current contents. Similar to + [git reset --hard ]. *) + + val fast_forward : + t -> ?max_depth:int -> ?n:int -> commit -> (unit, ff_error) result Lwt.t + (** [fast_forward t h] is similar to {!set} but the [t]'s head is updated to + [h] only if [h] is stricly in the future of [t]'s current head. + [max_depth] or [n] are used to limit the search space of the lowest + common ancestors (see {!lcas}). + + The result is: + + - [Ok ()] if the operation is succesfull; + - [Error `No_change] if [h] is already [t]'s head; + - [Error `Rejected] if [h] is not in the strict future of [t]'s head. + - [Error e] if the history exploration has been cut before getting + useful results. In that case. the operation can be retried using + different parameters of [n] and [max_depth] to get better results. *) + + val test_and_set : + t -> test:commit option -> set:commit option -> bool Lwt.t + (** Same as {!set} but check that the value is [test] before updating to + [set]. Use {!set} or {!val-merge} instead if possible. *) + + val merge : + into:t -> + info:Info.f -> + ?max_depth:int -> + ?n:int -> + commit -> + (unit, Merge.conflict) result Lwt.t + (** [merge ~into:t ?max_head ?n commit] merges the contents of the commit + associated to [commit] into [t]. [max_depth] is the maximal depth used + for getting the lowest common ancestor. [n] is the maximum number of + lowest common ancestors. If present, [max_depth] or [n] are used to + limit the search space of the lowest common ancestors (see {!lcas}). *) + end + + module Hash : Hash.S with type t = hash + (** Object hashes. *) + + (** [Commit] defines immutable objects to describe store updates. *) + module Commit : sig + type t = commit + (** The type for store commits. *) + + val t : repo -> t Type.t + (** [t] is the value type for {!type-t}. *) + + val pp_hash : t Fmt.t + (** [pp_hash] is a pretty-printer for a commit. Displays only the hash. *) + + val pp : t Fmt.t + [@@ocaml.toplevel_printer] + (** [pp] is a full pretty-printer for a commit. Displays all information. *) + + val v : + ?clear:bool -> + repo -> + info:info -> + parents:commit_key list -> + tree -> + commit Lwt.t + (** [v r i ~parents:p t] is the commit [c] such that: + + - [info c = i] + - [parents c = p] + - [tree c = t] + + When [clear] is set (the default), the tree cache is emptied upon the + function's completion, mirroring the effect of invoking {!Tree.clear}. + *) + + val tree : commit -> tree + (** [tree c] is [c]'s root tree. *) + + val parents : commit -> commit_key list + (** [parents c] are [c]'s parents. *) + + val info : commit -> info + (** [info c] is [c]'s info. *) + + val hash : commit -> hash + (** [hash c] is [c]'s hash. *) + + (** {1 Import/Export} *) + + val key : commit -> commit_key + (** [key c] is [c]'s key. *) + + val of_key : repo -> commit_key -> commit option Lwt.t + (** [of_key r k] is the the commit object in [r] with key [k], or [None] if + no such commit object exists. *) + + val of_hash : repo -> hash -> commit option Lwt.t + (** [of_hash r h] is the commit object in [r] with hash [h], or [None] if no + such commit object is indexed in [r]. + + {b Note:} in stores for which {!commit_key} = {!type-hash}, this + function has identical behaviour to {!of_key}. *) + end + + (** [Contents] provides base functions for the store's contents. *) + module Contents : sig + include Contents.S with type t = contents + + (** {1 Import/Export} *) + + val hash : contents -> hash + (** [hash c] it [c]'s hash. *) + + val of_key : repo -> contents_key -> contents option Lwt.t + (** [of_key r k] is the contents object in [r] with key [k], or [None] if no + such contents object exists. *) + + val of_hash : repo -> hash -> contents option Lwt.t + (** [of_hash r h] is the contents object in [r] with hash [h], or [None] if + no such contents object is indexed in [r]. + + {b Note:} in stores for which {!contents_key} = {!type-hash}, this + function has identical behaviour to {!of_key}. *) + end + + (** Managing store's trees. *) + module Tree : sig + include + Tree.S + with type t := tree + and type step := step + and type path := path + and type metadata := metadata + and type contents := contents + and type contents_key := contents_key + and type node := node + and type hash := hash + + val pp : tree Type.pp + [@@ocaml.toplevel_printer] + (** [pp] is a pretty-printer for a tree. *) + + (** {1 Import/Export} *) + + type kinded_key = + [ `Contents of contents_key * metadata | `Node of node_key ] + [@@deriving irmin] + (** Keys in the Irmin store are tagged with the type of the value they + reference (either {!contents} or {!node}). In the [contents] case, the + key is paired with corresponding {!metadata}. *) + + val key : tree -> kinded_key option + (** [key t] is the key of tree [t] in the underlying repository, if it + exists. Tree objects that exist entirely in memory (such as those built + with {!of_concrete}) have no backend key until they are exported to a + repository, and so will return [None]. *) + + val find_key : Repo.t -> tree -> kinded_key option Lwt.t + (** [find_key r t] is the key of a tree object with the same hash as [t] in + [r], if such a key exists and is indexed. *) + + val of_key : Repo.t -> kinded_key -> tree option Lwt.t + (** [of_key r h] is the tree object in [r] having [h] as key, or [None] if + no such tree object exists. *) + + val shallow : Repo.t -> kinded_key -> tree + (** [shallow r h] is the shallow tree object with the key [h]. No check is + performed to verify if [h] actually exists in [r]. *) + + val hash : ?cache:bool -> tree -> hash + (** [hash t] is the hash of tree [t]. *) + + type kinded_hash = [ `Contents of hash * metadata | `Node of hash ] + (** Like {!kinded_key}, but with hashes as value references rather than + keys. *) + + val kinded_hash : ?cache:bool -> tree -> kinded_hash + (** [kinded_hash t] is [c]'s kinded hash. *) + + val of_hash : Repo.t -> kinded_hash -> tree option Lwt.t + (** [of_hash r h] is the tree object in [r] with hash [h], or [None] if no + such tree object is indexed in [r]. + + {b Note:} in stores for which {!node_key} = {!contents_key} = + {!type-hash}, this function has identical behaviour to {!of_key}. *) + + (** {1 Proofs} *) + + type 'result producer := + repo -> + kinded_key -> + (tree -> (tree * 'result) Lwt.t) -> + (Proof.t * 'result) Lwt.t + (** [produce r h f] runs [f] on top of a real store [r], producing a proof + and a result using the initial root hash [h]. + + The trees produced during [f]'s computation will carry the full history + of reads. This history will be reset when [f] is complete so subtrees + escaping the scope of [f] will not cause memory leaks. + + Calling [produce_proof] recursively has an undefined behaviour. *) + + type verifier_error = [ `Proof_mismatch of string ] [@@deriving irmin] + (** The type for errors associated with functions that verify proofs. *) + + type 'result verifier := + Proof.t -> + (tree -> (tree * 'result) Lwt.t) -> + (tree * 'result, verifier_error) result Lwt.t + (** [verify p f] runs [f] in checking mode. [f] is a function that takes a + tree as input and returns a new version of the tree and a result. [p] is + a proof, that is a minimal representation of the tree that contains what + [f] should be expecting. + + Therefore, contrary to trees found in a storage, the contents of the + trees passed to [f] may not be available. For this reason, looking up a + value at some [path] can now produce three distinct outcomes: + + - A value [v] is present in the proof [p] and returned : + [find tree path] is a promise returning [Some v]; + - [path] is known to have no value in [tree] : [find tree path] is a + promise returning [None]; and + - [path] is known to have a value in [tree] but [p] does not provide it + because [f] should not need it: [verify] returns an error classifying + [path] as an invalid path (see below). + + The same semantics apply to all operations on the tree [t] passed to [f] + and on all operations on the trees built from [f]. + + The generated tree is the tree after [f] has completed. That tree is + disconnected from the backend. It is possible to run operations on it as + long as they don't require loading shallowed subtrees, otherwise it + would raise [Dangling_hash]. + + The result is [Error _] if the proof is rejected: + + - when [p.before] is different from the hash of [p.state]; + - when [p.after] is different from the hash of [f p.state]; + - when [f p.state] tries to access paths invalid paths in [p.state]; *) + + val produce_proof : 'a producer + (** [produce_proof] is the producer of tree proofs. *) + + val verify_proof : 'a verifier + (** [verify_proof] is the verifier of tree proofs. *) + + val hash_of_proof_state : Proof.tree -> kinded_hash + end + + (** {1 Reads} *) + + val kind : t -> path -> [ `Contents | `Node ] option Lwt.t + (** [kind] is {!Tree.kind} applied to [t]'s root tree. *) + + val list : t -> path -> (step * tree) list Lwt.t + (** [list t] is {!Tree.list} applied to [t]'s root tree. *) + + val mem : t -> path -> bool Lwt.t + (** [mem t] is {!Tree.mem} applied to [t]'s root tree. *) + + val mem_tree : t -> path -> bool Lwt.t + (** [mem_tree t] is {!Tree.mem_tree} applied to [t]'s root tree. *) + + val find_all : t -> path -> (contents * metadata) option Lwt.t + (** [find_all t] is {!Tree.find_all} applied to [t]'s root tree. *) + + val find : t -> path -> contents option Lwt.t + (** [find t] is {!Tree.find} applied to [t]'s root tree. *) + + val get_all : t -> path -> (contents * metadata) Lwt.t + (** [get_all t] is {!Tree.get_all} applied on [t]'s root tree. *) + + val get : t -> path -> contents Lwt.t + (** [get t] is {!Tree.get} applied to [t]'s root tree. *) + + val find_tree : t -> path -> tree option Lwt.t + (** [find_tree t] is {!Tree.find_tree} applied to [t]'s root tree. *) + + val get_tree : t -> path -> tree Lwt.t + (** [get_tree t k] is {!Tree.get_tree} applied to [t]'s root tree. *) + + type kinded_key := [ `Contents of contents_key | `Node of node_key ] + + val key : t -> path -> kinded_key option Lwt.t + (** [id t k] *) + + val hash : t -> path -> hash option Lwt.t + (** [hash t k] *) + + (** {1 Updates} *) + + type write_error = + [ Merge.conflict | `Too_many_retries of int | `Test_was of tree option ] + [@@deriving irmin] + (** The type for write errors. + + - Merge conflict. + - Concurrent transactions are competing to get the current operation + committed and too many attemps have been tried (livelock). + - A "test and set" operation has failed and the current value is [v] + instead of the one we were waiting for. *) + + val set : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + contents -> + (unit, write_error) result Lwt.t + (** [set t k ~info v] sets [k] to the value [v] in [t]. Discard any previous + results but ensure that no operation is lost in the history. + + This function always uses {!Metadata.default} as metadata. Use {!set_tree} + with `[Contents (c, m)] for different ones. + + When [clear] is set (the default), the tree cache is emptied upon the + function's completion, mirroring the effect of invoking {!Tree.clear}. + + The result is [Error `Too_many_retries] if the concurrent operations do + not allow the operation to commit to the underlying storage layer + (livelock). *) + + val set_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + contents -> + unit Lwt.t + (** [set_exn] is like {!set} but raise [Failure _] instead of using a result + type. *) + + 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 + (** [set_tree] is like {!set} but for trees. *) + + val set_tree_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + tree -> + unit Lwt.t + (** [set_tree] is like {!set_exn} but for trees. *) + + val remove : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + (unit, write_error) result Lwt.t + (** [remove t ~info k] remove any bindings to [k] in [t]. + + The result is [Error `Too_many_retries] if the concurrent operations do + not allow the operation to commit to the underlying storage layer + (livelock). *) + + val remove_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + unit Lwt.t + (** [remove_exn] is like {!remove} but raise [Failure _] instead of a using + result type. *) + + 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 + (** [test_and_set ~test ~set] is like {!set} but it atomically checks that the + tree is [test] before modifying it to [set]. + + This function always uses {!Metadata.default} as metadata. Use + {!test_and_set_tree} with `[Contents (c, m)] for different ones. + + The result is [Error (`Test t)] if the current tree is [t] instead of + [test]. + + The result is [Error `Too_many_retries] if the concurrent operations do + not allow the operation to commit to the underlying storage layer + (livelock). *) + + val test_and_set_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + t -> + path -> + test:contents option -> + set:contents option -> + unit Lwt.t + (** [test_and_set_exn] is like {!test_and_set} but raise [Failure _] instead + of using a result type. *) + + val test_and_set_tree : + ?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 + (** [test_and_set_tree] is like {!test_and_set} but for trees. *) + + 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 + (** [test_and_set_tree_exn] is like {!test_and_set_exn} but for trees. *) + + val test_set_and_get : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:(unit -> info) -> + t -> + path -> + test:contents option -> + set:contents option -> + (commit option, write_error) result Lwt.t + (** [test_set_and_get] is like {!test_and_set} except it also returns the + commit associated with updating the store with the new value if the + [test_and_set] is successful. No commit is returned if there was no update + to the store. *) + + val test_set_and_get_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:(unit -> info) -> + t -> + path -> + test:contents option -> + set:contents option -> + commit option Lwt.t + (** [test_set_and_get_exn] is like {!test_set_and_get} but raises [Failure _] + instead. *) + + val test_set_and_get_tree : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:(unit -> info) -> + t -> + path -> + test:tree option -> + set:tree option -> + (commit option, write_error) result Lwt.t + (** [test_set_and_get_tree] is like {!test_set_and_get} but for a {!tree} *) + + val test_set_and_get_tree_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:(unit -> info) -> + t -> + path -> + test:tree option -> + set:tree option -> + commit option Lwt.t + (** [test_set_and_get_tree_exn] is like {!test_set_and_get_tree} but raises + [Failure _] instead. *) + + 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 + (** [merge ~old] is like {!set} but merge the current tree and the new tree + using [old] as ancestor in case of conflicts. + + This function always uses {!Metadata.default} as metadata. Use + {!merge_tree} with `[Contents (c, m)] for different ones. + + The result is [Error (`Conflict c)] if the merge failed with the conflict + [c]. + + The result is [Error `Too_many_retries] if the concurrent operations do + not allow the operation to commit to the underlying storage layer + (livelock). *) + + val merge_exn : + ?clear:bool -> + ?retries:int -> + ?allow_empty:bool -> + ?parents:commit list -> + info:Info.f -> + old:contents option -> + t -> + path -> + contents option -> + unit Lwt.t + (** [merge_exn] is like {!val-merge} but raise [Failure _] instead of using a + result type. *) + + 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 + (** [merge_tree] is like {!merge_tree} but for trees. *) + + 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 + (** [merge_tree] is like {!merge_tree} but for trees. *) + + 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 Lwt.t) -> + (unit, write_error) result Lwt.t + (** [with_tree t k ~info f] replaces {i atomically} the subtree [v] under [k] + in the store [t] by the contents of the tree [f v], using the commit info + [info ()]. + + If [v = f v] and [allow_empty] is unset (default) then, the operation is a + no-op. + + If [v != f v] and no other changes happen concurrently, [f v] becomes the + new subtree under [k]. If other changes happen concurrently to that + operations, the semantics depend on the value of [strategy]: + + - if [strategy = `Set], use {!set} and discard any concurrent updates to + [k]. + - if [strategy = `Test_and_set] (default), use {!test_and_set} and ensure + that no concurrent operations are updating [k]. + - if [strategy = `Merge], use {!val-merge} and ensure that concurrent + updates and merged with the values present at the beginning of the + transaction. + + {b Note:} Irmin transactions provides + {{:https://en.wikipedia.org/wiki/Snapshot_isolation} snapshot isolation} + guarantees: reads and writes are isolated in every transaction, but only + write conflicts are visible on commit. *) + + val with_tree_exn : + ?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 Lwt.t) -> + unit Lwt.t + (** [with_tree_exn] is like {!with_tree} but raise [Failure _] instead of + using a return type. *) + + (** {1 Clones} *) + + val clone : src:t -> dst:branch -> t Lwt.t + (** [clone ~src ~dst] makes [dst] points to [Head.get src]. [dst] is created + if needed. Remove the current contents en [dst] if [src] is {!empty}. *) + + (** {1 Watches} *) + + type watch + (** The type for store watches. *) + + val watch : t -> ?init:commit -> (commit Diff.t -> unit Lwt.t) -> watch Lwt.t + (** [watch t f] calls [f] every time the contents of [t]'s head is updated. + + {b Note:} even if [f] might skip some head updates, it will never be + called concurrently: all consecutive calls to [f] are done in sequence, so + we ensure that the previous one ended before calling the next one. *) + + val watch_key : + t -> + path -> + ?init:commit -> + ((commit * tree) Diff.t -> unit Lwt.t) -> + watch Lwt.t + (** [watch_key t key f] calls [f] every time the [key]'s value is added, + removed or updated. If the current branch is deleted, no signal is sent to + the watcher. *) + + val unwatch : watch -> unit Lwt.t + (** [unwatch w] disable [w]. Return once the [w] is fully disabled. *) + + (** {1 Merges and Common Ancestors} *) + + type 'a merge = + info:Info.f -> + ?max_depth:int -> + ?n:int -> + 'a -> + (unit, Merge.conflict) result Lwt.t + (** The type for merge functions. *) + + val merge_into : into:t -> t merge + (** [merge_into ~into:x ~info:i t] merges [t]'s current branch into [x]'s + current branch using the info [i]. After that operation, the two stores + are still independent. Similar to [git merge ]. *) + + val merge_with_branch : t -> branch merge + (** Same as {!val-merge} but with a branch ID. *) + + val merge_with_commit : t -> commit merge + (** Same as {!val-merge} but with a commit_id. *) + + val lcas : + ?max_depth:int -> ?n:int -> t -> t -> (commit list, lca_error) result Lwt.t + (** [lca ?max_depth ?n msg t1 t2] returns the collection of least common + ancestors between the heads of [t1] and [t2] branches. + + - [max_depth] is the maximum depth of the exploration (default is + [max_int]). Return [Error `Max_depth_reached] if this depth is exceeded. + - [n] is the maximum expected number of lcas. Stop the exploration as soon + as [n] lcas are found. Return [Error `Too_many_lcas] if more [lcas] are + found. *) + + val lcas_with_branch : + t -> + ?max_depth:int -> + ?n:int -> + branch -> + (commit list, lca_error) result Lwt.t + (** Same as {!lcas} but takes a branch ID as argument. *) + + val lcas_with_commit : + t -> + ?max_depth:int -> + ?n:int -> + commit -> + (commit list, lca_error) result Lwt.t + (** Same as {!lcas} but takes a commmit as argument. *) + + (** {1 History} *) + + module History : Graph.Sig.P with type V.t = commit + (** An history is a DAG of heads. *) + + val history : + ?depth:int -> ?min:commit list -> ?max:commit list -> t -> History.t Lwt.t + (** [history ?depth ?min ?max t] is a view of the history of the store [t], of + depth at most [depth], starting from the [t]'s head (or from [max] if the + head is not set) and stopping at [min] if specified. *) + + val last_modified : ?depth:int -> ?n:int -> t -> path -> commit list Lwt.t + (** [last_modified ?number c k] is the list of the last [number] commits that + modified [path], in ascending order of date. [depth] is the maximum depth + to be explored in the commit graph, if any. Default value for [number] is + 1. *) + + (** Manipulate branches. *) + module Branch : sig + (** {1 Branch Store} + + Manipulate relations between {{!branch} branches} and + {{!commit} commits}. *) + + val mem : repo -> branch -> bool Lwt.t + (** [mem r b] is true iff [b] is present in [r]. *) + + val find : repo -> branch -> commit option Lwt.t + (** [find r b] is [Some c] iff [c] is bound to [b] in [t]. It is [None] if + [b] is not present in [t]. *) + + val get : repo -> branch -> commit Lwt.t + (** [get t b] is similar to {!find} but raise [Invalid_argument] if [b] is + not present in [t]. *) + + val set : repo -> branch -> commit -> unit Lwt.t + (** [set t b c] bounds [c] to [b] in [t]. *) + + val remove : repo -> branch -> unit Lwt.t + (** [remove t b] removes [b] from [t]. *) + + val list : repo -> branch list Lwt.t + (** [list t] is the list of branches present in [t]. *) + + val watch : + repo -> + branch -> + ?init:commit -> + (commit Diff.t -> unit Lwt.t) -> + watch Lwt.t + (** [watch t b f] calls [f] on every change in [b]. *) + + val watch_all : + repo -> + ?init:(branch * commit) list -> + (branch -> commit Diff.t -> unit Lwt.t) -> + watch Lwt.t + (** [watch_all t f] calls [f] on every branch-related change in [t], + including creation/deletion events. *) + + val pp : branch Fmt.t + [@@ocaml.toplevel_printer] + (** [pp] is a pretty-printer for a branch. *) + + include Branch.S with type t = branch + (** Base functions for branches. *) + end + + (** [Path] provides base functions for the stores's paths. *) + module Path : Path.S with type t = path and type step = step + + module Metadata : Metadata.S with type t = metadata + (** [Metadata] provides base functions for node metadata. *) + + (** Backend functions, which might be used by the backends. *) + module Backend : + Backend.S + with module Schema = Schema + with type Slice.t = slice + and type Repo.t = repo + and module Hash = Hash + and module Node.Path = Path + and type Contents.key = contents_key + and type Node.key = node_key + and type Commit.key = commit_key + + type Remote.t += + | E of Backend.Remote.endpoint + (** Extend the [remote] type with [endpoint]. *) + + (** {2 Converters to backend types} *) + + 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 + (** [to_backend_commit c] is the backend commit object associated with the + commit [c]. *) + + val of_backend_commit : + repo -> Backend.Commit.Key.t -> Backend.Commit.value -> commit + (** [of_backend_commit r k c] is the commit associated with the backend commit + object [c] that hash key [k] in [r]. *) + + val save_contents : + [> write ] Backend.Contents.t -> contents -> contents_key Lwt.t + (** Save a content into the database *) + + val save_tree : + ?clear:bool -> + repo -> + [> write ] Backend.Contents.t -> + [> read_write ] Backend.Node.t -> + tree -> + kinded_key Lwt.t + (** Save a tree into the database. Does not do any reads. + + When [clear] is set (the default), the tree cache is emptied upon the + function's completion, mirroring the effect of invoking {!Tree.clear}. *) + + (** {Deprecated} *) + + val master : repo -> t Lwt.t + [@@ocaml.deprecated "Use `main` instead."] + (** @deprecated Use {!main} instead *) +end + +module type S = sig + type hash + + (** @inline *) + include + S_generic_key + 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 S_is_a_generic_keyed (X : S) : S_generic_key = X + +module type Maker_generic_key = sig + type endpoint + + include Key.Store_spec.S + + module Make (Schema : Schema.S) : + S_generic_key + with module Schema = Schema + and type Backend.Remote.endpoint = endpoint + and type contents_key = (Schema.Hash.t, Schema.Contents.t) contents_key + and type node_key = Schema.Hash.t node_key + and type commit_key = Schema.Hash.t commit_key +end + +module type Maker = + Maker_generic_key + with type ('h, _) contents_key = 'h + and type 'h node_key = 'h + and type 'h commit_key = 'h + +module type Json_tree = functor + (Store : S with type Schema.Contents.t = Contents.json) + -> sig + include Contents.S with type t = Contents.json + + val to_concrete_tree : t -> Store.Tree.concrete + val of_concrete_tree : Store.Tree.concrete -> t + + val get_tree : Store.tree -> Store.path -> t Lwt.t + (** Extract a [json] value from tree at the given key. *) + + val set_tree : Store.tree -> Store.path -> t -> Store.tree Lwt.t + (** Project a [json] value onto a tree at the given key. *) + + val get : Store.t -> Store.path -> t Lwt.t + (** Extract a [json] value from a store at the given key. *) + + val set : + Store.t -> Store.path -> t -> info:(unit -> Store.info) -> unit Lwt.t + (** Project a [json] value onto a store at the given key. *) +end + +module type KV_generic_key = + S_generic_key + with type Schema.Path.step = string + and type Schema.Path.t = string list + and type Schema.Branch.t = string + +module type KV = + S + with type Schema.Path.step = string + and type Schema.Path.t = string list + and type Schema.Branch.t = string + +module type KV_maker_generic_key = sig + type endpoint + type metadata + type hash + type info + + include Key.Store_spec.S + + module Make (C : Contents.S) : + KV_generic_key + with module Schema.Contents = C + and type Schema.Metadata.t = metadata + and type Backend.Remote.endpoint = endpoint + and type Schema.Hash.t = hash + and type contents_key = (hash, C.t) contents_key + and type node_key = hash node_key + and type commit_key = hash commit_key + and type Schema.Info.t = info +end + +module type KV_maker = + KV_maker_generic_key + with type ('h, _) contents_key = 'h + and type 'h node_key = 'h + and type 'h commit_key = 'h + +module type Sigs = sig + module type S = S + module type Maker = Maker + module type Json_tree = Json_tree + module type KV = KV + module type KV_maker = KV_maker + + module Generic_key : sig + module type S = S_generic_key + module type KV = KV_generic_key + module type Maker = Maker_generic_key + module type KV_maker = KV_maker_generic_key + end + + type Remote.t += + | Store : (module Generic_key.S with type t = 'a) * 'a -> Remote.t + + module Json_tree : Json_tree + (** [Json_tree] is used to project JSON values onto trees. Instead of the + entire object being stored under one key, it is split across several keys + starting at the specified root key. *) +end diff --git a/src/irmin-lwt/core/store_properties.ml b/src/irmin-lwt/core/store_properties.ml new file mode 100644 index 0000000000..d76495a7bc --- /dev/null +++ b/src/irmin-lwt/core/store_properties.ml @@ -0,0 +1,6 @@ +include Store_properties_intf + +(* Alias to Irmin (eio)'s [Closed] so exceptions raised by the underlying + Eio backend through [Lwt_eio.run_eio] match [Lwt.catch] handlers on + [Irmin_lwt.Closed]. *) +exception Closed = Irmin.Closed diff --git a/src/irmin-lwt/core/store_properties.mli b/src/irmin-lwt/core/store_properties.mli new file mode 100644 index 0000000000..5ac3f90862 --- /dev/null +++ b/src/irmin-lwt/core/store_properties.mli @@ -0,0 +1,18 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Store_properties_intf.Sigs +(** @inline *) diff --git a/src/irmin-lwt/core/store_properties_intf.ml b/src/irmin-lwt/core/store_properties_intf.ml new file mode 100644 index 0000000000..ce56bf71dd --- /dev/null +++ b/src/irmin-lwt/core/store_properties_intf.ml @@ -0,0 +1,72 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open Import + +module type Batch = sig + type 'a t + + val batch : read t -> ([ read | write ] t -> 'a Lwt.t) -> 'a Lwt.t + (** [batch t f] applies the writes in [f] in a separate batch. The exact + guarantees depend on the implementation. *) +end + +module type Closeable = sig + type 'a t + + val close : 'a t -> unit Lwt.t + (** [close t] frees up all the resources associated with [t]. Any operations + run on a closed handle will raise [Closed]. *) +end + +module type Of_config = sig + type 'a t + + val v : Conf.t -> read t Lwt.t + (** [v config] is a function returning fresh store handles, with the + configuration [config], which is provided by the backend. *) +end + +module type Clearable = sig + type 'a t + + val clear : 'a t -> unit Lwt.t + (** Clear the store. This operation is expected to be slow. *) +end + +module type Sigs = sig + exception Closed + + module type Batch = sig + include Batch + (** @inline *) + end + + module type Closeable = sig + include Closeable + (** @inline *) + end + + module type Of_config = sig + include Of_config + (** @inline *) + end + + module type Clearable = sig + include Clearable + (** @inline *) + end +end diff --git a/src/irmin-lwt/core/sync.ml b/src/irmin-lwt/core/sync.ml new file mode 100644 index 0000000000..3aae1b58e5 --- /dev/null +++ b/src/irmin-lwt/core/sync.ml @@ -0,0 +1,222 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Sync_intf + +module type REMOTE = Remote.S + +let invalid_argf fmt = Fmt.kstr Lwt.fail_invalid_arg fmt +let src = Logs.Src.create "irmin.sync" ~doc:"Irmin remote sync" + +module Log = (val Logs.src_log src : Logs.LOG) + +let remote_store m x = Store.Store (m, x) + +module Make (S : Store.Generic_key.S) = struct + module B = S.Backend.Remote + + type db = S.t + type commit = S.commit + type commit_key = S.commit_key [@@deriving irmin ~pp] + type info = S.info + + let conv dx dy = + let dx_to_bin_string = Type.(unstage (to_bin_string dx)) in + let dy_of_bin_string = Type.(unstage (of_bin_string dy)) in + Type.stage (fun x -> dy_of_bin_string (dx_to_bin_string x)) + + let convert_slice (type r s) (module RP : Backend.S with type Slice.t = r) + (module SP : Backend.S with type Slice.t = s) r = + let conv_contents_k = + Type.unstage (conv RP.Contents.Hash.t SP.Contents.Hash.t) + in + let conv_contents_v = + Type.unstage (conv RP.Contents.Val.t SP.Contents.Val.t) + in + let conv_node_k = Type.unstage (conv RP.Node.Hash.t SP.Node.Hash.t) in + let conv_node_v = Type.unstage (conv RP.Node.Val.t SP.Node.Val.t) in + let conv_commit_k = Type.unstage (conv RP.Commit.Hash.t SP.Commit.Hash.t) in + let conv_commit_v = Type.unstage (conv RP.Commit.Val.t SP.Commit.Val.t) in + let* s = SP.Slice.empty () in + let* () = + RP.Slice.iter r (function + | `Contents (k, v) -> ( + let k = conv_contents_k k in + let v = conv_contents_v v in + match (k, v) with + | Ok k, Ok v -> SP.Slice.add s (`Contents (k, v)) + | _ -> Lwt.return_unit) + | `Node (k, v) -> ( + let k = conv_node_k k in + let v = conv_node_v v in + match (k, v) with + | Ok k, Ok v -> SP.Slice.add s (`Node (k, v)) + | _ -> Lwt.return_unit) + | `Commit (k, v) -> ( + let k = conv_commit_k k in + let v = conv_commit_v v in + match (k, v) with + | Ok k, Ok v -> SP.Slice.add s (`Commit (k, v)) + | _ -> Lwt.return_unit)) + in + Lwt.return s + + let convs src dst l = + let conv = Type.unstage (conv src dst) in + List.fold_left + (fun acc x -> match conv x with Ok x -> x :: acc | _ -> acc) + [] l + + let pp_branch = Type.pp S.Branch.t + + type status = [ `Empty | `Head of commit ] + + let pp_status ppf = function + | `Empty -> Fmt.string ppf "empty" + | `Head c -> S.Commit.pp_hash ppf c + + let status_t t = + let open Type in + variant "status" (fun empty head -> function + | `Empty -> empty + | `Head c -> head c) + |~ case0 "empty" `Empty + |~ case1 "head" S.(commit_t @@ repo t) (fun c -> `Head c) + |> sealv + + let fetch t ?depth remote = + match remote with + | Store.Store ((module R), r) -> ( + [%log.debug "fetch store"]; + let s_repo = S.repo t in + let r_repo = R.repo r in + let conv = + Type.unstage (conv R.(commit_t r_repo) S.(commit_t s_repo)) + in + let* min = S.Repo.heads s_repo in + let min = convs S.(commit_t s_repo) R.(commit_t r_repo) min in + R.Head.find r >>= function + | None -> Lwt.return (Ok `Empty) + | Some h -> ( + let* r_slice = + R.Repo.export (R.repo r) ?depth ~min ~max:(`Max [ h ]) + in + let* s_slice = + convert_slice (module R.Backend) (module S.Backend) r_slice + in + S.Repo.import s_repo s_slice >|= function + | Error e -> Error e + | Ok () -> ( + match conv h with Ok h -> Ok (`Head h) | Error e -> Error e))) + | S.E e -> ( + match S.status t with + | `Empty | `Commit _ -> Lwt.return (Ok `Empty) + | `Branch br -> ( + [%log.debug "Fetching branch %a" pp_branch br]; + let* g = B.v (S.repo t) in + B.fetch g ?depth e br >>= function + | Error _ as e -> Lwt.return e + | Ok (Some key) -> ( + [%log.debug "Fetched %a" pp_commit_key key]; + S.Commit.of_key (S.repo t) key >|= function + | None -> Ok `Empty + | Some x -> Ok (`Head x)) + | Ok None -> ( + S.Head.find t >>= function + | Some h -> Lwt.return (Ok (`Head h)) + | None -> Lwt.return (Ok `Empty)))) + | _ -> Lwt.return (Error (`Msg "fetch operation is not available")) + + let fetch_exn t ?depth remote = + fetch t ?depth remote >>= function + | Ok h -> Lwt.return h + | Error (`Msg e) -> invalid_argf "Sync.fetch_exn: %s" e + + type pull_error = [ `Msg of string | Merge.conflict ] + + let pp_pull_error ppf = function + | `Msg s -> Fmt.string ppf s + | `Conflict c -> Fmt.pf ppf "conflict: %s" c + + let pull t ?depth remote kind : (status, pull_error) result Lwt.t = + fetch t ?depth remote >>= function + | Error e -> Lwt.return (Error (e :> pull_error)) + | Ok (`Head k) -> ( + match kind with + | `Set -> S.Head.set t k >|= fun () -> Ok (`Head k) + | `Merge info -> ( + S.Head.merge ~into:t ~info k >>= function + | Ok () -> Lwt.return (Ok (`Head k)) + | Error e -> Lwt.return (Error (e :> pull_error)))) + | Ok `Empty -> Lwt.return (Ok `Empty) + + let pull_exn t ?depth remote kind = + pull t ?depth remote kind >>= function + | Ok x -> Lwt.return x + | Error e -> invalid_argf "Sync.pull_exn: %a" pp_pull_error e + + type push_error = [ `Msg of string | `Detached_head ] + + let pp_push_error ppf = function + | `Msg s -> Fmt.string ppf s + | `Detached_head -> Fmt.string ppf "cannot push to a non-persistent store" + + let push t ?depth remote = + [%log.debug "push"]; + match remote with + | Store.Store ((module R), r) -> ( + S.Head.find t >>= function + | None -> Lwt.return (Ok `Empty) + | Some h -> ( + [%log.debug "push store"]; + let* min = R.Repo.heads (R.repo r) in + let r_repo = R.repo r in + let s_repo = S.repo t in + let min = convs R.(commit_t r_repo) S.(commit_t s_repo) min in + let conv = + Type.unstage (conv S.(commit_t s_repo) R.(commit_t r_repo)) + in + let* s_slice = S.Repo.export (S.repo t) ?depth ~min in + let* r_slice = + convert_slice (module S.Backend) (module R.Backend) s_slice + in + R.Repo.import (R.repo r) r_slice >>= function + | Error e -> Lwt.return (Error (e :> push_error)) + | Ok () -> ( + match conv h with + | Error e -> Lwt.return (Error (e :> push_error)) + | Ok h -> + R.Head.set r h >>= fun () -> + let+ head = S.Head.get t in + Ok (`Head head)))) + | S.E e -> ( + match S.status t with + | `Empty -> Lwt.return (Ok `Empty) + | `Commit _ -> Lwt.return (Error `Detached_head) + | `Branch br -> ( + let* head = S.of_branch (S.repo t) br >>= S.Head.get in + let* g = B.v (S.repo t) in + B.push g ?depth e br >>= function + | Ok () -> Lwt.return (Ok (`Head head)) + | Error err -> Lwt.return (Error (err :> push_error)))) + | _ -> Lwt.return (Error (`Msg "push operation is not available")) + + let push_exn t ?depth remote = + push t ?depth remote >>= function + | Ok x -> Lwt.return x + | Error e -> invalid_argf "Sync.push_exn: %a" pp_push_error e +end diff --git a/src/irmin-lwt/core/sync.mli b/src/irmin-lwt/core/sync.mli new file mode 100644 index 0000000000..7a9e317dee --- /dev/null +++ b/src/irmin-lwt/core/sync.mli @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Store Synchronisation. *) + +include Sync_intf.Sigs +(** @inline *) diff --git a/src/irmin-lwt/core/sync_intf.ml b/src/irmin-lwt/core/sync_intf.ml new file mode 100644 index 0000000000..1260e8665c --- /dev/null +++ b/src/irmin-lwt/core/sync_intf.ml @@ -0,0 +1,102 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + (** {1 Native Synchronization} *) + + type db + (** Type type for store handles. *) + + type commit + (** The type for store heads. *) + + type status = [ `Empty | `Head of commit ] + (** The type for remote status. *) + + type info + (** The type for commit info. *) + + val status_t : db -> status Type.t + (** [status_t db] is the value type for {!status} of remote [db]. *) + + val pp_status : status Fmt.t + (** [pp_status] pretty-prints return statuses. *) + + val fetch : + db -> ?depth:int -> Remote.t -> (status, [ `Msg of string ]) result Lwt.t + (** [fetch t ?depth r] populate the local store [t] with objects from the + remote store [r], using [t]'s current branch. The [depth] parameter limits + the history depth. Return [`Empty] if either the local or remote store do + not have a valid head. *) + + val fetch_exn : db -> ?depth:int -> Remote.t -> status Lwt.t + (** Same as {!fetch} but raise [Invalid_argument] if either the local or + remote store do not have a valid head. *) + + type pull_error = [ `Msg of string | Merge.conflict ] + (** The type for pull errors. *) + + val pp_pull_error : pull_error Fmt.t + (** [pp_pull_error] pretty-prints pull errors. *) + + val pull : + db -> + ?depth:int -> + Remote.t -> + [ `Merge of unit -> info | `Set ] -> + (status, pull_error) result Lwt.t + (** [pull t ?depth r s] is similar to {{!Sync.fetch} fetch} but it also + updates [t]'s current branch. [s] is the update strategy: + + - [`Merge] uses [Head.merge]. Can return a conflict. + - [`Set] uses [S.Head.set]. *) + + val pull_exn : + db -> + ?depth:int -> + Remote.t -> + [ `Merge of unit -> info | `Set ] -> + status Lwt.t + (** Same as {!pull} but raise [Invalid_arg] in case of conflict. *) + + type push_error = [ `Msg of string | `Detached_head ] + (** The type for push errors. *) + + val pp_push_error : push_error Fmt.t + (** [pp_push_error] pretty-prints push errors. *) + + val push : db -> ?depth:int -> Remote.t -> (status, push_error) result Lwt.t + (** [push t ?depth r] populates the remote store [r] with objects from the + current store [t], using [t]'s current branch. If [b] is [t]'s current + branch, [push] also updates the head of [b] in [r] to be the same as in + [t]. + + {b Note:} {e Git} semantics is to update [b] only if the new head if more + recent. This is not the case in {e Irmin}. *) + + val push_exn : db -> ?depth:int -> Remote.t -> status Lwt.t + (** Same as {!push} but raise [Invalid_argument] if an error happens. *) +end + +module type Sigs = sig + module type S = S + + val remote_store : + (module Store.Generic_key.S with type t = 'a) -> 'a -> Remote.t + + module Make (X : Store.Generic_key.S) : + S with type db = X.t and type commit = X.commit and type info = X.info +end diff --git a/src/irmin-lwt/core/tree.ml b/src/irmin-lwt/core/tree.ml new file mode 100644 index 0000000000..71bebe142d --- /dev/null +++ b/src/irmin-lwt/core/tree.ml @@ -0,0 +1,29 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * Copyright (c) 2017 Grégoire Henry + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Tree module types only. + + The implementation functor [Tree.Make (B : Backend.S)] (~2800 lines, + verbatim from main) used to live here. It was the in-memory tree machinery + consumed exclusively by [Store.Make]. Both have been removed from + [irmin-lwt]: backends now go through [Wrap_store.Make], which delegates the + tree implementation to Irmin 4's [Tree] module via [Inner.Tree]. The + Lwt-typed [Tree.S] surface is still used as a public module type + ([module type Tree = Tree.S] in [irmin_lwt.ml]) so this file re-exports the + signatures from [Tree_intf]. *) + +include Tree_intf diff --git a/src/irmin-lwt/core/tree.mli b/src/irmin-lwt/core/tree.mli new file mode 100644 index 0000000000..53cb60905c --- /dev/null +++ b/src/irmin-lwt/core/tree.mli @@ -0,0 +1,19 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * Copyright (c) 2017 Grégoire Henry + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Tree_intf.Sigs +(** @inline *) diff --git a/src/irmin-lwt/core/tree_intf.ml b/src/irmin-lwt/core/tree_intf.ml new file mode 100644 index 0000000000..a1f2b1f81b --- /dev/null +++ b/src/irmin-lwt/core/tree_intf.ml @@ -0,0 +1,468 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * Copyright (c) 2017 Grégoire Henry + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import + +(* Records hoisted out of [module type S] so that consumers of the [Tree] + module can refer to them through a top-level path ([Tree_intf.counters], + [Tree.counters]). This is what lets implementations of [Tree.S] -- in + particular [Maker_v2] -- equate their own [counters] type with the one + the signature expects. *) +type stats = { nodes : int; leafs : int; skips : int; depth : int; width : int } +[@@deriving irmin] + +type counters = { + mutable contents_hash : int; + mutable contents_find : int; + mutable contents_add : int; + mutable contents_mem : int; + mutable node_hash : int; + mutable node_mem : int; + mutable node_index : int; + mutable node_add : int; + mutable node_find : int; + mutable node_val_v : int; + mutable node_val_find : int; + mutable node_val_list : int; +} + +module type S = sig + type path [@@deriving irmin] + type step [@@deriving irmin] + type metadata [@@deriving irmin] + type contents [@@deriving irmin] + type contents_key [@@deriving irmin] + type node [@@deriving irmin] + type hash [@@deriving irmin] + + (** [Tree] provides immutable, in-memory partial mirror of the store, with + lazy reads and delayed writes. + + Trees are like staging area in Git: they are immutable temporary + non-persistent areas (they disappear if the host crash), held in memory + for efficiency, where reads are done lazily and writes are done only when + needed on commit: if you modify a key twice, only the last change will be + written to the store when you commit. *) + + type t [@@deriving irmin] + (** The type of trees. *) + + (** {1 Constructors} *) + + val empty : unit -> t + (** [empty ()] is the empty tree. The empty tree does not have associated + backend configuration values, as they can perform in-memory operation, + independently of any given backend. *) + + val singleton : path -> ?metadata:metadata -> contents -> t + (** [singleton k c] is the tree with a single binding mapping the key [k] to + the contents [c]. *) + + val of_contents : ?metadata:metadata -> contents -> t + (** [of_contents c] is the subtree built from the contents [c]. *) + + val of_node : node -> t + (** [of_node n] is the subtree built from the node [n]. *) + + type elt = [ `Node of node | `Contents of contents * metadata ] + (** The type for tree elements. *) + + val v : elt -> t + (** General-purpose constructor for trees. *) + + type kinded_hash = [ `Contents of hash * metadata | `Node of hash ] + [@@deriving irmin] + + val pruned : kinded_hash -> t + (** [pruned h] is a purely in-memory tree with the hash [h]. Such trees can be + used as children of other in-memory tree nodes, for instance in order to + compute the hash of the parent, but they cannot be dereferenced. + + Any operation that would require loading the contents of a pruned node + (e.g. calling {!find} on one of its children) will instead raise a + {!Pruned_hash} exception. Attempting to export a tree containing pruned + sub-trees to a repository will fail similarly. *) + + val kind : t -> path -> [ `Contents | `Node ] option Lwt.t + (** [kind t k] is the type of [s] in [t]. It could either be a tree node or + some file contents. It is [None] if [k] is not present in [t]. *) + + val is_empty : t -> bool + (** [is_empty t] is true iff [t] is {!empty} (i.e. a tree node with no + children). Trees with {!kind} = [`Contents] are never considered empty. *) + + (** {1 Diffs} *) + + val diff : t -> t -> (path * (contents * metadata) Diff.t) list Lwt.t + (** [diff x y] is the difference of contents between [x] and [y]. *) + + (** {1 Manipulating Contents} *) + + exception Dangling_hash of { context : string; hash : hash } + (** The exception 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 } + (** The exception raised by functions that attempts to load {!pruned} tree + nodes. *) + + exception Portable_value of { context : string } + (** The exception raised by functions that attemps to perform IO on a portable + tree. *) + + type error = + [ `Dangling_hash of hash | `Pruned_hash of hash | `Portable_value ] + + type 'a or_error = ('a, error) result + + (** Operations on lazy tree contents. *) + module Contents : sig + type t + (** The type of lazy tree contents. *) + + val hash : ?cache:bool -> t -> hash + (** [hash t] is the hash of the {!contents} value returned when [t] is + {!val-force}d successfully. See {!caching} for an explanation of the + [cache] parameter. *) + + val key : t -> contents_key option + (** [key t] is the key of the {!contents} value returned when [t] is + {!val-force}d successfully. *) + + val force : t -> contents or_error Lwt.t + (** [force t] forces evaluation of the lazy content value [t], or returns an + error if no such value exists in the underlying repository. *) + + val force_exn : t -> contents Lwt.t + (** Equivalent to {!val-force}, but raises an exception if the lazy content + value is not present in the underlying repository. *) + + val clear : t -> unit + (** [clear t] clears [t]'s cache. *) + + (** {2:caching caching} + + [cache] regulates the caching behaviour regarding the node's internal + data which are be lazily loaded from the backend. + + [cache] defaults to [true] which may greatly reduce the IOs and the + runtime but may also grealy increase the memory consumption. + + [cache = false] doesn't replace a call to [clear], it only prevents the + storing of new data, it doesn't discard the existing one. *) + end + + val mem : t -> path -> bool Lwt.t + (** [mem t k] is true iff [k] is associated to some contents in [t]. *) + + val find_all : t -> path -> (contents * metadata) option Lwt.t + (** [find_all t k] is [Some (b, m)] if [k] is associated to the contents [b] + and metadata [m] in [t] and [None] if [k] is not present in [t]. *) + + val length : t -> ?cache:bool -> path -> int Lwt.t + (** [length t key] is the number of files and sub-nodes stored under [key] in + [t]. + + It is equivalent to [List.length (list t k)] but backends might optimise + this call: for instance it's a constant time operation in [irmin-pack]. + + [cache] defaults to [true], see {!caching} for an explanation of the + parameter.*) + + val find : t -> path -> contents option Lwt.t + (** [find] is similar to {!find_all} but it discards metadata. *) + + val get_all : t -> path -> (contents * metadata) Lwt.t + (** Same as {!find_all} but raise [Invalid_arg] if [k] is not present in [t]. + *) + + val list : + t -> + ?offset:int -> + ?length:int -> + ?cache:bool -> + path -> + (step * t) list Lwt.t + (** [list t key] is the list of files and sub-nodes stored under [k] in [t]. + The result order is not specified but is stable. + + [offset] and [length] are used for pagination. + + [cache] defaults to [true], see {!Contents.caching} for an explanation of + the parameter. *) + + val seq : + t -> + ?offset:int -> + ?length:int -> + ?cache:bool -> + path -> + (step * t) Seq.t Lwt.t + (** [seq t key] follows the same behavior as {!list} but returns a sequence. + *) + + val get : t -> path -> contents Lwt.t + (** Same as {!get_all} but ignore the metadata. *) + + val add : t -> path -> ?metadata:metadata -> contents -> t Lwt.t + (** [add t k c] is the tree where the key [k] is bound to the contents [c] but + is similar to [t] for other bindings. *) + + val update : + t -> + path -> + ?metadata:metadata -> + (contents option -> contents option) -> + t Lwt.t + (** [update t k f] is the tree [t'] that is the same as [t] for all keys + except [k], and whose binding for [k] is determined by [f (find t k)]. + + If [k] refers to an internal node of [t], [f] is called with [None] to + determine the value with which to replace it. *) + + val remove : t -> path -> t Lwt.t + (** [remove t k] is the tree where [k] bindings has been removed but is + similar to [t] for other bindings. *) + + (** {1 Manipulating Subtrees} *) + + val mem_tree : t -> path -> bool Lwt.t + (** [mem_tree t k] is false iff [find_tree k = None]. *) + + val find_tree : t -> path -> t option Lwt.t + (** [find_tree t k] is [Some v] if [k] is associated to [v] in [t]. It is + [None] if [k] is not present in [t]. *) + + val get_tree : t -> path -> t Lwt.t + (** [get_tree t k] is [v] if [k] is associated to [v] in [t]. Raise + [Invalid_arg] if [k] is not present in [t].*) + + val add_tree : t -> path -> t -> t Lwt.t + (** [add_tree t k v] is the tree where the key [k] is bound to the non-empty + tree [v] but is similar to [t] for other bindings. + + If [v] is empty, this is equivalent to [remove t k]. *) + + val update_tree : t -> path -> (t option -> t option) -> t Lwt.t + (** [update_tree t k f] is the tree [t'] that is the same as [t] for all + subtrees except under [k], and whose subtree at [k] is determined by + [f (find_tree t k)]. + + [f] returning either [None] or [Some empty] causes the subtree at [k] to + be unbound (i.e. it is equivalent to [remove t k]). *) + + val merge : t Merge.t + (** [merge] is the 3-way merge function for trees. *) + + (** {1 Folds} *) + + val destruct : t -> [ `Node of node | `Contents of Contents.t * metadata ] + (** General-purpose destructor for trees. *) + + type marks + (** The type for fold marks. *) + + val empty_marks : unit -> marks + (** [empty_marks ()] is an empty collection of marks. *) + + type 'a force = [ `True | `False of path -> 'a -> 'a Lwt.t ] + (** The type for {!fold}'s [force] parameter. [`True] forces the fold to read + the objects of the lazy nodes and contents. [`False f] is applying [f] on + every lazy node and content value instead. *) + + type uniq = [ `False | `True | `Marks of marks ] + (** The type for {!fold}'s [uniq] parameters. [`False] folds over all the + nodes. [`True] does not recurse on nodes already seen. [`Marks m] uses the + collection of marks [m] to store the cache of keys: the fold will modify + [m]. This can be used for incremental folds. *) + + type ('a, 'b) folder = path -> 'b -> 'a -> 'a Lwt.t + (** The type for {!fold}'s folders: [pre], [post], [contents], [node], and + [tree], where ['a] is the accumulator and ['b] is the item folded. *) + + type depth = [ `Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int ] + [@@deriving irmin] + (** The type for fold depths. + + - [Eq d] folds over nodes and contents of depth exactly [d]. + - [Lt d] folds over nodes and contents of depth strictly less than [d]. + - [Gt d] folds over nodes and contents of depth strictly more than [d]. + + [Le d] is [Eq d] and [Lt d]. [Ge d] is [Eq d] and [Gt d]. *) + + 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 + (** [fold t acc] folds over [t]'s nodes with node-specific folders: + [contents], [node], and [tree], based on a node's {!kind}. + + The default for all folders is identity. + + For every node [n] of [t], including itself: + + - If [n] is a [`Contents] kind, call [contents path c] where [c] is the + {!contents} of [n]. + - If [n] is a [`Node] kind, (1) call [pre path steps]; (2) call + [node path n]; (3) recursively fold on each child; (4) call + [post path steps]. + - If [n] is any kind, call [tree path t'] where [t'] is the tree of [n]. + + See + {{:https://github.com/mirage/irmin/blob/main/examples/fold.ml} + examples/fold.ml} for a demo of the different {!folder}s. + + See {!force} for details about the [force] parameters. By default it is + [`True]. + + See {!uniq} for details about the [uniq] parameters. By default it is + [`False]. + + The fold depth is controlled by the [depth] parameter. + + [cache] defaults to [false], see {!Contents.caching} for an explanation of + the parameter. + + If [order] is [`Sorted] (the default), the elements are traversed in + lexicographic order of their keys. If [`Random state], they are traversed + in a random order. For large nodes, these two modes are memory-consuming, + use [`Undefined] for a more memory efficient [fold]. *) + + (** {1 Stats} *) + + type nonrec stats = stats = { + nodes : int; (** Number of node. *) + leafs : int; (** Number of leafs. *) + skips : int; (** Number of lazy nodes. *) + depth : int; (** Maximal depth. *) + width : int; (** Maximal width. *) + } + [@@deriving irmin] + (** The type for tree stats. *) + + val stats : ?force:bool -> t -> stats Lwt.t + (** [stats ~force t] are [t]'s statistics. If [force] is true, this will force + the reading of lazy nodes. By default it is [false]. *) + + (** {1 Concrete Trees} *) + + type concrete = + [ `Tree of (step * concrete) list | `Contents of contents * metadata ] + [@@deriving irmin] + (** The type for concrete trees. *) + + val of_concrete : concrete -> t + (** [of_concrete c] is the subtree equivalent of the concrete tree [c]. + + @raise Invalid_argument + if [c] contains duplicate bindings for a given path. *) + + val to_concrete : t -> concrete Lwt.t + (** [to_concrete t] is the concrete tree equivalent of the subtree [t]. *) + + (** {1 Proofs} *) + + module Proof : sig + include + Proof.S + with type contents := contents + and type hash := hash + and type step := step + and type metadata := metadata + + type irmin_tree + + val to_tree : t -> irmin_tree + (** [to_tree p] is the tree [t] representing the tree proof [p]. Blinded + parts of the proof will raise [Dangling_hash] when traversed. *) + end + with type irmin_tree := t + + (** {1 Caches} *) + + val clear : ?depth:int -> t -> unit + (** [clear ?depth t] clears all caches in the tree [t] for subtrees with a + depth higher than [depth]. If [depth] is not set, all of the subtrees are + cleared. + + A call to [clear] doesn't discard the subtrees of [t], only their cache + are discarded. Even the lazily loaded and unmodified subtrees remain. *) + + (** {1 Performance counters} *) + + type nonrec counters = counters = { + mutable contents_hash : int; + mutable contents_find : int; + mutable contents_add : int; + mutable contents_mem : int; + mutable node_hash : int; + mutable node_mem : int; + mutable node_index : int; + mutable node_add : int; + mutable node_find : int; + mutable node_val_v : int; + mutable node_val_find : int; + mutable node_val_list : int; + } + + val counters : unit -> counters + val dump_counters : unit Fmt.t + val reset_counters : unit -> unit + + val inspect : + t -> + [ `Contents | `Node of [ `Map | `Key | `Value | `Portable_dirty | `Pruned ] ] + (** [inspect t] is similar to {!kind}, with additional state information for + nodes. It is primarily useful for debugging and testing. + + If [t] holds a node, additional information about its state is included: + + - [`Map], if [t] is from {!of_concrete}. + - [`Value], if [t]'s node has modifications that have not been persisted + to a store. + - [`Portable_dirty], if [t]'s node has modifications and is + {!Node.Portable}. Currently only used with {!Proof}. + - [`Pruned], if [t] is from {!pruned}. + - Otherwise [`Key], the default state for a node loaded from a store. *) + + module Private : sig + module Env : sig + type t [@@deriving irmin] + + val is_empty : t -> bool + end + + val get_env : t -> Env.t + end +end + +module type Sigs = sig + module type S = sig + include S + (** @inline *) + end +end diff --git a/src/irmin-lwt/core/type.ml b/src/irmin-lwt/core/type.ml new file mode 100644 index 0000000000..a053b98efd --- /dev/null +++ b/src/irmin-lwt/core/type.ml @@ -0,0 +1,7 @@ +include Repr + +module type Defaultable = sig + include S + + val default : t +end diff --git a/src/irmin-lwt/core/watch.ml b/src/irmin-lwt/core/watch.ml new file mode 100644 index 0000000000..55723d184f --- /dev/null +++ b/src/irmin-lwt/core/watch.ml @@ -0,0 +1,326 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open! Import +include Watch_intf + +let src = Logs.Src.create "irmin.watch" ~doc:"Irmin watch notifications" + +module Log = (val Logs.src_log src : Logs.LOG) + +let none _ _ = + Printf.eprintf "Listen hook not set!\n%!"; + assert false + +let listen_dir_hook = ref none + +type hook = + int -> string -> (string -> unit Lwt.t) -> (unit -> unit Lwt.t) Lwt.t + +let set_listen_dir_hook (h : hook) = listen_dir_hook := h + +let id () = + let c = ref 0 in + fun () -> + incr c; + !c + +let global = id () +let workers_r = ref 0 +let workers () = !workers_r + +let scheduler () = + let p = ref None in + let niet () = () in + let c = ref niet in + let push elt = + match !p with + | Some p -> p elt + | None -> + let stream, push = Lwt_stream.create () in + incr workers_r; + Lwt.async (fun () -> + (* FIXME: we would like to skip some updates if more recent ones + are at the back of the queue. *) + Lwt_stream.iter_s (fun f -> f ()) stream); + p := Some push; + (c := fun () -> push None); + push elt + in + let clean () = + !c (); + decr workers_r; + c := niet; + p := None + in + let enqueue v = push (Some v) in + (clean, enqueue) + +module Make (K : sig + type t + + val t : t Type.t +end) (V : sig + type t + + val t : t Type.t +end) = +struct + type key = K.t + type value = V.t + type watch = int + + module KMap = Map.Make (struct + type t = K.t + + let compare = Type.(unstage (compare K.t)) + end) + + module IMap = Map.Make (struct + type t = int + + let compare (x : int) (y : int) = compare x y + end) + + type key_handler = value Diff.t -> unit Lwt.t + type all_handler = key -> value Diff.t -> unit Lwt.t + + let pp_value = Type.pp V.t + let equal_opt_values = Type.(unstage (equal (option V.t))) + let equal_keys = Type.(unstage (equal K.t)) + + type t = { + id : int; + (* unique watch manager id. *) + lock : Lwt_mutex.t; + (* protect [keys] and [glob]. *) + mutable next : int; + (* next id, to identify watch handlers. *) + mutable keys : (key * value option * key_handler) IMap.t; + (* key handlers. *) + mutable glob : (value KMap.t * all_handler) IMap.t; + (* global handlers. *) + enqueue : (unit -> unit Lwt.t) -> unit; + (* enqueue notifications. *) + clean : unit -> unit; + (* destroy the notification thread. *) + mutable listeners : int; + (* number of listeners. *) + mutable stop_listening : unit -> unit Lwt.t; + (* clean-up listen resources. *) + mutable notifications : int; (* number of notifcations. *) + } + + let stats t = (IMap.cardinal t.keys, IMap.cardinal t.glob) + + let to_string t = + let k, a = stats t in + Printf.sprintf "[%d: %dk/%dg|%d]" t.id k a t.listeners + + let next t = + let id = t.next in + t.next <- id + 1; + id + + let is_empty t = IMap.is_empty t.keys && IMap.is_empty t.glob + + let clear_unsafe t = + t.keys <- IMap.empty; + t.glob <- IMap.empty; + t.next <- 0 + + let clear t = + Lwt_mutex.with_lock t.lock (fun () -> + clear_unsafe t; + Lwt.return_unit) + + let v () = + let lock = Lwt_mutex.create () in + let clean, enqueue = scheduler () in + { + lock; + clean; + enqueue; + id = global (); + next = 0; + keys = IMap.empty; + glob = IMap.empty; + listeners = 0; + stop_listening = (fun () -> Lwt.return_unit); + notifications = 0; + } + + let unwatch_unsafe t id = + [%log.debug "unwatch %s: id=%d" (to_string t) id]; + let glob = IMap.remove id t.glob in + let keys = IMap.remove id t.keys in + t.glob <- glob; + t.keys <- keys + + let unwatch t id = + Lwt_mutex.with_lock t.lock (fun () -> + unwatch_unsafe t id; + if is_empty t then t.clean (); + Lwt.return_unit) + + let mk old value = + match (old, value) with + | None, None -> assert false + | Some v, None -> `Removed v + | None, Some v -> `Added v + | Some x, Some y -> `Updated (x, y) + + let protect f () = + Lwt.catch f (fun e -> + [%log.err + "watch callback got: %a\n%s" Fmt.exn e (Printexc.get_backtrace ())]; + Lwt.return_unit) + + let pp_option = Fmt.option ~none:(Fmt.any "") + let pp_key = Type.pp K.t + + let notify_all_unsafe t key value = + let todo = ref [] in + let glob = + IMap.fold + (fun id ((init, f) as arg) acc -> + let fire old_value = + todo := + protect (fun () -> + [%log.debug + "notify-all[%d.%d:%a]: %d firing! (%a -> %a)" t.id id pp_key + key t.notifications (pp_option pp_value) old_value + (pp_option pp_value) value]; + t.notifications <- t.notifications + 1; + f key (mk old_value value)) + :: !todo; + let init = + match value with + | None -> KMap.remove key init + | Some v -> KMap.add key v init + in + IMap.add id (init, f) acc + in + let old_value = + try Some (KMap.find key init) with Not_found -> None + in + if equal_opt_values old_value value then ( + [%log.debug + "notify-all[%d:%d:%a]: same value, skipping." t.id id pp_key key]; + IMap.add id arg acc) + else fire old_value) + t.glob IMap.empty + in + t.glob <- glob; + match !todo with + | [] -> () + | ts -> t.enqueue (fun () -> Lwt_list.iter_p (fun x -> x ()) ts) + + let notify_key_unsafe t key value = + let todo = ref [] in + let keys = + IMap.fold + (fun id ((k, old_value, f) as arg) acc -> + if not (equal_keys key k) then IMap.add id arg acc + else if equal_opt_values value old_value then ( + [%log.debug + "notify-key[%d.%d:%a]: same value, skipping." t.id id pp_key key]; + IMap.add id arg acc) + else ( + todo := + protect (fun () -> + [%log.debug + "notify-key[%d:%d:%a] %d firing! (%a -> %a)" t.id id pp_key + key t.notifications (pp_option pp_value) old_value + (pp_option pp_value) value]; + t.notifications <- t.notifications + 1; + f (mk old_value value)) + :: !todo; + IMap.add id (k, value, f) acc)) + t.keys IMap.empty + in + t.keys <- keys; + match !todo with + | [] -> () + | ts -> t.enqueue (fun () -> Lwt_list.iter_p (fun x -> x ()) ts) + + let notify t key value = + Lwt_mutex.with_lock t.lock (fun () -> + if is_empty t then Lwt.return_unit + else ( + notify_all_unsafe t key value; + notify_key_unsafe t key value; + Lwt.return_unit)) + + let watch_key_unsafe t key ?init f = + let id = next t in + [%log.debug "watch-key %s: id=%d" (to_string t) id]; + t.keys <- IMap.add id (key, init, f) t.keys; + id + + let watch_key t key ?init f = + Lwt_mutex.with_lock t.lock (fun () -> + let id = watch_key_unsafe t ?init key f in + Lwt.return id) + + let kmap_of_alist l = + List.fold_left (fun map (k, v) -> KMap.add k v map) KMap.empty l + + let watch_unsafe t ?(init = []) f = + let id = next t in + [%log.debug "watch %s: id=%d" (to_string t) id]; + t.glob <- IMap.add id (kmap_of_alist init, f) t.glob; + id + + let watch t ?init f = + Lwt_mutex.with_lock t.lock (fun () -> + let id = watch_unsafe t ?init f in + Lwt.return id) + + let listen_dir t dir ~key ~value = + let init () = + if t.listeners = 0 then ( + [%log.debug "%s: start listening to %s" (to_string t) dir]; + let+ f = + !listen_dir_hook t.id dir (fun file -> + match key file with + | None -> Lwt.return_unit + | Some key -> + let rec read n = + let* value = value key in + let n' = t.notifications in + if n = n' then notify t key value + else ( + [%log.debug "Stale event, trying reading again"]; + read n') + in + read t.notifications) + in + t.stop_listening <- f) + else ( + [%log.debug "%s: already listening on %s" (to_string t) dir]; + Lwt.return_unit) + in + init () >|= fun () -> + t.listeners <- t.listeners + 1; + function + | () -> + if t.listeners > 0 then t.listeners <- t.listeners - 1; + if t.listeners <> 0 then Lwt.return_unit + else ( + [%log.debug "%s: stop listening to %s" (to_string t) dir]; + t.stop_listening ()) +end diff --git a/src/irmin-lwt/core/watch.mli b/src/irmin-lwt/core/watch.mli new file mode 100644 index 0000000000..38f6002ff3 --- /dev/null +++ b/src/irmin-lwt/core/watch.mli @@ -0,0 +1,21 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** [Watch] provides helpers to register event notifications on read-write + stores. *) + +include Watch_intf.Sigs +(** @inline *) diff --git a/src/irmin-lwt/core/watch_intf.ml b/src/irmin-lwt/core/watch_intf.ml new file mode 100644 index 0000000000..fad0d17a14 --- /dev/null +++ b/src/irmin-lwt/core/watch_intf.ml @@ -0,0 +1,96 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module type S = sig + (** {1 Watch Helpers} *) + + type key + (** The type for store keys. *) + + type value + (** The type for store values. *) + + type watch + (** The type for watch handlers. *) + + type t + (** The type for watch state. *) + + val stats : t -> int * int + (** [stats t] is a tuple [(k,a)] represeting watch stats. [k] is the number of + single key watchers for the store [t] and [a] the number of global + watchers for [t]. *) + + val notify : t -> key -> value option -> unit Lwt.t + (** Notify all listeners in the given watch state that a key has changed, with + the new value associated to this key. [None] means the key has been + removed. *) + + val v : unit -> t + (** Create a watch state. *) + + val clear : t -> unit Lwt.t + (** Clear all register listeners in the given watch state. *) + + val watch_key : + t -> key -> ?init:value -> (value Diff.t -> unit Lwt.t) -> watch Lwt.t + (** Watch a given key for changes. More efficient than {!watch}. *) + + val watch : + t -> + ?init:(key * value) list -> + (key -> value Diff.t -> unit Lwt.t) -> + watch Lwt.t + (** Add a watch handler. To watch a specific key, use {!watch_key} which is + more efficient. *) + + val unwatch : t -> watch -> unit Lwt.t + (** Remove a watch handler. *) + + val listen_dir : + t -> + string -> + key:(string -> key option) -> + value:(key -> value option Lwt.t) -> + (unit -> unit Lwt.t) Lwt.t + (** Register a thread looking for changes in the given directory and return a + function to stop watching and free up resources. *) +end + +module type Sigs = sig + module type S = S + (** The signature for watch helpers. *) + + val workers : unit -> int + (** [workers ()] is the number of background worker threads managing event + notification currently active. *) + + type hook = + int -> string -> (string -> unit Lwt.t) -> (unit -> unit Lwt.t) Lwt.t + (** The type for watch hooks. *) + + val none : hook + (** [none] is the hooks which asserts false. *) + + val set_listen_dir_hook : hook -> unit + (** Register a function which looks for file changes in a directory and return + a function to stop watching. It is probably best to use + {!Irmin_watcher.hook} there. By default, it uses {!none}. *) + + (** [Make] builds an implementation of watch helpers. *) + module Make (K : Type.S) (V : Type.S) : + S with type key = K.t and type value = V.t +end diff --git a/src/irmin-lwt/core/wrap_store.ml b/src/irmin-lwt/core/wrap_store.ml new file mode 100644 index 0000000000..82466910c7 --- /dev/null +++ b/src/irmin-lwt/core/wrap_store.ml @@ -0,0 +1,816 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Reusable Lwt-vs-Eio wrapping of an Irmin 4 [Generic_key.S] store. Threads + [Schema_eio] explicitly so that [Inner.Schema = Schema_eio] binds the user's + types through the whole [Backend] surface, including [Node_portable] / + [Commit_portable] sub-modules. *) + +let run = Lwt_eio.run_eio + +module Make + (S : Schema.S) + (Schema_eio : + Irmin.Schema.S + with module Hash = S.Hash + and module Branch = S.Branch + and module Info = S.Info + and module Path = S.Path + and type Metadata.t = S.Metadata.t + and type Contents.t = S.Contents.t) + (Inner : Irmin.Generic_key.S with module Schema = Schema_eio) = +struct + (* === Schema === + Expose the user's original Lwt-typed schema, not the Eio-adapted + [Schema_eio] used internally to feed Irmin.Maker. *) + module Schema = S + + (* === Top-level types === *) + type repo = Inner.repo + type t = Inner.t + type step = Inner.step + type path = Inner.path + type metadata = Inner.metadata + type contents = Inner.contents + type node = Inner.node + type tree = Inner.tree + type hash = Inner.hash + type commit = Inner.commit + type branch = Inner.branch + type slice = Inner.slice + type info = Inner.info + type lca_error = Inner.lca_error + type ff_error = Inner.ff_error + type contents_key = Inner.contents_key + type node_key = Inner.node_key + type commit_key = Inner.commit_key + + let step_t = Inner.step_t + let path_t = Inner.path_t + let metadata_t = Inner.metadata_t + let contents_t = Inner.contents_t + let node_t = Inner.node_t + let tree_t = Inner.tree_t + let hash_t = Inner.hash_t + let commit_t = Inner.commit_t + let branch_t = Inner.branch_t + let slice_t = Inner.slice_t + let info_t = Inner.info_t + let lca_error_t = Inner.lca_error_t + let ff_error_t = Inner.ff_error_t + let contents_key_t = Inner.contents_key_t + let node_key_t = Inner.node_key_t + let commit_key_t = Inner.commit_key_t + + (* === Info === *) + module Info = struct + include (Inner.Info : module type of Inner.Info with type t = info) + + let pp = Inner.Info.pp + end + + (* === Status === *) + module Status = struct + type t = Inner.Status.t + + let t = Inner.Status.t + let pp = Inner.Status.pp + end + + let status t = Inner.status t + + (* === Hash (pure) === *) + module Hash = Inner.Hash + + (* === Top-level store builders === *) + let empty r = run (fun () -> Inner.empty r) + let main r = run (fun () -> Inner.main r) + let of_branch r b = run (fun () -> Inner.of_branch r b) + let of_commit c = run (fun () -> Inner.of_commit c) + let repo t = Inner.repo t + let tree t = run (fun () -> Inner.tree t) + + (* === Repo === *) + module Repo = struct + type t = repo + + let v c = run (fun () -> Inner.Repo.v c) + let config = Inner.Repo.config + let close r = run (fun () -> Inner.Repo.close r) + let heads r = run (fun () -> Inner.Repo.heads r) + let branches r = run (fun () -> Inner.Repo.branches r) + + let export ?full ?depth ?min ?max r = + run (fun () -> Inner.Repo.export ?full ?depth ?min ?max r) + + let import r s = run (fun () -> Inner.Repo.import r s) + + type elt = Inner.Repo.elt + + let elt_t = Inner.Repo.elt_t + + let default_pred_commit r k = + run (fun () -> Inner.Repo.default_pred_commit r k) + + let default_pred_node r k = run (fun () -> Inner.Repo.default_pred_node r k) + + let default_pred_contents r k = + run (fun () -> Inner.Repo.default_pred_contents r k) + + 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 r = + let bridge1 f = + Option.map (fun f x -> Lwt_eio.Promise.await_lwt (f x)) f + in + let bridge2 f = + Option.map (fun f x y -> Lwt_eio.Promise.await_lwt (f x y)) f + in + run (fun () -> + Inner.Repo.iter ?cache_size ~min ~max ?edge:(bridge2 edge) + ?branch:(bridge1 branch) ?commit:(bridge1 commit) + ?node:(bridge1 node) ?contents:(bridge1 contents) + ?skip_branch:(bridge1 skip_branch) + ?skip_commit:(bridge1 skip_commit) ?skip_node:(bridge1 skip_node) + ?skip_contents:(bridge1 skip_contents) + ?pred_branch:(bridge2 pred_branch) + ?pred_commit:(bridge2 pred_commit) ?pred_node:(bridge2 pred_node) + ?pred_contents:(bridge2 pred_contents) ?rev r) + + let breadth_first_traversal ?cache_size ~max ?branch ?commit ?node ?contents + ?pred_branch ?pred_commit ?pred_node ?pred_contents r = + let bridge1 f = + Option.map (fun f x -> Lwt_eio.Promise.await_lwt (f x)) f + in + let bridge2 f = + Option.map (fun f x y -> Lwt_eio.Promise.await_lwt (f x y)) f + in + run (fun () -> + Inner.Repo.breadth_first_traversal ?cache_size ~max + ?branch:(bridge1 branch) ?commit:(bridge1 commit) + ?node:(bridge1 node) ?contents:(bridge1 contents) + ?pred_branch:(bridge2 pred_branch) + ?pred_commit:(bridge2 pred_commit) ?pred_node:(bridge2 pred_node) + ?pred_contents:(bridge2 pred_contents) r) + end + + (* === Head === *) + module Head = struct + let list r = run (fun () -> Inner.Head.list r) + let find t = run (fun () -> Inner.Head.find t) + let get t = run (fun () -> Inner.Head.get t) + let set t c = run (fun () -> Inner.Head.set t c) + + let fast_forward t ?max_depth ?n c = + run (fun () -> Inner.Head.fast_forward t ?max_depth ?n c) + + let test_and_set t ~test ~set = + run (fun () -> Inner.Head.test_and_set t ~test ~set) + + let merge ~into ~info ?max_depth ?n c = + run (fun () -> Inner.Head.merge ~into ~info ?max_depth ?n c) + end + + (* === Commit === *) + module Commit = struct + type t = commit + + let t = Inner.Commit.t + let pp_hash = Inner.Commit.pp_hash + let pp = Inner.Commit.pp + + let v ?clear r ~info ~parents tree = + run (fun () -> Inner.Commit.v ?clear r ~info ~parents tree) + + let tree = Inner.Commit.tree + let parents = Inner.Commit.parents + let info = Inner.Commit.info + let hash = Inner.Commit.hash + let key = Inner.Commit.key + let of_key r k = run (fun () -> Inner.Commit.of_key r k) + let of_hash r h = run (fun () -> Inner.Commit.of_hash r h) + end + + (* === Contents === *) + module Contents = struct + type t = contents + + let t = Inner.Contents.t + + let merge = + Lwt_to_eio.merge_of_eio + Type.(option Inner.Contents.t) + Inner.Contents.merge + + let hash = Inner.Contents.hash + let of_key r k = run (fun () -> Inner.Contents.of_key r k) + let of_hash r h = run (fun () -> Inner.Contents.of_hash r h) + end + + (* === Branch === *) + type watch = Inner.watch + + module Branch = struct + let mem r b = run (fun () -> Inner.Branch.mem r b) + let find r b = run (fun () -> Inner.Branch.find r b) + let get r b = run (fun () -> Inner.Branch.get r b) + let set r b c = run (fun () -> Inner.Branch.set r b c) + let remove r b = run (fun () -> Inner.Branch.remove r b) + let list r = run (fun () -> Inner.Branch.list r) + + let watch r b ?init f = + run (fun () -> + Inner.Branch.watch r b ?init (fun d -> + Lwt_eio.Promise.await_lwt (f d))) + + let watch_all r ?init f = + run (fun () -> + Inner.Branch.watch_all r ?init (fun b d -> + Lwt_eio.Promise.await_lwt (f b d))) + + let pp = Inner.Branch.pp + + (* Branch.S re-exports: Inner.Branch already satisfies the basic + Branch.S (no Lwt in those fields), so we delegate the field set. *) + type t = branch + + let t = Inner.Branch.t + let main = Inner.Branch.main + let is_valid = Inner.Branch.is_valid + end + + (* === Path === *) + module Path : Path.S with type t = path and type step = step = Inner.Path + + (* === Metadata === *) + module Metadata = struct + type t = metadata + + let t = Inner.Metadata.t + let merge = Lwt_to_eio.merge_of_eio Inner.Metadata.t Inner.Metadata.merge + let default = Inner.Metadata.default + end + + (* === Watches (top-level) === *) + let watch t ?init f = + run (fun () -> + Inner.watch t ?init (fun d -> Lwt_eio.Promise.await_lwt (f d))) + + let watch_key t k ?init f = + run (fun () -> + Inner.watch_key t k ?init (fun d -> Lwt_eio.Promise.await_lwt (f d))) + + let unwatch w = run (fun () -> Inner.unwatch w) + + (* === Merges === *) + type 'a merge = + info:Info.f -> + ?max_depth:int -> + ?n:int -> + 'a -> + (unit, Merge.conflict) result Lwt.t + + let merge_into ~into ~info ?max_depth ?n t = + run (fun () -> Inner.merge_into ~into ~info ?max_depth ?n t) + + let merge_with_branch t ~info ?max_depth ?n b = + run (fun () -> Inner.merge_with_branch t ~info ?max_depth ?n b) + + let merge_with_commit t ~info ?max_depth ?n c = + run (fun () -> Inner.merge_with_commit t ~info ?max_depth ?n c) + + let lcas ?max_depth ?n t1 t2 = run (fun () -> Inner.lcas ?max_depth ?n t1 t2) + + let lcas_with_branch t ?max_depth ?n b = + run (fun () -> Inner.lcas_with_branch t ?max_depth ?n b) + + let lcas_with_commit t ?max_depth ?n c = + run (fun () -> Inner.lcas_with_commit t ?max_depth ?n c) + + (* === Clone === *) + let clone ~src ~dst = run (fun () -> Inner.clone ~src ~dst) + + (* === History === *) + module History = Inner.History + + let history ?depth ?min ?max t = + run (fun () -> Inner.history ?depth ?min ?max t) + + (* === Backend === + Re-export pure sub-modules from Inner; wrap the Lwt-flavoured stores + (Contents / Node / Commit / Branch) through Lwt_to_eio.{Indexable, + Atomic_write}_of_eio, and wrap Repo's Lwt-typed v / close / batch + through Lwt_eio.run_eio. *) + module Backend = struct + module Schema = S + module Hash = Inner.Backend.Hash + + module Contents = struct + include Lwt_to_eio.Indexable_of_eio (Inner.Backend.Contents) + + let merge t = + Lwt_to_eio.merge_of_eio + Type.(option Inner.Backend.Contents.Key.t) + (Inner.Backend.Contents.merge t) + + (* Val needs the Lwt-typed Contents.S the user supplied, not the + Eio-adapted [Schema_eio.Contents] that Inner sees. *) + module Val = S.Contents + module Hash = Inner.Backend.Contents.Hash + end + + module Node = struct + include Lwt_to_eio.Indexable_of_eio (Inner.Backend.Node) + + let merge t = + Lwt_to_eio.merge_of_eio + Type.(option Inner.Backend.Node.Key.t) + (Inner.Backend.Node.merge t) + + (* Path and Metadata are exposed as the user's Lwt-typed versions + (Metadata.merge differs in shape from Inner's Eio version). *) + module Path = S.Path + module Metadata = S.Metadata + + module Val = struct + include Inner.Backend.Node.Val + module Metadata = S.Metadata + module Path = S.Path + + (* Bridge Val.merge (~contents ~node) Lwt <-> Eio. *) + let merge ~contents ~node = + let contents_eio = + Lwt_to_eio.merge_to_eio + Type.(option Inner.Backend.Contents.Key.t) + contents + in + let node_eio = + Lwt_to_eio.merge_to_eio Type.(option Inner.Backend.Node.Key.t) node + in + Lwt_to_eio.merge_of_eio Inner.Backend.Node.Val.t + (Inner.Backend.Node.Val.merge ~contents:contents_eio ~node:node_eio) + end + + module Hash = Inner.Backend.Node.Hash + module Contents = Contents + end + + module Node_portable = struct + include Inner.Backend.Node_portable + module Metadata = S.Metadata + + (* In Node.Portable.S [contents_key = node_key = hash]; the merge + args are hashes, not the user's [node_key]. *) + let merge ~contents ~node = + let contents_eio = + Lwt_to_eio.merge_to_eio Type.(option Inner.hash_t) contents + in + let node_eio = + Lwt_to_eio.merge_to_eio Type.(option Inner.hash_t) node + in + Lwt_to_eio.merge_of_eio Inner.Backend.Node_portable.t + (Inner.Backend.Node_portable.merge ~contents:contents_eio + ~node:node_eio) + end + + module Commit = struct + include Lwt_to_eio.Indexable_of_eio (Inner.Backend.Commit) + + let merge t ~info = + Lwt_to_eio.merge_of_eio + Type.(option Inner.Backend.Commit.Key.t) + (Inner.Backend.Commit.merge t ~info) + + module Info = S.Info + module Val = Inner.Backend.Commit.Val + module Hash = Inner.Backend.Commit.Hash + module Node = Node + end + + module Commit_portable = Inner.Backend.Commit_portable + + module Branch = struct + include Lwt_to_eio.Atomic_write_of_eio (Inner.Backend.Branch) + module Key = Inner.Backend.Branch.Key + module Val = Inner.Backend.Branch.Val + end + + module Slice = struct + type t = Inner.Backend.Slice.t + type contents = Inner.Backend.Slice.contents + type node = Inner.Backend.Slice.node + type commit = Inner.Backend.Slice.commit + type value = Inner.Backend.Slice.value + + let t = Inner.Backend.Slice.t + let contents_t = Inner.Backend.Slice.contents_t + let node_t = Inner.Backend.Slice.node_t + let commit_t = Inner.Backend.Slice.commit_t + let value_t = Inner.Backend.Slice.value_t + let empty () = run (fun () -> Inner.Backend.Slice.empty ()) + let add t v = run (fun () -> Inner.Backend.Slice.add t v) + + let iter t f = + run (fun () -> + Inner.Backend.Slice.iter t (fun v -> + Lwt_eio.Promise.await_lwt (f v))) + end + + module Repo = struct + type t = Inner.Backend.Repo.t + + let v c = run (fun () -> Inner.Backend.Repo.v c) + let close r = run (fun () -> Inner.Backend.Repo.close r) + let contents_t = Inner.Backend.Repo.contents_t + let node_t = Inner.Backend.Repo.node_t + let commit_t = Inner.Backend.Repo.commit_t + let config = Inner.Backend.Repo.config + + let batch r f = + run (fun () -> + Inner.Backend.Repo.batch r (fun c n c2 -> + Lwt_eio.Promise.await_lwt (f c n c2))) + + let branch_t = Inner.Backend.Repo.branch_t + end + + module Remote = struct + type t = Inner.Backend.Remote.t + type commit = Inner.Backend.Remote.commit + type branch = Inner.Backend.Remote.branch + type endpoint = Inner.Backend.Remote.endpoint + + let fetch t ?depth e b = + run (fun () -> Inner.Backend.Remote.fetch t ?depth e b) + + let push t ?depth e b = + run (fun () -> Inner.Backend.Remote.push t ?depth e b) + + let v r = run (fun () -> Inner.Backend.Remote.v r) + end + end + + (* === Top-level reads === *) + let kind t p = run (fun () -> Inner.kind t p) + let list t p = run (fun () -> Inner.list t p) + let mem t p = run (fun () -> Inner.mem t p) + let mem_tree t p = run (fun () -> Inner.mem_tree t p) + let find_all t p = run (fun () -> Inner.find_all t p) + let find t p = run (fun () -> Inner.find t p) + let get_all t p = run (fun () -> Inner.get_all t p) + let get t p = run (fun () -> Inner.get t p) + let find_tree t p = run (fun () -> Inner.find_tree t p) + let get_tree t p = run (fun () -> Inner.get_tree t p) + let key t p = run (fun () -> Inner.key t p) + let hash t p = run (fun () -> Inner.hash t p) + + (* === Top-level writes === *) + type write_error = Inner.write_error + + let write_error_t = Inner.write_error_t + + let set ?clear ?retries ?allow_empty ?parents ~info t p c = + run (fun () -> Inner.set ?clear ?retries ?allow_empty ?parents ~info t p c) + + let set_exn ?clear ?retries ?allow_empty ?parents ~info t p c = + run (fun () -> + Inner.set_exn ?clear ?retries ?allow_empty ?parents ~info t p c) + + let set_tree ?clear ?retries ?allow_empty ?parents ~info t p tr = + run (fun () -> + Inner.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 (fun () -> + Inner.set_tree_exn ?clear ?retries ?allow_empty ?parents ~info t p tr) + + let remove ?clear ?retries ?allow_empty ?parents ~info t p = + run (fun () -> Inner.remove ?clear ?retries ?allow_empty ?parents ~info t p) + + let remove_exn ?clear ?retries ?allow_empty ?parents ~info t p = + run (fun () -> + Inner.remove_exn ?clear ?retries ?allow_empty ?parents ~info t p) + + let test_and_set ?clear ?retries ?allow_empty ?parents ~info t p ~test ~set = + run (fun () -> + Inner.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 (fun () -> + Inner.test_and_set_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 (fun () -> + Inner.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 (fun () -> + Inner.test_set_and_get_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 (fun () -> + Inner.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 (fun () -> + Inner.test_and_set_tree_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 (fun () -> + Inner.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 (fun () -> + Inner.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 (fun () -> + Inner.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 (fun () -> + Inner.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 (fun () -> + Inner.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 (fun () -> + Inner.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 (fun () -> + Inner.with_tree ?clear ?retries ?allow_empty ?parents ?strategy ~info t + p (fun tr -> Lwt_eio.Promise.await_lwt (f tr))) + + let with_tree_exn ?clear ?retries ?allow_empty ?parents ?strategy ~info t p f + = + run (fun () -> + Inner.with_tree_exn ?clear ?retries ?allow_empty ?parents ?strategy + ~info t p (fun tr -> Lwt_eio.Promise.await_lwt (f tr))) + + let last_modified ?depth ?n t p = + run (fun () -> Inner.last_modified ?depth ?n t p) + + (* === Tree === *) + module Tree = struct + (* Type rebindings *) + type t = tree + type kinded_hash = Inner.Tree.kinded_hash + type kinded_key = Inner.Tree.kinded_key + type elt = Inner.Tree.elt + type error = Inner.Tree.error + type 'a or_error = ('a, error) result + type marks = Inner.Tree.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 = + [ `Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int ] + + type concrete = Inner.Tree.concrete + + (* [counters] is rebound to the top-level [Tree_intf.counters] hoisted + out of [Tree.S], so that Maker_v2.Make.Tree.counters has the same + nominal identity as the [counters] expected by [Tree.S with ...] + in [Store.S]. *) + type counters = Tree_intf.counters = { + mutable contents_hash : int; + mutable contents_find : int; + mutable contents_add : int; + mutable contents_mem : int; + mutable node_hash : int; + mutable node_mem : int; + mutable node_index : int; + mutable node_add : int; + mutable node_find : int; + mutable node_val_v : int; + mutable node_val_find : int; + mutable node_val_list : int; + } + + type stats = Tree_intf.stats = { + nodes : int; + leafs : int; + skips : int; + depth : int; + width : int; + } + + type verifier_error = Inner.Tree.verifier_error + + let t = Inner.Tree.t + let kinded_hash_t = Inner.Tree.kinded_hash_t + let kinded_key_t = Inner.Tree.kinded_key_t + let depth_t = Inner.Tree.depth_t + let stats_t = Tree_intf.stats_t + let concrete_t = Inner.Tree.concrete_t + let verifier_error_t = Inner.Tree.verifier_error_t + + (* Type descriptors for the included path/step/... types *) + let path_t = Inner.Tree.path_t + let step_t = Inner.Tree.step_t + let metadata_t = Inner.Tree.metadata_t + let contents_t = Inner.Tree.contents_t + let contents_key_t = Inner.Tree.contents_key_t + let node_t = Inner.Tree.node_t + let hash_t = Inner.Tree.hash_t + + (* Exceptions thrown by Tree (re-bound from Inner) *) + exception Dangling_hash = Inner.Tree.Dangling_hash + exception Pruned_hash = Inner.Tree.Pruned_hash + exception Portable_value = Inner.Tree.Portable_value + + (* Constructors (sync, no wrapping needed) *) + let empty = Inner.Tree.empty + let singleton = Inner.Tree.singleton + let of_contents = Inner.Tree.of_contents + let of_node = Inner.Tree.of_node + let v = Inner.Tree.v + let pruned = Inner.Tree.pruned + + (* Reads *) + let kind tr p = run (fun () -> Inner.Tree.kind tr p) + let is_empty = Inner.Tree.is_empty + let diff a b = run (fun () -> Inner.Tree.diff a b) + let mem tr p = run (fun () -> Inner.Tree.mem tr p) + let find_all tr p = run (fun () -> Inner.Tree.find_all tr p) + let length tr ?cache p = run (fun () -> Inner.Tree.length tr ?cache p) + let find tr p = run (fun () -> Inner.Tree.find tr p) + let get_all tr p = run (fun () -> Inner.Tree.get_all tr p) + + let list tr ?offset ?length ?cache p = + run (fun () -> Inner.Tree.list tr ?offset ?length ?cache p) + + let seq tr ?offset ?length ?cache p = + run (fun () -> Inner.Tree.seq tr ?offset ?length ?cache p) + + let get tr p = run (fun () -> Inner.Tree.get tr p) + let mem_tree tr p = run (fun () -> Inner.Tree.mem_tree tr p) + let find_tree tr p = run (fun () -> Inner.Tree.find_tree tr p) + let get_tree tr p = run (fun () -> Inner.Tree.get_tree tr p) + + (* Writes *) + let add tr p ?metadata c = run (fun () -> Inner.Tree.add tr p ?metadata c) + + let update tr p ?metadata f = + run (fun () -> Inner.Tree.update tr p ?metadata f) + + let remove tr p = run (fun () -> Inner.Tree.remove tr p) + let add_tree tr p sub = run (fun () -> Inner.Tree.add_tree tr p sub) + let update_tree tr p f = run (fun () -> Inner.Tree.update_tree tr p f) + let merge = Lwt_to_eio.merge_of_eio Inner.Tree.t Inner.Tree.merge + let destruct = Inner.Tree.destruct + let pp = Inner.Tree.pp + + (* Identity / hashing *) + let key = Inner.Tree.key + let find_key r tr = run (fun () -> Inner.Tree.find_key r tr) + let of_key r k = run (fun () -> Inner.Tree.of_key r k) + let shallow = Inner.Tree.shallow + let hash = Inner.Tree.hash + let kinded_hash = Inner.Tree.kinded_hash + let of_hash r kh = run (fun () -> Inner.Tree.of_hash r kh) + + (* Folds *) + let empty_marks = Inner.Tree.empty_marks + + let fold (type a) ?order ?(force : a force option) ?cache ?uniq + ?(pre : (a, step list) folder option) + ?(post : (a, step list) folder option) ?depth + ?(contents : (a, contents) folder option) + ?(node : (a, node) folder option) ?(tree : (a, t) folder option) tr + (acc : a) = + let force_eio = + match force with + | None -> None + | Some `True -> Some `True + | Some (`False f) -> + Some (`False (fun p a -> Lwt_eio.Promise.await_lwt (f p a))) + in + let bridge f = + Option.map (fun f p b a -> Lwt_eio.Promise.await_lwt (f p b a)) f + in + run (fun () -> + Inner.Tree.fold ?order ?force:force_eio ?cache ?uniq ?pre:(bridge pre) + ?post:(bridge post) ?depth ?contents:(bridge contents) + ?node:(bridge node) ?tree:(bridge tree) tr acc) + + (* Stats / concrete *) + let stats ?force tr = + run (fun () -> + let s = Inner.Tree.stats ?force tr in + { + nodes = s.Inner.Tree.nodes; + leafs = s.leafs; + skips = s.skips; + depth = s.depth; + width = s.width; + }) + + let of_concrete = Inner.Tree.of_concrete + let to_concrete tr = run (fun () -> Inner.Tree.to_concrete tr) + + (* Caches / counters *) + let clear = Inner.Tree.clear + + let counters () = + let c = Inner.Tree.counters () in + { + contents_hash = c.Inner.Tree.contents_hash; + contents_find = c.contents_find; + contents_add = c.contents_add; + contents_mem = c.contents_mem; + node_hash = c.node_hash; + node_mem = c.node_mem; + node_index = c.node_index; + node_add = c.node_add; + node_find = c.node_find; + node_val_v = c.node_val_v; + node_val_find = c.node_val_find; + node_val_list = c.node_val_list; + } + + let dump_counters = Inner.Tree.dump_counters + let reset_counters = Inner.Tree.reset_counters + let inspect = Inner.Tree.inspect + + (* Proof producer / verifier *) + let produce_proof r kk f = + run (fun () -> + Inner.Tree.produce_proof r kk (fun tr -> + Lwt_eio.Promise.await_lwt (f tr))) + + let verify_proof p f = + run (fun () -> + Inner.Tree.verify_proof p (fun tr -> Lwt_eio.Promise.await_lwt (f tr))) + + let hash_of_proof_state = Inner.Tree.hash_of_proof_state + + (* Sub-modules: Contents (lazy), Proof, Private *) + module Contents = struct + type t = Inner.Tree.Contents.t + + let hash = Inner.Tree.Contents.hash + let key = Inner.Tree.Contents.key + let force tc = run (fun () -> Inner.Tree.Contents.force tc) + let force_exn tc = run (fun () -> Inner.Tree.Contents.force_exn tc) + let clear = Inner.Tree.Contents.clear + end + + module Proof = Inner.Tree.Proof + module Private = Inner.Tree.Private + end + + (* Now that our Remote.t is aliased to Irmin.remote, Inner.E is the same + extensible variant constructor and can be re-exported directly. *) + type Remote.t += E = Inner.E + + (* === Backend converters === *) + let of_backend_node = Inner.of_backend_node + let to_backend_node n = run (fun () -> Inner.to_backend_node n) + + let to_backend_portable_node n = + run (fun () -> Inner.to_backend_portable_node n) + + let to_backend_commit = Inner.to_backend_commit + let of_backend_commit = Inner.of_backend_commit + let save_contents t c = run (fun () -> Inner.save_contents t c) + + let save_tree ?clear r ct nt tr = + run (fun () -> Inner.save_tree ?clear r ct nt tr) + + (* === Deprecated alias === *) + let master r = run (fun () -> Inner.master r) [@@warning "-3"] +end diff --git a/src/irmin-lwt/fs/dune b/src/irmin-lwt/fs/dune new file mode 100644 index 0000000000..01dd206db8 --- /dev/null +++ b/src/irmin-lwt/fs/dune @@ -0,0 +1,4 @@ +(library + (name irmin_lwt_fs) + (public_name irmin-lwt-fs) + (libraries irmin irmin-fs irmin-fs.unix irmin-lwt lwt lwt_eio eio)) diff --git a/src/irmin-lwt/fs/irmin_lwt_fs.ml b/src/irmin-lwt/fs/irmin_lwt_fs.ml new file mode 100644 index 0000000000..fe0ad72cbb --- /dev/null +++ b/src/irmin-lwt/fs/irmin_lwt_fs.ml @@ -0,0 +1,79 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* Lwt-flavoured shim over Irmin 4's irmin-fs.unix backend. Each Lwt-typed + operation forwards to its Irmin 4 counterpart through Lwt_eio.run_eio. *) + +let run = Lwt_eio.run_eio +let config = Irmin_fs_unix.config +let spec = Irmin_fs_unix.spec + +module Append_only (K : Irmin_lwt.Type.S) (V : Irmin_lwt.Type.S) = struct + module M = Irmin_fs_unix.Append_only (K) (V) + + type 'a t = 'a M.t + type key = K.t + type value = V.t + + let v c = run (fun () -> M.v c) + let mem t k = run (fun () -> M.mem t k) + let find t k = run (fun () -> M.find t k) + let add t k v = run (fun () -> M.add t k v) + let close t = run (fun () -> M.close t) + + let batch t f = + run (fun () -> M.batch t (fun rw -> Lwt_eio.Promise.await_lwt (f rw))) +end + +module Atomic_write (K : Irmin_lwt.Type.S) (V : Irmin_lwt.Type.S) = struct + module M = Irmin_fs_unix.Atomic_write (K) (V) + + type t = M.t + type key = K.t + type value = V.t + type watch = M.watch + + let v c = run (fun () -> M.v c) + let mem t k = run (fun () -> M.mem t k) + let find t k = run (fun () -> M.find t k) + let set t k v = run (fun () -> M.set t k v) + + let test_and_set t k ~test ~set = + run (fun () -> M.test_and_set t k ~test ~set) + + let remove t k = run (fun () -> M.remove t k) + let list t = run (fun () -> M.list t) + + let watch t ?init f = + run (fun () -> + M.watch t ?init (fun k d -> Lwt_eio.Promise.await_lwt (f k d))) + + let watch_key t k ?init f = + run (fun () -> + M.watch_key t k ?init (fun d -> Lwt_eio.Promise.await_lwt (f d))) + + let unwatch t w = run (fun () -> M.unwatch t w) + let close t = run (fun () -> M.close t) + let clear t = run (fun () -> M.clear t) +end + +(* [irmin-fs] builds [Content_addressable] on top of [Append_only] via + [Irmin.Content_addressable.Make]. We do the same with the Lwt-typed + counterparts. *) + +module Content_addressable = Irmin_lwt.Content_addressable.Make (Append_only) +include Irmin_lwt.Maker (Content_addressable) (Atomic_write) +module KV = Irmin_lwt.KV_maker (Content_addressable) (Atomic_write) diff --git a/src/irmin-lwt/fs/irmin_lwt_fs.mli b/src/irmin-lwt/fs/irmin_lwt_fs.mli new file mode 100644 index 0000000000..5a76e5f216 --- /dev/null +++ b/src/irmin-lwt/fs/irmin_lwt_fs.mli @@ -0,0 +1,52 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** On-disk filesystem backend for [irmin-lwt]. + + A thin Lwt-flavoured shim over Irmin 4's [irmin-fs.unix] backend. Each + Lwt-typed operation forwards to its Irmin 4 counterpart through + {!Lwt_eio.run_eio}. The configuration leaks Eio types: [config] takes + [_ Eio.Path.t] for the root directory and [_ Eio.Time.clock] (used for file + lock staleness detection); Lwt callers obtain these from their + [Eio_main.run] runner. See LIMITATIONS.md. *) + +val config : + root:_ Eio.Path.t -> clock:_ Eio.Time.clock -> Irmin_lwt.Backend.Conf.t +(** [config ~root ~clock] is a configuration with the root directory and the + clock set. *) + +val spec : + path:_ Eio.Path.t -> clock:_ Eio.Time.clock -> Irmin_lwt.Backend.Conf.Spec.t + +module Append_only : Irmin_lwt.Append_only.Maker +(** Append-only store on top of the filesystem. *) + +module Atomic_write : Irmin_lwt.Atomic_write.Maker +(** Atomic-write store on top of the filesystem (with file locking for + [test_and_set]). *) + +module Content_addressable : Irmin_lwt.Content_addressable.Maker +(** Content-addressable store derived from {!Append_only}. *) + +(** Constructor for filesystem KV stores. *) +module KV : + Irmin_lwt.KV_maker + with type endpoint = unit + and type metadata = unit + and type info = Irmin_lwt.Info.default + +include Irmin_lwt.Maker with type endpoint = unit +(** Constructor for filesystem-backed Irmin stores. *) diff --git a/src/irmin-lwt/git/dune b/src/irmin-lwt/git/dune new file mode 100644 index 0000000000..b7ce3d50d0 --- /dev/null +++ b/src/irmin-lwt/git/dune @@ -0,0 +1,4 @@ +(library + (name irmin_lwt_git) + (public_name irmin-lwt-git) + (libraries irmin irmin-git irmin-git.unix irmin-lwt lwt lwt_eio)) diff --git a/src/irmin-lwt/git/irmin_lwt_git.ml b/src/irmin-lwt/git/irmin_lwt_git.ml new file mode 100644 index 0000000000..fbbcb232e6 --- /dev/null +++ b/src/irmin-lwt/git/irmin_lwt_git.ml @@ -0,0 +1,115 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* Lwt-flavoured shim over [Irmin_git_unix]. The user provides a Lwt-typed + [Contents.S]; we bridge it to Eio, apply [Irmin_git_unix]'s git Maker, and + wrap the resulting Eio store back to a Lwt-typed [Irmin_lwt.Generic_key.S] + via [Wrap_store.Make]. The git-specific extras ([module Git], [git_commit], + [git_of_repo], [repo_of_git], [remote]) are passed through. *) + +let config = Irmin_git.config + +module Maker (G : Irmin_git.G) = struct + module G = G + + type endpoint = Mimic.ctx * Smart_git.Endpoint.t + + module Inner_maker = Irmin_git_unix.Maker (G) + + module KV (V : Irmin_lwt.Contents.S) = struct + module V_eio = Irmin_lwt.Lwt_to_eio.Contents (V) + module Inner = Inner_maker.KV (V_eio) + + (* Build a Lwt-typed [Schema.S] reusing the pure modules from Inner's + Eio Schema (Hash, Branch, Info, Path are all module types without + Lwt.t in either direction; same module value satisfies both Lwt + and Eio Schema.S constraints). Metadata's [merge] is bridged. *) + module Schema_lwt = struct + module Hash = Inner.Schema.Hash + module Branch = Inner.Schema.Branch + module Info = Inner.Schema.Info + module Path = Inner.Schema.Path + + module Metadata = struct + type t = Inner.Schema.Metadata.t + + let t = Inner.Schema.Metadata.t + let default = Inner.Schema.Metadata.default + + let merge = + Irmin_lwt.Lwt_to_eio.merge_of_eio Inner.Schema.Metadata.t + Inner.Schema.Metadata.merge + end + + module Contents = V + end + + include Irmin_lwt.Wrap_store.Make (Schema_lwt) (Inner.Schema) (Inner) + + (* Pass-through git-specific extras. [git_commit] returns [Lwt.t] + upstream because ocaml-git is still Lwt-typed; we keep the same + shape, no extra wrap. *) + module Git = G + + let git_commit = Inner.git_commit + let git_of_repo = Inner.git_of_repo + let repo_of_git = Inner.repo_of_git + let remote = Inner.remote + end + + module Ref (V : Irmin_lwt.Contents.S) = struct + module V_eio = Irmin_lwt.Lwt_to_eio.Contents (V) + module Inner = Inner_maker.Ref (V_eio) + + module Schema_lwt = struct + module Hash = Inner.Schema.Hash + module Branch = Inner.Schema.Branch + module Info = Inner.Schema.Info + module Path = Inner.Schema.Path + + module Metadata = struct + type t = Inner.Schema.Metadata.t + + let t = Inner.Schema.Metadata.t + let default = Inner.Schema.Metadata.default + + let merge = + Irmin_lwt.Lwt_to_eio.merge_of_eio Inner.Schema.Metadata.t + Inner.Schema.Metadata.merge + end + + module Contents = V + end + + include Irmin_lwt.Wrap_store.Make (Schema_lwt) (Inner.Schema) (Inner) + module Git = G + + let git_commit = Inner.git_commit + let git_of_repo = Inner.git_of_repo + let repo_of_git = Inner.repo_of_git + let remote = Inner.remote + end +end + +module FS = struct + include Maker (Git_unix.Store) + module G = Git_unix.Store +end + +module Mem = struct + include Maker (Irmin_git.Mem) + module G = Irmin_git.Mem +end diff --git a/src/irmin-lwt/mem/dune b/src/irmin-lwt/mem/dune new file mode 100644 index 0000000000..5ac62b7169 --- /dev/null +++ b/src/irmin-lwt/mem/dune @@ -0,0 +1,4 @@ +(library + (name irmin_lwt_mem) + (public_name irmin-lwt-mem) + (libraries irmin irmin.mem irmin-lwt lwt lwt_eio)) diff --git a/src/irmin-lwt/mem/irmin_lwt_mem.ml b/src/irmin-lwt/mem/irmin_lwt_mem.ml new file mode 100644 index 0000000000..e1387a864b --- /dev/null +++ b/src/irmin-lwt/mem/irmin_lwt_mem.ml @@ -0,0 +1,102 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* Lwt-flavoured shim over Irmin 4's in-memory backend. Each Lwt-typed + operation forwards to its Irmin 4 counterpart through Lwt_eio.run_eio. *) + +let run = Lwt_eio.run_eio + +module Conf = Irmin_mem.Conf + +let config = Irmin_mem.config + +module Append_only (K : Irmin_lwt.Type.S) (V : Irmin_lwt.Type.S) = struct + module M = Irmin_mem.Append_only (K) (V) + + type 'a t = 'a M.t + type key = K.t + type value = V.t + + let v c = run (fun () -> M.v c) + let mem t k = run (fun () -> M.mem t k) + let find t k = run (fun () -> M.find t k) + let add t k v = run (fun () -> M.add t k v) + let close t = run (fun () -> M.close t) + + let batch t f = + run (fun () -> M.batch t (fun rw -> Lwt_eio.Promise.await_lwt (f rw))) +end + +module Content_addressable (H : Irmin_lwt.Hash.S) (V : Irmin_lwt.Type.S) = +struct + module M = Irmin_mem.Content_addressable (H) (V) + + type 'a t = 'a M.t + type key = H.t + type value = V.t + + (* Irmin 4's Content_addressable.S does not expose a [module Key] (its keys + are concrete [Hash.t] values); our Lwt-flavoured Content_addressable.S + inherits Indexable.S which does. Build it from Hash. *) + module Key = Irmin_lwt.Key.Of_hash (H) + + let v c = run (fun () -> M.v c) + let mem t k = run (fun () -> M.mem t k) + let find t k = run (fun () -> M.find t k) + let add t v = run (fun () -> M.add t v) + let unsafe_add t h v = run (fun () -> M.unsafe_add t h v) + let close t = run (fun () -> M.close t) + + let batch t f = + run (fun () -> M.batch t (fun rw -> Lwt_eio.Promise.await_lwt (f rw))) +end + +module Atomic_write (K : Irmin_lwt.Type.S) (V : Irmin_lwt.Type.S) = struct + module M = Irmin_mem.Atomic_write (K) (V) + + type t = M.t + type key = K.t + type value = V.t + type watch = M.watch + + let v c = run (fun () -> M.v c) + let mem t k = run (fun () -> M.mem t k) + let find t k = run (fun () -> M.find t k) + let set t k v = run (fun () -> M.set t k v) + + let test_and_set t k ~test ~set = + run (fun () -> M.test_and_set t k ~test ~set) + + let remove t k = run (fun () -> M.remove t k) + let list t = run (fun () -> M.list t) + + let watch t ?init f = + run (fun () -> + M.watch t ?init (fun k d -> Lwt_eio.Promise.await_lwt (f k d))) + + let watch_key t k ?init f = + run (fun () -> + M.watch_key t k ?init (fun d -> Lwt_eio.Promise.await_lwt (f d))) + + let unwatch t w = run (fun () -> M.unwatch t w) + let close t = run (fun () -> M.close t) + let clear t = run (fun () -> M.clear t) +end + +(* Plug the wrapped backends into Irmin_lwt.Maker / KV_maker. *) + +include Irmin_lwt.Maker (Content_addressable) (Atomic_write) +module KV = Irmin_lwt.KV_maker (Content_addressable) (Atomic_write) diff --git a/src/irmin-lwt/mem/irmin_lwt_mem.mli b/src/irmin-lwt/mem/irmin_lwt_mem.mli new file mode 100644 index 0000000000..82e8058edb --- /dev/null +++ b/src/irmin-lwt/mem/irmin_lwt_mem.mli @@ -0,0 +1,47 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** In-memory backend for [irmin-lwt]. + + A thin Lwt-flavoured shim over Irmin 4's in-memory backend. Each Lwt-typed + operation forwards to its Irmin 4 counterpart through {!Lwt_eio.run_eio}. + Apart from the Lwt return types, the API mirrors [Irmin_mem]. *) + +module Conf : sig + val spec : Irmin_lwt.Backend.Conf.Spec.t +end + +val config : unit -> Irmin_lwt.config +(** Configuration values. *) + +module Append_only : Irmin_lwt.Append_only.Maker +(** An in-memory store for append-only values. *) + +module Content_addressable : Irmin_lwt.Content_addressable.Maker +(** An in-memory store for content-addressable values. *) + +module Atomic_write : Irmin_lwt.Atomic_write.Maker +(** An in-memory store with atomic-write guarantees. *) + +(** Constructor for in-memory KV stores. *) +module KV : + Irmin_lwt.KV_maker + with type endpoint = unit + and type metadata = unit + and type info = Irmin_lwt.Info.default + +include Irmin_lwt.Maker with type endpoint = unit +(** Constructor for in-memory Irmin store. *) diff --git a/src/irmin-lwt/pack/dune b/src/irmin-lwt/pack/dune new file mode 100644 index 0000000000..60adc34fb8 --- /dev/null +++ b/src/irmin-lwt/pack/dune @@ -0,0 +1,11 @@ +(library + (name irmin_lwt_pack) + (public_name irmin-lwt-pack) + (libraries + irmin + irmin-pack + irmin-pack.io + irmin-pack.unix + irmin-lwt + lwt + lwt_eio)) diff --git a/src/irmin-lwt/pack/irmin_lwt_pack.ml b/src/irmin-lwt/pack/irmin_lwt_pack.ml new file mode 100644 index 0000000000..2e495b0f2c --- /dev/null +++ b/src/irmin-lwt/pack/irmin_lwt_pack.ml @@ -0,0 +1,143 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Conf = Irmin_pack.Conf + +let runeio = Lwt_eio.run_eio +let await = Lwt_eio.Promise.await_lwt + +module Maker (Config : Irmin_pack.Conf.S) = struct + type endpoint = unit + + module Inner_maker = Irmin_pack_unix.Maker (Config) + + type ('h, 'v) contents_key = ('h, 'v) Inner_maker.contents_key + type 'h node_key = 'h Inner_maker.node_key + type 'h commit_key = 'h Inner_maker.commit_key + + module Make (S : Irmin_lwt.Schema.S) = struct + module Schema_eio = Irmin_lwt.Lwt_to_eio.Schema_extended (S) + module Inner = Inner_maker.Make (Schema_eio) + include Irmin_lwt.Wrap_store.Make (S) (Schema_eio) (Inner) + + (* {1 irmin-pack-unix advanced surface, bridged to Lwt} *) + + (* {2 Integrity checks} *) + + let integrity_check ?ppf ?heads ~auto_repair r = + runeio (fun () -> Inner.integrity_check ?ppf ?heads ~auto_repair r) + + let integrity_check_inodes ?heads r = + runeio (fun () -> Inner.integrity_check_inodes ?heads r) + + let traverse_pack_file mode config = + runeio (fun () -> Inner.traverse_pack_file mode config) + + let test_traverse_pack_file mode config = + runeio (fun () -> Inner.test_traverse_pack_file mode config) + + (* {2 Chunking / lower layer / on-disk} *) + + let split r = runeio (fun () -> Inner.split r) + let is_split_allowed r = runeio (fun () -> Inner.is_split_allowed r) + let add_volume r = runeio (fun () -> Inner.add_volume r) + let reload r = runeio (fun () -> Inner.reload r) + let flush r = runeio (fun () -> Inner.flush r) + + let create_one_commit_store ~domain_mgr r ck path = + runeio (fun () -> Inner.create_one_commit_store ~domain_mgr r ck path) + + (* {2 Statistics} *) + + let stats ~dump_blob_paths_to ~commit r = + runeio (fun () -> Inner.stats ~dump_blob_paths_to ~commit r) + + (* {2 Garbage collection} *) + + module Gc = struct + type process_state = Inner.Gc.process_state + type msg = Inner.Gc.msg + + let start_exn ~domain_mgr ?unlink r ck = + runeio (fun () -> Inner.Gc.start_exn ~domain_mgr ?unlink r ck) + + let finalise_exn ?wait r' = + runeio (fun () -> Inner.Gc.finalise_exn ?wait r') + + (* [Inner.Gc.run]'s [?finished] callback runs in Eio direct-style. + Bridge it: user gives us a Lwt-typed callback, we await its + promise inside Eio. *) + let run ~domain_mgr ?finished r ck = + let finished_eio = + Option.map (fun f result -> await (f result)) finished + in + runeio (fun () -> Inner.Gc.run ~domain_mgr ?finished:finished_eio r ck) + + let wait r = runeio (fun () -> Inner.Gc.wait r) + let cancel r = runeio (fun () -> Inner.Gc.cancel r) + let is_finished r = runeio (fun () -> Inner.Gc.is_finished r) + let behaviour r = runeio (fun () -> Inner.Gc.behaviour r) + let is_allowed r = runeio (fun () -> Inner.Gc.is_allowed r) + let latest_gc_target r = runeio (fun () -> Inner.Gc.latest_gc_target r) + end + + (* {2 Snapshots} *) + + module Snapshot = struct + type kinded_hash = Inner.Snapshot.kinded_hash = + | Contents of hash * metadata + | Node of hash + [@@deriving irmin] + + type entry = Inner.Snapshot.entry = { step : string; hash : kinded_hash } + [@@deriving irmin] + + type inode_tree = Inner.Snapshot.inode_tree = { + depth : int; + length : int; + pointers : (int * hash) list; + } + [@@deriving irmin] + + type v = Inner.Snapshot.v = + | Inode_tree of inode_tree + | Inode_value of entry list + [@@deriving irmin] + + type inode = Inner.Snapshot.inode = { v : v; root : bool } + [@@deriving irmin] + + type t = Inner.Snapshot.t = + | Inode of inode + | Blob of Inner.Backend.Contents.Val.t + [@@deriving irmin] + + let export ?on_disk r f ~root_key = + runeio (fun () -> + Inner.Snapshot.export ?on_disk r + (fun elt -> await (f elt)) + ~root_key) + + module Import = struct + type process = Inner.Snapshot.Import.process + + let v ?on_disk r = runeio (fun () -> Inner.Snapshot.Import.v ?on_disk r) + let save_elt p t = runeio (fun () -> Inner.Snapshot.Import.save_elt p t) + let close p r = runeio (fun () -> Inner.Snapshot.Import.close p r) + end + end + end +end diff --git a/src/irmin-lwt/pack/irmin_lwt_pack.mli b/src/irmin-lwt/pack/irmin_lwt_pack.mli new file mode 100644 index 0000000000..049518f949 --- /dev/null +++ b/src/irmin-lwt/pack/irmin_lwt_pack.mli @@ -0,0 +1,177 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Lwt-flavoured shim over Irmin 4's [irmin-pack-unix] backend. + + [Maker (Config).Make (Schema)] produces a Lwt-typed Irmin store on top of + [Irmin_pack_unix.Maker (Config).Make (Schema_eio)] via [Wrap_store.Make], + plus the [irmin-pack-unix]-specific surface (integrity checks, chunking, + lower layer, GC, snapshots, statistics) wrapped in [Lwt.t]. Each Eio-direct + effectful operation in [Inner] becomes a Lwt promise here. + + Some entry points unavoidably leak Eio types because they take Eio + capabilities as arguments (notably [Eio.Domain_manager.t] and [Eio.Path.t]). + Users on Lwt who want to call these have to obtain the corresponding Eio + values from their runner -- this shim does not hide Eio entirely. See + LIMITATIONS.md. *) + +module Conf = Irmin_pack.Conf + +(** {1 Maker} *) + +module Maker (Config : Irmin_pack.Conf.S) : sig + type endpoint = unit + + type ('h, 'v) contents_key = + ('h, 'v) Irmin_pack_unix.Maker(Config).contents_key + + type 'h node_key = 'h Irmin_pack_unix.Maker(Config).node_key + type 'h commit_key = 'h Irmin_pack_unix.Maker(Config).commit_key + + module Make (S : Irmin_lwt.Schema.S) : sig + include Irmin_lwt.Generic_key.S with module Schema = S + (** @inline *) + + (** {1 Integrity checks} *) + + 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_lwt.config -> + unit Lwt.t + + val test_traverse_pack_file : + [ `Reconstruct_index of [ `In_place | `Output of string ] + | `Check_index + | `Check_and_fix_index ] -> + Irmin_lwt.config -> + unit Lwt.t + + (** {1 Chunking / lower layer / on-disk} *) + + val split : repo -> unit Lwt.t + val is_split_allowed : repo -> bool Lwt.t + 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 + + (** {1 Statistics} *) + + val stats : + dump_blob_paths_to:string option -> commit:commit -> repo -> unit Lwt.t + + (** {1 Garbage collection} *) + + module Gc : sig + type process_state = + [ `Idle | `Running | `Finalised of Irmin_pack_io.Stats.Latest_gc.stats ] + + type msg = [ `Msg of string ] + + 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 Lwt.t + val behaviour : repo -> [ `Archive | `Delete ] Lwt.t + val is_allowed : repo -> bool Lwt.t + val latest_gc_target : repo -> commit_key option Lwt.t + end + + (** {1 Snapshots} *) + + module Snapshot : sig + type kinded_hash = Contents of hash * metadata | Node of hash + [@@deriving irmin] + + type entry = { step : string; hash : kinded_hash } [@@deriving irmin] + + type inode_tree = { + depth : int; + length : int; + pointers : (int * hash) list; + } + [@@deriving irmin] + + type v = Inode_tree of inode_tree | Inode_value of entry list + [@@deriving irmin] + + type inode = { v : v; root : bool } [@@deriving irmin] + + type t = Inode of inode | Blob of Backend.Contents.Val.t + [@@deriving irmin] + + val export : + ?on_disk:[ `Path of Eio.Fs.dir_ty Eio.Path.t ] -> + repo -> + (t -> unit Lwt.t) -> + root_key:Tree.kinded_key -> + int Lwt.t + + module Import : sig + type process + + val v : + ?on_disk:[ `Path of Eio.Fs.dir_ty Eio.Path.t | `Reuse ] -> + repo -> + process Lwt.t + + val save_elt : process -> t -> node_key Lwt.t + val close : process -> repo -> unit Lwt.t + end + end + end +end diff --git a/src/irmin-lwt/test/common.ml b/src/irmin-lwt/test/common.ml new file mode 100644 index 0000000000..519a9453f0 --- /dev/null +++ b/src/irmin-lwt/test/common.ml @@ -0,0 +1,334 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Irmin = Irmin_lwt +open! Import + +let random_char () = char_of_int (Random.int 256) + +let random_ascii () = + let chars = "0123456789abcdefghijklmnopqrstABCDEFGHIJKLMNOPQRST-_." in + chars.[Random.int @@ String.length chars] + +let random_string n = String.init n (fun _i -> random_char ()) +let long_random_string = random_string (* 1024_000 *) 10 +let random_ascii_string n = String.init n (fun _i -> random_ascii ()) +let long_random_ascii_string = random_ascii_string 1024_000 + +let merge_exn msg x = + match x with + | Ok x -> Lwt.return x + | Error (`Conflict m) -> Alcotest.failf "%s: %s" msg m + +open Astring + +module type S = + Irmin.S + with type Schema.Path.step = string + and type Schema.Path.t = string list + and type Schema.Contents.t = string + and type Schema.Branch.t = string + +module type Generic_key = + Irmin.Generic_key.S + with type Schema.Path.step = string + and type Schema.Path.t = string list + and type Schema.Contents.t = string + and type Schema.Branch.t = string + +module Schema = struct + module Hash = Irmin.Hash.SHA1 + module Commit = Irmin.Commit.Make (Hash) + module Path = Irmin.Path.String_list + module Metadata = Irmin.Metadata.None + module Node = Irmin.Node.Generic_key.Make (Hash) (Path) (Metadata) + module Branch = Irmin.Branch.String + module Info = Irmin.Info.Default + module Contents = Irmin.Contents.String +end + +let store : (module Irmin.Maker) -> (module Irmin.Metadata.S) -> (module S) = + fun (module B) (module M) -> + let module Schema = struct + include Schema + module Metadata = M + module Node = Irmin.Node.Generic_key.Make (Hash) (Path) (Metadata) + end in + let module S = B.Make (Schema) in + (module S) + +type store = S of (module S) | Generic_key of (module Generic_key) + +type t = { + name : string; + init : config:Irmin.config -> unit Lwt.t; + clean : config:Irmin.config -> unit Lwt.t; + config : Irmin.config; + store : store; + stats : (unit -> int * int) option; + (* Certain store implementations currently don't support implementing + repository state from a slice, because their slice formats contain + non-portable objects. For now, we disable the tests require this feature + for such backends. + + TODO: fix slices to always contain portable objects, and extend + [Store.import] to re-hydrate the keys in these slices (by tracking keys of + added objects), then require all backends to run thee tests. *) + import_supported : bool; +} + +module Suite = struct + type nonrec t = t + + let default_clean ~config ~store = + let (module Store : Generic_key) = + match store with + | Generic_key x -> x + | S (module S) -> (module S : Generic_key) + in + let open Lwt.Syntax in + let* repo = Store.Repo.v config in + let* branches = Store.Repo.branches repo in + let* () = Lwt_list.iter_p (Store.Branch.remove repo) branches in + Store.Repo.close repo + + let create ~name ?(init = fun ~config:_ -> Lwt.return_unit) ?clean ~config + ~store ?stats ?(import_supported = true) () = + let store = S store in + let clean = Option.value clean ~default:(default_clean ~store) in + { name; init; clean; config; store; stats; import_supported } + + let create_generic_key ~name ?(init = fun ~config:_ -> Lwt.return_unit) ?clean + ~config ~store ?stats ?(import_supported = true) () = + let store = Generic_key store in + let clean = Option.value clean ~default:(default_clean ~store) in + { name; init; clean; config; store; stats; import_supported } + + let name t = t.name + let config t = t.config + let store t = match t.store with S x -> Some x | Generic_key _ -> None + + let store_generic_key t = + match t.store with + | Generic_key x -> x + | S (module S) -> (module S : Generic_key) + + let init t = t.init + let clean t = t.clean +end + +module type Store_tests = functor (S : Generic_key) -> sig + val tests : (string * (Suite.t -> unit -> unit Lwt.t)) list +end + +module Make_helpers (S : Generic_key) = struct + module B = S.Backend + module Graph = Irmin.Node.Graph (B.Node) + + let info message = + let date = Int64.of_float 0. in + let author = Printf.sprintf "TESTS" in + S.Info.v ~author ~message date + + let infof fmt = Fmt.kstr (fun str () -> info str) fmt + + let get_contents_key = function + | `Contents key -> key + | _ -> Alcotest.fail "expecting contents_key" + + let get_node_key = function + | `Node key -> key + | _ -> Alcotest.fail "expecting node_key" + + type x = int [@@deriving irmin] + + let v repo = B.Repo.contents_t repo + let n repo = B.Repo.node_t repo + let ct repo = B.Repo.commit_t repo + let g repo = B.Repo.node_t repo + let h repo = B.Repo.commit_t repo + let b repo = B.Repo.branch_t repo + let v1 = long_random_string + let v2 = "" + let with_contents repo f = B.Repo.batch repo (fun t _ _ -> f t) + let with_node repo f = B.Repo.batch repo (fun _ t _ -> f t) + let with_commit repo f = B.Repo.batch repo (fun _ _ t -> f t) + let with_info repo n f = with_commit repo (fun h -> f h ~info:(info n)) + let kv1 ~repo = with_contents repo (fun t -> B.Contents.add t v1) + let kv2 ~repo = with_contents repo (fun t -> B.Contents.add t v2) + let normal x = `Contents (x, S.Metadata.default) + let b1 = "foo" + let b2 = "bar/toto" + + let n1 ~repo = + let* kv1 = kv1 ~repo in + with_node repo (fun t -> Graph.v t [ ("x", normal kv1) ]) + + let n2 ~repo = + let* kn1 = n1 ~repo in + with_node repo (fun t -> Graph.v t [ ("b", `Node kn1) ]) + + let n3 ~repo = + let* kn2 = n2 ~repo in + with_node repo (fun t -> Graph.v t [ ("a", `Node kn2) ]) + + let n4 ~repo = + let* kn1 = n1 ~repo in + let* kv2 = kv2 ~repo in + let* kn4 = with_node repo (fun t -> Graph.v t [ ("x", normal kv2) ]) in + let* kn5 = + with_node repo (fun t -> Graph.v t [ ("b", `Node kn1); ("c", `Node kn4) ]) + in + with_node repo (fun t -> Graph.v t [ ("a", `Node kn5) ]) + + let r1 ~repo = + let* kn2 = n2 ~repo in + S.Tree.of_key repo (`Node kn2) >>= function + | None -> Alcotest.fail "r1" + | Some tree -> + S.Commit.v repo ~info:S.Info.empty ~parents:[] (tree :> S.tree) + + let r2 ~repo = + let* kn3 = n3 ~repo in + let* kr1 = r1 ~repo in + S.Tree.of_key repo (`Node kn3) >>= function + | None -> Alcotest.fail "r2" + | Some t3 -> + S.Commit.v repo ~info:S.Info.empty + ~parents:[ S.Commit.key kr1 ] + (t3 :> S.tree) + + let ignore_thunk_errors f = Lwt.catch f (fun _ -> Lwt.return_unit) + + let run (x : Suite.t) test = + let repo_ptr = ref None in + let config_ptr = ref None in + Lwt.catch + (fun () -> + let module Conf = Irmin.Backend.Conf in + let generate_random_root config = + let sp = Conf.spec config in + match Conf.Spec.find_key sp "root" with + | None -> config + | Some (K k) -> + let id = Random.int 100 |> string_of_int in + let root_value = + match Conf.find_root config with + | None -> "test_" ^ id + | Some v -> v ^ "_" ^ id + in + let v = + (* Irmin 4 exposes [Conf.of_string] directly on the key + instead of the [Conf.ty] / [Type.of_string] pair main + used. *) + Conf.of_string k root_value |> Result.get_ok + in + Conf.add config k v + in + let config = generate_random_root x.config in + config_ptr := Some config; + let* () = x.init ~config in + let* repo = S.Repo.v config in + repo_ptr := Some repo; + let* () = test repo in + let* () = + (* [test] might have already closed the repo. That + [ignore_thunk_errors] shall be removed as soon as all stores + support double closes. *) + ignore_thunk_errors (fun () -> S.Repo.close repo) + in + x.clean ~config) + (fun exn -> + (* [test] failed, attempt an errorless cleanup and forward the right + backtrace to the user. *) + let bt = Printexc.get_raw_backtrace () in + let* () = + match !repo_ptr with + | Some repo -> ignore_thunk_errors (fun () -> S.Repo.close repo) + | None -> Lwt.return_unit + in + let+ () = + match !config_ptr with + | Some config -> ignore_thunk_errors (fun () -> x.clean ~config) + | None -> Lwt.return_unit + in + Printexc.raise_with_backtrace exn bt) +end + +let filter_src src = + not + (List.mem ~equal:String.equal (Logs.Src.name src) + [ + "git.inflater.decoder"; + "git.deflater.encoder"; + "git.encoder"; + "git.decoder"; + "git.loose"; + "git.store"; + "cohttp.lwt.io"; + ]) + +let reporter ?prefix () = + Irmin.Export_for_backends.Logging.reporter ~filter_src ?prefix + (module Mtime_clock) + +let () = + Logs.set_level (Some Logs.Debug); + Logs.set_reporter (reporter ()) + +let line ppf ?color c = + let line = String.v ~len:80 (fun _ -> c) in + match color with + | Some c -> Fmt.pf ppf "%a\n%!" Fmt.(styled c string) line + | None -> Fmt.pf ppf "%s\n%!" line + +let line msg = + let line () = line Fmt.stderr ~color:`Yellow '-' in + line (); + [%logs.info "ASSERT %s" msg]; + line () + +let ( / ) = Filename.concat + +let testable t = + Alcotest.testable (Irmin.Type.pp_dump t) Irmin.Type.(unstage (equal t)) + +let check t = Alcotest.check (testable t) + +let checks t = + let t = Alcotest.slist (testable t) Irmin.Type.(unstage (compare t)) in + Alcotest.check t + +(* also in test/irmin-pack/common.ml *) +let check_raises_lwt msg exn (type a) (f : unit -> a Lwt.t) = + Lwt.catch + (fun x -> + let* (_ : a) = f x in + Alcotest.failf + "Fail %s: expected function to raise %s, but it returned instead." msg + (Printexc.to_string exn)) + (function + | e when e = exn -> Lwt.return_unit + | e -> + Alcotest.failf + "Fail %s: expected function to raise %s, but it raised %s instead." + msg (Printexc.to_string exn) (Printexc.to_string e)) + +module T = Irmin.Type + +module type Sleep = sig + val sleep : float -> unit Lwt.t +end diff --git a/src/irmin-lwt/test/dune b/src/irmin-lwt/test/dune new file mode 100644 index 0000000000..1fb4108e92 --- /dev/null +++ b/src/irmin-lwt/test/dune @@ -0,0 +1,16 @@ +(library + (name irmin_lwt_test) + (public_name irmin-lwt-test) + (modules Irmin_test Node Store Store_graph Store_watch Common Import) + (preprocess + (pps ppx_irmin.internal)) + (libraries + alcotest-lwt + astring + fmt + irmin-lwt + jsonm + logs.fmt + lwt + mtime + mtime.clock.os)) diff --git a/src/irmin-lwt/test/helpers.ml b/src/irmin-lwt/test/helpers.ml new file mode 100644 index 0000000000..0e7edddff0 --- /dev/null +++ b/src/irmin-lwt/test/helpers.ml @@ -0,0 +1,21 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Irmin = Irmin_lwt + +let init_logs () = + Logs.set_level (Some Debug); + Logs.set_reporter (Common.reporter ()) diff --git a/src/irmin-lwt/test/import.ml b/src/irmin-lwt/test/import.ml new file mode 100644 index 0000000000..c531843b5e --- /dev/null +++ b/src/irmin-lwt/test/import.ml @@ -0,0 +1,23 @@ +(* + * Copyright (c) 2021 Craig Ferguson + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Irmin = Irmin_lwt +include Irmin.Export_for_backends +include Lwt.Syntax + +let ( >>= ) = Lwt.Infix.( >>= ) +let ( >|= ) = Lwt.Infix.( >|= ) diff --git a/src/irmin-lwt/test/irmin_test.ml b/src/irmin-lwt/test/irmin_test.ml new file mode 100644 index 0000000000..cac12cf3c4 --- /dev/null +++ b/src/irmin-lwt/test/irmin_test.ml @@ -0,0 +1,20 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +include Common +module Store = Store +module Common = Common +module Node = Node diff --git a/src/irmin-lwt/test/irmin_test.mli b/src/irmin-lwt/test/irmin_test.mli new file mode 100644 index 0000000000..b1a9872a87 --- /dev/null +++ b/src/irmin-lwt/test/irmin_test.mli @@ -0,0 +1,76 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Irmin = Irmin_lwt + +module type S = Common.S +module type Generic_key = Common.Generic_key + +val reporter : ?prefix:string -> unit -> Logs.reporter + +module Suite : sig + type t + + val create : + name:string -> + ?init:(config:Irmin.config -> unit Lwt.t) -> + ?clean:(config:Irmin.config -> unit Lwt.t) -> + config:Irmin.config -> + store:(module S) -> + ?stats:(unit -> int * int) -> + ?import_supported:bool -> + unit -> + t + + val create_generic_key : + name:string -> + ?init:(config:Irmin.config -> unit Lwt.t) -> + ?clean:(config:Irmin.config -> unit Lwt.t) -> + config:Irmin.config -> + store:(module Generic_key) -> + ?stats:(unit -> int * int) -> + ?import_supported:bool -> + unit -> + t + + val name : t -> string + val config : t -> Irmin.config + val store : t -> (module S) option + val init : t -> config:Irmin.config -> unit Lwt.t + val clean : t -> config:Irmin.config -> unit Lwt.t +end + +val line : string -> unit + +module Schema = Common.Schema + +val store : (module Irmin.Maker) -> (module Irmin.Metadata.S) -> (module S) +val testable : 'a Irmin.Type.t -> 'a Alcotest.testable +val check : 'a Irmin.Type.t -> string -> 'a -> 'a -> unit +val checks : 'a Irmin.Type.t -> string -> 'a list -> 'a list -> unit + +module Store : sig + val run : + string -> + ?slow:bool -> + ?random_seed:int -> + sleep:(float -> unit Lwt.t) -> + misc:unit Alcotest_lwt.test list -> + (Alcotest.speed_level * Suite.t) list -> + unit Lwt.t +end + +module Node = Node diff --git a/src/irmin-lwt/test/node.ml b/src/irmin-lwt/test/node.ml new file mode 100644 index 0000000000..5c2a366457 --- /dev/null +++ b/src/irmin-lwt/test/node.ml @@ -0,0 +1,152 @@ +(* + * Copyright (c) 2018-2022 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Irmin = Irmin_lwt + +let check pos typ ~expected actual = + let typ = + Alcotest.testable Irmin.Type.(pp_dump typ) Irmin.Type.(unstage (equal typ)) + in + Alcotest.(check ~pos typ) "" expected actual + +module type Map = sig + type t [@@deriving irmin] + type data [@@deriving irmin] + type key := string + + val empty : unit -> t + val is_empty : t -> bool + val length : t -> int + val list : ?offset:int -> ?length:int -> ?cache:bool -> t -> (key * data) list + val find : ?cache:bool -> t -> key -> data option + val add : t -> key -> data -> t + val remove : t -> key -> t + + (* Generators for use by the tests: *) + val random_data : unit -> data +end + +module Suite (Map : Map) = struct + type key = string [@@deriving irmin] + + let random_bindings n = + List.init n (fun i -> (string_of_int i, Map.random_data ())) + + let map_of_bindings kvs = + List.fold_left (fun t (k, v) -> Map.add t k v) (Map.empty ()) kvs + + let test_empty () = + check __POS__ [%typ: bool] ~expected:true Map.(is_empty (empty ())); + check __POS__ [%typ: int] ~expected:0 Map.(length (empty ())); + check __POS__ [%typ: (key * Map.data) list] ~expected:[] + Map.(list (empty ())) + + let test_add () = + let with_binding k v t = Map.add t k v in + let d1 = Map.random_data () and d2 = Map.random_data () in + let a = Map.empty () |> with_binding "1" d1 |> with_binding "2" d2 in + check __POS__ [%typ: int] ~expected:2 (Map.length a) + + let test_remove () = + (* Remove is a no-op on an empty node *) + check __POS__ [%typ: Map.t] ~expected:(Map.empty ()) + Map.(remove (empty ()) "foo") + + let test_find () = + let bindings = random_bindings 256 in + let node = map_of_bindings bindings in + bindings + |> List.iter (fun (k, v) -> + check __POS__ [%typ: Map.data option] ~expected:(Some v) + (Map.find node k)) + + let test_equal () = + let module Map = struct + include Map + + type nonrec t = t [@@deriving irmin ~equal ~to_bin_string ~of_bin_string] + end in + let bindings = random_bindings 256 in + let m = map_of_bindings bindings in + + let m_rev = map_of_bindings (List.rev bindings) in + check __POS__ [%typ: bool] ~expected:true (Map.equal m m_rev); + + let m_subset = map_of_bindings (List.tl bindings) in + check __POS__ [%typ: bool] ~expected:false (Map.equal m m_subset); + + let m_serialised = + m |> Map.to_bin_string |> Map.of_bin_string |> Result.get_ok + in + check __POS__ [%typ: bool] ~expected:true (Map.equal m m_serialised) + + let suite = + [ + ("empty", test_empty); + ("add", test_add); + ("remove", test_remove); + ("find", test_find); + ("equal", test_equal); + ] +end + +module Make (Make_node : Irmin.Node.Generic_key.Maker) : sig + val suite : unit Alcotest.test_case list +end = struct + (* For each [Node] maker, we can instantiate the test suite above twice: once + for regular nodes, and once for portable nodes. *) + + module Schema = Irmin.Schema.KV (Irmin.Contents.String) + module Hash = Schema.Hash + module Key = Irmin.Key.Of_hash (Hash) + module Node = Make_node (Hash) (Schema.Path) (Schema.Metadata) (Key) (Key) + + type key = Key.t [@@deriving irmin] + + module Extras = struct + type data = [ `Node of Key.t | `Contents of Key.t * unit ] + [@@deriving irmin] + + let random_data = + let hash_of_string = Irmin.Type.(unstage (of_bin_string Hash.t)) in + let random_string = + Irmin.Type.(unstage (random (string_of (`Fixed Hash.hash_size)))) + in + fun () -> + match hash_of_string (random_string ()) with + | Error _ -> assert false + | Ok x -> ( + match Random.int 2 with + | 0 -> `Node x + | 1 -> `Contents (x, ()) + | _ -> assert false) + end + + let suite = + let tc (name, f) = Alcotest.test_case name `Quick f in + let module Suite_node = Suite (struct + include Node + include Extras + end) in + let module Suite_node_portable = Suite (struct + include Node.Portable + include Extras + end) in + List.map tc Suite_node.suite + @ List.map + (fun (name, f) -> tc ("Portable." ^ name, f)) + Suite_node_portable.suite +end diff --git a/src/irmin-lwt/test/store.ml b/src/irmin-lwt/test/store.ml new file mode 100644 index 0000000000..33bb6d34ef --- /dev/null +++ b/src/irmin-lwt/test/store.ml @@ -0,0 +1,2497 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Irmin = Irmin_lwt +open! Import +open Common + +let src = Logs.Src.create "test" ~doc:"Irmin tests" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Make (S : Generic_key) = struct + include Common.Make_helpers (S) + module History = Irmin.Commit.History (B.Commit) + + let with_binding k v t = S.Tree.add t k v + let random_value value = random_string value + + let random_path ~label ~path = + let short () = random_ascii_string label in + let rec aux = function 0 -> [] | n -> short () :: aux (n - 1) in + aux path + + let random_node ~label ~path ~value = + (random_path ~label ~path, random_value value) + + let random_nodes ?(label = 8) ?(path = 5) ?(value = 1024) n = + let rec aux acc = function + | 0 -> acc + | n -> aux (random_node ~label ~path ~value :: acc) (n - 1) + in + aux [] n + + let old k () = Lwt.return_ok (Some k) + + let may repo commits = function + | None -> Lwt.return_unit + | Some f -> f repo commits + + let may_get_keys repo keys = function + | None -> Lwt.return_unit + | Some f -> + let* commits = + Lwt_list.map_p + (fun key -> + S.Commit.of_key repo key >|= function + | None -> Alcotest.fail "Cannot read commit hash" + | Some c -> c) + keys + in + f repo commits + + let may_with_branch branches repo hook = + let* heads = + Lwt_list.map_p + (fun branch -> + let+ h = S.Head.find branch in + match h with + | None -> Alcotest.fail "Cannot read head" + | Some head -> head) + branches + in + may repo heads hook + + let contents c = S.Tree.v (`Contents (c, S.Metadata.default)) + + let test_contents x () = + let test repo = + let t = B.Repo.contents_t repo in + let check_key = check B.Contents.Key.t in + let check_val = check (T.option S.contents_t) in + let* kv2 = kv2 ~repo in + let* k2' = with_contents repo (fun t -> B.Contents.add t v2) in + check_key "kv2" kv2 k2'; + let* v2' = B.Contents.find t k2' in + check_val "v2" (Some v2) v2'; + let* k2'' = with_contents repo (fun t -> B.Contents.add t v2) in + check_key "kv2" kv2 k2''; + let* kv1 = kv1 ~repo in + let* k1' = with_contents repo (fun t -> B.Contents.add t v1) in + check_key "kv1" kv1 k1'; + let* k1'' = with_contents repo (fun t -> B.Contents.add t v1) in + check_key "kv1" kv1 k1''; + let* v1' = B.Contents.find t kv1 in + check_val "v1" (Some v1) v1'; + let* v2' = B.Contents.find t kv2 in + check_val "v2" (Some v2) v2'; + B.Repo.close repo >>= fun () -> + Lwt.catch + (fun () -> + let+ _ = with_contents repo (fun t -> B.Contents.add t v2) in + Alcotest.fail "Add after close should not be allowed") + (function Irmin.Closed -> Lwt.return_unit | exn -> Lwt.fail exn) + in + run x test + + let get = function None -> Alcotest.fail "get" | Some v -> v + + let test_nodes x () = + let test repo = + let g = g repo and n = n repo in + let* k = + with_contents repo (fun c -> B.Contents.add c "foo") >|= normal + in + let check_hash = check B.Hash.t in + let check_key = check B.Node.Key.t in + let check_val = check [%typ: Graph.value option] in + let check_list = checks [%typ: S.step * B.Node.Val.value] in + let check_node msg v = + let h' = B.Node.Hash.hash v in + let+ key = with_node repo (fun n -> B.Node.add n v) in + check_hash (msg ^ ": hash(v) = add(v)") (B.Node.Key.to_hash key) h' + in + let v = B.Node.Val.empty () in + check_node "empty node" v >>= fun () -> + let v1 = B.Node.Val.add v "x" k in + check_node "node: x" v1 >>= fun () -> + let v2 = B.Node.Val.add v "x" k in + check_node "node: x (bis)" v2 >>= fun () -> + check B.Node.Val.t "add x" v1 v2; + let v0 = B.Node.Val.remove v1 "x" in + check B.Node.Val.t "remove x" v v0; + let v3 = B.Node.Val.add v1 "x" k in + Alcotest.(check bool) "same same" true (v1 == v3); + let u = B.Node.Val.add v3 "y" k in + check_node "node: x+y" v3 >>= fun () -> + let u = B.Node.Val.add u "z" k in + check_node "node: x+y+z" u >>= fun () -> + let check_values u = + check_val "find x" (Some k) (B.Node.Val.find u "x"); + check_val "find y" (Some k) (B.Node.Val.find u "y"); + check_val "find z" (Some k) (B.Node.Val.find u "x"); + check_val "find xx" None (B.Node.Val.find u "xx") + in + check_values u; + let () = + let _w = B.Node.Val.of_list [ ("y", k); ("z", k); ("x", k) ] in + (* XXX: this isn't a valid check. [u] is not concrete, and [w] is. *) + (* check B.Node.Val.t "v" u w; *) + () + in + let all = B.Node.Val.list u in + check_list "list all" [ ("x", k); ("y", k); ("z", k) ] all; + let l = B.Node.Val.list ~length:1 u in + check_list "list length=1" [ ("x", k) ] l; + let l = B.Node.Val.list ~offset:1 u in + check_list "list offset=1" [ ("y", k); ("z", k) ] l; + let l = B.Node.Val.list ~offset:1 ~length:1 u in + check_list "list offset=1 length=1" [ List.nth all 1 ] l; + let u = B.Node.Val.add u "a" k in + check_node "node: x+y+z+a" u >>= fun () -> + let u = B.Node.Val.add u "b" k in + check_node "node: x+y+z+a+b" u >>= fun () -> + let h = B.Node.Hash.hash u in + let* k = with_node repo (fun n -> B.Node.add n u) in + check_hash "hash(v) = add(v)" h (B.Node.Key.to_hash k); + let* w = B.Node.find n k in + check_values (get w); + let* kv1 = kv1 ~repo in + let* k1 = with_node repo (fun g -> Graph.v g [ ("x", normal kv1) ]) in + let* k1' = with_node repo (fun g -> Graph.v g [ ("x", normal kv1) ]) in + check_key "k1.1" k1 k1'; + let* t1 = B.Node.find n k1 in + let k' = B.Node.Val.find (get t1) "x" in + check + (Irmin.Type.option B.Node.Val.value_t) + "find x" + (Some (normal kv1)) + k'; + let* k1'' = with_node repo (fun n -> B.Node.add n (get t1)) in + check_key "k1.2" k1 k1''; + let* k2 = with_node repo (fun g -> Graph.v g [ ("b", `Node k1) ]) in + let* k2' = with_node repo (fun g -> Graph.v g [ ("b", `Node k1) ]) in + check_key "k2.1" k2 k2'; + let* t2 = B.Node.find n k2 in + let* k2'' = with_node repo (fun n -> B.Node.add n (get t2)) in + check_key "k2.2" k2 k2''; + let* k1''' = Graph.find g k2 [ "b" ] in + check_val "k1.3" (Some (`Node k1)) k1'''; + let* k3 = with_node repo (fun g -> Graph.v g [ ("a", `Node k2) ]) in + let* k3' = with_node repo (fun g -> Graph.v g [ ("a", `Node k2) ]) in + check_key "k3.1" k3 k3'; + let* t3 = B.Node.find n k3 in + let* k3'' = with_node repo (fun n -> B.Node.add n (get t3)) in + check_key "k3.2" k3 k3''; + let* k2'' = Graph.find g k3 [ "a" ] in + check_val "k2.3" (Some (`Node k2)) k2''; + let* k1'''' = Graph.find g k2' [ "b" ] in + check_val "t1.2" (Some (`Node k1)) k1''''; + let* k1''''' = Graph.find g k3 [ "a"; "b" ] in + check_val "t1.3" (Some (`Node k1)) k1'''''; + let* kv11 = Graph.find g k1 [ "x" ] in + check_val "v1.1" (Some (normal kv1)) kv11; + let* kv12 = Graph.find g k2 [ "b"; "x" ] in + check_val "v1.2" (Some (normal kv1)) kv12; + let* kv13 = Graph.find g k3 [ "a"; "b"; "x" ] in + check_val "v1" (Some (normal kv1)) kv13; + let* kv2 = kv2 ~repo in + let* k4 = with_node repo (fun g -> Graph.v g [ ("x", normal kv2) ]) in + let* k5 = + with_node repo (fun g -> Graph.v g [ ("b", `Node k1); ("c", `Node k4) ]) + in + let* k6 = with_node repo (fun g -> Graph.v g [ ("a", `Node k5) ]) in + let* k6' = + with_node repo (fun g -> Graph.add g k3 [ "a"; "c"; "x" ] (normal kv2)) + in + check_key "node k6" k6 k6'; + let* n6' = B.Node.find n k6' in + let* n6 = B.Node.find n k6 in + check T.(option B.Node.Val.t) "node n6" n6 n6'; + let assert_no_duplicates n node = + let names = ref [] in + let+ all = Graph.list g node in + List.iter + (fun (s, _) -> + if List.mem ~equal:String.equal s !names then + Alcotest.failf "%s: duplicate!" n + else names := s :: !names) + all + in + let* n0 = with_node repo (fun g -> Graph.v g []) in + let* n1 = with_node repo (fun g -> Graph.add g n0 [ "b" ] (`Node n0)) in + let* n2 = with_node repo (fun g -> Graph.add g n1 [ "a" ] (`Node n0)) in + let* n3 = with_node repo (fun g -> Graph.add g n2 [ "a" ] (`Node n0)) in + assert_no_duplicates "1" n3 >>= fun () -> + let* n1 = with_node repo (fun g -> Graph.add g n0 [ "a" ] (`Node n0)) in + let* n2 = with_node repo (fun g -> Graph.add g n1 [ "b" ] (`Node n0)) in + let* n3 = with_node repo (fun g -> Graph.add g n2 [ "a" ] (`Node n0)) in + assert_no_duplicates "2" n3 >>= fun () -> + let* n1 = with_node repo (fun g -> Graph.add g n0 [ "b" ] (normal kv1)) in + let* n2 = with_node repo (fun g -> Graph.add g n1 [ "a" ] (normal kv1)) in + let* n3 = with_node repo (fun g -> Graph.add g n2 [ "a" ] (normal kv1)) in + assert_no_duplicates "3" n3 >>= fun () -> + let* n1 = with_node repo (fun g -> Graph.add g n0 [ "a" ] (normal kv1)) in + let* n2 = with_node repo (fun g -> Graph.add g n1 [ "b" ] (normal kv1)) in + let* n3 = with_node repo (fun g -> Graph.add g n2 [ "b" ] (normal kv1)) in + assert_no_duplicates "4" n3 >>= fun () -> + S.Repo.close repo >>= fun () -> + Lwt.catch + (fun () -> + let* n0 = with_node repo (fun g -> Graph.v g []) in + let* _ = + with_node repo (fun g -> Graph.add g n0 [ "b" ] (`Node n0)) + in + Alcotest.fail "Add after close should not be allowed") + (function Irmin.Closed -> Lwt.return_unit | exn -> Lwt.fail exn) + in + run x test + + let test_commits x () = + let test repo = + let info date = + let message = Fmt.str "Test commit: %d" date in + S.Info.v ~author:"test" ~message (Int64.of_int date) + in + let* kv1 = kv1 ~repo in + let h = h repo and c = B.Repo.commit_t repo in + let check_val = check (T.option B.Commit.Val.t) in + let check_key = check B.Commit.Key.t in + let check_keys = checks B.Commit.Key.t in + (* t3 -a-> t2 -b-> t1 -x-> (v1) *) + let* kt1 = with_node repo (fun g -> Graph.v g [ ("x", normal kv1) ]) in + let* kt2 = with_node repo (fun g -> Graph.v g [ ("a", `Node kt1) ]) in + let* kt3 = with_node repo (fun g -> Graph.v g [ ("b", `Node kt2) ]) in + (* r1 : t2 *) + let with_info n fn = with_commit repo (fun h -> fn h ~info:(info n)) in + let* kr1, _ = with_info 3 (History.v ~node:kt2 ~parents:[]) in + let* kr1', _ = with_info 3 (History.v ~node:kt2 ~parents:[]) in + let* t1 = B.Commit.find c kr1 in + let* t1' = B.Commit.find c kr1' in + check_val "t1" t1 t1'; + check_key "kr1" kr1 kr1'; + + (* r1 -> r2 : t3 *) + let* kr2, _ = with_info 4 (History.v ~node:kt3 ~parents:[ kr1 ]) in + let* kr2', _ = with_info 4 (History.v ~node:kt3 ~parents:[ kr1 ]) in + check_key "kr2" kr2 kr2'; + let* kr1s = History.closure h ~min:[] ~max:[ kr1 ] in + check_keys "g1" [ kr1 ] kr1s; + let* kr2s = History.closure h ~min:[] ~max:[ kr2 ] in + check_keys "g2" [ kr1; kr2 ] kr2s; + let* () = + S.Commit.of_key repo kr1 >|= function + | None -> Alcotest.fail "Cannot read commit hash" + | Some c -> + Alcotest.(check string) + "author" "test" + (S.Info.author (S.Commit.info c)) + in + S.Repo.close repo >>= fun () -> + Lwt.catch + (fun () -> + let+ _ = with_info 3 (History.v ~node:kt1 ~parents:[]) in + Alcotest.fail "Add after close should not be allowed") + (function Irmin.Closed -> Lwt.return_unit | exn -> Lwt.fail exn) + in + run x test + + let test_closure x () = + let test repo = + let info date = + let message = Fmt.str "Test commit: %d" date in + S.Info.v ~author:"test" ~message (Int64.of_int date) + in + let check_keys = checks B.Commit.Key.t in + let equal_key = Irmin.Type.(unstage (equal B.Commit.Key.t)) in + let h = h repo in + let initialise_nodes = + Lwt_list.map_p + (fun i -> + let* kv = + with_contents repo (fun t -> B.Contents.add t (string_of_int i)) + in + with_node repo (fun g -> Graph.v g [ (string_of_int i, normal kv) ])) + [ 0; 1; 2; 3; 4; 5; 6; 7; 8 ] + in + let with_info n fn = with_commit repo (fun h -> fn h ~info:(info n)) in + let initialise_graph nodes = + match nodes with + | [] -> assert false + | node :: rest -> + let* kr0, _ = with_info 0 (History.v ~node ~parents:[]) in + let commits = Array.make 9 kr0 in + let commit ~node ~parents i = + let+ kr1, _ = with_info i (History.v ~node ~parents) in + commits.(i) <- kr1; + i + 1 + in + let+ _ = + Lwt_list.fold_left_s + (fun i node -> + match i with + | 1 -> commit ~node ~parents:[ commits.(0) ] 1 + | 2 -> commit ~node ~parents:[] 2 + | 3 -> commit ~node ~parents:[ commits.(1) ] 3 + | 4 -> commit ~node ~parents:[ commits.(1); commits.(2) ] 4 + | 5 -> commit ~node ~parents:[ commits.(3); commits.(4) ] 5 + | 6 -> commit ~node ~parents:[ commits.(4) ] 6 + | 7 -> commit ~node ~parents:[] 7 + | 8 -> commit ~node ~parents:[ commits.(7) ] 8 + | _ -> assert false) + 1 rest + in + commits + in + (* initialise_graph creates the following graph of commits: + 0 <- 1 <- 3 <- 5 and 7 <- 8 + \ / + 2 <-- 4 <- 6 *) + let* commits = initialise_nodes >>= initialise_graph in + let* krs = History.closure h ~min:[ commits.(1) ] ~max:[ commits.(5) ] in + check_keys "commits between 1 and 5" + [ commits.(1); commits.(2); commits.(3); commits.(4); commits.(5) ] + krs; + let* krs = History.closure h ~min:[] ~max:[ commits.(5) ] in + check_keys "all commits under 5" + [ + commits.(0); + commits.(1); + commits.(2); + commits.(3); + commits.(4); + commits.(5); + ] + krs; + let* krs = + History.closure h + ~min:[ commits.(1); commits.(2) ] + ~max:[ commits.(5); commits.(6) ] + in + check_keys "disconnected max and min returns a connected graph" + [ + commits.(1); + commits.(2); + commits.(3); + commits.(4); + commits.(5); + commits.(6); + ] + krs; + let* krs = + History.closure h + ~min:[ commits.(1); commits.(7) ] + ~max:[ commits.(4); commits.(8) ] + in + check_keys "disconnected min and max returns a disconnected graph" + [ commits.(1); commits.(2); commits.(7); commits.(4); commits.(8) ] + krs; + let* () = + History.closure h ~min:[ commits.(7) ] ~max:[] >|= function + | [] -> () + | _ -> Alcotest.fail "expected empty list" + in + let* () = + let+ ls = History.closure h ~min:[ commits.(7) ] ~max:[ commits.(6) ] in + if List.mem ~equal:equal_key commits.(7) ls then + Alcotest.fail "disconnected node should not be in closure" + in + let* krs = + History.closure h ~min:[ commits.(4) ] ~max:[ commits.(4); commits.(6) ] + in + check_keys "min and max have the same commit" + [ commits.(6); commits.(4) ] + krs; + let* () = + let+ ls = + History.closure h + ~min:[ commits.(4); commits.(0) ] + ~max:[ commits.(4); commits.(6) ] + in + if List.mem ~equal:equal_key commits.(0) ls then + Alcotest.fail "disconnected node should not be in closure" + in + S.Repo.close repo + in + run x test + + let test_branches ?hook x () = + let test repo = + let check_keys = checks S.Branch.t in + let check_val = check (T.option @@ S.commit_t repo) in + let* kv1 = r1 ~repo in + let* kv2 = r2 ~repo in + line "pre-update"; + S.Branch.set repo b1 kv1 >>= fun () -> + may repo [ kv2 ] hook >>= fun () -> + line "post-update"; + let* k1' = S.Branch.find repo b1 in + check_val "r1" (Some kv1) k1'; + S.Branch.set repo b2 kv2 >>= fun () -> + let* k2' = S.Branch.find repo b2 in + check_val "r2" (Some kv2) k2'; + S.Branch.set repo b1 kv2 >>= fun () -> + let* k2'' = S.Branch.find repo b1 in + check_val "r1-after-update" (Some kv2) k2''; + let* bs = S.Branch.list repo in + check_keys "list" [ b1; b2 ] bs; + S.Branch.remove repo b1 >>= fun () -> + let* empty = S.Branch.find repo b1 in + check_val "empty" None empty; + let* b2' = S.Branch.list repo in + check_keys "all-after-remove" [ b2 ] b2'; + S.Repo.close repo >>= fun () -> + Lwt.catch + (fun () -> + let+ _ = S.Branch.set repo b1 kv1 in + Alcotest.fail "Add after close should not be allowed") + (function Irmin.Closed -> Lwt.return_unit | exn -> Lwt.fail exn) + in + run x test + + let test_tree_hashes x () = + let test repo = + let node bindings = + with_node repo (fun g -> + let* empty = Graph.empty g in + Lwt_list.fold_left_s + (fun t (k, v) -> + let* v = with_contents repo (fun t -> B.Contents.add t v) in + Graph.add g t k (`Contents (v, S.Metadata.default))) + empty bindings) + in + let tree bindings = + Lwt_list.fold_left_s + (fun t (k, v) -> S.Tree.add t k v) + (S.Tree.empty ()) bindings + in + let check_hash msg bindings = + let* node = node bindings in + let+ tree = tree bindings in + check B.Hash.t msg (B.Node.Key.to_hash node) (S.Tree.hash tree) + in + check_hash "empty" [] >>= fun () -> + let bindings1 = [ ([ "a" ], "x"); ([ "b" ], "y") ] in + check_hash "1 level" bindings1 >>= fun () -> + let bindings2 = [ ([ "a"; "b" ], "x"); ([ "a"; "c" ], "y") ] in + check_hash "2 levels" bindings2 >>= fun () -> S.Repo.close repo + in + run x test + + let test_simple_merges ?hook x () = + (* simple merges *) + let check_merge () = + let ok = Irmin.Merge.ok in + let dt = [%typ: int64 option] in + let dx = [%typ: (string * int64) list] in + let merge_skip ~old:_ _ _ = ok None in + let merge_left ~old:_ x _ = ok x in + let merge_right ~old:_ _ y = ok y in + let merge_default = Irmin.Merge.default dt in + let merge = function + | "left" -> Irmin.Merge.v dt merge_left + | "right" -> Irmin.Merge.v dt merge_right + | "skip" -> Irmin.Merge.v dt merge_skip + | _ -> merge_default + in + let merge_x = Irmin.Merge.alist T.string T.int64 merge in + let old () = ok (Some [ ("left", 1L); ("foo", 2L) ]) in + let x = [ ("left", 2L); ("right", 0L) ] in + let y = [ ("left", 1L); ("bar", 3L); ("skip", 0L) ] in + let m = [ ("left", 2L); ("bar", 3L) ] in + Irmin.Merge.(f merge_x) ~old x y >>= function + | Error (`Conflict c) -> Alcotest.failf "conflict %s" c + | Ok m' -> + check dx "compound merge" m m'; + Lwt.return_unit + in + let test repo = + check_merge () >>= fun () -> + let* kv1 = kv1 ~repo in + let* kv2 = kv2 ~repo in + let result = + T.(result (option B.Contents.Key.t) Irmin.Merge.conflict_t) + in + (* merge contents *) + let* kv1' = + with_contents repo (fun v -> + Irmin.Merge.f (B.Contents.merge v) ~old:(old (Some kv1)) (Some kv1) + (Some kv1)) + in + check result "merge kv1" (Ok (Some kv1)) kv1'; + let* kv2' = + with_contents repo (fun v -> + Irmin.Merge.f (B.Contents.merge v) ~old:(old (Some kv1)) (Some kv1) + (Some kv2)) + in + check result "merge kv2" (Ok (Some kv2)) kv2'; + + (* merge nodes *) + let g = g repo in + (* The empty node *) + let* k0 = with_node repo (fun g -> Graph.v g []) in + (* Create the node t1 -x-> (v1) *) + let* k1 = with_node repo (fun g -> Graph.v g [ ("x", normal kv1) ]) in + (* Create the node t2 -b-> t1 -x-> (v1) *) + let* k2 = with_node repo (fun g -> Graph.v g [ ("b", `Node k1) ]) in + (* Create the node t3 -c-> t1 -x-> (v1) *) + let* k3 = with_node repo (fun g -> Graph.v g [ ("c", `Node k1) ]) in + (* Should create the node: + t4 -b-> t1 -x-> (v1) + \c/ *) + let* k4 = + with_node repo (fun g -> + Irmin.Merge.(f @@ B.Node.merge g) + ~old:(old (Some k0)) (Some k2) (Some k3)) + in + let* k4 = merge_exn "k4" k4 in + let k4 = match k4 with Some k -> k | None -> failwith "k4" in + let _ = k4 in + let succ_t = [%typ: string * Graph.value] in + let* succ = Graph.list g k4 in + checks succ_t "k4" [ ("b", `Node k1); ("c", `Node k1) ] succ; + let info date = + let i = Int64.of_int date in + S.Info.v ~author:"test" ~message:"Test commit" i + in + let c = B.Repo.commit_t repo in + let with_info n fn = with_commit repo (fun h -> fn h ~info:(info n)) in + let* kr0, _ = with_info 0 (History.v ~node:k0 ~parents:[]) in + let* kr1, _ = with_info 1 (History.v ~node:k2 ~parents:[ kr0 ]) in + let* kr2, _ = with_info 2 (History.v ~node:k3 ~parents:[ kr0 ]) in + may_get_keys repo [ kr1; kr2 ] hook >>= fun () -> + let* kr3 = + with_info 3 (fun h ~info -> + Irmin.Merge.f + (History.merge h ~info:(fun () -> info)) + ~old:(old kr0) kr1 kr2) + in + let* kr3 = merge_exn "kr3" kr3 in + may_get_keys repo [ kr3 ] hook >>= fun () -> + let* kr3_key' = + with_info 4 (fun h ~info -> + Irmin.Merge.f + (History.merge h ~info:(fun () -> info)) + ~old:(old kr2) kr2 kr3) + in + let* kr3_key' = merge_exn "kr3_key'" kr3_key' in + let check_key = check B.Commit.Key.t in + check_key "kr3 id with immediate parent'" kr3 kr3_key'; + let* kr3_key = + with_info 5 (fun h ~info -> + Irmin.Merge.f + (History.merge h ~info:(fun () -> info)) + ~old:(old kr0) kr0 kr3) + in + let* kr3_key = merge_exn "kr3_key" kr3_key in + check_key "kr3 key with old parent" kr3 kr3_key; + let* kr3', _ = with_info 3 @@ History.v ~node:k4 ~parents:[ kr1; kr2 ] in + let* r3 = B.Commit.find c kr3 in + let* r3' = B.Commit.find c kr3' in + check T.(option B.Commit.Val.t) "r3" r3 r3'; + check_key "kr3" kr3 kr3'; + B.Repo.close repo + in + run x test + + let test_history ?hook x () = + let test repo = + let info date = + let i = Int64.of_int date in + S.Info.v ~author:"test" ~message:"Test commit" i + in + let assert_lcas_err msg err l2 = + let err_str = function + | `Too_many_lcas -> "Too_many_lcas" + | `Max_depth_reached -> "Max_depth_reached" + in + let pp_commits = Fmt.Dump.(list S.Commit.pp_hash) in + let l2 = + match l2 with + | Ok x -> Alcotest.failf "%s: %a" msg pp_commits x + | Error e -> err_str e + in + Alcotest.(check string) msg (err_str err) l2 + in + let assert_lcas msg l1 l2 = + let l2 = + match l2 with + | Ok x -> x + | Error `Too_many_lcas -> Alcotest.failf "%s: Too many LCAs" msg + | Error `Max_depth_reached -> + Alcotest.failf "%s: max depth reached" msg + in + checks (S.commit_t repo) msg l1 l2 + in + let assert_lcas msg ~max_depth n a b expected = + let* a = S.of_commit a in + let* b = S.of_commit b in + let* lcas = S.lcas ~max_depth ~n a b in + assert_lcas msg expected lcas; + let* lcas = S.lcas ~max_depth:(max_depth - 1) ~n a b in + let msg = Printf.sprintf "%s [max-depth=%d]" msg (max_depth - 1) in + assert_lcas_err msg `Max_depth_reached lcas; + Lwt.return_unit + in + let assert_last_modified msg ?depth ~n t key expected = + let+ last = S.last_modified ?depth ~n t key in + S.repo t |> fun repo -> + let msg = Printf.sprintf "%s [n=%d]" msg n in + checks (S.commit_t repo) msg expected last + in + let assert_history_empty msg c expected = + let* t = S.of_commit c in + S.history t + >|= S.History.is_empty + >|= Alcotest.(check bool) msg expected + in + let tree = S.Tree.empty () in + let k0 = random_path ~label:8 ~path:5 in + let k1 = random_path ~label:8 ~path:4 in + let k2 = random_path ~label:8 ~path:6 in + + (* test that we don't compute too many lcas + + 0(k0, k1) -> 1(k1) -> 2(k0) -> 3(k1, k0) -> 4(k1) + *) + let* tree = S.Tree.add tree k0 (random_value 1024) in + let* tree = S.Tree.add tree k1 (random_value 1024) in + let* c0 = S.Commit.v repo ~info:(info 0) ~parents:[] tree in + may repo [ c0 ] hook >>= fun () -> + assert_history_empty "nonempty 1 commit" c0 false >>= fun () -> + let* tree = S.Tree.add tree k1 (random_value 1024) in + let* c1 = + S.Commit.v repo ~info:(info 1) ~parents:[ S.Commit.key c0 ] tree + in + assert_history_empty "nonempty 2 commits" c0 false >>= fun () -> + let* tree = S.Tree.add tree k0 (random_value 1024) in + let* c2 = + S.Commit.v repo ~info:(info 2) ~parents:[ S.Commit.key c1 ] tree + in + let* tree = S.Tree.add tree k0 (random_value 1024) in + let* tree = S.Tree.add tree k1 (random_value 1024) in + let* c3 = + S.Commit.v repo ~info:(info 3) ~parents:[ S.Commit.key c2 ] tree + in + may repo [ c3 ] hook >>= fun () -> + let* tree = S.Tree.add tree k1 (random_value 1024) in + let* c4 = + S.Commit.v repo ~info:(info 4) ~parents:[ S.Commit.key c3 ] tree + in + assert_lcas "line lcas 1" ~max_depth:0 3 c3 c4 [ c3 ] >>= fun () -> + assert_lcas "line lcas 2" ~max_depth:1 3 c2 c4 [ c2 ] >>= fun () -> + assert_lcas "line lcas 3" ~max_depth:2 3 c1 c4 [ c1 ] >>= fun () -> + let* store = S.of_commit c4 in + let* () = + assert_last_modified "line last_modified 1" ~n:1 store k0 [ c3 ] + in + let* () = + assert_last_modified "line last_modified 2" ~n:2 store k0 [ c2; c3 ] + in + let* () = + assert_last_modified "line last_modified 3" ~n:3 store k0 [ c0; c2; c3 ] + in + let* () = + assert_last_modified "line last_modified 4" ~depth:1 ~n:3 store k0 + [ c3 ] + in + assert_last_modified "line last_modified 5" ~n:1 store k2 [] >>= fun () -> + let* () = + assert_last_modified "line last_modified 5" ~depth:0 ~n:2 store k0 [] + in + (* test for multiple lca + + 4(k1) -> 10 (k2) ---> 11(k0, k2) --> 13(k1) --> 15(k1, k2) + | \_______________________/____ + | _____________________/ \ + | / \ + \---> 12 (k0, k1) --> 14 (k2) --> 16 (k2) --> 17 (k0) + *) + let* tree = S.Tree.add tree k2 (random_value 1024) in + let* c10 = + S.Commit.v repo ~info:(info 10) ~parents:[ S.Commit.key c4 ] tree + in + let* tree_up = S.Tree.add tree k0 (random_value 1024) in + let* tree_up = S.Tree.add tree_up k2 (random_value 1024) in + let* c11 = + S.Commit.v repo ~info:(info 11) ~parents:[ S.Commit.key c10 ] tree_up + in + let* tree_down = S.Tree.add tree k0 (random_value 1024) in + let* tree_12 = S.Tree.add tree_down k1 (random_value 1024) in + let* c12 = + S.Commit.v repo ~info:(info 12) ~parents:[ S.Commit.key c10 ] tree_12 + in + let* tree_up = S.Tree.add tree_up k1 (random_value 1024) in + let* c13 = + S.Commit.v repo ~info:(info 13) ~parents:[ S.Commit.key c11 ] tree_up + in + let* tree_down = S.Tree.add tree_12 k2 (random_value 1024) in + let* c14 = + S.Commit.v repo ~info:(info 14) ~parents:[ S.Commit.key c12 ] tree_down + in + let* tree_up = S.Tree.add tree_12 k1 (random_value 1024) in + let* tree_up = S.Tree.add tree_up k2 (random_value 1024) in + let* c15 = + S.Commit.v repo ~info:(info 15) + ~parents:[ S.Commit.key c12; S.Commit.key c13 ] + tree_up + in + let* tree_down = S.Tree.add tree_down k2 (random_value 1024) in + let* c16 = + S.Commit.v repo ~info:(info 16) ~parents:[ S.Commit.key c14 ] tree_down + in + let* tree_down = S.Tree.add tree_down k0 (random_value 1024) in + let* c17 = + S.Commit.v repo ~info:(info 17) + ~parents:[ S.Commit.key c11; S.Commit.key c16 ] + tree_down + in + assert_lcas "x lcas 0" ~max_depth:0 5 c10 c10 [ c10 ] >>= fun () -> + assert_lcas "x lcas 1" ~max_depth:0 5 c14 c14 [ c14 ] >>= fun () -> + assert_lcas "x lcas 2" ~max_depth:0 5 c10 c11 [ c10 ] >>= fun () -> + assert_lcas "x lcas 3" ~max_depth:1 5 c12 c16 [ c12 ] >>= fun () -> + assert_lcas "x lcas 4" ~max_depth:1 5 c10 c13 [ c10 ] >>= fun () -> + assert_lcas "x lcas 5" ~max_depth:2 5 c13 c14 [ c10 ] >>= fun () -> + assert_lcas "x lcas 6" ~max_depth:3 5 c15 c16 [ c12 ] >>= fun () -> + assert_lcas "x lcas 7" ~max_depth:3 5 c15 c17 [ c11; c12 ] >>= fun () -> + let* store = S.of_commit c17 in + let* () = + assert_last_modified "x last_modified 1" ~n:3 store k0 [ c11; c12; c17 ] + in + let* () = + assert_last_modified "x last_modified 2" ~n:1 store k2 [ c16 ] + in + let* () = + assert_last_modified "x last_modified 3" ~n:2 store k1 [ c4; c12 ] + in + let* () = + assert_last_modified "x last_modified 4" ~depth:3 ~n:5 store k1 + [ c4; c12 ] + in + let* () = + assert_last_modified "x last_modified 5" ~depth:2 ~n:3 store k0 + [ c11; c17 ] + in + (* lcas on non transitive reduced graphs + + /->16 + | + 4->10->11->12->13->14->15 + | \--|--/ + \-----------/ + *) + let* c10 = + S.Commit.v repo ~info:(info 10) ~parents:[ S.Commit.key c4 ] tree + in + let* c11 = + S.Commit.v repo ~info:(info 11) ~parents:[ S.Commit.key c10 ] tree + in + let* c12 = + S.Commit.v repo ~info:(info 12) ~parents:[ S.Commit.key c11 ] tree + in + let* c13 = + S.Commit.v repo ~info:(info 13) ~parents:[ S.Commit.key c12 ] tree + in + let* c14 = + S.Commit.v repo ~info:(info 14) + ~parents:[ S.Commit.key c11; S.Commit.key c13 ] + tree + in + let* c15 = + S.Commit.v repo ~info:(info 15) + ~parents:[ S.Commit.key c13; S.Commit.key c14 ] + tree + in + let* c16 = + S.Commit.v repo ~info:(info 16) ~parents:[ S.Commit.key c11 ] tree + in + assert_lcas "weird lcas 1" ~max_depth:0 3 c14 c15 [ c14 ] >>= fun () -> + assert_lcas "weird lcas 2" ~max_depth:0 3 c13 c15 [ c13 ] >>= fun () -> + assert_lcas "weird lcas 3" ~max_depth:1 3 c12 c15 [ c12 ] >>= fun () -> + assert_lcas "weird lcas 4" ~max_depth:1 3 c11 c15 [ c11 ] >>= fun () -> + assert_lcas "weird lcas 4" ~max_depth:3 3 c15 c16 [ c11 ] >>= fun () -> + (* fast-forward *) + let ff = testable Irmin.Type.(result unit S.ff_error_t) in + let* t12 = S.of_commit c12 in + let* b1 = S.Head.fast_forward t12 c16 in + Alcotest.(check ff) "ff 1.1" (Error `Rejected) b1; + let* k12' = S.Head.get t12 in + check (S.commit_t repo) "ff 1.2" c12 k12'; + let* b2 = S.Head.fast_forward t12 ~n:1 c14 in + Alcotest.(check ff) "ff 2.1" (Error `Rejected) b2; + let* k12'' = S.Head.get t12 in + check (S.commit_t repo) "ff 2.2" c12 k12''; + let* b3 = S.Head.fast_forward t12 c14 in + Alcotest.(check ff) "ff 2.2" (Ok ()) b3; + let* c14' = S.Head.get t12 in + check (S.commit_t repo) "ff 2.3" c14 c14'; + B.Repo.close repo + in + run x test + + let test_empty ?hook x () = + let test repo = + let* t = S.empty repo in + let* h = S.Head.find t in + check T.(option @@ S.commit_t repo) "empty" None h; + let* r1 = r1 ~repo in + may repo [ r1 ] hook >>= fun () -> + S.set_exn t ~info:S.Info.none [ "b"; "x" ] v1 >>= fun () -> + let* h = S.Head.find t in + check T.(option @@ S.commit_t repo) "not empty" (Some r1) h; + B.Repo.close repo + in + run x test + + let test_slice ?hook x () = + let test repo = + let* t = S.main repo in + let a = "" in + let b = "haha" in + S.set_exn t ~info:(infof "slice") [ "x"; "a" ] a >>= fun () -> + S.set_exn t ~info:(infof "slice") [ "x"; "b" ] b >>= fun () -> + may_with_branch [ t ] repo hook >>= fun () -> + let* slice = S.Repo.export repo in + let str = T.to_json_string B.Slice.t slice in + let slice' = + match T.decode_json B.Slice.t (Jsonm.decoder (`String str)) with + | Ok t -> t + | Error (`Msg e) -> Alcotest.failf "decoding error: %s" e + in + check B.Slice.t "slices" slice slice'; + B.Repo.close repo + in + run x test + + let test_backend_nodes ?hook x () = + let test repo = + let check_val = check [%typ: S.contents option] in + let vx = "VX" in + let vy = "VY" in + let* t = S.main repo in + S.set_exn t ~info:(infof "add x/y/z") [ "x"; "y"; "z" ] vx >>= fun () -> + let* tree = S.get_tree t [ "x" ] in + S.set_tree_exn t ~info:(infof "update") [ "u" ] tree >>= fun () -> + let* vx' = S.find t [ "u"; "y"; "z" ] in + check_val "vx" (Some vx) vx'; + let* tree1 = S.get_tree t [ "u" ] in + S.set_exn t ~info:(infof "add u/x/y") [ "u"; "x"; "y" ] vy >>= fun () -> + may_with_branch [ t ] repo hook >>= fun () -> + let* tree2 = S.get_tree t [ "u" ] in + let* tree3 = S.Tree.add tree [ "x"; "z" ] vx in + let* v' = + Irmin.Merge.f S.Tree.merge ~old:(Irmin.Merge.promise tree1) tree2 tree3 + >>= merge_exn "tree" + in + S.set_tree_exn t ~info:(infof "merge") [ "u" ] v' >>= fun () -> + let* vy' = S.find t [ "u"; "x"; "y" ] in + check_val "vy after merge" (Some vy) vy'; + let* vx' = S.find t [ "u"; "x"; "z" ] in + check_val "vx after merge" (Some vx) vx'; + B.Repo.close repo + in + run x test + + let test_stores x () = + let test repo = + let check_val = check [%typ: S.contents option] in + let check_list = checks [%typ: S.Path.step * S.tree] in + let* t = S.main repo in + S.set_exn t ~info:(infof "init") [ "a"; "b" ] v1 >>= fun () -> + let* b0 = S.mem t [ "a"; "b" ] in + Alcotest.(check bool) "mem0" true b0; + let* t = S.clone ~src:t ~dst:"test" in + let* b1 = S.mem t [ "a"; "b" ] in + Alcotest.(check bool) "mem1" true b1; + let* b2 = S.mem t [ "a" ] in + Alcotest.(check bool) "mem2" false b2; + let* v1' = S.find t [ "a"; "b" ] in + check_val "v1.1" (Some v1) v1'; + let* r1 = S.Head.get t in + let* t = S.clone ~src:t ~dst:"test" in + S.set_exn t ~info:(infof "update") [ "a"; "c" ] v2 >>= fun () -> + let* b1 = S.mem t [ "a"; "b" ] in + Alcotest.(check bool) "mem3" true b1; + let* b2 = S.mem t [ "a" ] in + Alcotest.(check bool) "mem4" false b2; + let* v1' = S.find t [ "a"; "b" ] in + check_val "v1.1" (Some v1) v1'; + let* b1 = S.mem t [ "a"; "c" ] in + Alcotest.(check bool) "mem5" true b1; + let* v2' = S.find t [ "a"; "c" ] in + check_val "v1.1" (Some v2) v2'; + S.remove_exn t ~info:(infof "remove") [ "a"; "b" ] >>= fun () -> + let* v1'' = S.find t [ "a"; "b" ] in + check_val "v1.2" None v1''; + S.Head.set t r1 >>= fun () -> + let* v1'' = S.find t [ "a"; "b" ] in + check_val "v1.3" (Some v1) v1''; + let* ks = S.list t [ "a" ] in + check_list "path" [ ("b", contents v1) ] ks; + let* () = + S.set_exn t ~info:(infof "update2") [ "a"; long_random_ascii_string ] v1 + in + S.remove_exn t ~info:(infof "remove rec") [ "a" ] >>= fun () -> + let* dirs = S.list t [] in + check_list "remove rec" [] dirs; + let* () = + Lwt.catch + (fun () -> + S.set_exn t ~info:(infof "update root") [] v1 >>= fun () -> + Alcotest.fail "update root") + (function + | Invalid_argument _ -> Lwt.return_unit + | e -> Alcotest.fail ("update root: " ^ Printexc.to_string e)) + in + let* none = S.find t [] in + check_val "read root" none None; + S.set_exn t ~info:(infof "update") [ "a" ] v1 >>= fun () -> + S.remove_exn t ~info:(infof "remove rec --all") [] >>= fun () -> + let* dirs = S.list t [] in + check_list "remove rec root" [] dirs; + let a = "ok" in + let b = "maybe?" in + S.set_exn t ~info:(infof "fst one") [ "fst" ] a >>= fun () -> + S.set_exn t ~info:(infof "snd one") [ "fst"; "snd" ] b >>= fun () -> + let* fst = S.find t [ "fst" ] in + check_val "data model 1" None fst; + let* snd = S.find t [ "fst"; "snd" ] in + check_val "data model 2" (Some b) snd; + S.set_exn t ~info:(infof "fst one") [ "fst" ] a >>= fun () -> + let* fst = S.find t [ "fst" ] in + check_val "data model 3" (Some a) fst; + let* snd = S.find t [ "fst"; "snd" ] in + check_val "data model 4" None snd; + let tagx = "x" in + let tagy = "y" in + let xy = [ "x"; "y" ] in + let vx = "VX" in + let* tx = S.of_branch repo tagx in + S.Branch.remove repo tagx >>= fun () -> + S.Branch.remove repo tagy >>= fun () -> + S.set_exn tx ~info:(infof "update") xy vx >>= fun () -> + let* ty = S.clone ~src:tx ~dst:tagy in + let* vx' = S.find ty xy in + check_val "update tag" (Some vx) vx'; + S.status tx |> fun tagx' -> + S.status ty |> fun tagy' -> + check (S.Status.t repo) "tagx" (`Branch tagx) tagx'; + check (S.Status.t repo) "tagy" (`Branch tagy) tagy'; + let* t = S.main repo in + S.Repo.close repo >>= fun () -> + Lwt.catch + (fun () -> + let+ _ = S.set_exn t ~info:(infof "add after close") [ "a" ] "bar" in + Alcotest.fail "Add after close should not be allowed") + (function Irmin.Closed -> Lwt.return_unit | exn -> Lwt.fail exn) + in + run x test + + let test_atomic x () = + let test repo = + let check_commit = check T.(option (S.commit_t repo)) in + let* t = S.main repo in + let* _c_empty = + S.test_set_and_get_exn t ~info:(infof "init") [ "a"; "b" ] ~test:None + ~set:(Some v1) + in + let* c_none = + S.test_set_and_get_exn t ~info:(infof "init") [ "a"; "b" ] + ~test:(Some v1) ~set:(Some v1) + in + check_commit "No commit" None c_none; + let message0 = "first" in + let message1 = "second" in + let v3 = "v3" in + let* c0 = + S.test_set_and_get_exn t ~info:(infof "%s" message0) [ "a"; "b" ] + ~test:(Some v1) ~set:(Some v2) + in + let c0 = Option.get c0 in + let c0_message = S.Commit.info c0 |> S.Info.message in + Alcotest.(check string) "commit0" message0 c0_message; + let* c1 = + S.test_set_and_get_exn t ~info:(infof "%s" message1) [ "a"; "b" ] + ~test:(Some v2) ~set:(Some v3) + in + let* c0_store = S.of_commit c0 in + let* v2' = S.get c0_store [ "a"; "b" ] in + Alcotest.(check string) "commit0 value" v2 v2'; + let* c1_store = S.of_commit (Option.get c1) in + let* v3' = S.get c1_store [ "a"; "b" ] in + Alcotest.(check string) "commit1 value" v3 v3'; + S.Repo.close repo + in + run x test + + let stats_t = Alcotest.testable (Irmin.Type.pp_dump S.Tree.stats_t) ( = ) + + let empty_stats = + { S.Tree.nodes = 0; leafs = 0; skips = 0; depth = 0; width = 0 } + + let inspect = + Alcotest.testable + (fun ppf -> function + | `Contents -> Fmt.string ppf "contents" + | `Node `Key -> Fmt.string ppf "key" + | `Node `Map -> Fmt.string ppf "map" + | `Node `Value -> Fmt.string ppf "value" + | `Node `Portable_dirty -> Fmt.string ppf "portable_dirty" + | `Node `Pruned -> Fmt.string ppf "pruned") + ( = ) + + let test_tree_caches x () = + let test repo = + let info = S.Info.none in + let* t1 = S.main repo in + S.set_exn t1 ~info [ "a"; "b" ] "foo" >>= fun () -> + (* Testing cache *) + S.Tree.reset_counters (); + let* v = S.get_tree t1 [] in + Alcotest.(check inspect) "inspect" (`Node `Key) (S.Tree.inspect v); + let* v = S.Tree.add v [ "foo" ] "foo" in + Alcotest.(check inspect) "inspect:0" (`Node `Value) (S.Tree.inspect v); + Alcotest.(check int) "val-v:0" 0 (S.Tree.counters ()).node_val_v; + let* v = S.Tree.add v [ "bar"; "foo" ] "bar" in + Alcotest.(check inspect) "inspect:1" (`Node `Value) (S.Tree.inspect v); + Alcotest.(check int) "val-v:1" 0 (S.Tree.counters ()).node_val_v; + Alcotest.(check int) "val-list:1" 0 (S.Tree.counters ()).node_val_list; + let _ = S.Tree.hash v in + Alcotest.(check inspect) "inspect:2" (`Node `Value) (S.Tree.inspect v); + Alcotest.(check int) "val-v:2" 1 (S.Tree.counters ()).node_val_v; + Alcotest.(check int) "val-list:2" 0 (S.Tree.counters ()).node_val_list; + S.set_tree_exn t1 ~info [] v >>= fun () -> + Alcotest.(check inspect) "inspect:3" (`Node `Key) (S.Tree.inspect v); + Alcotest.(check int) "val-v:3" 2 (S.Tree.counters ()).node_val_v; + Alcotest.(check int) "val-list:3" 0 (S.Tree.counters ()).node_val_list; + B.Repo.close repo + in + run x test + + let pp_depth = Irmin.Type.pp S.Tree.depth_t + let pp_key = Irmin.Type.pp S.Path.t + let contents_t = T.pair S.contents_t S.metadata_t + let diff_t = T.(pair S.path_t (Irmin.Diff.t contents_t)) + let check_diffs = checks diff_t + let check_ls = checks T.(pair S.step_t S.tree_t) + + let test_trees x () = + let test repo = + let* t = S.main repo in + let nodes = random_nodes 100 in + let foo1 = random_value 10 in + let foo2 = random_value 10 in + let* v1 = + S.Tree.singleton [ "foo"; "bar"; "toto" ] foo2 + |> with_binding [ "foo"; "toto" ] foo1 + in + S.Tree.clear v1; + let* () = + let dont_skip k = + Alcotest.failf "should not have skipped: '%a'" pp_key k + in + S.Tree.fold ~depth:(`Eq 1) ~force:(`False dont_skip) v1 () + in + let* () = + S.Tree.fold ~depth:(`Eq 1) ~force:`True (S.Tree.empty ()) () + ~contents:(fun k _ -> + assert (List.length k = 1); + Alcotest.fail "contents") + ~node:(fun k _ -> + assert (List.length k = 1); + Alcotest.fail "node") + in + let fold depth ecs ens = + let* cs, ns = + S.Tree.fold v1 ?depth ~force:`True ~cache:false + ~contents:(fun path _ (cs, ns) -> Lwt.return (path :: cs, ns)) + ~node:(fun path _ (cs, ns) -> Lwt.return (cs, path :: ns)) + ([], []) + in + let paths = Alcotest.slist (testable S.Path.t) compare in + Alcotest.(check paths) + (Fmt.str "contents depth=%a" Fmt.(Dump.option pp_depth) depth) + ecs cs; + Alcotest.(check paths) + (Fmt.str "nodes depth=%a" Fmt.(Dump.option pp_depth) depth) + ens ns; + Lwt.return () + in + let* () = + fold None + [ [ "foo"; "bar"; "toto" ]; [ "foo"; "toto" ] ] + [ []; [ "foo" ]; [ "foo"; "bar" ] ] + in + fold (Some (`Eq 0)) [] [ [] ] >>= fun () -> + fold (Some (`Eq 1)) [] [ [ "foo" ] ] >>= fun () -> + let* () = + fold (Some (`Eq 2)) [ [ "foo"; "toto" ] ] [ [ "foo"; "bar" ] ] + in + fold (Some (`Lt 2)) [] [ []; [ "foo" ] ] >>= fun () -> + let* () = + fold + (Some (`Le 2)) + [ [ "foo"; "toto" ] ] + [ []; [ "foo" ]; [ "foo"; "bar" ] ] + in + let* () = + fold + (Some (`Ge 2)) + [ [ "foo"; "toto" ]; [ "foo"; "bar"; "toto" ] ] + [ [ "foo"; "bar" ] ] + in + fold (Some (`Gt 2)) [ [ "foo"; "bar"; "toto" ] ] [] >>= fun () -> + let* v1 = S.Tree.remove v1 [ "foo"; "bar"; "toto" ] in + let* v = S.Tree.find v1 [ "foo"; "toto" ] in + Alcotest.(check (option string)) "remove" (Some foo1) v; + let v1 = S.Tree.empty () in + let* s = S.Tree.stats v1 in + Alcotest.(check stats_t) "empty stats" empty_stats s; + let* v1 = S.Tree.add v1 [ "foo"; "1" ] foo1 in + let* v1 = S.Tree.add v1 [ "foo"; "2" ] foo2 in + let* s = S.Tree.stats v1 in + Alcotest.(check stats_t) + "stats 1" + { S.Tree.nodes = 2; leafs = 2; skips = 0; depth = 2; width = 2 } + s; + let* v1 = S.Tree.remove v1 [ "foo"; "1" ] in + let* v1 = S.Tree.remove v1 [ "foo"; "2" ] in + let* s = S.Tree.stats v1 in + Alcotest.(check stats_t) "empty stats" empty_stats s; + S.set_tree_exn t ~info:(infof "empty tree") [] v1 >>= fun () -> + let* head = S.Head.get t in + S.Commit.key head |> fun head -> + let* commit = B.Commit.find (ct repo) head in + let node = B.Commit.Val.node (get commit) in + let* node = B.Node.find (n repo) node in + check + T.(option B.Node.Val.t) + "empty tree" + (Some (B.Node.Val.empty ())) + node; + + (* Testing [Tree.diff] *) + let contents_t = T.pair S.contents_t S.metadata_t in + let diff = T.(pair S.path_t (Irmin.Diff.t contents_t)) in + let check_diffs = checks diff in + let check_val = check T.(option contents_t) in + let check_ls = checks T.(pair S.step_t S.tree_t) in + let normal c = Some (c, S.Metadata.default) in + let d0 = S.Metadata.default in + let v0 = S.Tree.empty () in + let v1 = S.Tree.empty () in + let v2 = S.Tree.empty () in + let* v1 = S.Tree.add v1 [ "foo"; "1" ] foo1 in + let* f = S.Tree.find_all v1 [ "foo"; "1" ] in + check_val "tree update" (normal foo1) f; + let* v1' = S.Tree.add v1 [ "foo"; "1" ] foo1 in + Alcotest.(check bool) "Tree.add keeps sharing" true (v1 == v1'); + let* v1' = S.Tree.remove v1 [ "foo"; "2" ] in + Alcotest.(check bool) "Tree.remove keeps sharing" true (v1 == v1'); + let* v1' = S.Tree.add_tree v1 [] v1 in + Alcotest.(check bool) "Tree.add_tree keeps sharing" true (v1 == v1'); + let* v2 = S.Tree.add v2 [ "foo"; "1" ] foo2 in + let* v2 = S.Tree.add v2 [ "foo"; "2" ] foo1 in + let* d1 = S.Tree.diff v0 v1 in + check_diffs "diff 1" [ ([ "foo"; "1" ], `Added (foo1, d0)) ] d1; + let* d2 = S.Tree.diff v1 v0 in + check_diffs "diff 2" [ ([ "foo"; "1" ], `Removed (foo1, d0)) ] d2; + let* d3 = S.Tree.diff v1 v2 in + check_diffs "diff 3" + [ + ([ "foo"; "1" ], `Updated ((foo1, d0), (foo2, d0))); + ([ "foo"; "2" ], `Added (foo1, d0)); + ] + d3; + let* v3 = S.Tree.add v2 [ "foo"; "bar"; "1" ] foo1 in + let* d4 = S.Tree.diff v2 v3 in + check_diffs "diff 4" [ ([ "foo"; "bar"; "1" ], `Added (foo1, d0)) ] d4; + let* d5 = S.Tree.diff v3 v2 in + check_diffs "diff 4" [ ([ "foo"; "bar"; "1" ], `Removed (foo1, d0)) ] d5; + + (* Testing length *) + let check_length msg t = + let* n = S.Tree.length t [] in + let+ l = S.Tree.list t [] in + Alcotest.(check int) msg n (List.length l) + in + let* () = check_length "bindings1 length" v2 in + let* () = + let t = contents "foo" in + check_length "contents length" t + in + + (* Testing paginated lists *) + let tree = + let c ?(info = S.Metadata.default) blob = `Contents (blob, info) in + S.Tree.of_concrete + (`Tree + [ + ("aa", c "0"); + ("a", c "1"); + ("bbb", c "3"); + ("b", c "3"); + ("aaa", c "1"); + ]) + in + let* _ = S.set_tree_exn t ~info:(infof "add tree") [] tree in + let* e = S.Tree.get_tree tree [ "a" ] in + let ls = + [ + ("aa", contents "0"); + ("a", e); + ("bbb", contents "3"); + ("b", contents "3"); + ("aaa", e); + ] + in + let* () = + let* l1 = S.Tree.list ~offset:0 ~length:2 tree [] in + let* l2 = S.Tree.list ~offset:2 ~length:2 tree [] in + let+ l3 = S.Tree.list ~offset:4 ~length:2 tree [] in + Alcotest.(check int) "size l1" 2 (List.length l1); + Alcotest.(check int) "size l2" 2 (List.length l2); + Alcotest.(check int) "size l3" 1 (List.length l3); + check_ls "2 paginated list" ls (l1 @ l2 @ l3) + in + let* () = + let* l1 = S.Tree.list ~offset:0 ~length:3 tree [] in + let+ l2 = S.Tree.list ~offset:3 ~length:6 tree [] in + Alcotest.(check int) "size l1" 3 (List.length l1); + Alcotest.(check int) "size l2" 2 (List.length l2); + check_ls "3 paginated list" ls (l1 @ l2) + in + let* () = + let* l1 = S.Tree.list ~offset:0 ~length:4 tree [] in + let+ l2 = S.Tree.list ~offset:4 ~length:4 tree [] in + Alcotest.(check int) "size l1" 4 (List.length l1); + Alcotest.(check int) "size l2" 1 (List.length l2); + check_ls "4 paginated list" ls (l1 @ l2) + in + let* () = + let* l1 = S.Tree.list ~offset:0 ~length:5 tree [] in + let+ l2 = S.Tree.list ~offset:5 ~length:5 tree [] in + Alcotest.(check int) "size l1" 5 (List.length l1); + Alcotest.(check int) "size l2" 0 (List.length l2); + check_ls "5 paginated list" ls (l1 @ l2) + in + let* c0 = + S.Tree.singleton [ "foo"; "a" ] "1" + |> with_binding [ "foo"; "b"; "c" ] "2" + >>= with_binding [ "foo"; "c" ] "3" + >>= with_binding [ "foo"; "d" ] "4" + in + let* b = S.Tree.get_tree c0 [ "foo"; "b" ] in + let* ls = S.Tree.list c0 [ "foo" ] in + check_ls "list all" + [ + ("a", contents "1"); ("b", b); ("c", contents "3"); ("d", contents "4"); + ] + ls; + let* ls = S.Tree.list ~offset:2 c0 [ "foo" ] in + check_ls "list offset=2" [ ("c", contents "3"); ("d", contents "4") ] ls; + let* ls = S.Tree.list ~offset:2 ~length:1 c0 [ "foo" ] in + check_ls "list offset=2 length=1" [ ("c", contents "3") ] ls; + let* ls = S.Tree.list ~length:1 c0 [ "foo" ] in + check_ls "list length=1" [ ("a", contents "1") ] ls; + + (* Testing concrete representation *) + let* c0 = + Lwt.return (S.Tree.empty ()) + >>= with_binding [ "foo"; "a" ] "1" + >>= with_binding [ "foo"; "b"; "c" ] "2" + >>= with_binding [ "bar"; "d" ] "3" + >>= with_binding [ "e" ] "4" + in + let* t0 = c0 |> S.Tree.to_concrete >|= S.Tree.of_concrete in + let* () = + let+ d0 = S.Tree.diff c0 t0 in + check_diffs "concrete roundtrip" [] d0 + in + let* () = + let* c0' = S.Tree.list c0 [] in + let+ t0' = S.Tree.list t0 [] in + check_ls "concrete list /" c0' t0' + in + let* () = + let* c0' = S.Tree.list c0 [ "foo" ] in + let+ t0' = S.Tree.list t0 [ "foo" ] in + check_ls "concrete tree list /foo" c0' t0' + in + let* () = + let* c0' = S.Tree.list c0 [ "bar"; "d" ] in + let+ t0' = S.Tree.list t0 [ "bar"; "d" ] in + check_ls "concrete tree list /bar/d" c0' t0' + in + + (* Testing other tree operations. *) + let v0 = S.Tree.empty () in + let* c = S.Tree.to_concrete v0 in + (match c with + | `Tree [] -> () + | _ -> Alcotest.fail "Excpected empty tree"); + let* v0 = S.Tree.add v0 [] foo1 in + let* foo1' = S.Tree.find_all v0 [] in + check_val "read /" (normal foo1) foo1'; + let* v0 = S.Tree.add v0 [ "foo"; "1" ] foo1 in + let* foo1' = S.Tree.find_all v0 [ "foo"; "1" ] in + check_val "read foo/1" (normal foo1) foo1'; + let* v0 = S.Tree.add v0 [ "foo"; "2" ] foo2 in + let* foo2' = S.Tree.find_all v0 [ "foo"; "2" ] in + check_val "read foo/2" (normal foo2) foo2'; + let check_tree v = + let* ls = S.Tree.list v [ "foo" ] in + check_ls "path1" [ ("1", contents foo1); ("2", contents foo2) ] ls; + let* foo1' = S.Tree.find_all v [ "foo"; "1" ] in + check_val "foo1" (normal foo1) foo1'; + let* foo2' = S.Tree.find_all v [ "foo"; "2" ] in + check_val "foo2" (normal foo2) foo2'; + Lwt.return_unit + in + let* v0 = + Lwt_list.fold_left_s (fun v0 (k, v) -> S.Tree.add v0 k v) v0 nodes + in + check_tree v0 >>= fun () -> + S.set_tree_exn t ~info:(infof "update_path b/") [ "b" ] v0 >>= fun () -> + S.set_tree_exn t ~info:(infof "update_path a/") [ "a" ] v0 >>= fun () -> + let* ls = S.list t [ "b"; "foo" ] in + check_ls "path2" [ ("1", contents foo1); ("2", contents foo2) ] ls; + let* foo1' = S.find_all t [ "b"; "foo"; "1" ] in + check_val "foo1" (normal foo1) foo1'; + let* foo2' = S.find_all t [ "a"; "foo"; "2" ] in + check_val "foo2" (normal foo2) foo2'; + let* v0 = S.get_tree t [ "b" ] in + check_tree v0 >>= fun () -> + S.set_exn t ~info:(infof "update b/x") [ "b"; "x" ] foo1 >>= fun () -> + let* v2 = S.get_tree t [ "b" ] in + let* v1 = S.Tree.add v0 [ "y" ] foo2 in + let* v' = + Irmin.Merge.(f S.Tree.merge ~old:(promise v0) v1 v2) + >>= merge_exn "merge trees" + in + S.set_tree_exn t ~info:(infof "merge_path") [ "b" ] v' >>= fun () -> + let* foo1' = S.find_all t [ "b"; "x" ] in + let* foo2' = S.find_all t [ "b"; "y" ] in + check_val "merge: b/x" (normal foo1) foo1'; + check_val "merge: b/y" (normal foo2) foo2'; + let* () = + Lwt_list.iteri_s + (fun i (k, v) -> + let* v' = S.find_all t ("a" :: k) in + check_val ("a" ^ string_of_int i) (normal v) v'; + let* v' = S.find_all t ("b" :: k) in + check_val ("b" ^ string_of_int i) (normal v) v'; + Lwt.return_unit) + nodes + in + let* v2 = S.get_tree t [ "b" ] in + let* _ = S.Tree.find_all v2 [ "foo"; "1" ] in + let* v2 = S.Tree.add v2 [ "foo"; "1" ] foo2 in + S.set_tree_exn t ~info:(infof "v2") [ "b" ] v2 >>= fun () -> + let* foo2' = S.find_all t [ "b"; "foo"; "1" ] in + check_val "update tree" (normal foo2) foo2'; + let* v3 = S.get_tree t [ "b" ] in + let* _ = S.Tree.find_all v3 [ "foo"; "1" ] in + let* v3 = S.Tree.remove v3 [ "foo"; "1" ] in + S.set_tree_exn t ~info:(infof "v3") [ "b" ] v3 >>= fun () -> + let* foo2' = S.find_all t [ "b"; "foo"; "1" ] in + check_val "remove tree" None foo2'; + let* r1 = r1 ~repo in + let* r2 = r2 ~repo in + let i0 = S.Info.empty in + let* c = + S.Commit.v repo ~info:S.Info.empty + ~parents:[ S.Commit.key r1; S.Commit.key r2 ] + v3 + in + S.Head.set t c >>= fun () -> + let* h = S.Head.get t in + S.Commit.info h |> fun i -> + check S.Info.t "commit info" i0 i; + let* tt = S.of_commit h in + let* g = S.history tt in + let pred = S.History.pred g h in + checks (S.commit_t repo) "head" [ r1; r2 ] pred; + let* foo2'' = S.find_all tt [ "b"; "foo"; "1" ] in + check_val "remove tt" None foo2''; + let vx = "VX" in + let px = [ "x"; "y"; "z" ] in + S.set_exn tt ~info:(infof "update") px vx >>= fun () -> + let* tree = S.get_tree tt [] in + S.Tree.clear tree; + let* s = S.Tree.stats tree in + Alcotest.(check stats_t) + "lazy stats" + { S.Tree.nodes = 0; leafs = 0; skips = 1; depth = 0; width = 0 } + s; + S.Tree.clear tree; + let* s = S.Tree.stats ~force:true tree in + Alcotest.(check stats_t) + "forced stats" + { S.Tree.nodes = 404; leafs = 103; skips = 0; depth = 5; width = 103 } + s; + let* vx' = S.Tree.find_all tree px in + check_val "updates" (normal vx) vx'; + let v = S.Tree.singleton [] vx in + let* () = + S.set_tree_exn t ~info:(infof "update file as tree") [ "a" ] v + in + let* vx' = S.find_all t [ "a" ] in + check_val "update file as tree" (normal vx) vx'; + B.Repo.close repo + in + run x test + + let pp_proof = Irmin.Type.pp S.Tree.Proof.t + + let test_proofs x () = + let test repo = + (* Testing Merkle proof *) + let large_dir = + List.init 1000 (fun i -> + let v = string_of_int i in + ([ "dir"; v ], "BLOB:" ^ v)) + in + let* c0 = + Lwt.return (S.Tree.empty ()) + >>= with_binding [ "foo"; "a" ] "1" + >>= with_binding [ "foo"; "b"; "c" ] "2" + >>= with_binding [ "bar"; "d" ] "3" + >>= with_binding [ "e" ] "4" + >>= fun t -> + Lwt_list.fold_left_s (fun acc (k, v) -> S.Tree.add acc k v) t large_dir + in + let to_proof t = + let* store = S.empty repo in + let* () = S.set_tree_exn ~info:(infof "to_proof") store [] t in + let key = + match S.Tree.key t with None -> assert false | Some k -> k + in + let rec aux p t = + let* bindings = + Lwt.catch + (fun () -> S.Tree.list t []) + (function + | S.Tree.Pruned_hash _ -> Lwt.return [] | e -> Lwt.fail e) + in + Lwt_list.iter_s (fun (s, v) -> aux (p @ [ s ]) v) bindings + in + S.Tree.produce_proof repo key (fun t -> + let+ () = aux [] t in + (t, ())) + in + let* p0, () = to_proof c0 in + [%log.debug "p0=%a" pp_proof p0]; + let t0 = S.Tree.Proof.to_tree p0 in + let* () = + let+ d0 = S.Tree.diff c0 t0 in + check_diffs "proof roundtrip" [] d0 + in + let* () = + let* c0' = S.Tree.list c0 [] in + let+ t0' = S.Tree.list t0 [] in + check_ls "proof list /" c0' t0' + in + let* () = + let* c0' = S.Tree.list c0 [ "foo" ] in + let+ t0' = S.Tree.list t0 [ "foo" ] in + check_ls "proof tree list /foo" c0' t0' + in + let* () = + let* c0' = S.Tree.list c0 [ "bar"; "d" ] in + let+ t0' = S.Tree.list t0 [ "bar"; "d" ] in + check_ls "proof tree list /bar/d" c0' t0' + in + let* () = + let* c0' = S.Tree.list c0 [ "dir" ] in + let+ t0' = S.Tree.list t0 [ "dir" ] in + check_ls "proof tree list /dir" c0' t0' + in + let add_noise n prefix = + List.map (fun k -> (prefix @ [ k ], k)) (List.init n string_of_int) + in + let bindings = + [ + ([ "foo"; "age" ], "0"); + ([ "foo"; "version" ], "1"); + ([ "bar"; "age" ], "2"); + ([ "bar"; "version" ], "3"); + ] + @ add_noise 100 [ "foo" ] + @ add_noise 10 [ "hey" ] + @ add_noise 50 [ "bar" ] + in + let increment = function + | None -> assert false + | Some i -> Some (int_of_string i + 1 |> string_of_int) + in + let check_proof_f0 p = + let t = S.Tree.Proof.to_tree p in + let* i = S.Tree.find t [ "bar"; "age" ] in + Alcotest.(check (option string)) + "inside: find bar/age in proof" (Some "2") i; + let* i = S.Tree.find t [ "bar"; "version" ] in + Alcotest.(check (option string)) + "inside: find bar/version in proof" (Some "3") i; + let* i = S.Tree.find t [ "hello"; "there" ] in + Alcotest.(check (option string)) + "inside: do not find hello/there in proof" None i; + let+ () = + Lwt.catch + (fun () -> + let+ _ = S.Tree.find t [ "foo"; "version" ] in + Alcotest.fail "inside: should have raise: pruned_hash exn") + (function + | S.Tree.Pruned_hash _ | B.Node.Val.Dangling_hash _ -> + Lwt.return () + | e -> Lwt.fail e) + in + () + in + + let check_proof_f1 p = + let t = S.Tree.Proof.to_tree p in + let+ i = S.Tree.find t [ "foo"; "version" ] in + Alcotest.(check (option string)) + "outside: find foo/version" (Some "1") i + in + + let init_tree bindings = + let tree = S.Tree.empty () in + let* tree = + Lwt_list.fold_left_s + (fun tree (k, v) -> S.Tree.add tree k v) + tree bindings + in + let* store = S.empty repo in + let* () = S.set_tree_exn ~info:(infof "init_tree") store [] tree in + S.tree store + in + let* tree = init_tree bindings in + let key = + match S.Tree.key tree with None -> assert false | Some k -> k + in + + let f0 t0 = + let* t1 = S.Tree.update t0 [ "foo"; "age" ] increment in + let* t2 = S.Tree.update t1 [ "bar"; "age" ] increment in + let* t3 = S.Tree.get_tree t2 [ "bar" ] in + let* t4 = S.Tree.add_tree t2 [ "hello"; "there" ] t3 in + let* v = S.Tree.get t4 [ "hello"; "there"; "version" ] in + Alcotest.(check string) "hello/there/version" "3" v; + let t = S.Tree.empty () in + let* t5 = S.Tree.add_tree t [ "dir1"; "dir2" ] t4 in + let* v = S.Tree.get t5 [ "dir1"; "dir2"; "bar"; "age" ] in + Alcotest.(check string) "dir1/dir2/bar/age" "3" v; + let* t = S.Tree.remove t4 [ "bar" ] in + + (* Trigger certain paths in [S.Tree] during "verify" *) + let portable = + (* During "verify" [portable] is [Pruned] with [portable] in env *) + t0 + in + let portable_dirty = t in + let trigger_node_to_map t = + S.Tree.fold ~depth:(`Eq 1) ~order:`Sorted ~force:`True t () + in + let* () = trigger_node_to_map portable in + let* () = trigger_node_to_map portable_dirty in + let trigger_node_length t = + let+ (_ : int) = S.Tree.length t [] in + () + in + let* () = trigger_node_length portable in + let* () = trigger_node_length portable_dirty in + let trigger_node_fold_undefined t = + S.Tree.fold ~depth:(`Eq 1) ~order:`Undefined ~force:`True t () + in + let* () = trigger_node_fold_undefined portable in + let* () = trigger_node_fold_undefined portable_dirty in + let (_ : bool) = S.Tree.is_empty portable in + let trigger_node_to_backend_portable t = + match S.Tree.destruct t with + | `Contents _ -> assert false + | `Node n -> + let+ _ = S.to_backend_portable_node n in + () + in + let* () = trigger_node_to_backend_portable portable_dirty in + + Lwt.return (t, ()) + in + let f1 t0 = + let* p0, () = S.Tree.produce_proof repo key f0 in + let* () = check_proof_f0 p0 in + let+ v = S.Tree.get t0 [ "foo"; "version" ] in + Alcotest.(check string) "foo/version" "1" v; + (t0, ()) + in + let* p, () = S.Tree.produce_proof repo key f1 in + + let* () = check_proof_f1 p in + + let check_proof f = + let* p, () = S.Tree.produce_proof repo key f in + [%log.debug "Verifying proof %a" pp_proof p]; + let+ r = S.Tree.verify_proof p f in + match r with + | Ok (_, ()) -> () + | Error e -> + Alcotest.failf "check_proof: %a" + (Irmin.Type.pp S.Tree.verifier_error_t) + e + in + let* () = Lwt_list.iter_s check_proof [ f0; f1 ] in + + (* check env sharing *) + let tree () = + S.Tree.of_concrete + (`Tree [ ("foo", `Contents ("bar", S.Metadata.default)) ]) + in + let contents () = + S.Tree.of_concrete (`Contents ("bar", S.Metadata.default)) + in + let check_env_empty msg t b = + let env = S.Tree.Private.get_env t in + Alcotest.(check bool) msg b (S.Tree.Private.Env.is_empty env) + in + let check_env msg t t' = + let env = S.Tree.Private.get_env t in + let env' = S.Tree.Private.get_env t' in + check S.Tree.Private.Env.t msg env env' + in + let x = ref None in + let* _ = + S.Tree.produce_proof repo key (fun t -> + check_env_empty "env should be set inside the proof" t false; + x := Some t; + + let t0 = tree () in + check_env_empty "env should not be set for fresh trees" t0 true; + + (* test changing subtress: check that envirnoment is + attached only the tree roots *) + let* t1 = S.Tree.add_tree t [ "foo" ] t0 in + check_env_empty "1: t's env should not change" t false; + check_env_empty "1: t0's env should not change" t0 true; + check_env "1: t1's env should be the same as t's" t1 t; + + let t0 = contents () in + let* t1 = S.Tree.add_tree t [ "foo" ] t0 in + check_env_empty "2: t's env should not change" t false; + check_env_empty "2: t0's env should not change" t0 true; + check_env "2: t1's env should be the same as t's" t1 t; + + (* test changing roots *) + let t0 = tree () in + let* t1 = S.Tree.add_tree t [] t0 in + check_env_empty "3: t's env should not change" t false; + check_env_empty "3: t0's env should not change" t0 true; + check_env "3: t1's env should be the same as t0's" t1 t0; + + let t0 = contents () in + let* t1 = S.Tree.add_tree t [] t0 in + check_env_empty "4: t's env should not change" t false; + check_env_empty "4: t0's env should not change" t0 true; + check_env "4: t1's env should be the same as t0's" t1 t0; + + (* check subtrees *) + let* t2 = S.Tree.get_tree t [ "foo" ] in + check_env "5: t2's env should be the same as t's" t2 t; + let* t3 = S.Tree.get_tree t [ "foo"; "age" ] in + check_env "5: t3's env should be the same as t's" t3 t; + + Lwt.return (t, ())) + in + let t = match !x with Some t -> t | None -> assert false in + check_env_empty "env is unset outside of the proof)" t true; + + (* test negative proofs *) + let check_bad_proof p = + let+ r = S.Tree.verify_proof p f0 in + match r with + | Ok _ -> Alcotest.fail "verify should have failed" + | Error _ -> () + in + + let* p0, () = S.Tree.produce_proof repo key f0 in + let proof ?(before = S.Tree.Proof.before p0) + ?(after = S.Tree.Proof.after p0) ?(state = S.Tree.Proof.state p0) () = + S.Tree.Proof.v ~before ~after state + in + let wrong_hash = B.Contents.Hash.hash "not the right hash!" in + let wrong_kinded_hash = `Node wrong_hash in + let* () = check_bad_proof (proof ~before:wrong_kinded_hash ()) in + let* () = check_bad_proof (proof ~after:wrong_kinded_hash ()) in + let* _ = S.Tree.verify_proof (proof ()) f0 in + let some_contents : S.Tree.Proof.tree list = + [ + Blinded_node wrong_hash; + Node []; + Inode { length = 1024; proofs = [] }; + Blinded_contents (wrong_hash, S.Metadata.default); + Contents ("yo", S.Metadata.default); + ] + in + let* () = + Lwt_list.iter_s + (fun c -> check_bad_proof (proof ~state:c ())) + some_contents + in + B.Repo.close repo + in + run x test + + let test_wide_nodes x () = + let test repo = + let size = 500_000 in + let c0 = S.Tree.empty () in + let rec wide_node i c = + if i >= size then Lwt.return c + else + S.Tree.add c [ "foo"; string_of_int i ] (string_of_int i) >>= fun c -> + wide_node (i + 1) c + in + wide_node 0 c0 >>= fun c -> + S.Tree.list c [ "foo" ] >>= fun ls -> + Alcotest.(check int) "list wide dir" size (List.length ls); + S.Tree.fold ~force:`True c ~uniq:`False + ~contents:(fun k _ i -> + Alcotest.(check int) "contents at [foo; i]" (List.length k) 2; + Lwt.return (i + 1)) + ~node:(fun k _ i -> + if not (List.length k = 0 || List.length k = 1) then + Alcotest.failf "nodes should be at [] and [foo], got %a" + (Irmin.Type.pp S.path_t) k; + Lwt.return i) + 0 + >>= fun nb_contents -> + Alcotest.(check int) "nb of contents folded over" size nb_contents; + S.Tree.remove c [ "foo"; "499999" ] >>= fun c1 -> + S.Tree.add c0 [] "499999" >>= fun c2 -> + S.Tree.add_tree c1 [ "foo"; "499999" ] c2 >>= fun c' -> + let h' = S.Tree.hash c' in + let h = S.Tree.hash c in + check S.Hash.t "same tree" h h'; + let* c1 = S.Tree.get_tree c [ "foo" ] in + let* _ = + S.Backend.Repo.batch repo (fun c n _ -> S.save_tree repo c n c1) + in + (match S.Tree.destruct c1 with + | `Contents _ -> Alcotest.fail "got `Contents, expected `Node" + | `Node node -> ( + let* v = S.to_backend_node node in + let () = + let ls = B.Node.Val.list v in + Alcotest.(check int) "list wide node" size (List.length ls) + in + let* bar_key = + with_contents repo (fun t -> B.Contents.add t "bar") + in + let k = normal bar_key in + let v1 = B.Node.Val.add v "x" k in + let* () = + let h' = B.Node.Hash.hash v1 in + let+ h = with_node repo (fun n -> B.Node.add n v1) in + check B.Node.Hash.t "wide node + x: hash(v) = add(v)" + (B.Node.Key.to_hash h) h' + in + let () = + let v2 = B.Node.Val.add v "x" k in + check B.Node.Val.t "add x" v1 v2 + in + let () = + let v0 = B.Node.Val.remove v1 "x" in + check B.Node.Val.t "remove x" v v0 + in + let* () = + let v3 = B.Node.Val.remove v "1" in + let h' = B.Node.Hash.hash v3 in + with_node repo (fun n -> B.Node.add n v3) >|= fun h -> + check B.Node.Hash.t "wide node - 1 : hash(v) = add(v)" + (B.Node.Key.to_hash h) h' + in + (match B.Node.Val.find v "499999" with + | None | Some (`Node _) -> Alcotest.fail "value 499999 not found" + | Some (`Contents (x, _)) -> + let x = B.Contents.Key.to_hash x in + let x' = B.Contents.Hash.hash "499999" in + check B.Contents.Hash.t "find 499999" x x'); + match B.Node.Val.find v "500000" with + | None -> Lwt.return_unit + | Some _ -> Alcotest.fail "value 500000 should not be found")) + >>= fun () -> B.Repo.close repo + in + run x test + + let test_commit_wide_node x () = + let test repo = + let size = 500_000 in + let c0 = S.Tree.empty () in + let rec wide_node i c = + if i >= size then Lwt.return c + else + S.Tree.add c [ "foo"; string_of_int i ] (string_of_int i) >>= fun c -> + wide_node (i + 1) c + in + wide_node 0 c0 >>= fun c -> + S.main repo >>= fun t -> + S.set_tree_exn t [ "wide" ] ~info:(infof "commit_wide_nodes") c + >>= fun () -> + S.list t [ "wide"; "foo" ] >>= fun ls -> + Alcotest.(check int) "commit wide node list" size (List.length ls); + B.Repo.close repo + in + run x test + + module Sync = Irmin.Sync.Make (S) + + let test_sync x () = + let test repo = + let* t1 = S.main repo in + S.set_exn t1 ~info:(infof "update a/b") [ "a"; "b" ] v1 >>= fun () -> + let* h = S.Head.get t1 in + let* _r1 = S.Head.get t1 in + S.set_exn t1 ~info:(infof "update a/c") [ "a"; "c" ] v2 >>= fun () -> + let* r2 = S.Head.get t1 in + S.set_exn t1 ~info:(infof "update a/d") [ "a"; "d" ] v1 >>= fun () -> + let* _r3 = S.Head.get t1 in + let* h = S.history t1 ~min:[ h ] in + Alcotest.(check int) "history-v" 3 (S.History.nb_vertex h); + Alcotest.(check int) "history-e" 2 (S.History.nb_edges h); + let remote = Irmin.remote_store (module S) t1 in + let* partial = Sync.fetch_exn t1 ~depth:0 remote in + let partial = + match partial with + | `Head x -> x + | `Empty -> failwith "no head: partial" + in + let* full = Sync.fetch_exn t1 remote in + let full = + match full with `Head x -> x | `Empty -> failwith "no head: full" + in + (* Restart a fresh store and import everything in there. *) + let tag = "export" in + let* t2 = S.of_branch repo tag in + S.Head.set t2 partial >>= fun () -> + let* b1 = S.mem t2 [ "a"; "b" ] in + Alcotest.(check bool) "mem-ab" true b1; + let* b2 = S.mem t2 [ "a"; "c" ] in + Alcotest.(check bool) "mem-ac" true b2; + let* b3 = S.mem t2 [ "a"; "d" ] in + Alcotest.(check bool) "mem-ad" true b3; + let* v1' = S.get t2 [ "a"; "d" ] in + check S.contents_t "v1" v1 v1'; + S.Head.set t2 r2 >>= fun () -> + let* b4 = S.mem t2 [ "a"; "d" ] in + Alcotest.(check bool) "mem-ab" false b4; + S.Head.set t2 full >>= fun () -> + S.Head.set t2 r2 >>= fun () -> + let* b4 = S.mem t2 [ "a"; "d" ] in + Alcotest.(check bool) "mem-ad" false b4; + B.Repo.close repo + in + run x test + + module Dot = Irmin.Dot (S) + + let output_file x t file = + let buf = Buffer.create 1024 in + let date d = + let tm = Unix.localtime (Int64.to_float d) in + Fmt.str "%2d:%2d:%2d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec + in + Dot.output_buffer t ~date buf >>= fun () -> + let oc = + open_out_bin + (Filename.get_temp_dir_name () / Fmt.str "%s-%s.dot" x.name file) + in + output_string oc (Buffer.contents buf); + close_out oc; + Lwt.return_unit + + let test_merge ?hook x () = + let test repo = + let v1 = "X1" in + let v2 = "X2" in + let v3 = "X3" in + let* t1 = S.main repo in + let* () = + S.set_exn t1 ~info:(infof "update a/b/a") [ "a"; "b"; "a" ] v1 + in + let* () = + S.set_exn t1 ~info:(infof "update a/b/b") [ "a"; "b"; "b" ] v2 + in + let* () = + S.set_exn t1 ~info:(infof "update a/b/c") [ "a"; "b"; "c" ] v3 + in + let test = "test" in + let* t2 = S.clone ~src:t1 ~dst:test in + let* () = + S.set_exn t1 ~info:(infof "update main:a/b/b") [ "a"; "b"; "b" ] v1 + in + let* () = + S.set_exn t1 ~info:(infof "update main:a/b/b") [ "a"; "b"; "b" ] v3 + in + let* () = + S.set_exn t2 ~info:(infof "update test:a/b/c") [ "a"; "b"; "c" ] v1 + in + output_file x t1 "before" >>= fun () -> + let* m = S.merge_into ~info:(infof "merge test into main") t2 ~into:t1 in + merge_exn "m" m >>= fun () -> + may_with_branch [ t1 ] repo hook >>= fun () -> + output_file x t1 "after" >>= fun () -> + let* v1' = S.get t1 [ "a"; "b"; "c" ] in + let* v2' = S.get t2 [ "a"; "b"; "b" ] in + let* v3' = S.get t1 [ "a"; "b"; "b" ] in + check S.contents_t "v1" v1 v1'; + check S.contents_t "v2" v2 v2'; + check S.contents_t "v3" v3 v3'; + B.Repo.close repo + in + run x test + + (* in this test an outdated reference to a tree is used by a commit: [tree] is + the tree with root [x] created by [c1] and modified by [c2]. [c3] reuse [tree] + which implicitly deletes the changes of [c2]. *) + let test_merge_outdated_tree x () = + let check_val = check T.(option S.contents_t) in + let none_fail f msg = + f >>= function None -> Alcotest.fail msg | Some c -> Lwt.return c + in + let test repo = + let vx = "VX" in + let vy = "VY" in + let old () = Lwt.return (Ok None) in + let* t = S.main repo in + S.set_exn t ~info:(infof "add x/y/z") [ "x"; "y"; "z" ] vx >>= fun () -> + let* _c1 = none_fail (S.Head.find t) "head not found" in + let* tree = S.get_tree t [ "x" ] in + S.set_exn t ~info:(infof "add u/x/y") [ "u"; "x"; "y" ] vy >>= fun () -> + let* c2 = none_fail (S.Head.find t) "head not found" in + let* tree3 = S.Tree.add tree [ "x"; "z" ] vx in + S.set_tree_exn t ~info:(infof "update") [ "u" ] tree3 >>= fun () -> + let* c3 = none_fail (S.Head.find t) "head not found" in + let info () = S.Commit.info c3 in + with_commit repo (fun commit_t -> + Irmin.Merge.f + (B.Commit.merge commit_t ~info) + ~old + (Some (S.Commit.key c3)) + (Some (S.Commit.key c2))) + >>= merge_exn "commit" + >>= function + | None -> Lwt.return_unit + | Some c4 -> + let* k = none_fail (S.Commit.of_key repo c4) "of hash" in + S.Branch.set repo "foo" k >>= fun () -> + let* t = S.of_branch repo "foo" in + let* vy' = S.find t [ "u"; "x"; "y" ] in + check_val "vy after merge" None vy'; + B.Repo.close repo + in + run x test + + let test_merge_unrelated ?hook x () = + run x @@ fun repo -> + let v1 = "X1" in + let* foo = S.of_branch repo "foo" in + let* bar = S.of_branch repo "bar" in + S.set_exn foo ~info:(infof "update foo:a") [ "a" ] v1 >>= fun () -> + S.set_exn bar ~info:(infof "update bar:b") [ "b" ] v1 >>= fun () -> + may_with_branch [ foo; bar ] repo hook >>= fun () -> + let* _ = + S.merge_into ~info:(infof "merge bar into foo") bar ~into:foo + >>= merge_exn "merge unrelated" + in + B.Repo.close repo + + let rec write fn = function + | 0 -> [] + | i -> (fun () -> fn i >>= Lwt.pause) :: write fn (i - 1) + + let perform l = Lwt_list.iter_p (fun f -> f ()) l + + let rec read fn check = function + | 0 -> [] + | i -> (fun () -> fn i >|= fun v -> check i v) :: read fn check (i - 1) + + let test_concurrent_low x () = + let test_branches repo = + let k = b1 in + let* v = r1 ~repo in + let write = write (fun _i -> S.Branch.set repo k v) in + let read = + read + (fun _i -> S.Branch.find repo k >|= get) + (fun i -> check (S.commit_t repo) (Fmt.str "tag %d" i) v) + in + perform (write 1) >>= fun () -> + perform (write 10 @ read 10 @ write 10 @ read 10) + in + let test_contents repo = + let* k = kv2 ~repo in + let v = v2 in + let t = B.Repo.contents_t repo in + let write = + write (fun _i -> + let* _ = with_contents repo (fun t -> B.Contents.add t v) in + Lwt.return_unit) + in + let read = + read + (fun _i -> B.Contents.find t k >|= get) + (fun i -> check S.contents_t (Fmt.str "contents %d" i) v) + in + perform (write 1) >>= fun () -> + perform (write 10 @ read 10 @ write 10 @ read 10) + in + run x (fun repo -> + Lwt.choose [ test_branches repo; test_contents repo ] >>= fun () -> + B.Repo.close repo) + + let test_concurrent_updates x () = + let test_one repo = + let k = [ "a"; "b"; "d" ] in + let v = "X1" in + let* t1 = S.main repo in + let* t2 = S.main repo in + let write t = + write (fun i -> S.set_exn t ~info:(infof "update: one %d" i) k v) + in + let read t = + read + (fun _ -> S.get t k) + (fun i -> check S.contents_t (Fmt.str "update: one %d" i) v) + in + perform (write t1 10 @ write t2 10) >>= fun () -> perform (read t1 10) + in + let test_multi repo = + let k i = [ "a"; "b"; "c"; string_of_int i ] in + let v i = Fmt.str "X%d" i in + let* t1 = S.main repo in + let* t2 = S.main repo in + let write t = + write (fun i -> + S.set_exn t ~info:(infof "update: multi %d" i) (k i) (v i)) + in + let read t = + read + (fun i -> S.get t (k i)) + (fun i -> check S.contents_t (Fmt.str "update: multi %d" i) (v i)) + in + perform (write t1 10 @ write t2 10) >>= fun () -> perform (read t1 10) + in + run x (fun repo -> + test_one repo >>= fun () -> + test_multi repo >>= fun () -> B.Repo.close repo) + + let test_concurrent_merges x () = + let test repo = + let k i = [ "a"; "b"; "c"; string_of_int i ] in + let v i = Fmt.str "X%d" i in + let* t1 = S.main repo in + let* t2 = S.main repo in + let write t n = + write (fun i -> + let tag = Fmt.str "tmp-%d-%d" n i in + let* m = S.clone ~src:t ~dst:tag in + S.set_exn m ~info:(infof "update") (k i) (v i) >>= fun () -> + Lwt.pause () >>= fun () -> + S.merge_into ~info:(infof "update: multi %d" i) m ~into:t + >>= merge_exn "update: multi") + in + let read t = + read + (fun i -> S.get t (k i)) + (fun i -> check S.contents_t (Fmt.str "update: multi %d" i) (v i)) + in + S.set_exn t1 ~info:(infof "update") (k 0) (v 0) >>= fun () -> + perform (write t1 1 10 @ write t2 2 10) >>= fun () -> + perform (read t1 10) >>= fun () -> B.Repo.close repo + in + run x test + + let pp_write_error = Irmin.Type.pp S.write_error_t + let tree_t = testable S.tree_t + + let test_with_tree x () = + let test repo = + let* t = S.main repo in + let update ?retries key strategy r w = + S.with_tree t ?retries ~info:(infof "with-tree") ~strategy key (fun _ -> + let+ v = Lwt_mvar.take r in + Some (S.Tree.of_contents v)) + >>= Lwt_mvar.put w + in + let check_ok = function + | Ok () -> () + | Error e -> Alcotest.failf "%a" pp_write_error e + in + let check_test e = function + | Error (`Test_was e') -> + Alcotest.(check (option tree_t)) "test-was" e e' + | Ok () -> Alcotest.fail "error expected" + | Error e -> + Alcotest.failf "an other error was expected: %a" pp_write_error e + in + let check_conflict = function + | Error (`Conflict _) -> () + | Ok () -> Alcotest.fail "error expected" + | Error e -> + Alcotest.failf "an other error was expected: %a" pp_write_error e + in + let set () = + let rx = Lwt_mvar.create_empty () in + let wx = Lwt_mvar.create_empty () in + let ry = Lwt_mvar.create_empty () in + let wy = Lwt_mvar.create_empty () in + S.set_exn t ~info:(infof "init") [ "a" ] "0" >>= fun () -> + Lwt.join + [ + update [ "a" ] ~retries:0 `Set rx wx; + update [ "a" ] ~retries:0 `Set ry wy; + ( Lwt_mvar.put rx "1" >>= fun () -> + Lwt_mvar.take wx >|= check_ok >>= fun () -> + let* a = S.get t [ "a" ] in + Alcotest.(check string) "set x" "1" a; + Lwt_mvar.put ry "2" >>= fun () -> + Lwt_mvar.take wy >|= check_ok >>= fun () -> + let+ a = S.get t [ "a" ] in + Alcotest.(check string) "set y" "2" a ); + ] + in + let test_and_set () = + let rx = Lwt_mvar.create_empty () in + let wx = Lwt_mvar.create_empty () in + let ry = Lwt_mvar.create_empty () in + let wy = Lwt_mvar.create_empty () in + let rz = Lwt_mvar.create_empty () in + let wz = Lwt_mvar.create_empty () in + S.set_exn t ~info:(infof "init") [ "a" ] "0" >>= fun () -> + Lwt.join + [ + update [ "a" ] ~retries:0 `Test_and_set rx wx; + update [ "a" ] ~retries:0 `Test_and_set ry wy; + update [ "a" ] ~retries:1 `Test_and_set rz wz; + ( Lwt_mvar.put rx "1" >>= fun () -> + Lwt_mvar.take wx >|= check_ok >>= fun () -> + let* a = S.get t [ "a" ] in + Alcotest.(check string) "test-and-set x" "1" a; + Lwt_mvar.put ry "2" >>= fun () -> + let* e = Lwt_mvar.take wy in + check_test (Some (S.Tree.of_contents "1")) e; + let* a = S.get t [ "a" ] in + Alcotest.(check string) "test-and-set y" "1" a; + Lwt_mvar.put rz "3" >>= fun () -> + (* there's a conflict, the transaction is restarted so need to feed a + new value *) + Lwt_mvar.put rz "4" >>= fun () -> + Lwt_mvar.take wz >|= check_ok >>= fun () -> + let+ a = S.get t [ "a" ] in + Alcotest.(check string) "test-and-set z" "4" a ); + ] + in + let merge () = + let rx = Lwt_mvar.create_empty () in + let wx = Lwt_mvar.create_empty () in + let ry = Lwt_mvar.create_empty () in + let wy = Lwt_mvar.create_empty () in + let rz = Lwt_mvar.create_empty () in + let wz = Lwt_mvar.create_empty () in + S.set_exn t ~info:(infof "init") [ "a" ] "0" >>= fun () -> + Lwt.join + [ + update [ "a" ] ~retries:0 `Merge rx wx; + update [ "a" ] ~retries:0 `Merge ry wy; + update [ "a" ] ~retries:1 `Merge rz wz; + ( Lwt_mvar.put rx "1" >>= fun () -> + Lwt_mvar.take wx >|= check_ok >>= fun () -> + let* a = S.get t [ "a" ] in + Alcotest.(check string) "merge x" "1" a; + Lwt_mvar.put ry "2" >>= fun () -> + Lwt_mvar.take wy >|= check_conflict >>= fun () -> + let* a = S.get t [ "a" ] in + Alcotest.(check string) "merge y" a "1"; + Lwt_mvar.put rz "3" >>= fun () -> + (* there's a conflict, the transaction is restarted so need to feed a + new value *) + Lwt_mvar.put rz "4" >>= fun () -> + Lwt_mvar.take wz >|= check_ok >>= fun () -> + let+ a = S.get t [ "a" ] in + Alcotest.(check string) "merge z" a "4" ); + ] + in + set () >>= test_and_set >>= merge >>= fun () -> B.Repo.close repo + in + run x test + + let test_concurrent_head_updates x () = + let test repo = + let k i = [ "a"; "b"; "c"; string_of_int i ] in + let v i = Fmt.str "X%d" i in + let* t1 = S.main repo in + let* t2 = S.main repo in + let retry d fn = + let rec aux i = + fn () >>= function + | true -> + [%log.debug "%d: ok!" d]; + Lwt.return_unit + | false -> + [%log.debug "%d: conflict, retrying (%d)." d i]; + aux (i + 1) + in + aux 1 + in + let write t n = + write (fun i -> + retry i (fun () -> + let* test = S.Head.find t in + let tag = Fmt.str "tmp-%d-%d" n i in + let* m = S.clone ~src:t ~dst:tag in + S.set_exn m ~info:(infof "update") (k i) (v i) >>= fun () -> + let* set = S.Head.find m in + Lwt.pause () >>= fun () -> S.Head.test_and_set t ~test ~set)) + in + let read t = + read + (fun i -> S.get t (k i)) + (fun i -> check S.contents_t (Fmt.str "update: multi %d" i) (v i)) + in + S.set_exn t1 ~info:(infof "update") (k 0) (v 0) >>= fun () -> + perform (write t1 1 5 @ write t2 2 5) >>= fun () -> + perform (read t1 5) >>= fun () -> B.Repo.close repo + in + run x test + + let test_shallow_objects x () = + let test repo = + (* NOTE: A store of type `Irmin.Generic_key.S` does not currently expose + functions for building nodes / commits with non-existent children, due to + the need to have _keys_ for all store pointers. + + A future version of this API may support such operations (e.g. for + constructing Merkle proofs), but until then we must synthesise test keys + by adding test values to the correponding backend stores directly. *) + let contents (s : string) : S.contents_key Lwt.t = + with_contents repo (fun c -> B.Contents.add c s) + in + let node (s : string) : S.node_key Lwt.t = + with_node repo (fun n -> + let* contents = contents s in + let node = B.Node.Val.(add (empty ())) s (normal contents) in + B.Node.add n node) + in + let commit (s : string) : S.commit_key Lwt.t = + with_commit repo (fun c -> + let* node = node s in + let commit = B.Commit.Val.v ~info:(info "") ~node ~parents:[] in + B.Commit.add c commit) + in + let* foo_k = node "foo" in + let* bar_k = node "bar" in + let tree_1 = S.Tree.shallow repo (`Node foo_k) in + let tree_2 = S.Tree.shallow repo (`Node bar_k) in + let* node_3 = + let+ contents_foo = contents "foo" in + S.Backend.Node.Val.of_list + [ + ("foo", `Contents (contents_foo, S.Metadata.default)); + ("bar", `Node bar_k); + ] + in + let tree_3 = S.Tree.of_node (S.of_backend_node repo node_3) in + let* _ = + S.Backend.Repo.batch repo (fun c n _ -> S.save_tree repo c n tree_3) + in + let key_3 = get_node_key (Option.get (S.Tree.key tree_3)) in + let info () = info "shallow" in + let* t = S.main repo in + S.set_tree_exn t [ "1" ] tree_1 ~info >>= fun () -> + S.set_tree_exn t [ "2" ] tree_2 ~info >>= fun () -> + let* h = S.Head.get t in + let* commit_v = + let+ commit_foo = commit "foo" in + S.Backend.Commit.Val.v ~info:(info ()) ~node:key_3 + ~parents:[ S.Commit.key h; commit_foo ] + in + let* commit_key = with_commit repo (fun c -> B.Commit.add c commit_v) in + let commit = S.of_backend_commit repo commit_key commit_v in + S.set_tree_exn t [ "3" ] ~parents:[ commit ] tree_3 ~info >>= fun () -> + let* t1 = S.find_tree t [ "1" ] in + Alcotest.(check (option tree_t)) "shallow tree" (Some tree_1) t1; + B.Repo.close repo + in + run x test + + let test_pre_hash_collisions x () = + let pre_hash_of ty = + let f = Irmin.Type.(pre_hash ty |> unstage) in + fun x -> + let buf = Buffer.create 0 in + f x (Buffer.add_string buf); + Buffer.contents buf + in + let rec add_entries acc = function + | 0 -> Lwt.return acc + | i -> + let s = string_of_int i in + let* acc = S.Tree.add acc [ s ] s in + add_entries acc (i - 1) + in + let equal_hash = Irmin.Type.(equal S.Hash.t |> unstage) in + let test create_tree repo = + let* tree = create_tree () in + let* c = S.Commit.v repo ~info:S.Info.empty ~parents:[] tree in + + let* node_b = + S.Tree.destruct tree + |> ( function `Contents _ -> assert false | `Node n -> n ) + |> S.to_backend_node + in + let node_ph = pre_hash_of S.Backend.Node.Val.t node_b in + let node_h = S.Backend.Node.Hash.hash node_b in + + let commit_b = S.to_backend_commit c in + let commit_ph = pre_hash_of S.Backend.Commit.Val.t commit_b in + let commit_h = S.Backend.Commit.Hash.hash commit_b in + + let* blob_k = + with_contents repo (fun t -> S.Backend.Contents.add t node_ph) + in + let blob_h = S.Backend.Contents.Key.to_hash blob_k in + if equal_hash node_h blob_h then + Alcotest.failf + "node pre-hash attack succeeded. pre-hash is \"%s\". backend node is \ + %a." + (String.escaped node_ph) + (Irmin.Type.pp S.Backend.Node.Val.t) + node_b; + + let* blob_k = + with_contents repo (fun t -> S.Backend.Contents.add t commit_ph) + in + let blob_h = S.Backend.Contents.Key.to_hash blob_k in + if equal_hash commit_h blob_h then + Alcotest.failf + "commit pre-hash attack succeeded. pre-hash is \"%s\". backend \ + commit is %a." + (String.escaped commit_ph) + (Irmin.Type.pp S.Backend.Commit.Val.t) + commit_b; + + S.Backend.Repo.close repo + in + (* Test collisions with the empty node (and its commit), *) + let* () = run x (test @@ fun () -> S.Tree.empty () |> Lwt.return) in + (* with a length one node, *) + run x (test @@ fun () -> add_entries (S.Tree.empty ()) 1) >>= fun () -> + (* and with a length >256 node (which is the threshold for unstable inodes + in irmin pack). *) + run x (test @@ fun () -> add_entries (S.Tree.empty ()) 260) +end + +let suite' l ?(prefix = "") (_, x) = + let (module S) = Suite.store_generic_key x in + let module T = Make (S) in + (prefix ^ x.name, l) + +let when_ b x = if b then x else [] + +let suite sleep (speed, x) = + let (module S) = Suite.store_generic_key x in + let module Zzz = struct + let sleep = sleep + end in + let module T = Make (S) in + let module T_graph = Store_graph.Make (S) in + let module T_watch = Store_watch.Make (Log) (Zzz) (S) in + let with_tree_enabled = + (* Disabled for flakiness. See https://github.com/mirage/irmin/issues/1090. *) + not + (List.mem ~equal:String.equal (Suite.name x) + [ + "FS"; + "FS.UNIX"; + "GIT"; + "GIT.UNIX"; + "HTTP.FS"; + "HTTP.FS.UNIX"; + "HTTP.GIT"; + "HTTP.GIT.UNIX"; + ]) + in + suite' + ([ + ("High-level operations on trees", speed, T.test_trees x); + ("Basic operations on contents", speed, T.test_contents x); + ("Basic operations on nodes", speed, T.test_nodes x); + ("Basic operations on commits", speed, T.test_commits x); + ("Basic operations on branches", speed, T.test_branches x); + ("Hash operations on trees", speed, T.test_tree_hashes x); + ("Basic merge operations", speed, T.test_simple_merges x); + ("Test merges on tree updates", speed, T.test_merge_outdated_tree x); + ("Tree caches and hashconsing", speed, T.test_tree_caches x); + ("Tree proofs", speed, T.test_proofs x); + ("Complex histories", speed, T.test_history x); + ("Empty stores", speed, T.test_empty x); + ("Backend node manipulation", speed, T.test_backend_nodes x); + ("High-level store operations", speed, T.test_stores x); + ("High-level atomic store operations", speed, T.test_atomic x); + ("High-level store merges", speed, T.test_merge x); + ("Unrelated merges", speed, T.test_merge_unrelated x); + ("Low-level concurrency", speed, T.test_concurrent_low x); + ("Concurrent updates", speed, T.test_concurrent_updates x); + ("Concurrent head updates", speed, T.test_concurrent_head_updates x); + ("Concurrent merges", speed, T.test_concurrent_merges x); + ("Shallow objects", speed, T.test_shallow_objects x); + ("Closure with disconnected commits", speed, T.test_closure x); + ("Prehash collisions", speed, T.test_pre_hash_collisions x); + ] + @ when_ x.import_supported + [ + ("Basic operations on slices", speed, T.test_slice x); + ("High-level store synchronisation", speed, T.test_sync x); + ] + @ when_ with_tree_enabled + [ ("with_tree strategies", speed, T.test_with_tree x) ] + @ List.map (fun (n, test) -> ("Graph." ^ n, speed, test x)) T_graph.tests + @ List.map (fun (n, test) -> ("Watch." ^ n, speed, test x)) T_watch.tests) + (speed, x) + +let slow_suite (speed, x) = + let (module S) = Suite.store_generic_key x in + let module T = Make (S) in + suite' ~prefix:"SLOW_" + [ + ("Commit wide node", speed, T.test_commit_wide_node x); + ("Wide nodes", `Slow, T.test_wide_nodes x); + ] + (speed, x) + +let run name ?(slow = false) ?random_seed ~sleep ~misc tl = + let () = + match random_seed with + | Some x -> Random.init x + | None -> Random.self_init () + in + Printexc.record_backtrace true; + (* Ensure that failures occuring in async lwt threads are raised. *) + (Lwt.async_exception_hook := fun exn -> raise exn); + let tl1 = List.map (suite sleep) tl in + let tl1 = if slow then tl1 @ List.map slow_suite tl else tl1 in + Alcotest_lwt.run name (misc @ tl1) diff --git a/src/irmin-lwt/test/store.mli b/src/irmin-lwt/test/store.mli new file mode 100644 index 0000000000..57aeeb89dc --- /dev/null +++ b/src/irmin-lwt/test/store.mli @@ -0,0 +1,24 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +val run : + string -> + ?slow:bool -> + ?random_seed:int -> + sleep:(float -> unit Lwt.t) -> + misc:unit Alcotest_lwt.test list -> + (Alcotest.speed_level * Common.t) list -> + unit Lwt.t diff --git a/src/irmin-lwt/test/store_graph.ml b/src/irmin-lwt/test/store_graph.ml new file mode 100644 index 0000000000..c1b1c5b6d1 --- /dev/null +++ b/src/irmin-lwt/test/store_graph.ml @@ -0,0 +1,210 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Irmin = Irmin_lwt +open! Import +open Common + +module Make (S : Generic_key) = struct + include Common.Make_helpers (S) + + let test_iter x () = + let test repo = + let pp_id = Irmin.Type.pp S.Tree.kinded_key_t in + let eq_id = Irmin.Type.(unstage (equal S.Tree.kinded_key_t)) in + let mem k ls = List.exists (fun k' -> eq_id k k') ls in + let visited = ref [] in + let skipped = ref [] in + let rev_order oldest k = + if !visited = [] && not (eq_id k oldest) then + Alcotest.fail "traversal should start with oldest node" + in + let in_order oldest k = + if !visited = [] && eq_id k oldest then + Alcotest.fail "traversal shouldn't start with oldest node" + in + let node k = + if mem (`Node k) !visited then + Alcotest.failf "node %a visited twice" (Irmin.Type.pp B.Node.Key.t) k; + visited := `Node k :: !visited; + Lwt.return_unit + in + let contents ?order k = + let e = `Contents (k, S.Metadata.default) in + if mem e !visited then + Alcotest.failf "contents %a visited twice" + (Irmin.Type.pp B.Contents.Key.t) + k; + (match order with None -> () | Some f -> f e); + visited := e :: !visited; + Lwt.return_unit + in + let test_rev_order ~nodes ~max = + let oldest = List.hd nodes in + let contents = contents ~order:(rev_order oldest) in + let+ () = + Graph.iter (g repo) ~min:[] ~max ~node ~contents ~rev:true () + in + List.iter + (fun k -> + if not (mem k !visited) then + Alcotest.failf "%a should be visited" + (Irmin.Type.pp S.Tree.kinded_key_t) + k) + nodes + in + let test_in_order ~nodes ~max = + let oldest = List.hd nodes in + let contents = contents ~order:(in_order oldest) in + let+ () = + Graph.iter (g repo) ~min:[] ~max ~node ~contents ~rev:false () + in + List.iter + (fun k -> + if not (mem k !visited) then + Alcotest.failf "%a should be visited" pp_id k) + nodes + in + let test_skip ~max ~to_skip ~not_visited = + let skip_node k = + if mem (`Node k) to_skip then ( + skipped := `Node k :: !skipped; + Lwt.return_true) + else Lwt.return_false + in + let+ () = + Graph.iter (g repo) ~min:[] ~max ~node ~contents ~skip_node ~rev:false + () + in + List.iter + (fun k -> + if mem k !visited || not (mem k !skipped) then + Alcotest.failf "%a should be skipped" pp_id k) + to_skip; + List.iter + (fun k -> + if mem k !visited || mem k !skipped then + Alcotest.failf "%a should not be skipped nor visited" pp_id k) + not_visited + in + let test_min_max ~nodes ~min ~max ~not_visited = + Graph.iter (g repo) ~min ~max ~node ~contents ~rev:false () + >|= fun () -> + List.iter + (fun k -> + if mem k not_visited && mem k !visited then + Alcotest.failf "%a should not be visited" pp_id k; + if (not (mem k not_visited)) && not (mem k !visited) then + Alcotest.failf "%a should not be visited" pp_id k) + nodes + in + let test1 () = + let* foo = with_contents repo (fun c -> B.Contents.add c "foo") in + let foo_k = (foo, S.Metadata.default) in + let* k1 = with_node repo (fun g -> Graph.v g [ ("b", normal foo) ]) in + let* k2 = with_node repo (fun g -> Graph.v g [ ("a", `Node k1) ]) in + let* k3 = with_node repo (fun g -> Graph.v g [ ("c", `Node k1) ]) in + let nodes = [ `Contents foo_k; `Node k1; `Node k2; `Node k3 ] in + visited := []; + test_rev_order ~nodes ~max:[ k2; k3 ] >>= fun () -> + visited := []; + test_in_order ~nodes ~max:[ k2; k3 ] >>= fun () -> + visited := []; + skipped := []; + test_skip ~max:[ k2; k3 ] ~to_skip:[ `Node k1 ] ~not_visited:[] + >>= fun () -> + visited := []; + let* () = + test_min_max ~nodes ~min:[ k1 ] ~max:[ k2 ] + ~not_visited:[ `Contents foo_k; `Node k3 ] + in + visited := []; + test_min_max ~nodes ~min:[ k2; k3 ] ~max:[ k2; k3 ] + ~not_visited:[ `Contents foo_k; `Node k1 ] + in + let test2 () = + (* Graph.iter requires a node as max, we cannot test a graph with only + contents. *) + let* foo = with_contents repo (fun c -> B.Contents.add c "foo") in + let foo_k = (foo, S.Metadata.default) in + let* k1 = with_node repo (fun g -> Graph.v g [ ("b", normal foo) ]) in + visited := []; + test_rev_order ~nodes:[ `Contents foo_k; `Node k1 ] ~max:[ k1 ] + >>= fun () -> + visited := []; + skipped := []; + test_skip ~max:[ k1 ] + ~to_skip:[ `Node k1 ] + ~not_visited:[ `Contents foo_k ] + in + let test3 () = + let* foo = with_contents repo (fun c -> B.Contents.add c "foo") in + let foo_k = (foo, S.Metadata.default) in + let* kb1 = with_node repo (fun g -> Graph.v g [ ("b1", normal foo) ]) in + let* ka1 = with_node repo (fun g -> Graph.v g [ ("a1", `Node kb1) ]) in + let* ka2 = with_node repo (fun g -> Graph.v g [ ("a2", `Node kb1) ]) in + let* kb2 = with_node repo (fun g -> Graph.v g [ ("b2", normal foo) ]) in + let* kc = + with_node repo (fun g -> + Graph.v g + [ ("c1", `Node ka1); ("c2", `Node ka2); ("c3", `Node kb2) ]) + in + let nodes = + [ + `Contents foo_k; + `Node kb1; + `Node ka1; + `Node ka2; + `Node kb2; + `Node kc; + ] + in + visited := []; + test_rev_order ~nodes ~max:[ kc ] >>= fun () -> + visited := []; + test_in_order ~nodes ~max:[ kc ] >>= fun () -> + visited := []; + skipped := []; + let* () = + test_skip ~max:[ kc ] + ~to_skip:[ `Node ka1; `Node ka2 ] + ~not_visited:[ `Node kb1 ] + in + visited := []; + skipped := []; + let* () = + test_skip ~max:[ kc ] + ~to_skip:[ `Node ka1; `Node ka2; `Node kb2 ] + ~not_visited:[ `Node kb1; `Contents foo_k ] + in + visited := []; + let* () = + test_min_max ~nodes ~min:[ kb1 ] ~max:[ ka1 ] + ~not_visited:[ `Contents foo_k; `Node ka2; `Node kb2; `Node kc ] + in + visited := []; + test_min_max ~nodes ~min:[ kc ] ~max:[ kc ] + ~not_visited: + [ `Contents foo_k; `Node kb1; `Node ka1; `Node ka2; `Node kb2 ] + in + test1 () >>= fun () -> + test2 () >>= fun () -> + test3 () >>= fun () -> B.Repo.close repo + in + run x test + + let tests = [ ("Iter", test_iter) ] +end diff --git a/src/irmin-lwt/test/store_graph.mli b/src/irmin-lwt/test/store_graph.mli new file mode 100644 index 0000000000..5e5cf9415e --- /dev/null +++ b/src/irmin-lwt/test/store_graph.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make : Common.Store_tests diff --git a/src/irmin-lwt/test/store_watch.ml b/src/irmin-lwt/test/store_watch.ml new file mode 100644 index 0000000000..b733d98e9c --- /dev/null +++ b/src/irmin-lwt/test/store_watch.ml @@ -0,0 +1,380 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Irmin = Irmin_lwt +open! Import +open Common + +module type Sleep = sig + val sleep : float -> unit Lwt.t +end + +module Make (Log : Logs.LOG) (Zzz : Sleep) (S : Generic_key) = struct + include Common.Make_helpers (S) + + let sleep ?(sleep_t = 0.01) () = + let sleep_t = min sleep_t 1. in + Lwt.pause () >>= fun () -> Zzz.sleep sleep_t + + let now_s () = Mtime.span_to_s (Mtime_clock.elapsed ()) + + (* Re-apply [f] at intervals of [sleep_t] while [f] raises exceptions and + [while_ ()] holds. *) + let retry ?(timeout = 15.) ?(sleep_t = 0.) ~while_ fn = + let sleep_t = max sleep_t 0.001 in + let t = now_s () in + let str i = Fmt.str "%d, %.3fs" i (now_s () -. t) in + let rec aux i = + if now_s () -. t > timeout || not (while_ ()) then fn (str i); + try + fn (str i); + Lwt.return_unit + with ex -> + [%log.debug "retry ex: %s" (Printexc.to_string ex)]; + let sleep_t = sleep_t *. (1. +. (float i ** 2.)) in + sleep ~sleep_t () >>= fun () -> + [%log.debug "Test.retry %s" (str i)]; + aux (i + 1) + in + aux 0 + + let test_watch_exn x () = + let test repo = + let* t = S.main repo in + let* h = S.Head.find t in + let key = [ "a" ] in + let v1 = "bar" in + let v2 = "foo" in + let r = ref 0 in + let eq = Irmin.Type.(unstage (equal (Irmin.Diff.t (S.commit_t repo)))) in + let old_head = ref h in + let check x = + let+ h2 = S.Head.get t in + match !old_head with + | None -> if eq (`Added h2) x then incr r + | Some h -> if eq (`Updated (h, h2)) x then incr r + in + let* u = + S.watch ?init:h t (fun v -> check v >|= fun () -> failwith "test") + in + let* v = + S.watch ?init:h t (fun v -> check v >>= fun () -> Lwt.fail_with "test") + in + let* w = S.watch ?init:h t (fun v -> check v) in + S.set_exn t ~info:(infof "update") key v1 >>= fun () -> + let* () = + retry + ~while_:(fun () -> !r < 3) + (fun n -> Alcotest.(check int) ("watch 1 " ^ n) 3 !r) + in + let* h = S.Head.find t in + old_head := h; + S.set_exn t ~info:(infof "update") key v2 >>= fun () -> + let* () = + retry + ~while_:(fun () -> !r < 6) + (fun n -> Alcotest.(check int) ("watch 2 " ^ n) 6 !r) + in + S.unwatch u >>= fun () -> + S.unwatch v >>= fun () -> + S.unwatch w >>= fun () -> + let* h = S.Head.get t in + old_head := Some h; + let* u = + S.watch_key ~init:h t key (fun _ -> + incr r; + failwith "test") + in + let* v = + S.watch_key ~init:h t key (fun _ -> + incr r; + Lwt.fail_with "test") + in + let* w = + S.watch_key ~init:h t key (fun _ -> + incr r; + Lwt.return_unit) + in + S.set_exn t ~info:(infof "update") key v1 >>= fun () -> + let* () = + retry + ~while_:(fun () -> !r < 9) + (fun n -> Alcotest.(check int) ("watch 3 " ^ n) 9 !r) + in + S.set_exn t ~info:(infof "update") key v2 >>= fun () -> + let* () = + retry + ~while_:(fun () -> !r < 12) + (fun n -> Alcotest.(check int) ("watch 4 " ^ n) 12 !r) + in + S.unwatch u >>= fun () -> + S.unwatch v >>= fun () -> + S.unwatch w >>= fun () -> + Alcotest.(check unit) "ok!" () (); + B.Repo.close repo + in + run x test + + let test_watches x () = + let pp_w ppf (p, w) = Fmt.pf ppf "%d/%d" p w in + let pp_s ppf = function + | None -> Fmt.string ppf "*" + | Some w -> pp_w ppf (w ()) + in + let check_workers msg p w = + match x.stats with + | None -> Lwt.return_unit + | Some stats -> + retry + ~while_:(fun _ -> true) + (fun s -> + let got = stats () in + let exp = (p, w) in + let msg = Fmt.str "workers: %s %a (%s)" msg pp_w got s in + if got = exp then line msg + else ( + [%log.debug + "check-worker: expected %a, got %a" pp_w exp pp_w got]; + Alcotest.failf "%s: %a / %a" msg pp_w got pp_w exp)) + in + let module State = struct + type t = { + mutable adds : int; + mutable updates : int; + mutable removes : int; + } + + let pp ppf { adds; updates; removes } = + Fmt.pf ppf "{ adds=%d; updates=%d; removes=%d }" adds updates removes + + let empty () = { adds = 0; updates = 0; removes = 0 } + + let add t = + [%log.debug "add %a" pp t]; + t.adds <- t.adds + 1 + + let update t = + [%log.debug "update %a" pp t]; + t.updates <- t.updates + 1 + + let remove t = + [%log.debug "remove %a" pp t]; + t.removes <- t.removes + 1 + + let pretty ppf t = Fmt.pf ppf "%d/%d/%d" t.adds t.updates t.removes + let xpp ppf (a, u, r) = Fmt.pf ppf "%d/%d/%d" a u r + let xadd (a, u, r) = (a + 1, u, r) + let xupdate (a, u, r) = (a, u + 1, r) + let xremove (a, u, r) = (a, u, r + 1) + + let less_than a b = + a.adds <= b.adds + && a.updates <= b.updates + && a.removes <= b.removes + && not (a = b) + + let check ?sleep_t msg (p, w) (a_adds, a_updates, a_removes) b = + let a = { adds = a_adds; updates = a_updates; removes = a_removes } in + check_workers msg p w >>= fun () -> + retry ?sleep_t + ~while_:(fun () -> less_than b a (* While [b] converges toward [a] *)) + (fun s -> + let msg = Fmt.str "state: %s (%s)" msg s in + if a = b then line msg + else Alcotest.failf "%s: %a / %a" msg pp a pp b) + + let process ?sleep_t t head = + let* () = + match sleep_t with None -> Lwt.return_unit | Some s -> Zzz.sleep s + in + let () = + match head with + | `Added _ -> add t + | `Updated _ -> update t + | `Removed _ -> remove t + in + Lwt.return_unit + + let apply msg state kind fn ?(first = false) on s n = + let msg mode n w s = + let kind = + match kind with + | `Add -> "add" + | `Update -> "update" + | `Remove -> "remove" + in + let mode = + match mode with `Pre -> "[pre-condition]" | `Post -> "" + in + Fmt.str "%s %s %s %d on=%b expected=%a:%a current=%a:%a" mode msg kind + n on xpp s pp_w w pretty state pp_s x.stats + in + let check mode n w s = check (msg mode n w s) w s state in + let incr = + match kind with + | `Add -> xadd + | `Update -> xupdate + | `Remove -> xremove + in + let rec aux pre = function + | 0 -> Lwt.return_unit + | i -> + let pre_w = + if on then (1, if i = n && first then 0 else 1) else (0, 0) + in + let post_w = if on then (1, 1) else (0, 0) in + let post = if on then incr pre else pre in + (* check pre-condition *) + check `Pre (n - i) pre_w pre >>= fun () -> + [%log.debug "[waiting for] %s" (msg `Post (n - i) post_w post)]; + fn (n - i) >>= fun () -> + (* check post-condition *) + check `Post (n - i) post_w post >>= fun () -> aux post (i - 1) + in + aux s n + end in + let test repo1 = + let* t1 = S.main repo1 in + let* repo = S.Repo.v x.config in + let* t2 = S.main repo in + [%log.debug "WATCH"]; + let state = State.empty () in + let sleep_t = 0.02 in + let process = State.process ~sleep_t state in + let stops_0 = ref [] in + let stops_1 = ref [] in + let rec watch = function + | 0 -> Lwt.return_unit + | n -> + let t = if n mod 2 = 0 then t1 else t2 in + let* s = S.watch t process in + if n mod 2 = 0 then stops_0 := s :: !stops_0 + else stops_1 := s :: !stops_1; + watch (n - 1) + in + let v1 = "X1" in + let v2 = "X2" in + S.set_exn t1 ~info:(infof "update") [ "a"; "b" ] v1 >>= fun () -> + S.Branch.remove repo1 S.Branch.main >>= fun () -> + State.check "init" (0, 0) (0, 0, 0) state >>= fun () -> + watch 100 >>= fun () -> + State.check "watches on" (1, 0) (0, 0, 0) state >>= fun () -> + S.set_exn t1 ~info:(infof "update") [ "a"; "b" ] v1 >>= fun () -> + State.check "watches adds" (1, 1) (100, 0, 0) state >>= fun () -> + S.set_exn t2 ~info:(infof "update") [ "a"; "c" ] v1 >>= fun () -> + State.check "watches updates" (1, 1) (100, 100, 0) state >>= fun () -> + S.Branch.remove repo S.Branch.main >>= fun () -> + State.check "watches removes" (1, 1) (100, 100, 100) state >>= fun () -> + Lwt_list.iter_s (fun f -> S.unwatch f) !stops_0 >>= fun () -> + S.set_exn t2 ~info:(infof "update") [ "a" ] v1 >>= fun () -> + State.check "watches half off" (1, 1) (150, 100, 100) state >>= fun () -> + Lwt_list.iter_s (fun f -> S.unwatch f) !stops_1 >>= fun () -> + S.set_exn t1 ~info:(infof "update") [ "a" ] v2 >>= fun () -> + State.check "watches off" (0, 0) (150, 100, 100) state >>= fun () -> + [%log.debug "WATCH-ALL"]; + let state = State.empty () in + let* head = r1 ~repo in + let add = + State.apply "branch-watch-all" state `Add (fun n -> + let tag = Fmt.str "t%d" n in + S.Branch.set repo tag head) + in + let remove = + State.apply "branch-watch-all" state `Remove (fun n -> + let tag = Fmt.str "t%d" n in + S.Branch.remove repo tag) + in + let* main = S.Branch.get repo "main" in + let* u = + S.Branch.watch_all + ~init:[ ("main", main) ] + repo + (fun _ -> State.process state) + in + add true (0, 0, 0) 10 ~first:true >>= fun () -> + remove true (10, 0, 0) 5 >>= fun () -> + S.unwatch u >>= fun () -> + add false (10, 0, 5) 4 >>= fun () -> + remove false (10, 0, 5) 4 >>= fun () -> + [%log.debug "WATCH-KEY"]; + let state = State.empty () in + let path1 = [ "a"; "b"; "c" ] in + let path2 = [ "a"; "d" ] in + let path3 = [ "a"; "b"; "d" ] in + let add = + State.apply "branch-key" state `Add (fun _ -> + let v = "" in + S.set_exn t1 ~info:(infof "set1") path1 v >>= fun () -> + S.set_exn t1 ~info:(infof "set2") path2 v >>= fun () -> + S.set_exn t1 ~info:(infof "set3") path3 v >>= fun () -> + Lwt.return_unit) + in + let update = + State.apply "branch-key" state `Update (fun n -> + let v = string_of_int n in + S.set_exn t2 ~info:(infof "update1") path1 v >>= fun () -> + S.set_exn t2 ~info:(infof "update2") path2 v >>= fun () -> + S.set_exn t2 ~info:(infof "update3") path3 v >>= fun () -> + Lwt.return_unit) + in + let remove = + State.apply "branch-key" state `Remove (fun _ -> + S.remove_exn t1 ~info:(infof "remove1") path1 >>= fun () -> + S.remove_exn t1 ~info:(infof "remove2") path2 >>= fun () -> + S.remove_exn t1 ~info:(infof "remove3") path3 >>= fun () -> + Lwt.return_unit) + in + S.remove_exn t1 ~info:(infof "clean") [] >>= fun () -> + let* init = S.Head.get t1 in + let* u = S.watch_key t1 ~init path1 (State.process state) in + add true (0, 0, 0) 1 ~first:true >>= fun () -> + update true (1, 0, 0) 10 >>= fun () -> + remove true (1, 10, 0) 1 >>= fun () -> + S.unwatch u >>= fun () -> + add false (1, 10, 1) 3 >>= fun () -> + update false (1, 10, 1) 5 >>= fun () -> + remove false (1, 10, 1) 4 >>= fun () -> + [%log.debug "WATCH-MORE"]; + let state = State.empty () in + let update = + State.apply "watch-more" state `Update (fun n -> + let v = string_of_int n in + let path1 = [ "a"; "b"; "c"; string_of_int n; "1" ] in + let path2 = [ "a"; "x"; "c"; string_of_int n; "1" ] in + let path3 = [ "a"; "y"; "c"; string_of_int n; "1" ] in + S.set_exn t2 ~info:(infof "update1") path1 v >>= fun () -> + S.set_exn t2 ~info:(infof "update2") path2 v >>= fun () -> + S.set_exn t2 ~info:(infof "update3") path3 v >>= fun () -> + Lwt.return_unit) + in + S.remove_exn t1 ~info:(infof "remove") [ "a" ] >>= fun () -> + S.set_exn t1 ~info:(infof "prepare") [ "a"; "b"; "c" ] "" >>= fun () -> + let* h = S.Head.get t1 in + let* u = S.watch_key t2 ~init:h [ "a"; "b" ] (State.process state) in + update true (0, 0, 0) 10 ~first:true >>= fun () -> + S.unwatch u >>= fun () -> + update false (0, 10, 0) 10 >>= fun () -> + B.Repo.close repo >>= fun () -> B.Repo.close repo1 + in + run x test + + let tests = + (* [test_watches] has been disabled for being flaky. + TODO: work out why, fix it, and re-enable it. + See https://github.com/mirage/irmin/issues/1447. *) + let _ = ("Basic operations", test_watches) in + [ ("Callbacks and exceptions", test_watch_exn) ] +end diff --git a/src/irmin-lwt/test/store_watch.mli b/src/irmin-lwt/test/store_watch.mli new file mode 100644 index 0000000000..52f253c7bb --- /dev/null +++ b/src/irmin-lwt/test/store_watch.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2013-2022 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Make (_ : Logs.LOG) (_ : Common.Sleep) : Common.Store_tests diff --git a/src/irmin-lwt/tezos/dune b/src/irmin-lwt/tezos/dune new file mode 100644 index 0000000000..1f2e1ac06d --- /dev/null +++ b/src/irmin-lwt/tezos/dune @@ -0,0 +1,13 @@ +(library + (name irmin_lwt_tezos) + (public_name irmin-lwt-tezos) + (libraries + irmin + irmin-pack + irmin-pack.io + irmin-pack.unix + irmin-tezos + irmin-lwt + irmin-lwt-pack + lwt + lwt_eio)) diff --git a/src/irmin-lwt/tezos/irmin_lwt_tezos.ml b/src/irmin-lwt/tezos/irmin_lwt_tezos.ml new file mode 100644 index 0000000000..3e0aace335 --- /dev/null +++ b/src/irmin-lwt/tezos/irmin_lwt_tezos.ml @@ -0,0 +1,69 @@ +(* + * Copyright (c) 2018-2022 Tarides + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** Lwt-typed Tezos schema + pack store. + + The Tezos schema ([Irmin_tezos.Schema]) is already Eio-typed and includes + Tezos-specific customizations (BLAKE2B hash with Base58 prefix, V1 + pre-hashing for Node / Commit / Contents). We use it directly as + [Schema_eio] in [Wrap_store.Make] -- bypassing [Lwt_to_eio.Schema_extended], + which would otherwise replace the V1 pre-hashing with the default + [Generic_key.Make] -- and construct a parallel Lwt-side [Schema] reusing the + pure modules and bridging the Metadata / Contents merges. *) + +module Conf = Irmin_tezos.Conf + +(* The Tezos Eio-side Schema_eio_tezos. Aliased as a private module here; the + re-export at the bottom of the file (after [Wrap_store.Make]'s [Schema = + Schema_lwt]) cannot live alongside it. *) +module Schema_eio_tezos = Irmin_tezos.Schema +module Inner_maker = Irmin_pack_unix.Maker (Conf) +module Inner = Inner_maker.Make (Schema_eio_tezos) + +(* Lwt-side Schema_eio_tezos.S parallel to [Irmin_tezos.Schema]. The pure modules + (Hash / Branch / Info / Path) are reused directly because their module + types have no Lwt.t. Metadata and Contents are bridged. *) +module Schema_lwt = struct + module Hash = Schema_eio_tezos.Hash + module Branch = Schema_eio_tezos.Branch + module Info = Schema_eio_tezos.Info + module Path = Schema_eio_tezos.Path + + module Metadata = struct + type t = Schema_eio_tezos.Metadata.t + + let t = Schema_eio_tezos.Metadata.t + let default = Schema_eio_tezos.Metadata.default + + let merge = + Irmin_lwt.Lwt_to_eio.merge_of_eio Schema_eio_tezos.Metadata.t + Schema_eio_tezos.Metadata.merge + end + + module Contents = struct + type t = Schema_eio_tezos.Contents.t + + let t = Schema_eio_tezos.Contents.t + + let merge = + Irmin_lwt.Lwt_to_eio.merge_of_eio + Irmin.Type.(option Schema_eio_tezos.Contents.t) + Schema_eio_tezos.Contents.merge + end +end + +include Irmin_lwt.Wrap_store.Make (Schema_lwt) (Schema_eio_tezos) (Inner) diff --git a/test/irmin-lwt-chunk/dune b/test/irmin-lwt-chunk/dune new file mode 100644 index 0000000000..42430432da --- /dev/null +++ b/test/irmin-lwt-chunk/dune @@ -0,0 +1,12 @@ +(test + (name test) + (libraries + irmin + irmin-lwt + irmin-lwt-chunk + irmin-lwt-mem + irmin-lwt-test + lwt + lwt_eio + eio_main + unix)) diff --git a/test/irmin-lwt-chunk/test.ml b/test/irmin-lwt-chunk/test.ml new file mode 100644 index 0000000000..8b40dd9421 --- /dev/null +++ b/test/irmin-lwt-chunk/test.ml @@ -0,0 +1,77 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** End-to-end smoke test for irmin-lwt-chunk. + + Combines [Irmin_lwt_chunk.Content_addressable] (chunking layer) with + [Irmin_lwt_mem]'s Append_only and Atomic_write makers to build a Lwt-typed + chunked KV store. The chunking is exercised by writing a value larger than + the default chunk size threshold. *) + +module CA = Irmin_lwt_chunk.Content_addressable (Irmin_lwt_mem.Append_only) +module Chunk_maker = Irmin_lwt.Maker (CA) (Irmin_lwt_mem.Atomic_write) +module S = Irmin_lwt.KV_maker (CA) (Irmin_lwt_mem.Atomic_write) +module Store = S.Make (Irmin_lwt.Contents.String) +module Irmin_test = Irmin_lwt_test.Irmin_test +open Lwt.Syntax + +let info ?(author = "test") msg = + Store.Info.v ~author ~message:msg (Int64.of_float (Unix.gettimeofday ())) + +let test_basic () = + let config = + Irmin_lwt_chunk.config ~size:512 ~min_size:131 (Irmin_lwt_mem.config ()) + in + let* repo = Store.Repo.v config in + let* t = Store.main repo in + let small = "abc" in + let big = String.make 5000 'x' in + let* () = Store.set_exn t [ "small" ] small ~info:(fun () -> info "small") in + let* () = Store.set_exn t [ "big" ] big ~info:(fun () -> info "big") in + let* small' = Store.get t [ "small" ] in + let* big' = Store.get t [ "big" ] in + assert (small = small'); + assert (big = big'); + Store.Repo.close repo + +let run name f = + Printf.printf "%-30s " name; + flush stdout; + Lwt_eio.Promise.await_lwt (f ()); + print_endline "ok" + +let () = + Eio_main.run @@ fun env -> + Eio.Switch.run @@ fun sw -> + Irmin.Backend.Watch.set_watch_switch sw; + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> + run "chunked set/get small+big" test_basic; + print_endline "--- running irmin-lwt-test harness ---"; + let suite = + let store = + Irmin_test.store (module Chunk_maker) (module Irmin_lwt.Metadata.None) + in + let init ~config:_ = Lwt.return_unit in + let config = + Irmin_lwt_chunk.config ~size:512 ~min_size:131 (Irmin_lwt_mem.config ()) + in + Irmin_test.Suite.create ~name:"CHUNK" ~init ~store ~config () + in + Lwt_eio.Promise.await_lwt + (Irmin_test.Store.run "irmin-lwt-chunk" ~slow:false ~misc:[] + ~sleep:Lwt_unix.sleep + [ (`Quick, suite) ]); + print_endline "irmin-lwt-chunk: all tests passed" diff --git a/test/irmin-lwt-client/dune b/test/irmin-lwt-client/dune new file mode 100644 index 0000000000..faf05da6cd --- /dev/null +++ b/test/irmin-lwt-client/dune @@ -0,0 +1,16 @@ +(test + (name test) + (libraries + irmin + irmin.mem + irmin-lwt + irmin-lwt-client + irmin-server + irmin-server.unix + mirage-crypto-rng + mirage-crypto-rng.unix + lwt + lwt_eio + eio + eio_main + unix)) diff --git a/test/irmin-lwt-client/test.ml b/test/irmin-lwt-client/test.ml new file mode 100644 index 0000000000..1983e6415b --- /dev/null +++ b/test/irmin-lwt-client/test.ml @@ -0,0 +1,76 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** End-to-end smoke test for irmin-lwt-client. + + Spawns an [Irmin_server] in an Eio fiber listening on a Unix-domain socket, + then uses the Lwt-typed [Irmin_lwt_client] to connect and do basic set/get + operations over the wire. *) + +let () = Mirage_crypto_rng_unix.use_default () + +(* The server uses an in-memory Irmin store; the client mirrors its Schema + via [Irmin_lwt_client.Make (Irmin_lwt.Contents.String)]. *) +module Server_store = Irmin_mem.KV.Make (Irmin.Contents.String) +module Server = Irmin_server_unix.Make (Server_store) +module Client = Irmin_lwt_client.Make (Irmin_lwt.Contents.String) +open Lwt.Syntax + +let info ?(author = "test") msg = + Client.Info.v ~author ~message:msg (Int64.of_float (Unix.gettimeofday ())) + +let with_server ~sw ~clock f = + let dir = Unix.getcwd () in + let sock = Filename.concat dir "test-lwt-client.sock" in + (try Unix.unlink sock with _ -> ()); + let uri = Uri.of_string ("unix://" ^ sock) in + let stop, set_stop = Lwt.wait () in + Eio.Switch.on_release sw (fun () -> Lwt.wakeup_later set_stop ()); + Eio.Fiber.fork_daemon ~sw (fun () -> + let spec = Irmin.Backend.Conf.Spec.v "Unix_domain" in + let key = Irmin.Backend.Conf.root spec in + let conf = Irmin.Backend.Conf.singleton spec key "Unix_domain" in + Lwt_eio.run_lwt (fun () -> + let open Lwt.Infix in + Server.v ~uri conf >>= Server.serve ~stop); + `Stop_daemon); + Eio.Time.sleep clock 0.2; + f uri + +let test_set_get uri = + let* repo = Client.connect uri in + let* t = Client.main repo in + let* () = Client.set_exn t [ "k" ] "v" ~info:(fun () -> info "k") in + let* v = Client.get t [ "k" ] in + assert (v = "v"); + let* found = Client.find t [ "k" ] in + assert (found = Some "v"); + Client.close repo + +let run name f = + Printf.printf "%-30s " name; + flush stdout; + Lwt_eio.Promise.await_lwt (f ()); + print_endline "ok" + +let () = + Eio_main.run @@ fun env -> + Eio.Switch.run @@ fun sw -> + let clock = env#clock in + Lwt_eio.with_event_loop ~clock @@ fun _ -> + with_server ~sw ~clock @@ fun uri -> + run "set/get over Unix socket" (fun () -> test_set_get uri); + print_endline "irmin-lwt-client: smoke test passed" diff --git a/test/irmin-lwt-containers/dune b/test/irmin-lwt-containers/dune new file mode 100644 index 0000000000..d146f96678 --- /dev/null +++ b/test/irmin-lwt-containers/dune @@ -0,0 +1,13 @@ +(test + (name test) + (libraries + irmin + irmin-lwt + irmin-lwt-mem + irmin-lwt-containers + lwt + lwt_eio + eio_main + unix) + (preprocess + (pps ppx_irmin))) diff --git a/test/irmin-lwt-containers/test.ml b/test/irmin-lwt-containers/test.ml new file mode 100644 index 0000000000..81422be32f --- /dev/null +++ b/test/irmin-lwt-containers/test.ml @@ -0,0 +1,74 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** End-to-end smoke test for irmin-lwt-containers. + + Exercises Counter, Lww_register and Blob_log on top of [Irmin_lwt_mem]. *) + +open Lwt.Syntax + +let path = [ "k" ] + +let test_counter () = + let module C = Irmin_lwt_containers.Counter.Mem in + let* repo = C.Store.Repo.v (Irmin_lwt_mem.config ()) in + let* t = C.Store.main repo in + let* () = C.inc ~by:5L ~path t in + let* () = C.inc ~by:3L ~path t in + let* () = C.dec ~by:1L ~path t in + let* v = C.read ~path t in + assert (v = 7L); + C.Store.Repo.close repo + +let test_lww_register () = + let module L = Irmin_lwt_containers.Lww_register.Mem (struct + type t = string [@@deriving irmin] + end) in + let* repo = L.Store.Repo.v (Irmin_lwt_mem.config ()) in + let* t = L.Store.main repo in + let* () = L.write ~path t "first" in + let* () = L.write ~path t "second" in + let* v = L.read ~path t in + assert (v = Some "second"); + L.Store.Repo.close repo + +let test_blob_log () = + let module B = Irmin_lwt_containers.Blob_log.Mem (struct + type t = string [@@deriving irmin] + end) in + let* repo = B.Store.Repo.v (Irmin_lwt_mem.config ()) in + let* t = B.Store.main repo in + let* () = B.append ~path t "a" in + let* () = B.append ~path t "b" in + let* () = B.append ~path t "c" in + let* l = B.read_all ~path t in + (* entries are stored newest-first *) + assert (l = [ "c"; "b"; "a" ]); + B.Store.Repo.close repo + +let run name f = + Printf.printf "%-30s " name; + flush stdout; + Lwt_eio.Promise.await_lwt (f ()); + print_endline "ok" + +let () = + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> + run "Counter" test_counter; + run "Lww_register" test_lww_register; + run "Blob_log" test_blob_log; + print_endline "irmin-lwt-containers: all smoke tests passed" diff --git a/test/irmin-lwt-fs/dune b/test/irmin-lwt-fs/dune new file mode 100644 index 0000000000..49ee711829 --- /dev/null +++ b/test/irmin-lwt-fs/dune @@ -0,0 +1,12 @@ +(test + (name test) + (libraries + irmin + irmin-lwt + irmin-lwt-fs + irmin-lwt-test + irmin-watcher + lwt + lwt_eio + eio_main + unix)) diff --git a/test/irmin-lwt-fs/test.ml b/test/irmin-lwt-fs/test.ml new file mode 100644 index 0000000000..a700f6f377 --- /dev/null +++ b/test/irmin-lwt-fs/test.ml @@ -0,0 +1,130 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** End-to-end smoke test for the Lwt-over-Eio shim, fs (Unix) backend. + + Exercises the chain user code (Lwt) -> Irmin_lwt -> Irmin_lwt_fs -> + Irmin_fs_unix (Eio): writes / reads / commits / branches / persistence on a + filesystem-backed store rooted in a temporary directory. *) + +module S = Irmin_lwt_fs.KV.Make (Irmin_lwt.Contents.String) +open Lwt.Syntax + +let info ?(author = "test") msg = + S.Info.v ~author ~message:msg (Int64.of_float (Unix.gettimeofday ())) + +let test_basic_set_get config = + let* repo = S.Repo.v config in + let* t = S.main repo in + let* () = S.set_exn t [ "a"; "b" ] "1" ~info:(fun () -> info "set a/b") in + let* v = S.get t [ "a"; "b" ] in + assert (v = "1"); + let* found = S.find t [ "a"; "b" ] in + assert (found = Some "1"); + let* missing = S.find t [ "x" ] in + assert (missing = None); + S.Repo.close repo + +let test_branch_and_commit config = + let* repo = S.Repo.v config in + let* t = S.main repo in + let* () = S.set_exn t [ "k" ] "v0" ~info:(fun () -> info "init") in + let* head0 = S.Head.get t in + let* () = S.set_exn t [ "k" ] "v1" ~info:(fun () -> info "update") in + let* head1 = S.Head.get t in + let hash_eq = Irmin.Type.(unstage (equal S.Hash.t)) in + assert (not (hash_eq (S.Commit.hash head0) (S.Commit.hash head1))); + let* dev = S.of_branch repo "dev" in + let* () = S.set_exn dev [ "k" ] "branch" ~info:(fun () -> info "branch") in + let* main_v = S.get t [ "k" ] in + let* dev_v = S.get dev [ "k" ] in + assert (main_v = "v1"); + assert (dev_v = "branch"); + S.Repo.close repo + +let test_persistence config = + let* repo = S.Repo.v config in + let* t = S.main repo in + let* () = S.set_exn t [ "p" ] "persisted" ~info:(fun () -> info "p") in + let* () = S.Repo.close repo in + let* repo = S.Repo.v config in + let* t = S.main repo in + let* v = S.get t [ "p" ] in + assert (v = "persisted"); + S.Repo.close repo + +let run name f = + Printf.printf "%-30s " name; + flush stdout; + Lwt_eio.Promise.await_lwt (f ()); + print_endline "ok" + +let with_tmp_dir env f = + let fs = Eio.Stdenv.fs env in + let base = try Sys.getenv "TMPDIR" with Not_found -> "/tmp" in + let name = + Printf.sprintf "irmin-lwt-fs-test-%d-%d" (Unix.getpid ()) (Random.bits ()) + in + let path = Filename.concat base name in + let cleanup () = + try + let cmd = Printf.sprintf "rm -rf %s" (Filename.quote path) in + ignore (Sys.command cmd) + with _ -> () + in + Fun.protect ~finally:cleanup (fun () -> f ~fs ~path) + +module Irmin_test = Irmin_lwt_test.Irmin_test + +(* Bridge [Irmin_watcher.hook] (Lwt-typed) to [Irmin.Backend.Watch.hook] + (Eio direct-style). Required by the harness Watch test on filesystem + backends. *) +let bridged_listen_dir_hook : Irmin.Backend.Watch.hook = + fun id path f -> + let f_lwt s = Lwt_eio.run_eio (fun () -> f s) in + let unhook_lwt = + Lwt_eio.Promise.await_lwt (Irmin_watcher.hook id path f_lwt) + in + fun () -> Lwt_eio.Promise.await_lwt (unhook_lwt ()) + +let suite_for config = + let store = + Irmin_test.store (module Irmin_lwt_fs) (module Irmin_lwt.Metadata.None) + in + let init ~config:_ = Lwt.return_unit in + Irmin_test.Suite.create ~name:"FS" ~init ~store ~config () + +let () = + Eio_main.run @@ fun env -> + Eio.Switch.run @@ fun sw -> + Irmin.Backend.Watch.set_watch_switch sw; + Irmin.Backend.Watch.set_listen_dir_hook bridged_listen_dir_hook; + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> + with_tmp_dir env @@ fun ~fs ~path -> + let config_at sub = + Irmin_lwt_fs.config + ~root:Eio.Path.(fs / Filename.concat path sub) + ~clock:env#clock + in + run "basic set/get" (fun () -> test_basic_set_get (config_at "a")); + run "branch and commit" (fun () -> test_branch_and_commit (config_at "b")); + run "persistence across reopen" (fun () -> test_persistence (config_at "c")); + print_endline "--- running irmin-lwt-test harness ---"; + Lwt_eio.Promise.await_lwt + (Irmin_test.Store.run "irmin-lwt-fs" ~slow:false ~misc:[] + ~sleep:Lwt_unix.sleep + [ (`Quick, suite_for (config_at "harness")) ]); + print_endline "irmin-lwt-fs: all smoke tests + harness passed" diff --git a/test/irmin-lwt-git/dune b/test/irmin-lwt-git/dune new file mode 100644 index 0000000000..38fae714f5 --- /dev/null +++ b/test/irmin-lwt-git/dune @@ -0,0 +1,12 @@ +(test + (name test) + (libraries + irmin + irmin-lwt + irmin-lwt-git + irmin-git + irmin-lwt-test + lwt + lwt_eio + eio_main + unix)) diff --git a/test/irmin-lwt-git/test.ml b/test/irmin-lwt-git/test.ml new file mode 100644 index 0000000000..30b4576ec3 --- /dev/null +++ b/test/irmin-lwt-git/test.ml @@ -0,0 +1,94 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** End-to-end smoke test for irmin-lwt-git on the in-memory variant. + + Exercises the chain user code (Lwt) -> Irmin_lwt -> Irmin_lwt_git -> + Irmin_git (Eio) on top of the in-memory Git store [Irmin_git.Mem]. *) + +module S = Irmin_lwt_git.Mem.KV (Irmin_lwt.Contents.String) +module Irmin_test = Irmin_lwt_test.Irmin_test +open Lwt.Syntax + +let info ?(author = "test") msg = + S.Info.v ~author ~message:msg (Int64.of_float (Unix.gettimeofday ())) + +let test_basic_set_get () = + let* repo = S.Repo.v (Irmin_lwt_git.config "_build/test-lwt-git-mem") in + let* t = S.main repo in + let* () = S.set_exn t [ "a"; "b" ] "1" ~info:(fun () -> info "set a/b") in + let* v = S.get t [ "a"; "b" ] in + assert (v = "1"); + let* found = S.find t [ "a"; "b" ] in + assert (found = Some "1"); + let* missing = S.find t [ "x" ] in + assert (missing = None); + S.Repo.close repo + +let test_branch_and_commit () = + let* repo = S.Repo.v (Irmin_lwt_git.config "_build/test-lwt-git-mem-2") in + let* t = S.main repo in + let* () = S.set_exn t [ "k" ] "v0" ~info:(fun () -> info "init") in + let* head0 = S.Head.get t in + let* () = S.set_exn t [ "k" ] "v1" ~info:(fun () -> info "update") in + let* head1 = S.Head.get t in + let hash_eq = Irmin.Type.(unstage (equal S.Hash.t)) in + assert (not (hash_eq (S.Commit.hash head0) (S.Commit.hash head1))); + let* dev = S.of_branch repo "dev" in + let* () = S.set_exn dev [ "k" ] "branch" ~info:(fun () -> info "branch") in + let* main_v = S.get t [ "k" ] in + let* dev_v = S.get dev [ "k" ] in + assert (main_v = "v1"); + assert (dev_v = "branch"); + S.Repo.close repo + +let test_git_commit_passthrough () = + let* repo = S.Repo.v (Irmin_lwt_git.config "_build/test-lwt-git-mem-3") in + let* t = S.main repo in + let* () = S.set_exn t [ "k" ] "v" ~info:(fun () -> info "k") in + let* head = S.Head.get t in + let* git_commit = S.git_commit repo head in + (* The git commit object must be retrievable. *) + assert (Option.is_some git_commit); + S.Repo.close repo + +let run name f = + Printf.printf "%-30s " name; + flush stdout; + Lwt_eio.Promise.await_lwt (f ()); + print_endline "ok" + +let () = + Eio_main.run @@ fun env -> + Eio.Switch.run @@ fun sw -> + Irmin.Backend.Watch.set_watch_switch sw; + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> + run "basic set/get" test_basic_set_get; + run "branch and commit" test_branch_and_commit; + run "git_commit passthrough" test_git_commit_passthrough; + print_endline "--- running irmin-lwt-test harness ---"; + let suite = + let store = (module S : Irmin_test.Generic_key) in + let init ~config:_ = Lwt.return_unit in + Irmin_test.Suite.create_generic_key ~name:"GIT" ~init ~store + ~config:(Irmin_lwt_git.config "_build/test-lwt-git-harness") + () + in + Lwt_eio.Promise.await_lwt + (Irmin_test.Store.run "irmin-lwt-git" ~slow:false ~misc:[] + ~sleep:Lwt_unix.sleep + [ (`Quick, suite) ]); + print_endline "irmin-lwt-git: all smoke tests + harness passed" diff --git a/test/irmin-lwt-mem/dune b/test/irmin-lwt-mem/dune new file mode 100644 index 0000000000..344bf7f6e0 --- /dev/null +++ b/test/irmin-lwt-mem/dune @@ -0,0 +1,12 @@ +(test + (name test) + (libraries + irmin + irmin-lwt + irmin-lwt-mem + irmin-lwt-test + alcotest-lwt + lwt + lwt_eio + eio_main + unix)) diff --git a/test/irmin-lwt-mem/test.ml b/test/irmin-lwt-mem/test.ml new file mode 100644 index 0000000000..feef37d90c --- /dev/null +++ b/test/irmin-lwt-mem/test.ml @@ -0,0 +1,139 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** End-to-end smoke test for the Lwt-over-Eio shim. + + Exercises the chain user code (Lwt) -> Irmin_lwt -> Irmin_lwt_mem -> + Irmin_mem (Eio): a small set of writes / reads / commits / lookups on a KV + store backed by Irmin 4's in-memory backend. *) + +module S = Irmin_lwt_mem.KV.Make (Irmin_lwt.Contents.String) +open Lwt.Syntax + +let info ?(author = "test") msg = + S.Info.v ~author ~message:msg (Int64.of_float (Unix.gettimeofday ())) + +let test_basic_set_get () = + let* repo = S.Repo.v (Irmin_lwt_mem.config ()) in + let* t = S.main repo in + let* () = S.set_exn t [ "a"; "b" ] "1" ~info:(fun () -> info "set a/b") in + let* v = S.get t [ "a"; "b" ] in + assert (v = "1"); + let* found = S.find t [ "a"; "b" ] in + assert (found = Some "1"); + let* missing = S.find t [ "x" ] in + assert (missing = None); + S.Repo.close repo + +let test_branch_and_commit () = + let* repo = S.Repo.v (Irmin_lwt_mem.config ()) in + let* t = S.main repo in + let* () = S.set_exn t [ "k" ] "v0" ~info:(fun () -> info "init") in + let* head0 = S.Head.get t in + let* () = S.set_exn t [ "k" ] "v1" ~info:(fun () -> info "update") in + let* head1 = S.Head.get t in + let hash_eq = Irmin.Type.(unstage (equal S.Hash.t)) in + assert (not (hash_eq (S.Commit.hash head0) (S.Commit.hash head1))); + let* dev = S.of_branch repo "dev" in + let* () = S.set_exn dev [ "k" ] "branch" ~info:(fun () -> info "branch") in + let* main_v = S.get t [ "k" ] in + let* dev_v = S.get dev [ "k" ] in + assert (main_v = "v1"); + assert (dev_v = "branch"); + S.Repo.close repo + +(* Sync.fetch / push between two in-memory repos: validates that + [S.Backend.Slice], [S.Backend.Remote] and [S.Repo.export]/[import] + round-trip correctly through Wrap_store's Lwt <-> Eio bridges. *) +module Sync = Irmin_lwt.Sync.Make (S) + +let test_sync_between_repos () = + let* src_repo = S.Repo.v (Irmin_lwt_mem.config ()) in + let* dst_repo = S.Repo.v (Irmin_lwt_mem.config ()) in + let* src = S.main src_repo in + let* () = S.set_exn src [ "x" ] "from-src" ~info:(fun () -> info "x") in + let* () = S.set_exn src [ "y" ] "also" ~info:(fun () -> info "y") in + let* dst = S.main dst_repo in + let remote = Irmin_lwt.remote_store (module S) src in + let* status = Sync.pull_exn dst remote `Set in + (match status with `Empty -> assert false | `Head _ -> ()); + let* x = S.get dst [ "x" ] in + let* y = S.get dst [ "y" ] in + assert (x = "from-src"); + assert (y = "also"); + let* () = S.Repo.close src_repo in + S.Repo.close dst_repo + +(* Dot.output_buffer: validates that the dot graph generation round-trips + [S.Backend.Slice.iter] and [S.Backend.Branch.list] via Wrap_store. *) +module Dot = Irmin_lwt.Dot (S) + +(* [S.E] is the per-backend [Remote.t] constructor: [Wrap_store.Make] + forwards [E = Inner.E] so user code can construct [S.E e] with the + backend's endpoint type. We don't call Sync on it (irmin-mem has no + real remote and would fail with "fetch operation is not available") + — the goal here is just to type-check that [S.E ()] is a value of + [Irmin_lwt.remote] (= [Irmin.remote], the same extensible variant). *) +let test_remote_e_constructor () = + let _ : Irmin_lwt.remote = S.E () in + let _ : Irmin.remote = S.E () in + Lwt.return_unit + +let test_dot_output () = + let* repo = S.Repo.v (Irmin_lwt_mem.config ()) in + let* t = S.main repo in + let* () = S.set_exn t [ "a" ] "1" ~info:(fun () -> info "a") in + let* () = S.set_exn t [ "b" ] "2" ~info:(fun () -> info "b") in + let buf = Buffer.create 256 in + let* () = Dot.output_buffer t ~date:Int64.to_string buf in + let s = Buffer.contents buf in + assert (String.length s > 0); + (* Astring is not in scope here; do a substring search by hand. *) + let contains needle = + let nlen = String.length needle and slen = String.length s in + let rec loop i = + if i + nlen > slen then false + else if String.sub s i nlen = needle then true + else loop (i + 1) + in + loop 0 + in + assert (contains "digraph"); + S.Repo.close repo + +let run name f = + Printf.printf "%-30s " name; + flush stdout; + Lwt_eio.Promise.await_lwt (f ()); + print_endline "ok" + +let () = + Eio_main.run @@ fun env -> + Eio.Switch.run @@ fun sw -> + (* Watch.scheduler needs an Eio switch to fork its background fiber; the + hook is currently never set by Irmin itself. *) + Irmin.Backend.Watch.set_watch_switch sw; + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> + run "basic set/get" test_basic_set_get; + run "branch and commit" test_branch_and_commit; + run "sync between repos" test_sync_between_repos; + run "remote E constructor" test_remote_e_constructor; + run "dot output" test_dot_output; + print_endline "--- running irmin-lwt-test harness ---"; + Lwt_eio.Promise.await_lwt + (Irmin_lwt_test.Irmin_test.Store.run "irmin-lwt-mem" ~slow:false ~misc:[] + ~sleep:Lwt_unix.sleep + [ (`Quick, Test_mem.suite) ]) diff --git a/test/irmin-lwt-mem/test_mem.ml b/test/irmin-lwt-mem/test_mem.ml new file mode 100644 index 0000000000..904f4d0ea2 --- /dev/null +++ b/test/irmin-lwt-mem/test_mem.ml @@ -0,0 +1,24 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Irmin_test = Irmin_lwt_test.Irmin_test + +let store = + Irmin_test.store (module Irmin_lwt_mem) (module Irmin_lwt.Metadata.None) + +let config = Irmin_lwt_mem.config () +let init ~config:_ = Lwt.return_unit +let suite = Irmin_test.Suite.create ~name:"MEM" ~init ~store ~config () diff --git a/test/irmin-lwt-pack/dune b/test/irmin-lwt-pack/dune new file mode 100644 index 0000000000..1c4c6cf634 --- /dev/null +++ b/test/irmin-lwt-pack/dune @@ -0,0 +1,11 @@ +(test + (name test) + (libraries + irmin + irmin-pack + irmin-lwt + irmin-lwt-pack + lwt + lwt_eio + eio_main + unix)) diff --git a/test/irmin-lwt-pack/test.ml b/test/irmin-lwt-pack/test.ml new file mode 100644 index 0000000000..6d9566ee44 --- /dev/null +++ b/test/irmin-lwt-pack/test.ml @@ -0,0 +1,146 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** End-to-end smoke test for the Lwt-over-Eio shim, pack backend. + + Exercises user code (Lwt) -> Irmin_lwt -> Irmin_lwt_pack -> Irmin_pack_unix + (Eio): a small set of writes / reads / commits / branches on a pack store + backed by a temporary on-disk directory. *) + +module Conf = struct + let entries = 32 + let stable_hash = 256 + let contents_length_header = Some `Varint + let inode_child_order = `Seeded_hash + let forbid_empty_dir_persistence = false +end + +module Maker = Irmin_lwt_pack.Maker (Conf) +module S = Maker.Make (Irmin_lwt.Schema.KV (Irmin_lwt.Contents.String)) +open Lwt.Syntax + +let info ?(author = "test") msg = + S.Info.v ~author ~message:msg (Int64.of_float (Unix.gettimeofday ())) + +let test_basic_set_get config = + let* repo = S.Repo.v config in + let* t = S.main repo in + let* () = S.set_exn t [ "a"; "b" ] "1" ~info:(fun () -> info "set a/b") in + let* v = S.get t [ "a"; "b" ] in + assert (v = "1"); + let* found = S.find t [ "a"; "b" ] in + assert (found = Some "1"); + let* missing = S.find t [ "x" ] in + assert (missing = None); + S.Repo.close repo + +let test_branch_and_commit config = + let* repo = S.Repo.v config in + let* t = S.main repo in + let* () = S.set_exn t [ "k" ] "v0" ~info:(fun () -> info "init") in + let* head0 = S.Head.get t in + let* () = S.set_exn t [ "k" ] "v1" ~info:(fun () -> info "update") in + let* head1 = S.Head.get t in + let hash_eq = Irmin.Type.(unstage (equal S.Hash.t)) in + assert (not (hash_eq (S.Commit.hash head0) (S.Commit.hash head1))); + let* dev = S.of_branch repo "dev" in + let* () = S.set_exn dev [ "k" ] "branch" ~info:(fun () -> info "branch") in + let* main_v = S.get t [ "k" ] in + let* dev_v = S.get dev [ "k" ] in + assert (main_v = "v1"); + assert (dev_v = "branch"); + S.Repo.close repo + +let test_persistence config_fresh config_reopen = + let* repo = S.Repo.v config_fresh in + let* t = S.main repo in + let* () = S.set_exn t [ "p" ] "persisted" ~info:(fun () -> info "p") in + let* () = S.Repo.close repo in + let* repo = S.Repo.v config_reopen in + let* t = S.main repo in + let* v = S.get t [ "p" ] in + assert (v = "persisted"); + S.Repo.close repo + +(* Smoke test the irmin-pack-unix advanced surface bridged to Lwt: + integrity check, flush, GC predicates, stats. We do not exercise a + full GC run (requires a domain manager and full repo state) -- that + is a separate, heavier test. *) +let test_pack_advanced config = + let* repo = S.Repo.v config in + let* t = S.main repo in + let* () = S.set_exn t [ "k" ] "v" ~info:(fun () -> info "k") in + let* commit = S.Head.get t in + let* () = S.flush repo in + let* result = S.integrity_check ~auto_repair:false repo in + (match result with + | Ok (`Fixed _ | `No_error) -> () + | Error _ -> assert false); + let* split_ok = S.is_split_allowed repo in + let* gc_ok = S.Gc.is_allowed repo in + let* gc_finished = S.Gc.is_finished repo in + assert gc_finished; + ignore split_ok; + ignore gc_ok; + let* () = S.stats ~dump_blob_paths_to:None ~commit repo in + S.Repo.close repo + +let run name f = + Printf.printf "%-30s " name; + flush stdout; + Lwt_eio.Promise.await_lwt (f ()); + print_endline "ok" + +let with_tmp_dir env f = + let fs = Eio.Stdenv.fs env in + let base = try Sys.getenv "TMPDIR" with Not_found -> "/tmp" in + let name = + Printf.sprintf "irmin-lwt-pack-test-%d-%d" (Unix.getpid ()) (Random.bits ()) + in + let path = Filename.concat base name in + Eio.Switch.run @@ fun sw -> + let cleanup () = + try + let cmd = Printf.sprintf "rm -rf %s" (Filename.quote path) in + ignore (Sys.command cmd) + with _ -> () + in + Fun.protect ~finally:cleanup (fun () -> f ~sw ~fs ~path) + +let () = + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> + with_tmp_dir env @@ fun ~sw ~fs ~path -> + let config_fresh = + Irmin_pack.Conf.init ~sw ~fs ~fresh:true Eio.Path.(fs / path) + in + let config_reopen = + Irmin_pack.Conf.init ~sw ~fs ~fresh:false Eio.Path.(fs / path) + in + let path2 = path ^ "-2" in + let config_fresh2 () = + Irmin_pack.Conf.init ~sw ~fs ~fresh:true Eio.Path.(fs / path2) + in + run "basic set/get" (fun () -> test_basic_set_get (config_fresh2 ())); + run "branch and commit" (fun () -> test_branch_and_commit (config_fresh2 ())); + run "persistence across reopen" (fun () -> + test_persistence config_fresh config_reopen); + run "pack advanced surface" (fun () -> test_pack_advanced (config_fresh2 ())); + (try + let cmd = Printf.sprintf "rm -rf %s" (Filename.quote path2) in + ignore (Sys.command cmd) + with _ -> ()); + print_endline "irmin-lwt-pack: all smoke tests passed" diff --git a/test/irmin-lwt-tezos/dune b/test/irmin-lwt-tezos/dune new file mode 100644 index 0000000000..31db6c6761 --- /dev/null +++ b/test/irmin-lwt-tezos/dune @@ -0,0 +1,11 @@ +(test + (name test) + (libraries + irmin + irmin-pack + irmin-lwt + irmin-lwt-tezos + lwt + lwt_eio + eio_main + unix)) diff --git a/test/irmin-lwt-tezos/test.ml b/test/irmin-lwt-tezos/test.ml new file mode 100644 index 0000000000..101c9b74b9 --- /dev/null +++ b/test/irmin-lwt-tezos/test.ml @@ -0,0 +1,67 @@ +(* + * Copyright (c) 2026 Tarides + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** End-to-end smoke test for irmin-lwt-tezos. Validates that the + Tezos-flavoured Schema (BLAKE2B + Base58 hash, V1 pre-hashed Node / Commit / + Contents) round-trips through a Lwt-typed pack store on a temporary + directory. *) + +module S = Irmin_lwt_tezos +open Lwt.Syntax + +let info ?(author = "test") msg = + S.Info.v ~author ~message:msg (Int64.of_float (Unix.gettimeofday ())) + +let test_basic config = + let* repo = S.Repo.v config in + let* t = S.main repo in + let* () = + S.set_exn t [ "k" ] (Bytes.of_string "v") ~info:(fun () -> info "k") + in + let* v = S.get t [ "k" ] in + assert (Bytes.to_string v = "v"); + S.Repo.close repo + +let run name f = + Printf.printf "%-30s " name; + flush stdout; + Lwt_eio.Promise.await_lwt (f ()); + print_endline "ok" + +let with_tmp_dir env f = + let fs = Eio.Stdenv.fs env in + let base = try Sys.getenv "TMPDIR" with Not_found -> "/tmp" in + let name = + Printf.sprintf "irmin-lwt-tezos-test-%d-%d" (Unix.getpid ()) + (Random.bits ()) + in + let path = Filename.concat base name in + Eio.Switch.run @@ fun sw -> + let cleanup () = + try + let cmd = Printf.sprintf "rm -rf %s" (Filename.quote path) in + ignore (Sys.command cmd) + with _ -> () + in + Fun.protect ~finally:cleanup (fun () -> f ~sw ~fs ~path) + +let () = + Eio_main.run @@ fun env -> + Lwt_eio.with_event_loop ~clock:env#clock @@ fun _ -> + with_tmp_dir env @@ fun ~sw ~fs ~path -> + let config = Irmin_pack.Conf.init ~sw ~fs ~fresh:true Eio.Path.(fs / path) in + run "tezos schema basic" (fun () -> test_basic config); + print_endline "irmin-lwt-tezos: smoke test passed"